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