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