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