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