Revert RT #131190 patches.
[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             UV uv= (UV)mg->mg_obj;
642             if (uv == '+') {          /* @+ */
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 (uv == '-') {
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 UV uv= (UV)mg->mg_obj;
678             /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */
679             const I32 paren = mg->mg_len
680                             + (uv == '\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 (uv == '+')                /* @+ */
692                         i = t;
693                     else if (uv == '-')           /* @- */
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) & 1;
2201     const bool negrem = LvFLAGS(sv) & 2;
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) & 1;
2233     const bool neglen = LvFLAGS(sv) & 2;
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 & ~(1|4)));
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 {
2731             if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
2732                         if (PL_localizing != 2) {
2733                             deprecate_fatal_in("5.28",
2734                                "${^ENCODING} is no longer supported");
2735                         }
2736         }
2737         break;
2738     case '\006':        /* ^F */
2739         PL_maxsysfd = SvIV(sv);
2740         break;
2741     case '\010':        /* ^H */
2742         {
2743             U32 save_hints = PL_hints;
2744             PL_hints = SvUV(sv);
2745
2746             /* If wasn't UTF-8, and now is, notify the parser */
2747             if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
2748                 notify_parser_that_changed_to_utf8();
2749             }
2750         }
2751         break;
2752     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2753         Safefree(PL_inplace);
2754         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2755         break;
2756     case '\016':        /* ^N */
2757         if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2758          && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2759         goto croakparen;
2760     case '\017':        /* ^O */
2761         if (*(mg->mg_ptr+1) == '\0') {
2762             Safefree(PL_osname);
2763             PL_osname = NULL;
2764             if (SvOK(sv)) {
2765                 TAINT_PROPER("assigning to $^O");
2766                 PL_osname = savesvpv(sv);
2767             }
2768         }
2769         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2770             STRLEN len;
2771             const char *const start = SvPV(sv, len);
2772             const char *out = (const char*)memchr(start, '\0', len);
2773             SV *tmp;
2774
2775
2776             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2777             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2778
2779             /* Opening for input is more common than opening for output, so
2780                ensure that hints for input are sooner on linked list.  */
2781             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2782                                        SvUTF8(sv))
2783                 : newSVpvs_flags("", SvUTF8(sv));
2784             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2785             mg_set(tmp);
2786
2787             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2788                                         SvUTF8(sv));
2789             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2790             mg_set(tmp);
2791         }
2792         break;
2793     case '\020':        /* ^P */
2794           PL_perldb = SvIV(sv);
2795           if (PL_perldb && !PL_DBsingle)
2796               init_debugger();
2797       break;
2798     case '\024':        /* ^T */
2799 #ifdef BIG_TIME
2800         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2801 #else
2802         PL_basetime = (Time_t)SvIV(sv);
2803 #endif
2804         break;
2805     case '\025':        /* ^UTF8CACHE */
2806          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2807              PL_utf8cache = (signed char) sv_2iv(sv);
2808          }
2809          break;
2810     case '\027':        /* ^W & $^WARNING_BITS */
2811         if (*(mg->mg_ptr+1) == '\0') {
2812             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2813                 i = SvIV(sv);
2814                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2815                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2816             }
2817         }
2818         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2819             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2820                 if (!SvPOK(sv)) {
2821                     PL_compiling.cop_warnings = pWARN_STD;
2822                     break;
2823                 }
2824                 {
2825                     STRLEN len, i;
2826                     int accumulate = 0 ;
2827                     int any_fatals = 0 ;
2828                     const char * const ptr = SvPV_const(sv, len) ;
2829                     for (i = 0 ; i < len ; ++i) {
2830                         accumulate |= ptr[i] ;
2831                         any_fatals |= (ptr[i] & 0xAA) ;
2832                     }
2833                     if (!accumulate) {
2834                         if (!specialWARN(PL_compiling.cop_warnings))
2835                             PerlMemShared_free(PL_compiling.cop_warnings);
2836                         PL_compiling.cop_warnings = pWARN_NONE;
2837                     }
2838                     /* Yuck. I can't see how to abstract this:  */
2839                     else if (isWARN_on(
2840                                 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2841                                 WARN_ALL)
2842                             && !any_fatals)
2843                     {
2844                         if (!specialWARN(PL_compiling.cop_warnings))
2845                             PerlMemShared_free(PL_compiling.cop_warnings);
2846                         PL_compiling.cop_warnings = pWARN_ALL;
2847                         PL_dowarn |= G_WARN_ONCE ;
2848                     }
2849                     else {
2850                         STRLEN len;
2851                         const char *const p = SvPV_const(sv, len);
2852
2853                         PL_compiling.cop_warnings
2854                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2855                                                          p, len);
2856
2857                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2858                             PL_dowarn |= G_WARN_ONCE ;
2859                     }
2860
2861                 }
2862             }
2863         }
2864 #ifdef WIN32
2865         else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
2866             w32_sloppystat = (bool)sv_true(sv);
2867         }
2868 #endif
2869         break;
2870     case '.':
2871         if (PL_localizing) {
2872             if (PL_localizing == 1)
2873                 SAVESPTR(PL_last_in_gv);
2874         }
2875         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2876             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2877         break;
2878     case '^':
2879         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2880         IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2881         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2882         break;
2883     case '~':
2884         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2885         IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2886         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2887         break;
2888     case '=':
2889         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2890         break;
2891     case '-':
2892         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2893         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2894                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2895         break;
2896     case '%':
2897         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2898         break;
2899     case '|':
2900         {
2901             IO * const io = GvIO(PL_defoutgv);
2902             if(!io)
2903               break;
2904             if ((SvIV(sv)) == 0)
2905                 IoFLAGS(io) &= ~IOf_FLUSH;
2906             else {
2907                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2908                     PerlIO *ofp = IoOFP(io);
2909                     if (ofp)
2910                         (void)PerlIO_flush(ofp);
2911                     IoFLAGS(io) |= IOf_FLUSH;
2912                 }
2913             }
2914         }
2915         break;
2916     case '/':
2917         {
2918             SV *tmpsv= sv;
2919             if (SvROK(sv)) {
2920                 SV *referent= SvRV(sv);
2921                 const char *reftype= sv_reftype(referent, 0);
2922                 /* XXX: dodgy type check: This leaves me feeling dirty, but
2923                  * the alternative is to copy pretty much the entire
2924                  * sv_reftype() into this routine, or to do a full string
2925                  * comparison on the return of sv_reftype() both of which
2926                  * make me feel worse! NOTE, do not modify this comment
2927                  * without reviewing the corresponding comment in
2928                  * sv_reftype(). - Yves */
2929                 if (reftype[0] == 'S' || reftype[0] == 'L') {
2930                     IV val= SvIV(referent);
2931                     if (val <= 0) {
2932                         tmpsv= &PL_sv_undef;
2933                         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2934                             "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef. This will be fatal in Perl 5.28",
2935                             SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
2936                         );
2937                     }
2938                 } else {
2939                     sv_setsv(sv, PL_rs);
2940               /* diag_listed_as: Setting $/ to %s reference is forbidden */
2941                     Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
2942                                       *reftype == 'A' ? "n" : "", reftype);
2943                 }
2944             }
2945             SvREFCNT_dec(PL_rs);
2946             PL_rs = newSVsv(tmpsv);
2947         }
2948         break;
2949     case '\\':
2950         SvREFCNT_dec(PL_ors_sv);
2951         if (SvOK(sv)) {
2952             PL_ors_sv = newSVsv(sv);
2953         }
2954         else {
2955             PL_ors_sv = NULL;
2956         }
2957         break;
2958     case '[':
2959         if (SvIV(sv) != 0)
2960             Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2961         break;
2962     case '?':
2963 #ifdef COMPLEX_STATUS
2964         if (PL_localizing == 2) {
2965             SvUPGRADE(sv, SVt_PVLV);
2966             PL_statusvalue = LvTARGOFF(sv);
2967             PL_statusvalue_vms = LvTARGLEN(sv);
2968         }
2969         else
2970 #endif
2971 #ifdef VMSISH_STATUS
2972         if (VMSISH_STATUS)
2973             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2974         else
2975 #endif
2976             STATUS_UNIX_EXIT_SET(SvIV(sv));
2977         break;
2978     case '!':
2979         {
2980 #ifdef VMS
2981 #   define PERL_VMS_BANG vaxc$errno
2982 #else
2983 #   define PERL_VMS_BANG 0
2984 #endif
2985 #if defined(WIN32) && ! defined(UNDER_CE)
2986         SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
2987                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2988 #else
2989         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2990                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2991 #endif
2992         }
2993         break;
2994     case '<':
2995         {
2996         /* XXX $< currently silently ignores failures */
2997         const Uid_t new_uid = SvUID(sv);
2998         PL_delaymagic_uid = new_uid;
2999         if (PL_delaymagic) {
3000             PL_delaymagic |= DM_RUID;
3001             break;                              /* don't do magic till later */
3002         }
3003 #ifdef HAS_SETRUID
3004         PERL_UNUSED_RESULT(setruid(new_uid));
3005 #else
3006 #ifdef HAS_SETREUID
3007         PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3008 #else
3009 #ifdef HAS_SETRESUID
3010         PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3011 #else
3012         if (new_uid == PerlProc_geteuid()) {            /* special case $< = $> */
3013 #ifdef PERL_DARWIN
3014             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3015             if (new_uid != 0 && PerlProc_getuid() == 0)
3016                 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3017 #endif
3018             PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3019         } else {
3020             Perl_croak(aTHX_ "setruid() not implemented");
3021         }
3022 #endif
3023 #endif
3024 #endif
3025         break;
3026         }
3027     case '>':
3028         {
3029         /* XXX $> currently silently ignores failures */
3030         const Uid_t new_euid = SvUID(sv);
3031         PL_delaymagic_euid = new_euid;
3032         if (PL_delaymagic) {
3033             PL_delaymagic |= DM_EUID;
3034             break;                              /* don't do magic till later */
3035         }
3036 #ifdef HAS_SETEUID
3037         PERL_UNUSED_RESULT(seteuid(new_euid));
3038 #else
3039 #ifdef HAS_SETREUID
3040         PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3041 #else
3042 #ifdef HAS_SETRESUID
3043         PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3044 #else
3045         if (new_euid == PerlProc_getuid())              /* special case $> = $< */
3046             PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3047         else {
3048             Perl_croak(aTHX_ "seteuid() not implemented");
3049         }
3050 #endif
3051 #endif
3052 #endif
3053         break;
3054         }
3055     case '(':
3056         {
3057         /* XXX $( currently silently ignores failures */
3058         const Gid_t new_gid = SvGID(sv);
3059         PL_delaymagic_gid = new_gid;
3060         if (PL_delaymagic) {
3061             PL_delaymagic |= DM_RGID;
3062             break;                              /* don't do magic till later */
3063         }
3064 #ifdef HAS_SETRGID
3065         PERL_UNUSED_RESULT(setrgid(new_gid));
3066 #else
3067 #ifdef HAS_SETREGID
3068         PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3069 #else
3070 #ifdef HAS_SETRESGID
3071         PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3072 #else
3073         if (new_gid == PerlProc_getegid())                      /* special case $( = $) */
3074             PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3075         else {
3076             Perl_croak(aTHX_ "setrgid() not implemented");
3077         }
3078 #endif
3079 #endif
3080 #endif
3081         break;
3082         }
3083     case ')':
3084         {
3085 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3086  * but you can override it if you need to.
3087  */
3088 #ifndef INVALID_GID
3089 #define INVALID_GID ((Gid_t)-1)
3090 #endif
3091         /* XXX $) currently silently ignores failures */
3092         Gid_t new_egid;
3093 #ifdef HAS_SETGROUPS
3094         {
3095             const char *p = SvPV_const(sv, len);
3096             Groups_t *gary = NULL;
3097             const char* endptr;
3098             UV uv;
3099 #ifdef _SC_NGROUPS_MAX
3100            int maxgrp = sysconf(_SC_NGROUPS_MAX);
3101
3102            if (maxgrp < 0)
3103                maxgrp = NGROUPS;
3104 #else
3105            int maxgrp = NGROUPS;
3106 #endif
3107
3108             while (isSPACE(*p))
3109                 ++p;
3110             if (grok_atoUV(p, &uv, &endptr))
3111                 new_egid = (Gid_t)uv;
3112             else {
3113                 new_egid = INVALID_GID;
3114                 endptr = NULL;
3115             }
3116             for (i = 0; i < maxgrp; ++i) {
3117                 if (endptr == NULL)
3118                     break;
3119                 p = endptr;
3120                 while (isSPACE(*p))
3121                     ++p;
3122                 if (!*p)
3123                     break;
3124                 if (!gary)
3125                     Newx(gary, i + 1, Groups_t);
3126                 else
3127                     Renew(gary, i + 1, Groups_t);
3128                 if (grok_atoUV(p, &uv, &endptr))
3129                     gary[i] = (Groups_t)uv;
3130                 else {
3131                     gary[i] = INVALID_GID;
3132                     endptr = NULL;
3133                 }
3134             }
3135             if (i)
3136                 PERL_UNUSED_RESULT(setgroups(i, gary));
3137             Safefree(gary);
3138         }
3139 #else  /* HAS_SETGROUPS */
3140         new_egid = SvGID(sv);
3141 #endif /* HAS_SETGROUPS */
3142         PL_delaymagic_egid = new_egid;
3143         if (PL_delaymagic) {
3144             PL_delaymagic |= DM_EGID;
3145             break;                              /* don't do magic till later */
3146         }
3147 #ifdef HAS_SETEGID
3148         PERL_UNUSED_RESULT(setegid(new_egid));
3149 #else
3150 #ifdef HAS_SETREGID
3151         PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3152 #else
3153 #ifdef HAS_SETRESGID
3154         PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3155 #else
3156         if (new_egid == PerlProc_getgid())                      /* special case $) = $( */
3157             PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3158         else {
3159             Perl_croak(aTHX_ "setegid() not implemented");
3160         }
3161 #endif
3162 #endif
3163 #endif
3164         break;
3165         }
3166     case ':':
3167         PL_chopset = SvPV_force(sv,len);
3168         break;
3169     case '$': /* $$ */
3170         /* Store the pid in mg->mg_obj so we can tell when a fork has
3171            occurred.  mg->mg_obj points to *$ by default, so clear it. */
3172         if (isGV(mg->mg_obj)) {
3173             if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3174                 SvREFCNT_dec(mg->mg_obj);
3175             mg->mg_flags |= MGf_REFCOUNTED;
3176             mg->mg_obj = newSViv((IV)PerlProc_getpid());
3177         }
3178         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3179         break;
3180     case '0':
3181         LOCK_DOLLARZERO_MUTEX;
3182         S_set_dollarzero(aTHX_ sv);
3183         UNLOCK_DOLLARZERO_MUTEX;
3184         break;
3185     }
3186     return 0;
3187 }
3188
3189 I32
3190 Perl_whichsig_sv(pTHX_ SV *sigsv)
3191 {
3192     const char *sigpv;
3193     STRLEN siglen;
3194     PERL_ARGS_ASSERT_WHICHSIG_SV;
3195     sigpv = SvPV_const(sigsv, siglen);
3196     return whichsig_pvn(sigpv, siglen);
3197 }
3198
3199 I32
3200 Perl_whichsig_pv(pTHX_ const char *sig)
3201 {
3202     PERL_ARGS_ASSERT_WHICHSIG_PV;
3203     return whichsig_pvn(sig, strlen(sig));
3204 }
3205
3206 I32
3207 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3208 {
3209     char* const* sigv;
3210
3211     PERL_ARGS_ASSERT_WHICHSIG_PVN;
3212     PERL_UNUSED_CONTEXT;
3213
3214     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3215         if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3216             return PL_sig_num[sigv - (char* const*)PL_sig_name];
3217 #ifdef SIGCLD
3218     if (memEQs(sig, len, "CHLD"))
3219         return SIGCLD;
3220 #endif
3221 #ifdef SIGCHLD
3222     if (memEQs(sig, len, "CLD"))
3223         return SIGCHLD;
3224 #endif
3225     return -1;
3226 }
3227
3228 Signal_t
3229 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3230 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3231 #else
3232 Perl_sighandler(int sig)
3233 #endif
3234 {
3235 #ifdef PERL_GET_SIG_CONTEXT
3236     dTHXa(PERL_GET_SIG_CONTEXT);
3237 #else
3238     dTHX;
3239 #endif
3240     dSP;
3241     GV *gv = NULL;
3242     SV *sv = NULL;
3243     SV * const tSv = PL_Sv;
3244     CV *cv = NULL;
3245     OP *myop = PL_op;
3246     U32 flags = 0;
3247     XPV * const tXpv = PL_Xpv;
3248     I32 old_ss_ix = PL_savestack_ix;
3249     SV *errsv_save = NULL;
3250
3251
3252     if (!PL_psig_ptr[sig]) {
3253                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3254                                  PL_sig_name[sig]);
3255                 exit(sig);
3256         }
3257
3258     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3259         /* Max number of items pushed there is 3*n or 4. We cannot fix
3260            infinity, so we fix 4 (in fact 5): */
3261         if (PL_savestack_ix + 15 <= PL_savestack_max) {
3262             flags |= 1;
3263             PL_savestack_ix += 5;               /* Protect save in progress. */
3264             SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3265         }
3266     }
3267     /* sv_2cv is too complicated, try a simpler variant first: */
3268     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3269         || SvTYPE(cv) != SVt_PVCV) {
3270         HV *st;
3271         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3272     }
3273
3274     if (!cv || !CvROOT(cv)) {
3275         const HEK * const hek = gv
3276                         ? GvENAME_HEK(gv)
3277                         : cv && CvNAMED(cv)
3278                            ? CvNAME_HEK(cv)
3279                            : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3280         if (hek)
3281             Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3282                                 "SIG%s handler \"%" HEKf "\" not defined.\n",
3283                                  PL_sig_name[sig], HEKfARG(hek));
3284              /* diag_listed_as: SIG%s handler "%s" not defined */
3285         else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3286                            "SIG%s handler \"__ANON__\" not defined.\n",
3287                             PL_sig_name[sig]);
3288         goto cleanup;
3289     }
3290
3291     sv = PL_psig_name[sig]
3292             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3293             : newSVpv(PL_sig_name[sig],0);
3294     flags |= 8;
3295     SAVEFREESV(sv);
3296
3297     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3298         /* make sure our assumption about the size of the SAVEs are correct:
3299          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3300         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3301     }
3302
3303     PUSHSTACKi(PERLSI_SIGNAL);
3304     PUSHMARK(SP);
3305     PUSHs(sv);
3306 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3307     {
3308          struct sigaction oact;
3309
3310          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3311               if (sip) {
3312                    HV *sih = newHV();
3313                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3314                    /* The siginfo fields signo, code, errno, pid, uid,
3315                     * addr, status, and band are defined by POSIX/SUSv3. */
3316                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3317                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3318 #ifdef HAS_SIGINFO_SI_ERRNO
3319                    (void)hv_stores(sih, "errno",      newSViv(sip->si_errno));
3320 #endif
3321 #ifdef HAS_SIGINFO_SI_STATUS
3322                    (void)hv_stores(sih, "status",     newSViv(sip->si_status));
3323 #endif
3324 #ifdef HAS_SIGINFO_SI_UID
3325                    {
3326                         SV *uid = newSV(0);
3327                         sv_setuid(uid, sip->si_uid);
3328                         (void)hv_stores(sih, "uid", uid);
3329                    }
3330 #endif
3331 #ifdef HAS_SIGINFO_SI_PID
3332                    (void)hv_stores(sih, "pid",        newSViv(sip->si_pid));
3333 #endif
3334 #ifdef HAS_SIGINFO_SI_ADDR
3335                    (void)hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3336 #endif
3337 #ifdef HAS_SIGINFO_SI_BAND
3338                    (void)hv_stores(sih, "band",       newSViv(sip->si_band));
3339 #endif
3340                    EXTEND(SP, 2);
3341                    PUSHs(rv);
3342                    mPUSHp((char *)sip, sizeof(*sip));
3343               }
3344
3345          }
3346     }
3347 #endif
3348     PUTBACK;
3349
3350     errsv_save = newSVsv(ERRSV);
3351
3352     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3353
3354     POPSTACK;
3355     {
3356         SV * const errsv = ERRSV;
3357         if (SvTRUE_NN(errsv)) {
3358             SvREFCNT_dec(errsv_save);
3359 #ifndef PERL_MICRO
3360         /* Handler "died", for example to get out of a restart-able read().
3361          * Before we re-do that on its behalf re-enable the signal which was
3362          * blocked by the system when we entered.
3363          */
3364 #ifdef HAS_SIGPROCMASK
3365 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3366             if (sip || uap)
3367 #endif
3368             {
3369                 sigset_t set;
3370                 sigemptyset(&set);
3371                 sigaddset(&set,sig);
3372                 sigprocmask(SIG_UNBLOCK, &set, NULL);
3373             }
3374 #else
3375             /* Not clear if this will work */
3376             (void)rsignal(sig, SIG_IGN);
3377             (void)rsignal(sig, PL_csighandlerp);
3378 #endif
3379 #endif /* !PERL_MICRO */
3380             die_sv(errsv);
3381         }
3382         else {
3383             sv_setsv(errsv, errsv_save);
3384             SvREFCNT_dec(errsv_save);
3385         }
3386     }
3387
3388   cleanup:
3389     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3390     PL_savestack_ix = old_ss_ix;
3391     if (flags & 8)
3392         SvREFCNT_dec_NN(sv);
3393     PL_op = myop;                       /* Apparently not needed... */
3394
3395     PL_Sv = tSv;                        /* Restore global temporaries. */
3396     PL_Xpv = tXpv;
3397     return;
3398 }
3399
3400
3401 static void
3402 S_restore_magic(pTHX_ const void *p)
3403 {
3404     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3405     SV* const sv = mgs->mgs_sv;
3406     bool bumped;
3407
3408     if (!sv)
3409         return;
3410
3411     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3412         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3413         if (mgs->mgs_flags)
3414             SvFLAGS(sv) |= mgs->mgs_flags;
3415         else
3416             mg_magical(sv);
3417     }
3418
3419     bumped = mgs->mgs_bumped;
3420     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3421
3422     /* If we're still on top of the stack, pop us off.  (That condition
3423      * will be satisfied if restore_magic was called explicitly, but *not*
3424      * if it's being called via leave_scope.)
3425      * The reason for doing this is that otherwise, things like sv_2cv()
3426      * may leave alloc gunk on the savestack, and some code
3427      * (e.g. sighandler) doesn't expect that...
3428      */
3429     if (PL_savestack_ix == mgs->mgs_ss_ix)
3430     {
3431         UV popval = SSPOPUV;
3432         assert(popval == SAVEt_DESTRUCTOR_X);
3433         PL_savestack_ix -= 2;
3434         popval = SSPOPUV;
3435         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3436         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3437     }
3438     if (bumped) {
3439         if (SvREFCNT(sv) == 1) {
3440             /* We hold the last reference to this SV, which implies that the
3441                SV was deleted as a side effect of the routines we called.
3442                So artificially keep it alive a bit longer.
3443                We avoid turning on the TEMP flag, which can cause the SV's
3444                buffer to get stolen (and maybe other stuff). */
3445             sv_2mortal(sv);
3446             SvTEMP_off(sv);
3447         }
3448         else
3449             SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3450     }
3451 }
3452
3453 /* clean up the mess created by Perl_sighandler().
3454  * Note that this is only called during an exit in a signal handler;
3455  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3456  * skipped over. */
3457
3458 static void
3459 S_unwind_handler_stack(pTHX_ const void *p)
3460 {
3461     PERL_UNUSED_ARG(p);
3462
3463     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3464 }
3465
3466 /*
3467 =for apidoc magic_sethint
3468
3469 Triggered by a store to C<%^H>, records the key/value pair to
3470 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3471 anything that would need a deep copy.  Maybe we should warn if we find a
3472 reference.
3473
3474 =cut
3475 */
3476 int
3477 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3478 {
3479     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3480         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3481
3482     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3483
3484     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3485        an alternative leaf in there, with PL_compiling.cop_hints being used if
3486        it's NULL. If needed for threads, the alternative could lock a mutex,
3487        or take other more complex action.  */
3488
3489     /* Something changed in %^H, so it will need to be restored on scope exit.
3490        Doing this here saves a lot of doing it manually in perl code (and
3491        forgetting to do it, and consequent subtle errors.  */
3492     PL_hints |= HINT_LOCALIZE_HH;
3493     CopHINTHASH_set(&PL_compiling,
3494         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3495     return 0;
3496 }
3497
3498 /*
3499 =for apidoc magic_clearhint
3500
3501 Triggered by a delete from C<%^H>, records the key to
3502 C<PL_compiling.cop_hints_hash>.
3503
3504 =cut
3505 */
3506 int
3507 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3508 {
3509     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3510     PERL_UNUSED_ARG(sv);
3511
3512     PL_hints |= HINT_LOCALIZE_HH;
3513     CopHINTHASH_set(&PL_compiling,
3514         mg->mg_len == HEf_SVKEY
3515          ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3516                                  MUTABLE_SV(mg->mg_ptr), 0, 0)
3517          : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3518                                  mg->mg_ptr, mg->mg_len, 0, 0));
3519     return 0;
3520 }
3521
3522 /*
3523 =for apidoc magic_clearhints
3524
3525 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3526
3527 =cut
3528 */
3529 int
3530 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3531 {
3532     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3533     PERL_UNUSED_ARG(sv);
3534     PERL_UNUSED_ARG(mg);
3535     cophh_free(CopHINTHASH_get(&PL_compiling));
3536     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3537     return 0;
3538 }
3539
3540 int
3541 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3542                                  const char *name, I32 namlen)
3543 {
3544     MAGIC *nmg;
3545
3546     PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3547     PERL_UNUSED_ARG(sv);
3548     PERL_UNUSED_ARG(name);
3549     PERL_UNUSED_ARG(namlen);
3550
3551     sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3552     nmg = mg_find(nsv, mg->mg_type);
3553     assert(nmg);
3554     if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3555     nmg->mg_ptr = mg->mg_ptr;
3556     nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3557     nmg->mg_flags |= MGf_REFCOUNTED;
3558     return 1;
3559 }
3560
3561 int
3562 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3563     PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3564
3565 #if DBVARMG_SINGLE != 0
3566     assert(mg->mg_private >= DBVARMG_SINGLE);
3567 #endif
3568     assert(mg->mg_private < DBVARMG_COUNT);
3569
3570     PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3571
3572     return 1;
3573 }
3574
3575 int
3576 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3577     PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3578
3579 #if DBVARMG_SINGLE != 0
3580     assert(mg->mg_private >= DBVARMG_SINGLE);
3581 #endif
3582     assert(mg->mg_private < DBVARMG_COUNT);
3583     sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3584
3585     return 0;
3586 }
3587
3588 /*
3589  * ex: set ts=8 sts=4 sw=4 et:
3590  */