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