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