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