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