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