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