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