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