This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
change tied_method to use SVs with precomputed hash values
[perl5.git] / mg.c
CommitLineData
a0d0e21e 1/* mg.c
79072805 2 *
1129b882
NC		 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805
LW		 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW		 9 */
10
11/*
4ac71550
TC		 12 * Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent.
14 *
15 * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
79072805
LW		 16 */
17
ccfc67b7
JH		 18/*
19=head1 Magical Functions
166f8a29
DM		 20
21"Magic" is special data attached to SV structures in order to give them
22"magical" properties. When any Perl code tries to read from, or assign to,
23an SV marked as magical, it calls the 'get' or 'set' function associated
24with that SV's magic. A get is called prior to reading an SV, in order to
ddfa107c 25give it a chance to update its internal value (get on $. writes the line
166f8a29
DM		 26number of the last read filehandle into to the SV's IV slot), while
27set is called after an SV has been written to, in order to allow it to make
ddfa107c 28use of its changed value (set on $/ copies the SV's new value to the
166f8a29
DM		 29PL_rs global variable).
30
31Magic is implemented as a linked list of MAGIC structures attached to the
32SV. Each MAGIC struct holds the type of the magic, a pointer to an array
33of functions that implement the get(), set(), length() etc functions,
34plus space for some flags and pointers. For example, a tied variable has
35a MAGIC structure that contains a pointer to the object associated with the
36tie.
37
ccfc67b7
JH		 38*/
39
79072805 40#include "EXTERN.h"
864dbfa3 41#define PERL_IN_MG_C
79072805
LW		 42#include "perl.h"
43
5cd24f17 44#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
b7953727
JH		 45# ifdef I_GRP
46# include <grp.h>
47# endif
188ea221
CS		 48#endif
49
757f63d8
SP		 50#if defined(HAS_SETGROUPS)
51# ifndef NGROUPS
52# define NGROUPS 32
53# endif
54#endif
55
17aa7f3d
JH		 56#ifdef __hpux
57# include <sys/pstat.h>
58#endif
59
7636ea95
AB		 60#ifdef HAS_PRCTL_SET_NAME
61# include <sys/prctl.h>
62#endif
63
8aad04aa 64#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b6455c53 65Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
8aad04aa 66#else
e69880a5 67Signal_t Perl_csighandler(int sig);
8aad04aa 68#endif
e69880a5 69
9cffb111
OS		 70#ifdef __Lynx__
71/* Missing protos on LynxOS */
72void setruid(uid_t id);
73void seteuid(uid_t id);
74void setrgid(uid_t id);
75void setegid(uid_t id);
76#endif
77
c07a80fd 78/*
4bac9ae4 79 * Pre-magic setup and post-magic takedown.
c07a80fd 80 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81 */
82
83struct magic_state {
84 SV* mgs_sv;
455ece5e 85 I32 mgs_ss_ix;
f9c6fee5
CS		 86 U32 mgs_magical;
87 bool mgs_readonly;
150b625d 88 bool mgs_bumped;
c07a80fd 89};
455ece5e 90/* MGS is typedef'ed to struct magic_state in perl.h */
76e3520e
GS		 91
92STATIC void
8fb26106 93S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
c07a80fd 94{
97aff369 95 dVAR;
455ece5e 96 MGS* mgs;
150b625d 97 bool bumped = FALSE;
7918f24d
NC		 98
99 PERL_ARGS_ASSERT_SAVE_MAGIC;
100
4bac9ae4
CS		 101 assert(SvMAGICAL(sv));
102
150b625d
DM		 103 /* we shouldn't really be called here with RC==0, but it can sometimes
104 * happen via mg_clear() (which also shouldn't be called when RC==0,
105 * but it can happen). Handle this case gracefully(ish) by not RC++
106 * and thus avoiding the resultant double free */
107 if (SvREFCNT(sv) > 0) {
108 /* guard against sv getting freed midway through the mg clearing,
109 * by holding a private reference for the duration. */
110 SvREFCNT_inc_simple_void_NN(sv);
111 bumped = TRUE;
112 }
8985fe98 113
8772537c 114 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
455ece5e
AD		 115
116 mgs = SSPTR(mgs_ix, MGS*);
c07a80fd 117 mgs->mgs_sv = sv;
f9c6fee5 118 mgs->mgs_magical = SvMAGICAL(sv);
2fd13ecc 119 mgs->mgs_readonly = SvREADONLY(sv) && !SvIsCOW(sv);
455ece5e 120 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
150b625d 121 mgs->mgs_bumped = bumped;
c07a80fd 122
123 SvMAGICAL_off(sv);
2fd13ecc
FC		 124 /* Turning READONLY off for a copy-on-write scalar (including shared
125 hash keys) is a bad idea. */
126 if (!SvIsCOW(sv)) SvREADONLY_off(sv);
c07a80fd 127}
128
954c1994
GS		 129/*
130=for apidoc mg_magical
131
132Turns on the magical status of an SV. See C<sv_magic>.
133
134=cut
135*/
136
8990e307 137void
864dbfa3 138Perl_mg_magical(pTHX_ SV *sv)
8990e307 139{
e1ec3a88 140 const MAGIC* mg;
7918f24d 141 PERL_ARGS_ASSERT_MG_MAGICAL;
96a5add6 142 PERL_UNUSED_CONTEXT;
f9c6fee5
CS		 143
144 SvMAGICAL_off(sv);
218787bd 145 if ((mg = SvMAGIC(sv))) {
218787bd
VP		 146 do {
147 const MGVTBL* const vtbl = mg->mg_virtual;
148 if (vtbl) {
149 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
150 SvGMAGICAL_on(sv);
151 if (vtbl->svt_set)
152 SvSMAGICAL_on(sv);
153 if (vtbl->svt_clear)
154 SvRMAGICAL_on(sv);
155 }
156 } while ((mg = mg->mg_moremagic));
157 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
158 SvRMAGICAL_on(sv);
8990e307
LW		 159 }
160}
161
954c1994
GS		 162/*
163=for apidoc mg_get
164
4b1e7f06
DD		 165Do magic before a value is retrieved from the SV. The type of SV must
166be >= SVt_PVMG. See C<sv_magic>.
954c1994
GS		 167
168=cut
169*/
170
79072805 171int
864dbfa3 172Perl_mg_get(pTHX_ SV *sv)
79072805 173{
97aff369 174 dVAR;
35a4481c 175 const I32 mgs_ix = SSNEW(sizeof(MGS));
a9844598 176 bool saved = FALSE;
f9c6fee5 177 bool have_new = 0;
ff76feab 178 MAGIC *newmg, *head, *cur, *mg;
6683b158 179
7918f24d
NC		 180 PERL_ARGS_ASSERT_MG_GET;
181
407287f9
FC		 182 if (PL_localizing == 1 && sv == DEFSV) return 0;
183
ff76feab
AMS		 184 /* We must call svt_get(sv, mg) for each valid entry in the linked
185 list of magic. svt_get() may delete the current entry, add new
186 magic to the head of the list, or upgrade the SV. AMS 20010810 */
187
188 newmg = cur = head = mg = SvMAGIC(sv);
189 while (mg) {
35a4481c 190 const MGVTBL * const vtbl = mg->mg_virtual;
f9c6fee5 191 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
ff76feab 192
2b260de0 193 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
a9844598
CS		 194
195 /* taint's mg get is so dumb it doesn't need flag saving */
196 if (!saved && mg->mg_type != PERL_MAGIC_taint) {
197 save_magic(mgs_ix, sv);
198 saved = TRUE;
199 }
200
16c91539 201 vtbl->svt_get(aTHX_ sv, mg);
b77f7d40 202
58f82c5c
DM		 203 /* guard against magic having been deleted - eg FETCH calling
204 * untie */
f9c6fee5
CS		 205 if (!SvMAGIC(sv)) {
206 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
58f82c5c 207 break;
f9c6fee5 208 }
b77f7d40 209
f9c6fee5 210 /* recalculate flags if this entry was deleted. */
ff76feab 211 if (mg->mg_flags & MGf_GSKIP)
f9c6fee5 212 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
a0d0e21e 213 }
7d1328bb
FC		 214 else if (vtbl == &PL_vtbl_utf8) {
215 /* get-magic can reallocate the PV */
216 magic_setutf8(sv, mg);
217 }
ff76feab 218
f9c6fee5 219 mg = nextmg;
ff76feab 220
0723351e 221 if (have_new) {
ff76feab
AMS		 222 /* Have we finished with the new entries we saw? Start again
223 where we left off (unless there are more new entries). */
224 if (mg == head) {
0723351e 225 have_new = 0;
ff76feab
AMS		 226 mg = cur;
227 head = newmg;
228 }
229 }
230
231 /* Were any new entries added? */
0723351e
NC		 232 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
233 have_new = 1;
ff76feab
AMS		 234 cur = mg;
235 mg = newmg;
f9c6fee5 236 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
760ac839 237 }
79072805 238 }
463ee0b2 239
a9844598
CS		 240 if (saved)
241 restore_magic(INT2PTR(void *, (IV)mgs_ix));
242
79072805
LW		 243 return 0;
244}
245
954c1994
GS		 246/*
247=for apidoc mg_set
248
249Do magic after a value is assigned to the SV. See C<sv_magic>.
250
251=cut
252*/
253
79072805 254int
864dbfa3 255Perl_mg_set(pTHX_ SV *sv)
79072805 256{
97aff369 257 dVAR;
35a4481c 258 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 259 MAGIC* mg;
463ee0b2
LW		 260 MAGIC* nextmg;
261
7918f24d
NC		 262 PERL_ARGS_ASSERT_MG_SET;
263
b5ed8c44
FC		 264 if (PL_localizing == 2 && sv == DEFSV) return 0;
265
455ece5e 266 save_magic(mgs_ix, sv);
463ee0b2
LW		 267
268 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
e1ec3a88 269 const MGVTBL* vtbl = mg->mg_virtual;
463ee0b2 270 nextmg = mg->mg_moremagic; /* it may delete itself */
a0d0e21e
LW		 271 if (mg->mg_flags & MGf_GSKIP) {
272 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
f9c6fee5 273 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
a0d0e21e 274 }
e0a73de4 275 if (PL_localizing == 2
b5ed8c44 276 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
e7cbf6c6 277 continue;
2b260de0 278 if (vtbl && vtbl->svt_set)
16c91539 279 vtbl->svt_set(aTHX_ sv, mg);
79072805 280 }
463ee0b2 281
8772537c 282 restore_magic(INT2PTR(void*, (IV)mgs_ix));
79072805
LW		 283 return 0;
284}
285
954c1994
GS		 286/*
287=for apidoc mg_length
288
d4e99c76 289Reports on the SV's length in bytes, calling length magic if available,
bd8446cf
FC		 290but does not set the UTF8 flag on the sv. It will fall back to 'get'
291magic if there is no 'length' magic, but with no indication as to
292whether it called 'get' magic. It assumes the sv is a PVMG or
293higher. Use sv_len() instead.
954c1994
GS		 294
295=cut
296*/
297
79072805 298U32
864dbfa3 299Perl_mg_length(pTHX_ SV *sv)
79072805 300{
97aff369 301 dVAR;
79072805 302 MAGIC* mg;
463ee0b2 303 STRLEN len;
463ee0b2 304
7918f24d
NC		 305 PERL_ARGS_ASSERT_MG_LENGTH;
306
79072805 307 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 308 const MGVTBL * const vtbl = mg->mg_virtual;
2b260de0 309 if (vtbl && vtbl->svt_len) {
35a4481c 310 const I32 mgs_ix = SSNEW(sizeof(MGS));
455ece5e 311 save_magic(mgs_ix, sv);
a0d0e21e 312 /* omit MGf_GSKIP -- not changed here */
16c91539 313 len = vtbl->svt_len(aTHX_ sv, mg);
8772537c 314 restore_magic(INT2PTR(void*, (IV)mgs_ix));
85e6fe83
LW		 315 return len;
316 }
317 }
318
bd8446cf 319 (void)SvPV_const(sv, len);
463ee0b2 320 return len;
79072805
LW		 321}
322
8fb26106 323I32
864dbfa3 324Perl_mg_size(pTHX_ SV *sv)
93965878
NIS		 325{
326 MAGIC* mg;
ac27b0f5 327
7918f24d
NC		 328 PERL_ARGS_ASSERT_MG_SIZE;
329
93965878 330 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 331 const MGVTBL* const vtbl = mg->mg_virtual;
2b260de0 332 if (vtbl && vtbl->svt_len) {
35a4481c
AL		 333 const I32 mgs_ix = SSNEW(sizeof(MGS));
334 I32 len;
455ece5e 335 save_magic(mgs_ix, sv);
93965878 336 /* omit MGf_GSKIP -- not changed here */
16c91539 337 len = vtbl->svt_len(aTHX_ sv, mg);
8772537c 338 restore_magic(INT2PTR(void*, (IV)mgs_ix));
93965878
NIS		 339 return len;
340 }
341 }
342
343 switch(SvTYPE(sv)) {
344 case SVt_PVAV:
502c6561 345 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
93965878
NIS		 346 case SVt_PVHV:
347 /* FIXME */
348 default:
cea2e8a9 349 Perl_croak(aTHX_ "Size magic not implemented");
93965878
NIS		 350 break;
351 }
352 return 0;
353}
354
954c1994
GS		 355/*
356=for apidoc mg_clear
357
358Clear something magical that the SV represents. See C<sv_magic>.
359
360=cut
361*/
362
79072805 363int
864dbfa3 364Perl_mg_clear(pTHX_ SV *sv)
79072805 365{
35a4481c 366 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 367 MAGIC* mg;
8ac77ac9 368 MAGIC *nextmg;
463ee0b2 369
7918f24d
NC		 370 PERL_ARGS_ASSERT_MG_CLEAR;
371
455ece5e 372 save_magic(mgs_ix, sv);
463ee0b2 373
8ac77ac9 374 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
35a4481c 375 const MGVTBL* const vtbl = mg->mg_virtual;
a0d0e21e 376 /* omit GSKIP -- never set here */
727405f8 377
8ac77ac9
NC		 378 nextmg = mg->mg_moremagic; /* it may delete itself */
379
2b260de0 380 if (vtbl && vtbl->svt_clear)
16c91539 381 vtbl->svt_clear(aTHX_ sv, mg);
79072805 382 }
463ee0b2 383
8772537c 384 restore_magic(INT2PTR(void*, (IV)mgs_ix));
79072805
LW		 385 return 0;
386}
387
ed624ca8 388static MAGIC*
39de7f53
FR		 389S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
390{
391 PERL_UNUSED_CONTEXT;
392
393 assert(flags <= 1);
394
395 if (sv) {
396 MAGIC *mg;
397
398 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
399 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
400 return mg;
401 }
402 }
403 }
404
405 return NULL;
406}
407
954c1994
GS		 408/*
409=for apidoc mg_find
410
411Finds the magic pointer for type matching the SV. See C<sv_magic>.
412
413=cut
414*/
415
93a17b20 416MAGIC*
35a4481c 417Perl_mg_find(pTHX_ const SV *sv, int type)
93a17b20 418{
39de7f53
FR		 419 return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
420}
421
422/*
423=for apidoc mg_findext
424
425Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
426C<sv_magicext>.
427
428=cut
429*/
430
431MAGIC*
432Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
433{
434 return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
93a17b20
LW		 435}
436
954c1994
GS		 437/*
438=for apidoc mg_copy
439
440Copies the magic from one SV to another. See C<sv_magic>.
441
442=cut
443*/
444
79072805 445int
864dbfa3 446Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
79072805 447{
463ee0b2 448 int count = 0;
79072805 449 MAGIC* mg;
7918f24d
NC		 450
451 PERL_ARGS_ASSERT_MG_COPY;
452
463ee0b2 453 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 454 const MGVTBL* const vtbl = mg->mg_virtual;
68795e93 455 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
16c91539 456 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
68795e93 457 }
823a54a3
AL		 458 else {
459 const char type = mg->mg_type;
1e73acc8 460 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
823a54a3
AL		 461 sv_magic(nsv,
462 (type == PERL_MAGIC_tied)
463 ? SvTIED_obj(sv, mg)
464 : (type == PERL_MAGIC_regdata && mg->mg_obj)
465 ? sv
466 : mg->mg_obj,
467 toLOWER(type), key, klen);
468 count++;
469 }
79072805 470 }
79072805 471 }
463ee0b2 472 return count;
79072805
LW		 473}
474
954c1994 475/*
0cbee0a4
DM		 476=for apidoc mg_localize
477
9711599e
CS		 478Copy some of the magic from an existing SV to new localized version of that
479SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
480taint, pos).
481
af7df257 482If setmagic is false then no set magic will be called on the new (empty) SV.
9711599e
CS		 483This typically means that assignment will soon follow (e.g. 'local $x = $y'),
484and that will handle the magic.
0cbee0a4
DM		 485
486=cut
487*/
488
489void
af7df257 490Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
0cbee0a4 491{
97aff369 492 dVAR;
0cbee0a4 493 MAGIC *mg;
7918f24d
NC		 494
495 PERL_ARGS_ASSERT_MG_LOCALIZE;
496
658a9f31
JD		 497 if (nsv == DEFSV)
498 return;
499
0cbee0a4 500 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
2b1b43ea 501 const MGVTBL* const vtbl = mg->mg_virtual;
e0a73de4 502 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
0cbee0a4 503 continue;
0cbee0a4 504
a5063e7c 505 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
16c91539 506 (void)vtbl->svt_local(aTHX_ nsv, mg);
a5063e7c 507 else
0cbee0a4
DM		 508 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
509 mg->mg_ptr, mg->mg_len);
a5063e7c 510
0cbee0a4 511 /* container types should remain read-only across localization */
b2b95e4c 512 if (!SvIsCOW(sv)) SvFLAGS(nsv) |= SvREADONLY(sv);
0cbee0a4
DM		 513 }
514
515 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
516 SvFLAGS(nsv) |= SvMAGICAL(sv);
af7df257 517 if (setmagic) {
9711599e
CS		 518 PL_localizing = 1;
519 SvSETMAGIC(nsv);
520 PL_localizing = 0;
521 }
0cbee0a4
DM		 522 }
523}
524
d9088386
Z		 525#define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
526static void
527S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
528{
529 const MGVTBL* const vtbl = mg->mg_virtual;
530 if (vtbl && vtbl->svt_free)
531 vtbl->svt_free(aTHX_ sv, mg);
532 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
533 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
534 Safefree(mg->mg_ptr);
535 else if (mg->mg_len == HEf_SVKEY)
536 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
537 }
538 if (mg->mg_flags & MGf_REFCOUNTED)
539 SvREFCNT_dec(mg->mg_obj);
540 Safefree(mg);
541}
542
0cbee0a4 543/*
954c1994
GS		 544=for apidoc mg_free
545
546Free any magic storage used by the SV. See C<sv_magic>.
547
548=cut
549*/
550
79072805 551int
864dbfa3 552Perl_mg_free(pTHX_ SV *sv)
79072805
LW		 553{
554 MAGIC* mg;
555 MAGIC* moremagic;
7918f24d
NC		 556
557 PERL_ARGS_ASSERT_MG_FREE;
558
79072805 559 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
79072805 560 moremagic = mg->mg_moremagic;
d9088386 561 mg_free_struct(sv, mg);
c826f41b 562 SvMAGIC_set(sv, moremagic);
79072805 563 }
b162af07 564 SvMAGIC_set(sv, NULL);
68f8932e 565 SvMAGICAL_off(sv);
79072805
LW		 566 return 0;
567}
568
d9088386
Z		 569/*
570=for apidoc Am|void|mg_free_type|SV *sv|int how
571
572Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
573
574=cut
575*/
576
577void
578Perl_mg_free_type(pTHX_ SV *sv, int how)
579{
580 MAGIC *mg, *prevmg, *moremg;
581 PERL_ARGS_ASSERT_MG_FREE_TYPE;
582 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
583 MAGIC *newhead;
584 moremg = mg->mg_moremagic;
585 if (mg->mg_type == how) {
586 /* temporarily move to the head of the magic chain, in case
587 custom free code relies on this historical aspect of mg_free */
588 if (prevmg) {
589 prevmg->mg_moremagic = moremg;
590 mg->mg_moremagic = SvMAGIC(sv);
591 SvMAGIC_set(sv, mg);
592 }
593 newhead = mg->mg_moremagic;
594 mg_free_struct(sv, mg);
595 SvMAGIC_set(sv, newhead);
596 mg = prevmg;
597 }
598 }
599 mg_magical(sv);
600}
601
79072805 602#include <signal.h>
79072805 603
942e002e 604U32
864dbfa3 605Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 606{
97aff369 607 dVAR;
8772537c 608 PERL_UNUSED_ARG(sv);
6cef1e77 609
7918f24d
NC		 610 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
611
0bd48802 612 if (PL_curpm) {
eb578fdb 613 const REGEXP * const rx = PM_GETRE(PL_curpm);
0bd48802 614 if (rx) {
a678b0e4
YO		 615 if (mg->mg_obj) { /* @+ */
616 /* return the number possible */
07bc277f 617 return RX_NPARENS(rx);
a678b0e4 618 } else { /* @- */
07bc277f 619 I32 paren = RX_LASTPAREN(rx);
a678b0e4
YO		 620
621 /* return the last filled */
f46c4081 622 while ( paren >= 0
07bc277f
NC		 623 && (RX_OFFS(rx)[paren].start == -1
624 || RX_OFFS(rx)[paren].end == -1) )
f46c4081 625 paren--;
a678b0e4
YO		 626 return (U32)paren;
627 }
0bd48802 628 }
8f580fb8 629 }
ac27b0f5 630
942e002e 631 return (U32)-1;
6cef1e77
IZ		 632}
633
6502e081
DM		 634/* @-, @+ */
635
6cef1e77 636int
864dbfa3 637Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 638{
97aff369 639 dVAR;
7918f24d
NC		 640
641 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
642
0bd48802 643 if (PL_curpm) {
eb578fdb 644 const REGEXP * const rx = PM_GETRE(PL_curpm);
0bd48802 645 if (rx) {
eb578fdb
KW		 646 const I32 paren = mg->mg_len;
647 I32 s;
648 I32 t;
0bd48802
AL		 649 if (paren < 0)
650 return 0;
07bc277f
NC		 651 if (paren <= (I32)RX_NPARENS(rx) &&
652 (s = RX_OFFS(rx)[paren].start) != -1 &&
653 (t = RX_OFFS(rx)[paren].end) != -1)
0bd48802 654 {
eb578fdb 655 I32 i;
0bd48802
AL		 656 if (mg->mg_obj) /* @+ */
657 i = t;
658 else /* @- */
659 i = s;
660
661 if (i > 0 && RX_MATCH_UTF8(rx)) {
07bc277f 662 const char * const b = RX_SUBBEG(rx);
0bd48802 663 if (b)
6502e081
DM		 664 i = RX_SUBCOFFSET(rx) +
665 utf8_length((U8*)b,
666 (U8*)(b-RX_SUBOFFSET(rx)+i));
0bd48802 667 }
727405f8 668
0bd48802 669 sv_setiv(sv, i);
1aa99e6b 670 }
0bd48802 671 }
6cef1e77
IZ		 672 }
673 return 0;
674}
675
6502e081
DM		 676/* @-, @+ */
677
e4b89193 678int
a29d06ed
MG		 679Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
680{
7918f24d 681 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
d4c19fe8
AL		 682 PERL_UNUSED_ARG(sv);
683 PERL_UNUSED_ARG(mg);
cb077ed2 684 Perl_croak_no_modify();
0dbb1585 685 NORETURN_FUNCTION_END;
a29d06ed
MG		 686}
687
ad3296c6 688#define SvRTRIM(sv) STMT_START { \
eae92ea0
GA		 689 if (SvPOK(sv)) { \
690 STRLEN len = SvCUR(sv); \
691 char * const p = SvPVX(sv); \
8e6b4db6
PC		 692 while (len > 0 && isSPACE(p[len-1])) \
693 --len; \
694 SvCUR_set(sv, len); \
695 p[len] = '\0'; \
696 } \
ad3296c6
SH		 697} STMT_END
698
8b850bd5
NC		 699void
700Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
701{
7918f24d
NC		 702 PERL_ARGS_ASSERT_EMULATE_COP_IO;
703
8b850bd5
NC		 704 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
705 sv_setsv(sv, &PL_sv_undef);
706 else {
707 sv_setpvs(sv, "");
708 SvUTF8_off(sv);
709 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
20439bc7 710 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
8b850bd5
NC		 711 assert(value);
712 sv_catsv(sv, value);
713 }
714 sv_catpvs(sv, "\0");
715 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
20439bc7 716 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
8b850bd5
NC		 717 assert(value);
718 sv_catsv(sv, value);
719 }
720 }
721}
722
25bbd826
CB		 723#ifdef VMS
724#include <descrip.h>
725#include <starlet.h>
726#endif
727
79072805 728int
864dbfa3 729Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
79072805 730{
27da23d5 731 dVAR;
eb578fdb
KW		 732 I32 paren;
733 const char *s = NULL;
734 REGEXP *rx;
823a54a3
AL		 735 const char * const remaining = mg->mg_ptr + 1;
736 const char nextchar = *remaining;
79072805 737
7918f24d
NC		 738 PERL_ARGS_ASSERT_MAGIC_GET;
739
79072805 740 switch (*mg->mg_ptr) {
748a9306 741 case '\001': /* ^A */
f2da823f
FC		 742 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
743 else sv_setsv(sv, &PL_sv_undef);
125b9982
NT		 744 if (SvTAINTED(PL_bodytarget))
745 SvTAINTED_on(sv);
748a9306 746 break;
e5218da5 747 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
823a54a3 748 if (nextchar == '\0') {
e5218da5
GA		 749 sv_setiv(sv, (IV)PL_minus_c);
750 }
823a54a3 751 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
e5218da5
GA		 752 sv_setiv(sv, (IV)STATUS_NATIVE);
753 }
49460fe6
NIS		 754 break;
755
79072805 756 case '\004': /* ^D */
aea4f609 757 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
79072805 758 break;
28f23441 759 case '\005': /* ^E */
823a54a3 760 if (nextchar == '\0') {
e37778c2 761#if defined(VMS)
0a378802 762 {
0a378802
JH		 763 char msg[255];
764 $DESCRIPTOR(msgdsc,msg);
765 sv_setnv(sv,(NV) vaxc$errno);
766 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
767 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
768 else
76f68e9b 769 sv_setpvs(sv,"");
0a378802 770 }
4b645107 771#elif defined(OS2)
0a378802
JH		 772 if (!(_emx_env & 0x200)) { /* Under DOS */
773 sv_setnv(sv, (NV)errno);
774 sv_setpv(sv, errno ? Strerror(errno) : "");
775 } else {
776 if (errno != errno_isOS2) {
823a54a3 777 const int tmp = _syserrno();
0a378802
JH		 778 if (tmp) /* 2nd call to _syserrno() makes it 0 */
779 Perl_rc = tmp;
780 }
781 sv_setnv(sv, (NV)Perl_rc);
782 sv_setpv(sv, os2error(Perl_rc));
783 }
4b645107 784#elif defined(WIN32)
0a378802 785 {
d4c19fe8 786 const DWORD dwErr = GetLastError();
0a378802 787 sv_setnv(sv, (NV)dwErr);
823a54a3 788 if (dwErr) {
0a378802
JH		 789 PerlProc_GetOSError(sv, dwErr);
790 }
791 else
76f68e9b 792 sv_setpvs(sv, "");
0a378802
JH		 793 SetLastError(dwErr);
794 }
22fae026 795#else
f6c8f21d 796 {
4ee39169 797 dSAVE_ERRNO;
f6c8f21d 798 sv_setnv(sv, (NV)errno);
666ea192 799 sv_setpv(sv, errno ? Strerror(errno) : "");
4ee39169 800 RESTORE_ERRNO;
f6c8f21d 801 }
28f23441 802#endif
ad3296c6 803 SvRTRIM(sv);
0a378802
JH		 804 SvNOK_on(sv); /* what a wonderful hack! */
805 }
823a54a3 806 else if (strEQ(remaining, "NCODING"))
0a378802
JH		 807 sv_setsv(sv, PL_encoding);
808 break;
79072805 809 case '\006': /* ^F */
3280af22 810 sv_setiv(sv, (IV)PL_maxsysfd);
79072805 811 break;
9ebf26ad
FR		 812 case '\007': /* ^GLOBAL_PHASE */
813 if (strEQ(remaining, "LOBAL_PHASE")) {
814 sv_setpvn(sv, PL_phase_names[PL_phase],
815 strlen(PL_phase_names[PL_phase]));
816 }
817 break;
a0d0e21e 818 case '\010': /* ^H */
3280af22 819 sv_setiv(sv, (IV)PL_hints);
a0d0e21e 820 break;
9d116dd7 821 case '\011': /* ^I */ /* NOT \t in EBCDIC */
120f7abe 822 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
79072805 823 break;
8561ea1d
FC		 824 case '\014': /* ^LAST_FH */
825 if (strEQ(remaining, "AST_FH")) {
826 if (PL_last_in_gv) {
827 assert(isGV_with_GP(PL_last_in_gv));
828 SV_CHECK_THINKFIRST_COW_DROP(sv);
829 prepare_SV_for_RV(sv);
830 SvOK_off(sv);
831 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
832 SvROK_on(sv);
833 sv_rvweaken(sv);
834 }
835 else sv_setsv_nomg(sv, NULL);
836 }
837 break;
ac27b0f5 838 case '\017': /* ^O & ^OPEN */
823a54a3 839 if (nextchar == '\0') {
ac27b0f5 840 sv_setpv(sv, PL_osname);
3511154c
DM		 841 SvTAINTED_off(sv);
842 }
823a54a3 843 else if (strEQ(remaining, "PEN")) {
8b850bd5 844 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
ac27b0f5 845 }
28f23441 846 break;
9ebf26ad 847 case '\020':
cde0cee5
YO		 848 if (nextchar == '\0') { /* ^P */
849 sv_setiv(sv, (IV)PL_perldb);
850 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2c7b5d76
DM		 851
852 paren = RX_BUFF_IDX_CARET_PREMATCH;
853 goto do_numbuf_fetch;
cde0cee5 854 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2c7b5d76
DM		 855 paren = RX_BUFF_IDX_CARET_POSTMATCH;
856 goto do_numbuf_fetch;
cde0cee5 857 }
79072805 858 break;
fb73857a 859 case '\023': /* ^S */
823a54a3 860 if (nextchar == '\0') {
bc177e6b 861 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
0c34ef67 862 SvOK_off(sv);
3280af22 863 else if (PL_in_eval)
6dc8a9e4 864 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
a4268c0a
AMS		 865 else
866 sv_setiv(sv, 0);
d58bf5aa 867 }
fb73857a 868 break;
79072805 869 case '\024': /* ^T */
823a54a3 870 if (nextchar == '\0') {
88e89b8a 871#ifdef BIG_TIME
7c36658b 872 sv_setnv(sv, PL_basetime);
88e89b8a 873#else
7c36658b 874 sv_setiv(sv, (IV)PL_basetime);
88e89b8a 875#endif
7c36658b 876 }
823a54a3 877 else if (strEQ(remaining, "AINT"))
284167a5
S		 878 sv_setiv(sv, TAINTING_get
879 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
9aa05f58 880 : 0);
7c36658b 881 break;
e07ea26a 882 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
823a54a3 883 if (strEQ(remaining, "NICODE"))
a05d7ebb 884 sv_setuv(sv, (UV) PL_unicode);
823a54a3 885 else if (strEQ(remaining, "TF8LOCALE"))
7cebcbc0 886 sv_setuv(sv, (UV) PL_utf8locale);
e07ea26a
NC		 887 else if (strEQ(remaining, "TF8CACHE"))
888 sv_setiv(sv, (IV) PL_utf8cache);
fde18df1
JH		 889 break;
890 case '\027': /* ^W & $^WARNING_BITS */
823a54a3 891 if (nextchar == '\0')
4438c4b7 892 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
823a54a3 893 else if (strEQ(remaining, "ARNING_BITS")) {
013b78e8 894 if (PL_compiling.cop_warnings == pWARN_NONE) {
4438c4b7 895 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
013b78e8
RGS		 896 }
897 else if (PL_compiling.cop_warnings == pWARN_STD) {
7e4f0450
FC		 898 sv_setsv(sv, &PL_sv_undef);
899 break;
013b78e8 900 }
d3a7d8c7 901 else if (PL_compiling.cop_warnings == pWARN_ALL) {
75b6c4ca
RGS		 902 /* Get the bit mask for $warnings::Bits{all}, because
903 * it could have been extended by warnings::register */
4bac9ae4
CS		 904 HV * const bits = get_hv("warnings::Bits", 0);
905 SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
906 if (bits_all)
907 sv_copypv(sv, *bits_all);
908 else
909 sv_setpvn(sv, WARN_ALLstring, WARNsize);
ac27b0f5 910 }
4438c4b7 911 else {
72dc9ed5
NC		 912 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
913 *PL_compiling.cop_warnings);
ac27b0f5 914 }
4438c4b7 915 }
79072805 916 break;
cde0cee5
YO		 917 case '\015': /* $^MATCH */
918 if (strEQ(remaining, "ATCH")) {
2c7b5d76
DM		 919 paren = RX_BUFF_IDX_CARET_FULLMATCH;
920 goto do_numbuf_fetch;
921 }
922
79072805
LW		 923 case '1': case '2': case '3': case '4':
924 case '5': case '6': case '7': case '8': case '9': case '&':
2c7b5d76
DM		 925 /*
926 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
927 * XXX Does the new way break anything?
928 */
929 paren = atoi(mg->mg_ptr); /* $& is in [0] */
930 do_numbuf_fetch:
931 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
932 CALLREG_NUMBUF_FETCH(rx,paren,sv);
933 break;
934 }
935 sv_setsv(sv,&PL_sv_undef);
79072805
LW		 936 break;
937 case '+':
aaa362c4 938 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2c7b5d76
DM		 939 paren = RX_LASTPAREN(rx);
940 if (paren)
941 goto do_numbuf_fetch;
79072805 942 }
3280af22 943 sv_setsv(sv,&PL_sv_undef);
79072805 944 break;
a01268b5
JH		 945 case '\016': /* ^N */
946 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2c7b5d76
DM		 947 paren = RX_LASTCLOSEPAREN(rx);
948 if (paren)
949 goto do_numbuf_fetch;
a01268b5
JH		 950 }
951 sv_setsv(sv,&PL_sv_undef);
952 break;
79072805 953 case '`':
2c7b5d76
DM		 954 paren = RX_BUFF_IDX_PREMATCH;
955 goto do_numbuf_fetch;
79072805 956 case '\'':
2c7b5d76
DM		 957 paren = RX_BUFF_IDX_POSTMATCH;
958 goto do_numbuf_fetch;
79072805 959 case '.':
3280af22 960 if (GvIO(PL_last_in_gv)) {
357c8808 961 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
79072805 962 }
79072805
LW		 963 break;
964 case '?':
809a5acc 965 {
809a5acc 966 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 967#ifdef COMPLEX_STATUS
41cb7b2b 968 SvUPGRADE(sv, SVt_PVLV);
6b88bc9c
GS		 969 LvTARGOFF(sv) = PL_statusvalue;
970 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 971#endif
809a5acc 972 }
79072805
LW		 973 break;
974 case '^':
acbe1b9d 975 if (GvIOp(PL_defoutgv))
099be4f1 976 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW		 977 if (s)
978 sv_setpv(sv,s);
979 else {
3280af22 980 sv_setpv(sv,GvENAME(PL_defoutgv));
cb421d5e 981 sv_catpvs(sv,"_TOP");
79072805
LW		 982 }
983 break;
984 case '~':
acbe1b9d 985 if (GvIOp(PL_defoutgv))
0daa599b 986 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 987 if (!s)
3280af22 988 s = GvENAME(PL_defoutgv);
79072805
LW		 989 sv_setpv(sv,s);
990 break;
79072805 991 case '=':
099be4f1 992 if (GvIO(PL_defoutgv))
0daa599b 993 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW		 994 break;
995 case '-':
099be4f1 996 if (GvIO(PL_defoutgv))
0daa599b 997 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW		 998 break;
999 case '%':
099be4f1 1000 if (GvIO(PL_defoutgv))
0daa599b 1001 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805 1002 break;
79072805
LW		 1003 case ':':
1004 break;
1005 case '/':
1006 break;
1007 case '[':
e1dccc0d 1008 sv_setiv(sv, 0);
79072805
LW		 1009 break;
1010 case '|':
099be4f1 1011 if (GvIO(PL_defoutgv))
0daa599b 1012 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805 1013 break;
79072805 1014 case '\\':
b2ce0fda 1015 if (PL_ors_sv)
f28098ff 1016 sv_copypv(sv, PL_ors_sv);
4bac9ae4
CS		 1017 else
1018 sv_setsv(sv, &PL_sv_undef);
79072805 1019 break;
0e219455 1020 case '$': /* $$ */
9cdac2a2
FC		 1021 {
1022 IV const pid = (IV)PerlProc_getpid();
19db9fb7 1023 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
9cdac2a2
FC		 1024 /* never set manually, or at least not since last fork */
1025 sv_setiv(sv, pid);
19db9fb7
Z		 1026 /* never unsafe, even if reading in a tainted expression */
1027 SvTAINTED_off(sv);
1028 }
9cdac2a2
FC		 1029 /* else a value has been assigned manually, so do nothing */
1030 }
0e219455
MM		 1031 break;
1032
79072805 1033 case '!':
666d8aa2
CB		 1034 {
1035 dSAVE_ERRNO;
a5f75d66 1036#ifdef VMS
65202027 1037 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
a5f75d66 1038#else
65202027 1039 sv_setnv(sv, (NV)errno);
666d8aa2 1040#endif
88e89b8a 1041#ifdef OS2
ed344e4f
IZ		 1042 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1043 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 1044 else
a5f75d66 1045#endif
666ea192 1046 sv_setpv(sv, errno ? Strerror(errno) : "");
4ee39169 1047 RESTORE_ERRNO;
88e89b8a 1048 }
666d8aa2 1049
ad3296c6 1050 SvRTRIM(sv);
946ec16e 1051 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW		 1052 break;
1053 case '<':
dfff4baf 1054 sv_setuid(sv, PerlProc_getuid());
79072805
LW		 1055 break;
1056 case '>':
dfff4baf 1057 sv_setuid(sv, PerlProc_geteuid());
79072805
LW		 1058 break;
1059 case '(':
dfff4baf 1060 sv_setgid(sv, PerlProc_getgid());
79072805
LW		 1061 goto add_groups;
1062 case ')':
dfff4baf 1063 sv_setgid(sv, PerlProc_getegid());
79072805 1064 add_groups:
79072805 1065#ifdef HAS_GETGROUPS
79072805 1066 {
57d7c65e 1067 Groups_t *gary = NULL;
fb45abb2 1068 I32 i, num_groups = getgroups(0, gary);
57d7c65e
JC		 1069 Newx(gary, num_groups, Groups_t);
1070 num_groups = getgroups(num_groups, gary);
fb45abb2
GA		 1071 for (i = 0; i < num_groups; i++)
1072 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
57d7c65e 1073 Safefree(gary);
79072805 1074 }
155aba94 1075 (void)SvIOK_on(sv); /* what a wonderful hack! */
cd70abae 1076#endif
79072805 1077 break;
79072805
LW		 1078 case '0':
1079 break;
1080 }
a0d0e21e 1081 return 0;
79072805
LW		 1082}
1083
1084int
864dbfa3 1085Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 1086{
8772537c 1087 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805 1088
7918f24d
NC		 1089 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1090
79072805 1091 if (uf && uf->uf_val)
24f81a43 1092 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW		 1093 return 0;
1094}
1095
1096int
864dbfa3 1097Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805 1098{
27da23d5 1099 dVAR;
9ae3433d 1100 STRLEN len = 0, klen;
12033064 1101 const char * const key = MgPV_const(mg,klen);
888a67f6 1102 const char *s = "";
1e422769 1103
7918f24d
NC		 1104 PERL_ARGS_ASSERT_MAGIC_SETENV;
1105
613c63b4 1106 SvGETMAGIC(sv);
12033064 1107 if (SvOK(sv)) {
613c63b4
CS		 1108 /* defined environment variables are byte strings; unfortunately
1109 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1110 (void)SvPV_force_nomg_nolen(sv);
1111 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1112 if (SvUTF8(sv)) {
1113 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1114 SvUTF8_off(sv);
1115 }
1116 s = SvPVX(sv);
1117 len = SvCUR(sv);
12033064
CS		 1118 }
1119 my_setenv(key, s); /* does the deed */
1120
a0d0e21e
LW		 1121#ifdef DYNAMIC_ENV_FETCH
1122 /* We just undefd an environment var. Is a replacement */
1123 /* waiting in the wings? */
1124 if (!len) {
6bd66ee9 1125 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
fabdb6c0 1126 if (valp)
4ab59fcc 1127 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
a0d0e21e
LW		 1128 }
1129#endif
1e422769 1130
39e571d4 1131#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW		 1132 /* And you'll never guess what the dog had */
1133 /* in its mouth... */
284167a5 1134 if (TAINTING_get) {
1e422769 1135 MgTAINTEDDIR_off(mg);
1136#ifdef VMS
6bd66ee9 1137 if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
b8ffc8df 1138 char pathbuf[256], eltbuf[256], *cp, *elt;
1e422769 1139 int i = 0, j = 0;
1140
6fca0082 1141 my_strlcpy(eltbuf, s, sizeof(eltbuf));
b8ffc8df 1142 elt = eltbuf;
1e422769 1143 do { /* DCL$PATH may be a search list */
1144 while (1) { /* as may dev portion of any element */
1145 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1146 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1147 cando_by_name(S_IWUSR,0,elt) ) {
1148 MgTAINTEDDIR_on(mg);
1149 return 0;
1150 }
1151 }
bd61b366 1152 if ((cp = strchr(elt, ':')) != NULL)
1e422769 1153 *cp = '\0';
1154 if (my_trnlnm(elt, eltbuf, j++))
1155 elt = eltbuf;
1156 else
1157 break;
1158 }
1159 j = 0;
1160 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1161 }
1162#endif /* VMS */
12033064 1163 if (s && klen == 4 && strEQ(key,"PATH")) {
8772537c 1164 const char * const strend = s + len;
463ee0b2
LW		 1165
1166 while (s < strend) {
96827780 1167 char tmpbuf[256];
c623ac67 1168 Stat_t st;
5f74f29c 1169 I32 i;
f5a63d97
AL		 1170#ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1171 const char path_sep = '|';
1172#else
1173 const char path_sep = ':';
1174#endif
96827780 1175 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
427eaa01 1176 s, strend, path_sep, &i);
463ee0b2 1177 s++;
bb7a0f54 1178 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
326b5008
CB		 1179#ifdef VMS
1180 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1181#else
1182 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1183#endif
c6ed36e1 1184 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 1185 MgTAINTEDDIR_on(mg);
1e422769 1186 return 0;
1187 }
463ee0b2 1188 }
79072805
LW		 1189 }
1190 }
39e571d4 1191#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 1192
79072805
LW		 1193 return 0;
1194}
1195
1196int
864dbfa3 1197Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1198{
7918f24d 1199 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
8772537c 1200 PERL_UNUSED_ARG(sv);
bd61b366 1201 my_setenv(MgPV_nolen_const(mg),NULL);
85e6fe83
LW		 1202 return 0;
1203}
1204
88e89b8a 1205int
864dbfa3 1206Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1207{
97aff369 1208 dVAR;
7918f24d 1209 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
65e66c80 1210 PERL_UNUSED_ARG(mg);
b0269e46 1211#if defined(VMS)
cea2e8a9 1212 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1213#else
3280af22 1214 if (PL_localizing) {
fb73857a 1215 HE* entry;
b0269e46 1216 my_clearenv();
85fbaab2
NC		 1217 hv_iterinit(MUTABLE_HV(sv));
1218 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
fb73857a 1219 I32 keylen;
1220 my_setenv(hv_iterkey(entry, &keylen),
85fbaab2 1221 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
fb73857a 1222 }
1223 }
1224#endif
1225 return 0;
1226}
1227
1228int
864dbfa3 1229Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1230{
27da23d5 1231 dVAR;
7918f24d 1232 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
8772537c
AL		 1233 PERL_UNUSED_ARG(sv);
1234 PERL_UNUSED_ARG(mg);
b0269e46
AB		 1235#if defined(VMS)
1236 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1237#else
1238 my_clearenv();
1239#endif
3e3baf6d 1240 return 0;
66b1d557
HM		 1241}
1242
64ca3a65 1243#ifndef PERL_MICRO
2d4fcd5e
AJ		 1244#ifdef HAS_SIGPROCMASK
1245static void
1246restore_sigmask(pTHX_ SV *save_sv)
1247{
0bd48802 1248 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
f5a63d97 1249 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
2d4fcd5e
AJ		 1250}
1251#endif
66b1d557 1252int
864dbfa3 1253Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1254{
97aff369 1255 dVAR;
88e89b8a 1256 /* Are we fetching a signal entry? */
708854f2 1257 int i = (I16)mg->mg_private;
7918f24d
NC		 1258
1259 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1260
708854f2 1261 if (!i) {
84c7b88c
BF		 1262 STRLEN siglen;
1263 const char * sig = MgPV_const(mg, siglen);
1264 mg->mg_private = i = whichsig_pvn(sig, siglen);
708854f2
NC		 1265 }
1266
e02bfb16 1267 if (i > 0) {
22c35a8c
GS		 1268 if(PL_psig_ptr[i])
1269 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1270 else {
46da273f 1271 Sighandler_t sigstate = rsignal_state(i);
23ada85b 1272#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
46da273f
AL		 1273 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1274 sigstate = SIG_IGN;
2e34cc90
CL		 1275#endif
1276#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
46da273f
AL		 1277 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1278 sigstate = SIG_DFL;
85b332e2 1279#endif
88e89b8a 1280 /* cache state so we don't fetch it again */
8aad04aa 1281 if(sigstate == (Sighandler_t) SIG_IGN)
6502358f 1282 sv_setpvs(sv,"IGNORE");
88e89b8a 1283 else
3280af22 1284 sv_setsv(sv,&PL_sv_undef);
46da273f 1285 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
88e89b8a 1286 SvTEMP_off(sv);
1287 }
1288 }
1289 return 0;
1290}
1291int
864dbfa3 1292Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1293{
7918f24d 1294 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
179c85a2 1295
38a124f0 1296 magic_setsig(NULL, mg);
179c85a2 1297 return sv_unmagic(sv, mg->mg_type);
88e89b8a 1298}
3d37d572 1299
0a8e0eff 1300Signal_t
8aad04aa 1301#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b6455c53 1302Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
8aad04aa 1303#else
0a8e0eff 1304Perl_csighandler(int sig)
8aad04aa 1305#endif
0a8e0eff 1306{
1018e26f
NIS		 1307#ifdef PERL_GET_SIG_CONTEXT
1308 dTHXa(PERL_GET_SIG_CONTEXT);
1309#else
85b332e2
CL		 1310 dTHX;
1311#endif
23ada85b 1312#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1313 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1314 if (PL_sig_ignoring[sig]) return;
85b332e2 1315#endif
2e34cc90 1316#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1317 if (PL_sig_defaulting[sig])
2e34cc90
CL		 1318#ifdef KILL_BY_SIGPRC
1319 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1320#else
1321 exit(1);
1322#endif
1323#endif
406878dd 1324 if (
853d2c32
RGS		 1325#ifdef SIGILL
1326 sig == SIGILL ||
1327#endif
1328#ifdef SIGBUS
1329 sig == SIGBUS ||
1330#endif
1331#ifdef SIGSEGV
1332 sig == SIGSEGV ||
1333#endif
1334 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
4ffa73a3 1335 /* Call the perl level handler now--
31c91b43 1336 * with risk we may be in malloc() or being destructed etc. */
6e324d09 1337#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
80626cf1 1338 (*PL_sighandlerp)(sig, NULL, NULL);
6e324d09
CB		 1339#else
1340 (*PL_sighandlerp)(sig);
92807b6d 1341#endif
406878dd 1342 else {
31c91b43 1343 if (!PL_psig_pend) return;
406878dd
GA		 1344 /* Set a flag to say this signal is pending, that is awaiting delivery after
1345 * the current Perl opcode completes */
1346 PL_psig_pend[sig]++;
1347
1348#ifndef SIG_PENDING_DIE_COUNT
1349# define SIG_PENDING_DIE_COUNT 120
1350#endif
fe13d51d 1351 /* Add one to say _a_ signal is pending */
406878dd
GA		 1352 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1353 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1354 (unsigned long)SIG_PENDING_DIE_COUNT);
1355 }
0a8e0eff
NIS		 1356}
1357
2e34cc90
CL		 1358#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1359void
1360Perl_csighandler_init(void)
1361{
1362 int sig;
27da23d5 1363 if (PL_sig_handlers_initted) return;
2e34cc90
CL		 1364
1365 for (sig = 1; sig < SIG_SIZE; sig++) {
1366#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1367 dTHX;
27da23d5 1368 PL_sig_defaulting[sig] = 1;
5c1546dc 1369 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL		 1370#endif
1371#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1372 PL_sig_ignoring[sig] = 0;
2e34cc90
CL		 1373#endif
1374 }
27da23d5 1375 PL_sig_handlers_initted = 1;
2e34cc90
CL		 1376}
1377#endif
1378
7fe50b8b
LT		 1379#if defined HAS_SIGPROCMASK
1380static void
1381unblock_sigmask(pTHX_ void* newset)
1382{
1383 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1384}
1385#endif
1386
0a8e0eff
NIS		 1387void
1388Perl_despatch_signals(pTHX)
1389{
97aff369 1390 dVAR;
0a8e0eff
NIS		 1391 int sig;
1392 PL_sig_pending = 0;
1393 for (sig = 1; sig < SIG_SIZE; sig++) {
1394 if (PL_psig_pend[sig]) {
d0166017 1395 dSAVE_ERRNO;
7fe50b8b 1396#ifdef HAS_SIGPROCMASK
55534442
LT		 1397 /* From sigaction(2) (FreeBSD man page):
1398 * | Signal routines normally execute with the signal that
1399 * | caused their invocation blocked, but other signals may
1400 * | yet occur.
1401 * Emulation of this behavior (from within Perl) is enabled
1402 * using sigprocmask
1403 */
1404 int was_blocked;
1405 sigset_t newset, oldset;
1406
1407 sigemptyset(&newset);
1408 sigaddset(&newset, sig);
1409 sigprocmask(SIG_BLOCK, &newset, &oldset);
1410 was_blocked = sigismember(&oldset, sig);
7fe50b8b
LT		 1411 if (!was_blocked) {
1412 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1413 ENTER;
1414 SAVEFREESV(save_sv);
1415 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1416 }
55534442 1417#endif
25da4428 1418 PL_psig_pend[sig] = 0;
6e324d09 1419#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
80626cf1 1420 (*PL_sighandlerp)(sig, NULL, NULL);
6e324d09
CB		 1421#else
1422 (*PL_sighandlerp)(sig);
92807b6d 1423#endif
7fe50b8b 1424#ifdef HAS_SIGPROCMASK
55534442 1425 if (!was_blocked)
7fe50b8b 1426 LEAVE;
55534442 1427#endif
d0166017 1428 RESTORE_ERRNO;
0a8e0eff
NIS		 1429 }
1430 }
1431}
1432
38a124f0 1433/* sv of NULL signifies that we're acting as magic_clearsig. */
85e6fe83 1434int
864dbfa3 1435Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1436{
27da23d5 1437 dVAR;
79072805 1438 I32 i;
cbbf8932 1439 SV** svp = NULL;
2d4fcd5e
AJ		 1440 /* Need to be careful with SvREFCNT_dec(), because that can have side
1441 * effects (due to closures). We must make sure that the new disposition
1442 * is in place before it is called.
1443 */
cbbf8932 1444 SV* to_dec = NULL;
e72dc28c 1445 STRLEN len;
2d4fcd5e
AJ		 1446#ifdef HAS_SIGPROCMASK
1447 sigset_t set, save;
1448 SV* save_sv;
1449#endif
eb578fdb 1450 const char *s = MgPV_const(mg,len);
7918f24d
NC		 1451
1452 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1453
748a9306 1454 if (*s == '_') {
84c7b88c 1455 if (memEQs(s, len, "__DIE__"))
3280af22 1456 svp = &PL_diehook;
84c7b88c 1457 else if (memEQs(s, len, "__WARN__")
38a124f0
NC		 1458 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1459 /* Merge the existing behaviours, which are as follows:
1460 magic_setsig, we always set svp to &PL_warnhook
1461 (hence we always change the warnings handler)
1462 For magic_clearsig, we don't change the warnings handler if it's
1463 set to the &PL_warnhook. */
3280af22 1464 svp = &PL_warnhook;
84c7b88c
BF		 1465 } else if (sv) {
1466 SV *tmp = sv_newmortal();
1467 Perl_croak(aTHX_ "No such hook: %s",
1468 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1469 }
748a9306 1470 i = 0;
38a124f0 1471 if (svp && *svp) {
9289f461
RGS		 1472 if (*svp != PERL_WARNHOOK_FATAL)
1473 to_dec = *svp;
cbbf8932 1474 *svp = NULL;
4633a7c4 1475 }
748a9306
LW		 1476 }
1477 else {
708854f2
NC		 1478 i = (I16)mg->mg_private;
1479 if (!i) {
84c7b88c 1480 i = whichsig_pvn(s, len); /* ...no, a brick */
58a26b12 1481 mg->mg_private = (U16)i;
708854f2 1482 }
86d86cad 1483 if (i <= 0) {
84c7b88c
BF		 1484 if (sv) {
1485 SV *tmp = sv_newmortal();
1486 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1487 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1488 }
748a9306
LW		 1489 return 0;
1490 }
2d4fcd5e
AJ		 1491#ifdef HAS_SIGPROCMASK
1492 /* Avoid having the signal arrive at a bad time, if possible. */
1493 sigemptyset(&set);
1494 sigaddset(&set,i);
1495 sigprocmask(SIG_BLOCK, &set, &save);
1496 ENTER;
9ff8e806 1497 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
2d4fcd5e
AJ		 1498 SAVEFREESV(save_sv);
1499 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1500#endif
1501 PERL_ASYNC_CHECK();
2e34cc90 1502#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1503 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1504#endif
23ada85b 1505#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1506 PL_sig_ignoring[i] = 0;
85b332e2 1507#endif
2e34cc90 1508#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1509 PL_sig_defaulting[i] = 0;
2e34cc90 1510#endif
2d4fcd5e 1511 to_dec = PL_psig_ptr[i];
38a124f0
NC		 1512 if (sv) {
1513 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1514 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
79fd3822
NC		 1515
1516 /* Signals don't change name during the program's execution, so once
1517 they're cached in the appropriate slot of PL_psig_name, they can
1518 stay there.
1519
1520 Ideally we'd find some way of making SVs at (C) compile time, or
1521 at least, doing most of the work. */
1522 if (!PL_psig_name[i]) {
1523 PL_psig_name[i] = newSVpvn(s, len);
1524 SvREADONLY_on(PL_psig_name[i]);
1525 }
38a124f0 1526 } else {
79fd3822 1527 SvREFCNT_dec(PL_psig_name[i]);
38a124f0
NC		 1528 PL_psig_name[i] = NULL;
1529 PL_psig_ptr[i] = NULL;
1530 }
748a9306 1531 }
38a124f0 1532 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
2d4fcd5e 1533 if (i) {
5c1546dc 1534 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e 1535 }
748a9306 1536 else
b37c2d43 1537 *svp = SvREFCNT_inc_simple_NN(sv);
38a124f0 1538 } else {
9dfa190b
NC		 1539 if (sv && SvOK(sv)) {
1540 s = SvPV_force(sv, len);
1541 } else {
1542 sv = NULL;
1543 }
84c7b88c 1544 if (sv && memEQs(s, len,"IGNORE")) {
9dfa190b 1545 if (i) {
23ada85b 1546#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
9dfa190b
NC		 1547 PL_sig_ignoring[i] = 1;
1548 (void)rsignal(i, PL_csighandlerp);
85b332e2 1549#else
9dfa190b 1550 (void)rsignal(i, (Sighandler_t) SIG_IGN);
85b332e2 1551#endif
9dfa190b 1552 }
2d4fcd5e 1553 }
84c7b88c 1554 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
9dfa190b 1555 if (i) {
2e34cc90 1556#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
9dfa190b
NC		 1557 PL_sig_defaulting[i] = 1;
1558 (void)rsignal(i, PL_csighandlerp);
2e34cc90 1559#else
9dfa190b 1560 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2e34cc90 1561#endif
9dfa190b
NC		 1562 }
1563 }
1564 else {
1565 /*
1566 * We should warn if HINT_STRICT_REFS, but without
1567 * access to a known hint bit in a known OP, we can't
1568 * tell whether HINT_STRICT_REFS is in force or not.
1569 */
1570 if (!strchr(s,':') && !strchr(s,'\''))
1571 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1572 SV_GMAGIC);
1573 if (i)
1574 (void)rsignal(i, PL_csighandlerp);
1575 else
1576 *svp = SvREFCNT_inc_simple_NN(sv);
136e0459 1577 }
748a9306 1578 }
9dfa190b 1579
2d4fcd5e
AJ		 1580#ifdef HAS_SIGPROCMASK
1581 if(i)
1582 LEAVE;
1583#endif
ef8d46e8 1584 SvREFCNT_dec(to_dec);
79072805
LW		 1585 return 0;
1586}
64ca3a65 1587#endif /* !PERL_MICRO */
79072805
LW		 1588
1589int
864dbfa3 1590Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1591{
97aff369 1592 dVAR;
7918f24d 1593 PERL_ARGS_ASSERT_MAGIC_SETISA;
8772537c 1594 PERL_UNUSED_ARG(sv);
e1a479c5 1595
89c14e2e 1596 /* Skip _isaelem because _isa will handle it shortly */
354b0578 1597 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
89c14e2e
BB		 1598 return 0;
1599
0e446081 1600 return magic_clearisa(NULL, mg);
463ee0b2
LW		 1601}
1602
0e446081 1603/* sv of NULL signifies that we're acting as magic_setisa. */
463ee0b2 1604int
52b45067
RD		 1605Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1606{
1607 dVAR;
1608 HV* stash;
1609
7918f24d
NC		 1610 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1611
52b45067 1612 /* Bail out if destruction is going on */
627364f1 1613 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
52b45067 1614
0e446081
NC		 1615 if (sv)
1616 av_clear(MUTABLE_AV(sv));
52b45067 1617
6624142a
FC		 1618 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1619 /* This occurs with setisa_elem magic, which calls this
1620 same function. */
1621 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1622
1623 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1624 SV **svp = AvARRAY((AV *)mg->mg_obj);
1625 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1626 while (items--) {
1627 stash = GvSTASH((GV *)*svp++);
1628 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1629 }
1630
1631 return 0;
1632 }
1633
52b45067 1634 stash = GvSTASH(
6624142a 1635 (const GV *)mg->mg_obj
52b45067
RD		 1636 );
1637
00169e2c
FC		 1638 /* The stash may have been detached from the symbol table, so check its
1639 name before doing anything. */
1640 if (stash && HvENAME_get(stash))
5562fa71 1641 mro_isa_changed_in(stash);
52b45067
RD		 1642
1643 return 0;
1644}
1645
1646int
864dbfa3 1647Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1648{
85fbaab2 1649 HV * const hv = MUTABLE_HV(LvTARG(sv));
6ff81951 1650 I32 i = 0;
7918f24d
NC		 1651
1652 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
8772537c 1653 PERL_UNUSED_ARG(mg);
7719e241 1654
6ff81951 1655 if (hv) {
497b47a8 1656 (void) hv_iterinit(hv);
ad64d0ec 1657 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1b95d04f 1658 i = HvUSEDKEYS(hv);
497b47a8
JH		 1659 else {
1660 while (hv_iternext(hv))
1661 i++;
1662 }
6ff81951
GS		 1663 }
1664
1665 sv_setiv(sv, (IV)i);
1666 return 0;
1667}
1668
1669int
864dbfa3 1670Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1671{
7918f24d 1672 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
8772537c 1673 PERL_UNUSED_ARG(mg);
946ec16e 1674 if (LvTARG(sv)) {
85fbaab2 1675 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
946ec16e 1676 }
1677 return 0;
ac27b0f5 1678}
946ec16e 1679
efaf3674
DM		 1680/*
1681=for apidoc magic_methcall
1682
1683Invoke a magic method (like FETCH).
1684
2baee27b
FC		 1685C<sv> and C<mg> are the tied thingy and the tie magic.
1686
1687C<meth> is the name of the method to call.
1688
1689C<argc> is the number of args (in addition to $self) to pass to the method.
1690
1691The C<flags> can be:
1692
1693 G_DISCARD invoke method with G_DISCARD flag and don't
1694 return a value
1695 G_UNDEF_FILL fill the stack with argc pointers to
1696 PL_sv_undef
1697
1698The arguments themselves are any values following the C<flags> argument.
efaf3674
DM		 1699
1700Returns the SV (if any) returned by the method, or NULL on failure.
1701
1702
1703=cut
1704*/
1705
1706SV*
36925d9e 1707Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
046b0c7d 1708 U32 argc, ...)
a0d0e21e 1709{
97aff369 1710 dVAR;
a0d0e21e 1711 dSP;
efaf3674 1712 SV* ret = NULL;
463ee0b2 1713
7918f24d
NC		 1714 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1715
efaf3674 1716 ENTER;
d1d7a15d
NC		 1717
1718 if (flags & G_WRITING_TO_STDERR) {
1719 SAVETMPS;
1720
1721 save_re_context();
1722 SAVESPTR(PL_stderrgv);
1723 PL_stderrgv = NULL;
1724 }
1725
efaf3674 1726 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1727 PUSHMARK(SP);
efaf3674 1728
67549bd2
NC		 1729 EXTEND(SP, argc+1);
1730 PUSHs(SvTIED_obj(sv, mg));
1731 if (flags & G_UNDEF_FILL) {
1732 while (argc--) {
efaf3674 1733 PUSHs(&PL_sv_undef);
93965878 1734 }
67549bd2 1735 } else if (argc > 0) {
046b0c7d
NC		 1736 va_list args;
1737 va_start(args, argc);
1738
1739 do {
1740 SV *const sv = va_arg(args, SV *);
1741 PUSHs(sv);
1742 } while (--argc);
1743
1744 va_end(args);
88e89b8a 1745 }
463ee0b2 1746 PUTBACK;
efaf3674 1747 if (flags & G_DISCARD) {
36925d9e 1748 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
efaf3674
DM		 1749 }
1750 else {
36925d9e 1751 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
efaf3674
DM		 1752 ret = *PL_stack_sp--;
1753 }
1754 POPSTACK;
d1d7a15d
NC		 1755 if (flags & G_WRITING_TO_STDERR)
1756 FREETMPS;
efaf3674
DM		 1757 LEAVE;
1758 return ret;
1759}
1760
efaf3674 1761/* wrapper for magic_methcall that creates the first arg */
463ee0b2 1762
efaf3674 1763STATIC SV*
36925d9e 1764S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
efaf3674
DM		 1765 int n, SV *val)
1766{
1767 dVAR;
1768 SV* arg1 = NULL;
1769
1770 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1771
1772 if (mg->mg_ptr) {
1773 if (mg->mg_len >= 0) {
db4b3a1d 1774 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
efaf3674
DM		 1775 }
1776 else if (mg->mg_len == HEf_SVKEY)
1777 arg1 = MUTABLE_SV(mg->mg_ptr);
1778 }
1779 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
db4b3a1d 1780 arg1 = newSViv((IV)(mg->mg_len));
efaf3674
DM		 1781 sv_2mortal(arg1);
1782 }
1783 if (!arg1) {
046b0c7d 1784 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
efaf3674 1785 }
046b0c7d 1786 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
946ec16e 1787}
1788
76e3520e 1789STATIC int
36925d9e 1790S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
a0d0e21e 1791{
efaf3674
DM		 1792 dVAR;
1793 SV* ret;
463ee0b2 1794
7918f24d
NC		 1795 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1796
efaf3674
DM		 1797 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1798 if (ret)
1799 sv_setsv(sv, ret);
a0d0e21e
LW		 1800 return 0;
1801}
463ee0b2 1802
a0d0e21e 1803int
864dbfa3 1804Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1805{
7918f24d
NC		 1806 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1807
fd69380d 1808 if (mg->mg_type == PERL_MAGIC_tiedelem)
a0d0e21e 1809 mg->mg_flags |= MGf_GSKIP;
36925d9e 1810 magic_methpack(sv,mg,SV_CONST(FETCH));
463ee0b2
LW		 1811 return 0;
1812}
1813
1814int
864dbfa3 1815Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1816{
efaf3674 1817 dVAR;
b112cff9
DM		 1818 MAGIC *tmg;
1819 SV *val;
7918f24d
NC		 1820
1821 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1822
b112cff9
DM		 1823 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1824 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1825 * public flags indicate its value based on copying from $val. Doing
1826 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1827 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1828 * wrong if $val happened to be tainted, as sv hasn't got magic
1829 * enabled, even though taint magic is in the chain. In which case,
1830 * fake up a temporary tainted value (this is easier than temporarily
1831 * re-enabling magic on sv). */
1832
284167a5 1833 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
b112cff9
DM		 1834 && (tmg->mg_len & 1))
1835 {
1836 val = sv_mortalcopy(sv);
1837 SvTAINTED_on(val);
1838 }
1839 else
1840 val = sv;
1841
36925d9e 1842 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
463ee0b2
LW		 1843 return 0;
1844}
1845
1846int
864dbfa3 1847Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1848{
7918f24d
NC		 1849 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1850
4c13be3f 1851 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
36925d9e 1852 return magic_methpack(sv,mg,SV_CONST(DELETE));
a0d0e21e 1853}
463ee0b2 1854
93965878
NIS		 1855
1856U32
864dbfa3 1857Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1858{
efaf3674 1859 dVAR;
22846ab4 1860 I32 retval = 0;
efaf3674 1861 SV* retsv;
93965878 1862
7918f24d
NC		 1863 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1864
36925d9e 1865 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
efaf3674
DM		 1866 if (retsv) {
1867 retval = SvIV(retsv)-1;
22846ab4
AB		 1868 if (retval < -1)
1869 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
93965878 1870 }
22846ab4 1871 return (U32) retval;
93965878
NIS		 1872}
1873
cea2e8a9
GS		 1874int
1875Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1876{
efaf3674 1877 dVAR;
463ee0b2 1878
7918f24d
NC		 1879 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1880
36925d9e 1881 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
463ee0b2
LW		 1882 return 0;
1883}
1884
1885int
864dbfa3 1886Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1887{
efaf3674
DM		 1888 dVAR;
1889 SV* ret;
463ee0b2 1890
7918f24d
NC		 1891 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1892
36925d9e
RZ		 1893 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
1894 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
efaf3674
DM		 1895 if (ret)
1896 sv_setsv(key,ret);
79072805
LW		 1897 return 0;
1898}
1899
1900int
1146e912 1901Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
a0d0e21e 1902{
7918f24d
NC		 1903 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1904
36925d9e 1905 return magic_methpack(sv,mg,SV_CONST(EXISTS));
ac27b0f5 1906}
a0d0e21e 1907
a3bcc51e
TP		 1908SV *
1909Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1910{
efaf3674 1911 dVAR;
5fcbf73d 1912 SV *retval;
ad64d0ec
NC		 1913 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1914 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
a3bcc51e 1915
7918f24d
NC		 1916 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1917
a3bcc51e
TP		 1918 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1919 SV *key;
bfcb3514 1920 if (HvEITER_get(hv))
a3bcc51e
TP		 1921 /* we are in an iteration so the hash cannot be empty */
1922 return &PL_sv_yes;
1923 /* no xhv_eiter so now use FIRSTKEY */
1924 key = sv_newmortal();
ad64d0ec 1925 magic_nextpack(MUTABLE_SV(hv), mg, key);
bfcb3514 1926 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP		 1927 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1928 }
1929
1930 /* there is a SCALAR method that we can call */
36925d9e 1931 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
efaf3674 1932 if (!retval)
5fcbf73d 1933 retval = &PL_sv_undef;
a3bcc51e
TP		 1934 return retval;
1935}
1936
a0d0e21e 1937int
864dbfa3 1938Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 1939{
97aff369 1940 dVAR;
8772537c
AL		 1941 GV * const gv = PL_DBline;
1942 const I32 i = SvTRUE(sv);
1943 SV ** const svp = av_fetch(GvAV(gv),
01b8bcb7 1944 atoi(MgPV_nolen_const(mg)), FALSE);
7918f24d
NC		 1945
1946 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1947
8772537c
AL		 1948 if (svp && SvIOKp(*svp)) {
1949 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1950 if (o) {
7bbbc3c0
NC		 1951#ifdef PERL_DEBUG_READONLY_OPS
1952 Slab_to_rw(OpSLAB(o));
1953#endif
8772537c
AL		 1954 /* set or clear breakpoint in the relevant control op */
1955 if (i)
1956 o->op_flags |= OPf_SPECIAL;
1957 else
1958 o->op_flags &= ~OPf_SPECIAL;
7bbbc3c0
NC		 1959#ifdef PERL_DEBUG_READONLY_OPS
1960 Slab_to_ro(OpSLAB(o));
1961#endif
8772537c 1962 }
5df8de69 1963 }
79072805
LW		 1964 return 0;
1965}
1966
1967int
8772537c 1968Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
79072805 1969{
97aff369 1970 dVAR;
502c6561 1971 AV * const obj = MUTABLE_AV(mg->mg_obj);
7918f24d
NC		 1972
1973 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1974
83bf042f 1975 if (obj) {
e1dccc0d 1976 sv_setiv(sv, AvFILL(obj));
83bf042f
NC		 1977 } else {
1978 SvOK_off(sv);
1979 }
79072805
LW		 1980 return 0;
1981}
1982
1983int
864dbfa3 1984Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1985{
97aff369 1986 dVAR;
502c6561 1987 AV * const obj = MUTABLE_AV(mg->mg_obj);
7918f24d
NC		 1988
1989 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1990
83bf042f 1991 if (obj) {
e1dccc0d 1992 av_fill(obj, SvIV(sv));
83bf042f 1993 } else {
a2a5de95
NC		 1994 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1995 "Attempt to set length of freed array");
83bf042f
NC		 1996 }
1997 return 0;
1998}
1999
2000int
83f29afa
VP		 2001Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2002{
2003 dVAR;
2004
2005 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2006 PERL_UNUSED_ARG(sv);
2007
2008 /* Reset the iterator when the array is cleared */
3565fbf3
VP		 2009#if IVSIZE == I32SIZE
2010 *((IV *) &(mg->mg_len)) = 0;
2011#else
83f29afa
VP		 2012 if (mg->mg_ptr)
2013 *((IV *) mg->mg_ptr) = 0;
3565fbf3 2014#endif
83f29afa
VP		 2015
2016 return 0;
2017}
2018
2019int
83bf042f
NC		 2020Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2021{
97aff369 2022 dVAR;
7918f24d
NC		 2023
2024 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
53c1dcc0 2025 PERL_UNUSED_ARG(sv);
7918f24d 2026
94f3782b
DM		 2027 /* during global destruction, mg_obj may already have been freed */
2028 if (PL_in_clean_all)
1ea47f64 2029 return 0;
94f3782b 2030
83bf042f
NC		 2031 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2032
2033 if (mg) {
2034 /* arylen scalar holds a pointer back to the array, but doesn't own a
2035 reference. Hence the we (the array) are about to go away with it
2036 still pointing at us. Clear its pointer, else it would be pointing
2037 at free memory. See the comment in sv_magic about reference loops,
2038 and why it can't own a reference to us. */
2039 mg->mg_obj = 0;
2040 }
a0d0e21e
LW		 2041 return 0;
2042}
2043
2044int
864dbfa3 2045Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 2046{
97aff369 2047 dVAR;
16eb5365 2048 SV* const lsv = LvTARG(sv);
7918f24d
NC		 2049
2050 PERL_ARGS_ASSERT_MAGIC_GETPOS;
16eb5365 2051 PERL_UNUSED_ARG(mg);
ac27b0f5 2052
a0d0e21e 2053 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
3881461a
AL		 2054 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2055 if (found && found->mg_len >= 0) {
2056 I32 i = found->mg_len;
7e2040f0 2057 if (DO_UTF8(lsv))
a0ed51b3 2058 sv_pos_b2u(lsv, &i);
e1dccc0d 2059 sv_setiv(sv, i);
a0d0e21e
LW		 2060 return 0;
2061 }
2062 }
0c34ef67 2063 SvOK_off(sv);
a0d0e21e
LW		 2064 return 0;
2065}
2066
2067int
864dbfa3 2068Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 2069{
97aff369 2070 dVAR;
16eb5365 2071 SV* const lsv = LvTARG(sv);
a0d0e21e
LW		 2072 SSize_t pos;
2073 STRLEN len;
c00206c8 2074 STRLEN ulen = 0;
53d44271 2075 MAGIC* found;
aec43834 2076 const char *s;
a0d0e21e 2077
7918f24d 2078 PERL_ARGS_ASSERT_MAGIC_SETPOS;
16eb5365 2079 PERL_UNUSED_ARG(mg);
ac27b0f5 2080
a0d0e21e 2081 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
3881461a
AL		 2082 found = mg_find(lsv, PERL_MAGIC_regex_global);
2083 else
2084 found = NULL;
2085 if (!found) {
a0d0e21e
LW		 2086 if (!SvOK(sv))
2087 return 0;
d83f0a82
NC		 2088#ifdef PERL_OLD_COPY_ON_WRITE
2089 if (SvIsCOW(lsv))
2090 sv_force_normal_flags(lsv, 0);
2091#endif
3881461a 2092 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
53d44271 2093 NULL, 0);
a0d0e21e
LW		 2094 }
2095 else if (!SvOK(sv)) {
3881461a 2096 found->mg_len = -1;
a0d0e21e
LW		 2097 return 0;
2098 }
aec43834 2099 s = SvPV_const(lsv, len);
a0d0e21e 2100
e1dccc0d 2101 pos = SvIV(sv);
a0ed51b3 2102
7e2040f0 2103 if (DO_UTF8(lsv)) {
aec43834 2104 ulen = sv_or_pv_len_utf8(lsv, s, len);
a0ed51b3
LW		 2105 if (ulen)
2106 len = ulen;
a0ed51b3
LW		 2107 }
2108
a0d0e21e
LW		 2109 if (pos < 0) {
2110 pos += len;
2111 if (pos < 0)
2112 pos = 0;
2113 }
eb160463 2114 else if (pos > (SSize_t)len)
a0d0e21e 2115 pos = len;
a0ed51b3
LW		 2116
2117 if (ulen) {
4ddea69a 2118 pos = sv_or_pv_pos_u2b(lsv, s, pos, 0);
a0ed51b3 2119 }
727405f8 2120
3881461a
AL		 2121 found->mg_len = pos;
2122 found->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 2123
79072805
LW		 2124 return 0;
2125}
2126
2127int
864dbfa3 2128Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS		 2129{
2130 STRLEN len;
35a4481c 2131 SV * const lsv = LvTARG(sv);
b83604b4 2132 const char * const tmps = SvPV_const(lsv,len);
777f7c56
EB		 2133 STRLEN offs = LvTARGOFF(sv);
2134 STRLEN rem = LvTARGLEN(sv);
83f78d1a
FC		 2135 const bool negoff = LvFLAGS(sv) & 1;
2136 const bool negrem = LvFLAGS(sv) & 2;
7918f24d
NC		 2137
2138 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
8772537c 2139 PERL_UNUSED_ARG(mg);
6ff81951 2140
83f78d1a 2141 if (!translate_substr_offsets(
4ddea69a 2142 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
83f78d1a
FC		 2143 negoff ? -(IV)offs : (IV)offs, !negoff,
2144 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2145 )) {
2146 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2147 sv_setsv_nomg(sv, &PL_sv_undef);
2148 return 0;
2149 }
2150
9aa983d2 2151 if (SvUTF8(lsv))
4ddea69a 2152 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
1c900557 2153 sv_setpvn(sv, tmps + offs, rem);
9aa983d2 2154 if (SvUTF8(lsv))
2ef4b674 2155 SvUTF8_on(sv);
6ff81951
GS		 2156 return 0;
2157}
2158
2159int
864dbfa3 2160Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 2161{
97aff369 2162 dVAR;
83f78d1a 2163 STRLEN len, lsv_len, oldtarglen, newtarglen;
5fcbf73d 2164 const char * const tmps = SvPV_const(sv, len);
dd374669 2165 SV * const lsv = LvTARG(sv);
777f7c56
EB		 2166 STRLEN lvoff = LvTARGOFF(sv);
2167 STRLEN lvlen = LvTARGLEN(sv);
83f78d1a
FC		 2168 const bool negoff = LvFLAGS(sv) & 1;
2169 const bool neglen = LvFLAGS(sv) & 2;
7918f24d
NC		 2170
2171 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
8772537c 2172 PERL_UNUSED_ARG(mg);
075a4a2b 2173
a74fb2cd
FC		 2174 SvGETMAGIC(lsv);
2175 if (SvROK(lsv))
2176 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2177 "Attempt to use reference as lvalue in substr"
2178 );
fc061ed8
FC		 2179 SvPV_force_nomg(lsv,lsv_len);
2180 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
83f78d1a
FC		 2181 if (!translate_substr_offsets(
2182 lsv_len,
2183 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2184 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2185 ))
2186 Perl_croak(aTHX_ "substr outside of string");
2187 oldtarglen = lvlen;
1aa99e6b 2188 if (DO_UTF8(sv)) {
73a087f0 2189 sv_utf8_upgrade_nomg(lsv);
d931b1be 2190 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
a74fb2cd 2191 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
7a385470 2192 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
9aa983d2
JH		 2193 SvUTF8_on(lsv);
2194 }
0d336106 2195 else if (SvUTF8(lsv)) {
5fcbf73d 2196 const char *utf8;
d931b1be 2197 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
83f78d1a 2198 newtarglen = len;
5fcbf73d 2199 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
a74fb2cd 2200 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
5fcbf73d 2201 Safefree(utf8);
1aa99e6b 2202 }
b76f3ce2 2203 else {
a74fb2cd 2204 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
83f78d1a 2205 newtarglen = len;
b76f3ce2 2206 }
83f78d1a
FC		 2207 if (!neglen) LvTARGLEN(sv) = newtarglen;
2208 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
b76f3ce2 2209
79072805
LW		 2210 return 0;
2211}
2212
2213int
864dbfa3 2214Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2215{
97aff369 2216 dVAR;
7918f24d
NC		 2217
2218 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
8772537c 2219 PERL_UNUSED_ARG(sv);
9a9b5ec9
DM		 2220#ifdef NO_TAINT_SUPPORT
2221 PERL_UNUSED_ARG(mg);
2222#endif
7918f24d 2223
27cc343c 2224 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
463ee0b2
LW		 2225 return 0;
2226}
2227
2228int
864dbfa3 2229Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2230{
97aff369 2231 dVAR;
7918f24d
NC		 2232
2233 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
8772537c 2234 PERL_UNUSED_ARG(sv);
7918f24d 2235
b01e650a 2236 /* update taint status */
284167a5 2237 if (TAINT_get)
b01e650a
DM		 2238 mg->mg_len |= 1;
2239 else
2240 mg->mg_len &= ~1;
463ee0b2
LW		 2241 return 0;
2242}
2243
2244int
864dbfa3 2245Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 2246{
35a4481c 2247 SV * const lsv = LvTARG(sv);
7918f24d
NC		 2248
2249 PERL_ARGS_ASSERT_MAGIC_GETVEC;
8772537c 2250 PERL_UNUSED_ARG(mg);
6ff81951 2251
6136c704
AL		 2252 if (lsv)
2253 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2254 else
0c34ef67 2255 SvOK_off(sv);
6ff81951 2256
6ff81951
GS		 2257 return 0;
2258}
2259
2260int
864dbfa3 2261Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 2262{
7918f24d 2263 PERL_ARGS_ASSERT_MAGIC_SETVEC;
8772537c 2264 PERL_UNUSED_ARG(mg);
79072805
LW		 2265 do_vecset(sv); /* XXX slurp this routine */
2266 return 0;
2267}
2268
2269int
864dbfa3 2270Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 2271{
97aff369 2272 dVAR;
a0714e2c 2273 SV *targ = NULL;
7918f24d
NC		 2274
2275 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2276
5f05dabc 2277 if (LvTARGLEN(sv)) {
68dc0745 2278 if (mg->mg_obj) {
8772537c 2279 SV * const ahv = LvTARG(sv);
85fbaab2 2280 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
6d822dc4
MS		 2281 if (he)
2282 targ = HeVAL(he);
68dc0745 2283 }
2284 else {
502c6561 2285 AV *const av = MUTABLE_AV(LvTARG(sv));
68dc0745 2286 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2287 targ = AvARRAY(av)[LvTARGOFF(sv)];
2288 }
46da273f 2289 if (targ && (targ != &PL_sv_undef)) {
68dc0745 2290 /* somebody else defined it for us */
2291 SvREFCNT_dec(LvTARG(sv));
b37c2d43 2292 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
68dc0745 2293 LvTARGLEN(sv) = 0;
2294 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2295 mg->mg_obj = NULL;
68dc0745 2296 mg->mg_flags &= ~MGf_REFCOUNTED;
2297 }
5f05dabc 2298 }
71be2cbc 2299 else
2300 targ = LvTARG(sv);
3280af22 2301 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc 2302 return 0;
2303}
2304
2305int
864dbfa3 2306Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 2307{
7918f24d 2308 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
8772537c 2309 PERL_UNUSED_ARG(mg);
71be2cbc 2310 if (LvTARGLEN(sv))
68dc0745 2311 vivify_defelem(sv);
2312 if (LvTARG(sv)) {
5f05dabc 2313 sv_setsv(LvTARG(sv), sv);
68dc0745 2314 SvSETMAGIC(LvTARG(sv));
2315 }
5f05dabc 2316 return 0;
2317}
2318
71be2cbc 2319void
864dbfa3 2320Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2321{
97aff369 2322 dVAR;
74e13ce4 2323 MAGIC *mg;
a0714e2c 2324 SV *value = NULL;
71be2cbc 2325
7918f24d
NC		 2326 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2327
14befaf4 2328 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 2329 return;
68dc0745 2330 if (mg->mg_obj) {
8772537c 2331 SV * const ahv = LvTARG(sv);
85fbaab2 2332 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
6d822dc4
MS		 2333 if (he)
2334 value = HeVAL(he);
3280af22 2335 if (!value || value == &PL_sv_undef)
be2597df 2336 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
71be2cbc 2337 }
68dc0745 2338 else {
502c6561 2339 AV *const av = MUTABLE_AV(LvTARG(sv));
5aabfad6 2340 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
a0714e2c 2341 LvTARG(sv) = NULL; /* array can't be extended */
68dc0745 2342 else {
d4c19fe8 2343 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 2344 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 2345 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745 2346 }
2347 }
b37c2d43 2348 SvREFCNT_inc_simple_void(value);
68dc0745 2349 SvREFCNT_dec(LvTARG(sv));
2350 LvTARG(sv) = value;
71be2cbc 2351 LvTARGLEN(sv) = 0;
68dc0745 2352 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2353 mg->mg_obj = NULL;
68dc0745 2354 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc 2355}
2356
2357int
864dbfa3 2358Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2359{
7918f24d 2360 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
5648c0ae
DM		 2361 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2362 return 0;
810b8aa5
GS		 2363}
2364
2365int
864dbfa3 2366Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2367{
7918f24d 2368 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
96a5add6 2369 PERL_UNUSED_CONTEXT;
0177730e 2370 PERL_UNUSED_ARG(sv);
565764a8 2371 mg->mg_len = -1;
93a17b20
LW		 2372 return 0;
2373}
2374
2375int
864dbfa3 2376Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2377{
35a4481c 2378 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805 2379
7918f24d
NC		 2380 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2381
79072805 2382 if (uf && uf->uf_set)
24f81a43 2383 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW		 2384 return 0;
2385}
2386
c277df42 2387int
faf82a0b
AE		 2388Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2389{
488344d2 2390 const char type = mg->mg_type;
7918f24d
NC		 2391
2392 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2393
488344d2
NC		 2394 if (type == PERL_MAGIC_qr) {
2395 } else if (type == PERL_MAGIC_bm) {
2396 SvTAIL_off(sv);
2397 SvVALID_off(sv);
2398 } else {
2399 assert(type == PERL_MAGIC_fm);
488344d2
NC		 2400 }
2401 return sv_unmagic(sv, type);
faf82a0b
AE		 2402}
2403
7a4c00b4 2404#ifdef USE_LOCALE_COLLATE
79072805 2405int
864dbfa3 2406Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69 2407{
7918f24d
NC		 2408 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2409
bbce6d69 2410 /*
838b5b74 2411 * RenE<eacute> Descartes said "I think not."
bbce6d69 2412 * and vanished with a faint plop.
2413 */
96a5add6 2414 PERL_UNUSED_CONTEXT;
8772537c 2415 PERL_UNUSED_ARG(sv);
7a4c00b4 2416 if (mg->mg_ptr) {
2417 Safefree(mg->mg_ptr);
2418 mg->mg_ptr = NULL;
565764a8 2419 mg->mg_len = -1;
7a4c00b4 2420 }
bbce6d69 2421 return 0;
2422}
7a4c00b4 2423#endif /* USE_LOCALE_COLLATE */
bbce6d69 2424
7e8c5dac
HS		 2425/* Just clear the UTF-8 cache data. */
2426int
2427Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2428{
7918f24d 2429 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
96a5add6 2430 PERL_UNUSED_CONTEXT;
8772537c 2431 PERL_UNUSED_ARG(sv);
7e8c5dac 2432 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
3881461a 2433 mg->mg_ptr = NULL;
7e8c5dac
HS		 2434 mg->mg_len = -1; /* The mg_len holds the len cache. */
2435 return 0;
2436}
2437
bbce6d69 2438int
864dbfa3 2439Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2440{
97aff369 2441 dVAR;
eb578fdb
KW		 2442 const char *s;
2443 I32 paren;
2444 const REGEXP * rx;
2fdbfb4d 2445 const char * const remaining = mg->mg_ptr + 1;
79072805 2446 I32 i;
8990e307 2447 STRLEN len;
125b9982 2448 MAGIC *tmg;
2fdbfb4d 2449
7918f24d
NC		 2450 PERL_ARGS_ASSERT_MAGIC_SET;
2451
79072805 2452 switch (*mg->mg_ptr) {
2fdbfb4d
AB		 2453 case '\015': /* $^MATCH */
2454 if (strEQ(remaining, "ATCH"))
2455 goto do_match;
2456 case '`': /* ${^PREMATCH} caught below */
2457 do_prematch:
f1b875a0 2458 paren = RX_BUFF_IDX_PREMATCH;
2fdbfb4d
AB		 2459 goto setparen;
2460 case '\'': /* ${^POSTMATCH} caught below */
2461 do_postmatch:
f1b875a0 2462 paren = RX_BUFF_IDX_POSTMATCH;
2fdbfb4d
AB		 2463 goto setparen;
2464 case '&':
2465 do_match:
f1b875a0 2466 paren = RX_BUFF_IDX_FULLMATCH;
2fdbfb4d
AB		 2467 goto setparen;
2468 case '1': case '2': case '3': case '4':
2469 case '5': case '6': case '7': case '8': case '9':
104a8018 2470 paren = atoi(mg->mg_ptr);
2fdbfb4d 2471 setparen:
1e05feb3 2472 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9bad346 2473 setparen_got_rx:
2fdbfb4d 2474 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
1e05feb3 2475 } else {
2fdbfb4d
AB		 2476 /* Croak with a READONLY error when a numbered match var is
2477 * set without a previous pattern match. Unless it's C<local $1>
2478 */
d9bad346 2479 croakparen:
2fdbfb4d 2480 if (!PL_localizing) {
cb077ed2 2481 Perl_croak_no_modify();
2fdbfb4d
AB		 2482 }
2483 }
9b9e0be4 2484 break;
748a9306 2485 case '\001': /* ^A */
f2da823f
FC		 2486 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2487 else SvOK_off(PL_bodytarget);
64eff8b7
DM		 2488 FmLINES(PL_bodytarget) = 0;
2489 if (SvPOK(PL_bodytarget)) {
2490 char *s = SvPVX(PL_bodytarget);
2491 while ( ((s = strchr(s, '\n'))) ) {
2492 FmLINES(PL_bodytarget)++;
2493 s++;
2494 }
2495 }
125b9982 2496 /* mg_set() has temporarily made sv non-magical */
284167a5 2497 if (TAINTING_get) {
125b9982
NT		 2498 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2499 SvTAINTED_on(PL_bodytarget);
2500 else
2501 SvTAINTED_off(PL_bodytarget);
2502 }
748a9306 2503 break;
49460fe6 2504 case '\003': /* ^C */
f2338a2e 2505 PL_minus_c = cBOOL(SvIV(sv));
49460fe6
NIS		 2506 break;
2507
79072805 2508 case '\004': /* ^D */
b4ab917c 2509#ifdef DEBUGGING
b83604b4 2510 s = SvPV_nolen_const(sv);
ddcf8bc1 2511 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
a58fb6f9
CS		 2512 if (DEBUG_x_TEST || DEBUG_B_TEST)
2513 dump_all_perl(!DEBUG_B_TEST);
b4ab917c 2514#else
38ab35f8 2515 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
b4ab917c 2516#endif
79072805 2517 break;
28f23441 2518 case '\005': /* ^E */
d0063567 2519 if (*(mg->mg_ptr+1) == '\0') {
e37778c2 2520#ifdef VMS
38ab35f8 2521 set_vaxc_errno(SvIV(sv));
e37778c2
NC		 2522#else
2523# ifdef WIN32
d0063567 2524 SetLastError( SvIV(sv) );
e37778c2
NC		 2525# else
2526# ifdef OS2
38ab35f8 2527 os2_setsyserrno(SvIV(sv));
e37778c2 2528# else
d0063567 2529 /* will anyone ever use this? */
38ab35f8 2530 SETERRNO(SvIV(sv), 4);
048c1ddf
IZ		 2531# endif
2532# endif
22fae026 2533#endif
d0063567
DK		 2534 }
2535 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
ef8d46e8 2536 SvREFCNT_dec(PL_encoding);
d0063567
DK		 2537 if (SvOK(sv) || SvGMAGICAL(sv)) {
2538 PL_encoding = newSVsv(sv);
2539 }
2540 else {
a0714e2c 2541 PL_encoding = NULL;
d0063567
DK		 2542 }
2543 }
2544 break;
79072805 2545 case '\006': /* ^F */
38ab35f8 2546 PL_maxsysfd = SvIV(sv);
79072805 2547 break;
a0d0e21e 2548 case '\010': /* ^H */
38ab35f8 2549 PL_hints = SvIV(sv);
a0d0e21e 2550 break;
9d116dd7 2551 case '\011': /* ^I */ /* NOT \t in EBCDIC */
43c5f42d 2552 Safefree(PL_inplace);
bd61b366 2553 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
da78da6e 2554 break;
d9bad346
FC		 2555 case '\016': /* ^N */
2556 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2557 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2558 goto croakparen;
28f23441 2559 case '\017': /* ^O */
ac27b0f5 2560 if (*(mg->mg_ptr+1) == '\0') {
43c5f42d 2561 Safefree(PL_osname);
bd61b366 2562 PL_osname = NULL;
3511154c
DM		 2563 if (SvOK(sv)) {
2564 TAINT_PROPER("assigning to $^O");
2e0de35c 2565 PL_osname = savesvpv(sv);
3511154c 2566 }
ac27b0f5
NIS		 2567 }
2568 else if (strEQ(mg->mg_ptr, "\017PEN")) {
8b850bd5
NC		 2569 STRLEN len;
2570 const char *const start = SvPV(sv, len);
b54fc2b6 2571 const char *out = (const char*)memchr(start, '\0', len);
8b850bd5 2572 SV *tmp;
8b850bd5
NC		 2573
2574
2575 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
f747ebd6 2576 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
8b850bd5
NC		 2577
2578 /* Opening for input is more common than opening for output, so
2579 ensure that hints for input are sooner on linked list. */
59cd0e26 2580 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
f747ebd6
Z		 2581 SvUTF8(sv))
2582 : newSVpvs_flags("", SvUTF8(sv));
2583 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2584 mg_set(tmp);
8b850bd5 2585
f747ebd6
Z		 2586 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2587 SvUTF8(sv));
2588 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2589 mg_set(tmp);
ac27b0f5 2590 }
28f23441 2591 break;
79072805 2592 case '\020': /* ^P */
2fdbfb4d
AB		 2593 if (*remaining == '\0') { /* ^P */
2594 PL_perldb = SvIV(sv);
2595 if (PL_perldb && !PL_DBsingle)
2596 init_debugger();
2597 break;
2598 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2599 goto do_prematch;
2600 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2601 goto do_postmatch;
2602 }
9b9e0be4 2603 break;
79072805 2604 case '\024': /* ^T */
88e89b8a 2605#ifdef BIG_TIME
6b88bc9c 2606 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2607#else
38ab35f8 2608 PL_basetime = (Time_t)SvIV(sv);
88e89b8a 2609#endif
79072805 2610 break;
e07ea26a
NC		 2611 case '\025': /* ^UTF8CACHE */
2612 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2613 PL_utf8cache = (signed char) sv_2iv(sv);
2614 }
2615 break;
fde18df1 2616 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH		 2617 if (*(mg->mg_ptr+1) == '\0') {
2618 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
38ab35f8 2619 i = SvIV(sv);
ac27b0f5 2620 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2621 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2622 }
599cee73 2623 }
0a378802 2624 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2625 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
7e4f0450
FC		 2626 if (!SvPOK(sv)) {
2627 PL_compiling.cop_warnings = pWARN_STD;
d775746e
GS		 2628 break;
2629 }
f4fc7782 2630 {
b5477537 2631 STRLEN len, i;
d3a7d8c7 2632 int accumulate = 0 ;
f4fc7782 2633 int any_fatals = 0 ;
b83604b4 2634 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH		 2635 for (i = 0 ; i < len ; ++i) {
2636 accumulate |= ptr[i] ;
2637 any_fatals |= (ptr[i] & 0xAA) ;
2638 }
4243c432
NC		 2639 if (!accumulate) {
2640 if (!specialWARN(PL_compiling.cop_warnings))
2641 PerlMemShared_free(PL_compiling.cop_warnings);
2642 PL_compiling.cop_warnings = pWARN_NONE;
2643 }
72dc9ed5 2644 /* Yuck. I can't see how to abstract this: */
2f3f0b56
KW		 2645 else if (isWARN_on(
2646 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2647 WARN_ALL)
2648 && !any_fatals)
2649 {
4243c432
NC		 2650 if (!specialWARN(PL_compiling.cop_warnings))
2651 PerlMemShared_free(PL_compiling.cop_warnings);
f4fc7782
JH		 2652 PL_compiling.cop_warnings = pWARN_ALL;
2653 PL_dowarn |= G_WARN_ONCE ;
727405f8 2654 }
d3a7d8c7 2655 else {
72dc9ed5
NC		 2656 STRLEN len;
2657 const char *const p = SvPV_const(sv, len);
2658
2659 PL_compiling.cop_warnings
8ee4cf24 2660 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
72dc9ed5
NC		 2661 p, len);
2662
d3a7d8c7
GS		 2663 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2664 PL_dowarn |= G_WARN_ONCE ;
2665 }
f4fc7782 2666
d3a7d8c7 2667 }
4438c4b7 2668 }
971a9dd3 2669 }
79072805
LW		 2670 break;
2671 case '.':
3280af22
NIS		 2672 if (PL_localizing) {
2673 if (PL_localizing == 1)
7766f137 2674 SAVESPTR(PL_last_in_gv);
748a9306 2675 }
3280af22 2676 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2677 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW		 2678 break;
2679 case '^':
acbe1b9d
FC		 2680 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2681 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2682 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW		 2683 break;
2684 case '~':
acbe1b9d
FC		 2685 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2686 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2687 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW		 2688 break;
2689 case '=':
acbe1b9d 2690 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW		 2691 break;
2692 case '-':
acbe1b9d
FC		 2693 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2694 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
099be4f1 2695 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW		 2696 break;
2697 case '%':
acbe1b9d 2698 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW		 2699 break;
2700 case '|':
4b65379b 2701 {
099be4f1 2702 IO * const io = GvIO(PL_defoutgv);
720f287d
AB		 2703 if(!io)
2704 break;
38ab35f8 2705 if ((SvIV(sv)) == 0)
4b65379b
CS		 2706 IoFLAGS(io) &= ~IOf_FLUSH;
2707 else {
2708 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2709 PerlIO *ofp = IoOFP(io);
2710 if (ofp)
2711 (void)PerlIO_flush(ofp);
2712 IoFLAGS(io) |= IOf_FLUSH;
2713 }
2714 }
79072805
LW		 2715 }
2716 break;
79072805 2717 case '/':
3280af22 2718 SvREFCNT_dec(PL_rs);
8bfdd7d9 2719 PL_rs = newSVsv(sv);
79072805
LW		 2720 break;
2721 case '\\':
ef8d46e8 2722 SvREFCNT_dec(PL_ors_sv);
6bc2995b 2723 if (SvOK(sv)) {
7889fe52 2724 PL_ors_sv = newSVsv(sv);
009c130f 2725 }
e3c19b7b 2726 else {
a0714e2c 2727 PL_ors_sv = NULL;
e3c19b7b 2728 }
79072805 2729 break;
7d69d4a6
FC		 2730 case '[':
2731 if (SvIV(sv) != 0)
2732 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2733 break;
79072805 2734 case '?':
ff0cee69 2735#ifdef COMPLEX_STATUS
6b88bc9c 2736 if (PL_localizing == 2) {
41cb7b2b 2737 SvUPGRADE(sv, SVt_PVLV);
6b88bc9c
GS		 2738 PL_statusvalue = LvTARGOFF(sv);
2739 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69 2740 }
2741 else
2742#endif
2743#ifdef VMSISH_STATUS
2744 if (VMSISH_STATUS)
fb38d079 2745 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
ff0cee69 2746 else
2747#endif
38ab35f8 2748 STATUS_UNIX_EXIT_SET(SvIV(sv));
79072805
LW		 2749 break;
2750 case '!':
93189314
JH		 2751 {
2752#ifdef VMS
2753# define PERL_VMS_BANG vaxc$errno
2754#else
2755# define PERL_VMS_BANG 0
2756#endif
91487cfc 2757 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH		 2758 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2759 }
79072805
LW		 2760 break;
2761 case '<':
985213f2 2762 {
dfff4baf 2763 const Uid_t new_uid = SvUID(sv);
985213f2 2764 PL_delaymagic_uid = new_uid;
3280af22
NIS		 2765 if (PL_delaymagic) {
2766 PL_delaymagic |= DM_RUID;
79072805
LW		 2767 break; /* don't do magic till later */
2768 }
2769#ifdef HAS_SETRUID
dfff4baf 2770 (void)setruid(new_uid);
79072805
LW		 2771#else
2772#ifdef HAS_SETREUID
dfff4baf 2773 (void)setreuid(new_uid, (Uid_t)-1);
748a9306 2774#else
85e6fe83 2775#ifdef HAS_SETRESUID
dfff4baf 2776 (void)setresuid(new_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2777#else
985213f2 2778 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
75870ed3 2779#ifdef PERL_DARWIN
2780 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
985213f2 2781 if (new_uid != 0 && PerlProc_getuid() == 0)
75870ed3 2782 (void)PerlProc_setuid(0);
2783#endif
985213f2 2784 (void)PerlProc_setuid(new_uid);
75870ed3 2785 } else {
cea2e8a9 2786 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2787 }
79072805
LW		 2788#endif
2789#endif
85e6fe83 2790#endif
79072805 2791 break;
985213f2 2792 }
79072805 2793 case '>':
985213f2 2794 {
dfff4baf 2795 const Uid_t new_euid = SvUID(sv);
985213f2 2796 PL_delaymagic_euid = new_euid;
3280af22
NIS		 2797 if (PL_delaymagic) {
2798 PL_delaymagic |= DM_EUID;
79072805
LW		 2799 break; /* don't do magic till later */
2800 }
2801#ifdef HAS_SETEUID
dfff4baf 2802 (void)seteuid(new_euid);
79072805
LW		 2803#else
2804#ifdef HAS_SETREUID
dfff4baf 2805 (void)setreuid((Uid_t)-1, new_euid);
85e6fe83
LW		 2806#else
2807#ifdef HAS_SETRESUID
dfff4baf 2808 (void)setresuid((Uid_t)-1, new_euid, (Uid_t)-1);
79072805 2809#else
985213f2 2810 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
382669a9 2811 PerlProc_setuid(new_euid);
a0d0e21e 2812 else {
cea2e8a9 2813 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2814 }
79072805
LW		 2815#endif
2816#endif
85e6fe83 2817#endif
79072805 2818 break;
985213f2 2819 }
79072805 2820 case '(':
985213f2 2821 {
dfff4baf 2822 const Gid_t new_gid = SvGID(sv);
985213f2 2823 PL_delaymagic_gid = new_gid;
3280af22
NIS		 2824 if (PL_delaymagic) {
2825 PL_delaymagic |= DM_RGID;
79072805
LW		 2826 break; /* don't do magic till later */
2827 }
2828#ifdef HAS_SETRGID
dfff4baf 2829 (void)setrgid(new_gid);
79072805
LW		 2830#else
2831#ifdef HAS_SETREGID
dfff4baf 2832 (void)setregid(new_gid, (Gid_t)-1);
85e6fe83
LW		 2833#else
2834#ifdef HAS_SETRESGID
dfff4baf 2835 (void)setresgid(new_gid, (Gid_t)-1, (Gid_t) -1);
79072805 2836#else
985213f2
AB		 2837 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
2838 (void)PerlProc_setgid(new_gid);
748a9306 2839 else {
cea2e8a9 2840 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2841 }
79072805
LW		 2842#endif
2843#endif
85e6fe83 2844#endif
79072805 2845 break;
985213f2 2846 }
79072805 2847 case ')':
985213f2 2848 {
dfff4baf 2849 Gid_t new_egid;
5cd24f17 2850#ifdef HAS_SETGROUPS
2851 {
b83604b4 2852 const char *p = SvPV_const(sv, len);
757f63d8 2853 Groups_t *gary = NULL;
fb4089e0 2854#ifdef _SC_NGROUPS_MAX
2855 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2856
2857 if (maxgrp < 0)
2858 maxgrp = NGROUPS;
2859#else
2860 int maxgrp = NGROUPS;
2861#endif
757f63d8
SP		 2862
2863 while (isSPACE(*p))
2864 ++p;
dfff4baf 2865 new_egid = (Gid_t)Atol(p);
fb4089e0 2866 for (i = 0; i < maxgrp; ++i) {
757f63d8
SP		 2867 while (*p && !isSPACE(*p))
2868 ++p;
2869 while (isSPACE(*p))
2870 ++p;
2871 if (!*p)
2872 break;
2873 if(!gary)
2874 Newx(gary, i + 1, Groups_t);
2875 else
2876 Renew(gary, i + 1, Groups_t);
dfff4baf 2877 gary[i] = (Groups_t)Atol(p);
757f63d8
SP		 2878 }
2879 if (i)
2880 (void)setgroups(i, gary);
f5a63d97 2881 Safefree(gary);
5cd24f17 2882 }
2883#else /* HAS_SETGROUPS */
dfff4baf 2884 new_egid = SvGID(sv);
5cd24f17 2885#endif /* HAS_SETGROUPS */
985213f2 2886 PL_delaymagic_egid = new_egid;
3280af22
NIS		 2887 if (PL_delaymagic) {
2888 PL_delaymagic |= DM_EGID;
79072805
LW		 2889 break; /* don't do magic till later */
2890 }
2891#ifdef HAS_SETEGID
dfff4baf 2892 (void)setegid(new_egid);
79072805
LW		 2893#else
2894#ifdef HAS_SETREGID
dfff4baf 2895 (void)setregid((Gid_t)-1, new_egid);
85e6fe83
LW		 2896#else
2897#ifdef HAS_SETRESGID
dfff4baf 2898 (void)setresgid((Gid_t)-1, new_egid, (Gid_t)-1);
79072805 2899#else
985213f2
AB		 2900 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
2901 (void)PerlProc_setgid(new_egid);
748a9306 2902 else {
cea2e8a9 2903 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2904 }
79072805
LW		 2905#endif
2906#endif
85e6fe83 2907#endif
79072805 2908 break;
985213f2 2909 }
79072805 2910 case ':':
2d8e6c8d 2911 PL_chopset = SvPV_force(sv,len);
79072805 2912 break;
9cdac2a2
FC		 2913 case '$': /* $$ */
2914 /* Store the pid in mg->mg_obj so we can tell when a fork has
2915 occurred. mg->mg_obj points to *$ by default, so clear it. */
2916 if (isGV(mg->mg_obj)) {
2917 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2918 SvREFCNT_dec(mg->mg_obj);
2919 mg->mg_flags |= MGf_REFCOUNTED;
2920 mg->mg_obj = newSViv((IV)PerlProc_getpid());
2921 }
2922 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2923 break;
79072805 2924 case '0':
e2975953 2925 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS		 2926#ifdef HAS_SETPROCTITLE
2927 /* The BSDs don't show the argv[] in ps(1) output, they
2928 * show a string from the process struct and provide
2929 * the setproctitle() routine to manipulate that. */
a2722ac9 2930 if (PL_origalen != 1) {
b83604b4 2931 s = SvPV_const(sv, len);
98b76f99 2932# if __FreeBSD_version > 410001
9aad2c0e 2933 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS		 2934 * but not the "(perl) suffix from the ps(1)
2935 * output, because that's what ps(1) shows if the
2936 * argv[] is modified. */
6f2ad931 2937 setproctitle("-%s", s);
9aad2c0e 2938# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS		 2939 /* This doesn't really work if you assume that
2940 * $0 = 'foobar'; will wipe out 'perl' from the $0
2941 * because in ps(1) output the result will be like
2942 * sprintf("perl: %s (perl)", s)
2943 * I guess this is a security feature:
2944 * one (a user process) cannot get rid of the original name.
2945 * --jhi */
2946 setproctitle("%s", s);
2947# endif
2948 }
9d3968b2 2949#elif defined(__hpux) && defined(PSTAT_SETCMD)
a2722ac9 2950 if (PL_origalen != 1) {
17aa7f3d 2951 union pstun un;
b83604b4 2952 s = SvPV_const(sv, len);
6867be6d 2953 un.pst_command = (char *)s;
17aa7f3d
JH		 2954 pstat(PSTAT_SETCMD, un, len, 0, 0);
2955 }
9d3968b2 2956#else
2d2af554
GA		 2957 if (PL_origalen > 1) {
2958 /* PL_origalen is set in perl_parse(). */
2959 s = SvPV_force(sv,len);
2960 if (len >= (STRLEN)PL_origalen-1) {
2961 /* Longer than original, will be truncated. We assume that
2962 * PL_origalen bytes are available. */
2963 Copy(s, PL_origargv[0], PL_origalen-1, char);
2964 }
2965 else {
2966 /* Shorter than original, will be padded. */
235ac35d 2967#ifdef PERL_DARWIN
60777a0d
JH		 2968 /* Special case for Mac OS X: see [perl #38868] */
2969 const int pad = 0;
235ac35d 2970#else
8a89a4f1
MB		 2971 /* Is the space counterintuitive? Yes.
2972 * (You were expecting \0?)
2973 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2974 * --jhi */
60777a0d 2975 const int pad = ' ';
235ac35d 2976#endif
60777a0d
JH		 2977 Copy(s, PL_origargv[0], len, char);
2978 PL_origargv[0][len] = 0;
2979 memset(PL_origargv[0] + len + 1,
2980 pad, PL_origalen - len - 1);
2d2af554
GA		 2981 }
2982 PL_origargv[0][PL_origalen-1] = 0;
2983 for (i = 1; i < PL_origargc; i++)
2984 PL_origargv[i] = 0;
7636ea95
AB		 2985#ifdef HAS_PRCTL_SET_NAME
2986 /* Set the legacy process name in addition to the POSIX name on Linux */
2987 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2988 /* diag_listed_as: SKIPME */
2989 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2990 }
2991#endif
79072805 2992 }
9d3968b2 2993#endif
e2975953 2994 UNLOCK_DOLLARZERO_MUTEX;
79072805
LW		 2995 break;
2996 }
2997 return 0;
2998}
2999
3000I32
84c7b88c
BF		 3001Perl_whichsig_sv(pTHX_ SV *sigsv)
3002{
3003 const char *sigpv;
3004 STRLEN siglen;
3005 PERL_ARGS_ASSERT_WHICHSIG_SV;
3006 PERL_UNUSED_CONTEXT;
3007 sigpv = SvPV_const(sigsv, siglen);
3008 return whichsig_pvn(sigpv, siglen);
3009}
3010
3011I32
3012Perl_whichsig_pv(pTHX_ const char *sig)
3013{
3014 PERL_ARGS_ASSERT_WHICHSIG_PV;
3015 PERL_UNUSED_CONTEXT;
3016 return whichsig_pvn(sig, strlen(sig));
3017}
3018
3019I32
3020Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
79072805 3021{
eb578fdb 3022 char* const* sigv;
7918f24d 3023
84c7b88c 3024 PERL_ARGS_ASSERT_WHICHSIG_PVN;
96a5add6 3025 PERL_UNUSED_CONTEXT;
79072805 3026
aadb217d 3027 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
84c7b88c 3028 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
aadb217d 3029 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805 3030#ifdef SIGCLD
84c7b88c 3031 if (memEQs(sig, len, "CHLD"))
79072805
LW		 3032 return SIGCLD;
3033#endif
3034#ifdef SIGCHLD
84c7b88c 3035 if (memEQs(sig, len, "CLD"))
79072805
LW		 3036 return SIGCHLD;
3037#endif
7f1236c0 3038 return -1;
79072805
LW		 3039}
3040
ecfc5424 3041Signal_t
1e82f5a6 3042#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b3dbdd48 3043Perl_sighandler(int sig, siginfo_t *sip, void *uap)
1e82f5a6
SH		 3044#else
3045Perl_sighandler(int sig)
3046#endif
79072805 3047{
1018e26f
NIS		 3048#ifdef PERL_GET_SIG_CONTEXT
3049 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 3050#else
cea2e8a9 3051 dTHX;
71d280e3 3052#endif
79072805 3053 dSP;
a0714e2c
SS		 3054 GV *gv = NULL;
3055 SV *sv = NULL;
8772537c 3056 SV * const tSv = PL_Sv;
601f1833 3057 CV *cv = NULL;
533c011a 3058 OP *myop = PL_op;
84902520 3059 U32 flags = 0;
8772537c 3060 XPV * const tXpv = PL_Xpv;
0c4d3b5e 3061 I32 old_ss_ix = PL_savestack_ix;
100c03aa 3062 SV *errsv_save = NULL;
71d280e3 3063
84902520 3064
727405f8 3065 if (!PL_psig_ptr[sig]) {
99ef548b 3066 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS		 3067 PL_sig_name[sig]);
3068 exit(sig);
3069 }
ff0cee69 3070
a0d63a7b
DM		 3071 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3072 /* Max number of items pushed there is 3*n or 4. We cannot fix
3073 infinity, so we fix 4 (in fact 5): */
3074 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3075 flags |= 1;
3076 PL_savestack_ix += 5; /* Protect save in progress. */
3077 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3078 }
84902520 3079 }
84902520 3080 /* sv_2cv is too complicated, try a simpler variant first: */
ea726b52 3081 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
8772537c
AL		 3082 || SvTYPE(cv) != SVt_PVCV) {
3083 HV *st;
f2c0649b 3084 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
8772537c 3085 }
84902520 3086
a0d0e21e 3087 if (!cv || !CvROOT(cv)) {
a2a5de95
NC		 3088 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3089 PL_sig_name[sig], (gv ? GvENAME(gv)
3090 : ((cv && CvGV(cv))
3091 ? GvENAME(CvGV(cv))
3092 : "__ANON__")));
00d579c5 3093 goto cleanup;
79072805
LW		 3094 }
3095
0c4d3b5e
DM		 3096 sv = PL_psig_name[sig]
3097 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3098 : newSVpv(PL_sig_name[sig],0);
72048cfe 3099 flags |= 8;
0c4d3b5e
DM		 3100 SAVEFREESV(sv);
3101
a0d63a7b
DM		 3102 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3103 /* make sure our assumption about the size of the SAVEs are correct:
3104 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3105 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3106 }
e336de0d 3107
e788e7d3 3108 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 3109 PUSHMARK(SP);
79072805 3110 PUSHs(sv);
8aad04aa
JH		 3111#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3112 {
3113 struct sigaction oact;
3114
3115 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
8aad04aa
JH		 3116 if (sip) {
3117 HV *sih = newHV();
ad64d0ec 3118 SV *rv = newRV_noinc(MUTABLE_SV(sih));
8aad04aa
JH		 3119 /* The siginfo fields signo, code, errno, pid, uid,
3120 * addr, status, and band are defined by POSIX/SUSv3. */
85771703
NC		 3121 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3122 (void)hv_stores(sih, "code", newSViv(sip->si_code));
79dec0f4 3123#if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */
85771703
NC		 3124 hv_stores(sih, "errno", newSViv(sip->si_errno));
3125 hv_stores(sih, "status", newSViv(sip->si_status));
3126 hv_stores(sih, "uid", newSViv(sip->si_uid));
3127 hv_stores(sih, "pid", newSViv(sip->si_pid));
3128 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3129 hv_stores(sih, "band", newSViv(sip->si_band));
79dec0f4 3130#endif
8aad04aa 3131 EXTEND(SP, 2);
ad64d0ec 3132 PUSHs(rv);
22f1178f 3133 mPUSHp((char *)sip, sizeof(*sip));
8aad04aa 3134 }
b4552a27 3135
8aad04aa
JH		 3136 }
3137 }
3138#endif
79072805 3139 PUTBACK;
a0d0e21e 3140
100c03aa
JL		 3141 errsv_save = newSVsv(ERRSV);
3142
ad64d0ec 3143 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
79072805 3144
d3acc0f7 3145 POPSTACK;
eed484f9
DD		 3146 {
3147 SV * const errsv = ERRSV;
3148 if (SvTRUE_NN(errsv)) {
3149 SvREFCNT_dec(errsv_save);
c22d665b 3150#ifndef PERL_MICRO
1b266415
NIS		 3151 /* Handler "died", for example to get out of a restart-able read().
3152 * Before we re-do that on its behalf re-enable the signal which was
3153 * blocked by the system when we entered.
3154 */
c22d665b 3155#ifdef HAS_SIGPROCMASK
d488af49 3156#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
eed484f9 3157 if (sip || uap)
c22d665b 3158#endif
eed484f9
DD		 3159 {
3160 sigset_t set;
3161 sigemptyset(&set);
3162 sigaddset(&set,sig);
3163 sigprocmask(SIG_UNBLOCK, &set, NULL);
3164 }
c22d665b 3165#else
eed484f9
DD		 3166 /* Not clear if this will work */
3167 (void)rsignal(sig, SIG_IGN);
3168 (void)rsignal(sig, PL_csighandlerp);
c22d665b
LT		 3169#endif
3170#endif /* !PERL_MICRO */
eed484f9
DD		 3171 die_sv(errsv);
3172 }
3173 else {
3174 sv_setsv(errsv, errsv_save);
3175 SvREFCNT_dec(errsv_save);
3176 }
100c03aa
JL		 3177 }
3178
00d579c5 3179cleanup:
0c4d3b5e
DM		 3180 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3181 PL_savestack_ix = old_ss_ix;
72048cfe 3182 if (flags & 8)
2357bae7 3183 SvREFCNT_dec_NN(sv);
533c011a 3184 PL_op = myop; /* Apparently not needed... */
ac27b0f5 3185
3280af22
NIS		 3186 PL_Sv = tSv; /* Restore global temporaries. */
3187 PL_Xpv = tXpv;
53bb94e2 3188 return;
79072805 3189}
4e35701f
NIS		 3190
3191
51371543 3192static void
8772537c 3193S_restore_magic(pTHX_ const void *p)
51371543 3194{
97aff369 3195 dVAR;
8772537c
AL		 3196 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3197 SV* const sv = mgs->mgs_sv;
150b625d 3198 bool bumped;
51371543
GS		 3199
3200 if (!sv)
3201 return;
3202
4bac9ae4
CS		 3203 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3204 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
f8c7b90f 3205#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC		 3206 /* While magic was saved (and off) sv_setsv may well have seen
3207 this SV as a prime candidate for COW. */
3208 if (SvIsCOW(sv))
e424a81e 3209 sv_force_normal_flags(sv, 0);
f9701176 3210#endif
f9c6fee5
CS		 3211 if (mgs->mgs_readonly)
3212 SvREADONLY_on(sv);
3213 if (mgs->mgs_magical)
3214 SvFLAGS(sv) |= mgs->mgs_magical;
51371543
GS		 3215 else
3216 mg_magical(sv);
51371543
GS		 3217 }
3218
150b625d 3219 bumped = mgs->mgs_bumped;
51371543
GS		 3220 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3221
3222 /* If we're still on top of the stack, pop us off. (That condition
3223 * will be satisfied if restore_magic was called explicitly, but *not*
3224 * if it's being called via leave_scope.)
3225 * The reason for doing this is that otherwise, things like sv_2cv()
3226 * may leave alloc gunk on the savestack, and some code
3227 * (e.g. sighandler) doesn't expect that...
3228 */
3229 if (PL_savestack_ix == mgs->mgs_ss_ix)
3230 {
1be36ce0
NC		 3231 UV popval = SSPOPUV;
3232 assert(popval == SAVEt_DESTRUCTOR_X);
51371543 3233 PL_savestack_ix -= 2;
1be36ce0
NC		 3234 popval = SSPOPUV;
3235 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3236 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
51371543 3237 }
150b625d
DM		 3238 if (bumped) {
3239 if (SvREFCNT(sv) == 1) {
3240 /* We hold the last reference to this SV, which implies that the
3241 SV was deleted as a side effect of the routines we called.
3242 So artificially keep it alive a bit longer.
3243 We avoid turning on the TEMP flag, which can cause the SV's
3244 buffer to get stolen (and maybe other stuff). */
150b625d 3245 sv_2mortal(sv);
4bac9ae4 3246 SvTEMP_off(sv);
8985fe98 3247 }
150b625d 3248 else
2357bae7 3249 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
8985fe98 3250 }
51371543
GS		 3251}
3252
0c4d3b5e
DM		 3253/* clean up the mess created by Perl_sighandler().
3254 * Note that this is only called during an exit in a signal handler;
3255 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
9a7f166c 3256 * skipped over. */
0c4d3b5e 3257
51371543 3258static void
8772537c 3259S_unwind_handler_stack(pTHX_ const void *p)
51371543 3260{
27da23d5 3261 dVAR;
0c4d3b5e 3262 PERL_UNUSED_ARG(p);
7918f24d 3263
0c4d3b5e 3264 PL_savestack_ix -= 5; /* Unprotect save in progress. */
51371543 3265}
1018e26f 3266
66610fdd 3267/*
b3ca2e83
NC		 3268=for apidoc magic_sethint
3269
3270Triggered by a store to %^H, records the key/value pair to
c28fe1ec
NC		 3271C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3272anything that would need a deep copy. Maybe we should warn if we find a
3273reference.
b3ca2e83
NC		 3274
3275=cut
3276*/
3277int
3278Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3279{
3280 dVAR;
ad64d0ec 3281 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
59cd0e26 3282 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
b3ca2e83 3283
7918f24d
NC		 3284 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3285
e6e3e454
NC		 3286 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3287 an alternative leaf in there, with PL_compiling.cop_hints being used if
3288 it's NULL. If needed for threads, the alternative could lock a mutex,
3289 or take other more complex action. */
3290
5b9c0671
NC		 3291 /* Something changed in %^H, so it will need to be restored on scope exit.
3292 Doing this here saves a lot of doing it manually in perl code (and
3293 forgetting to do it, and consequent subtle errors. */
3294 PL_hints |= HINT_LOCALIZE_HH;
20439bc7
Z		 3295 CopHINTHASH_set(&PL_compiling,
3296 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
b3ca2e83
NC		 3297 return 0;
3298}
3299
3300/*
f175cff5 3301=for apidoc magic_clearhint
b3ca2e83 3302
c28fe1ec
NC		 3303Triggered by a delete from %^H, records the key to
3304C<PL_compiling.cop_hints_hash>.
b3ca2e83
NC		 3305
3306=cut
3307*/
3308int
3309Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3310{
3311 dVAR;
7918f24d
NC		 3312
3313 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
f5a63d97
AL		 3314 PERL_UNUSED_ARG(sv);
3315
5b9c0671 3316 PL_hints |= HINT_LOCALIZE_HH;
20439bc7 3317 CopHINTHASH_set(&PL_compiling,
e3352591
FC		 3318 mg->mg_len == HEf_SVKEY
3319 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3320 MUTABLE_SV(mg->mg_ptr), 0, 0)
3321 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3322 mg->mg_ptr, mg->mg_len, 0, 0));
b3ca2e83
NC		 3323 return 0;
3324}
3325
3326/*
f747ebd6
Z		 3327=for apidoc magic_clearhints
3328
3329Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3330
3331=cut
3332*/
3333int
3334Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3335{
3336 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3337 PERL_UNUSED_ARG(sv);
3338 PERL_UNUSED_ARG(mg);
20439bc7
Z		 3339 cophh_free(CopHINTHASH_get(&PL_compiling));
3340 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
f747ebd6
Z		 3341 return 0;
3342}
3343
09fb282d
FC		 3344int
3345Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3346 const char *name, I32 namlen)
3347{
3348 MAGIC *nmg;
3349
3350 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
4f8dbb2d 3351 PERL_UNUSED_ARG(sv);
09fb282d
FC		 3352 PERL_UNUSED_ARG(name);
3353 PERL_UNUSED_ARG(namlen);
3354
3355 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3356 nmg = mg_find(nsv, mg->mg_type);
3357 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3358 nmg->mg_ptr = mg->mg_ptr;
3359 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3360 nmg->mg_flags |= MGf_REFCOUNTED;
3361 return 1;
3362}
3363
f747ebd6 3364/*
66610fdd
RGS		 3365 * Local variables:
3366 * c-indentation-style: bsd
3367 * c-basic-offset: 4
14d04a33 3368 * indent-tabs-mode: nil
66610fdd
RGS		 3369 * End:
3370 *
14d04a33 3371 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3372 */
Unnamed repository; edit this file 'description' to name the repository.