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