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