This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
eliminate SVpbm_VALID flag
[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     assert(    type == PERL_MAGIC_fm
2447             || type == PERL_MAGIC_qr
2448             || type == PERL_MAGIC_bm);
2449     return sv_unmagic(sv, type);
2450 }
2451
2452 #ifdef USE_LOCALE_COLLATE
2453 int
2454 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2455 {
2456     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2457
2458     /*
2459      * RenE<eacute> Descartes said "I think not."
2460      * and vanished with a faint plop.
2461      */
2462     PERL_UNUSED_CONTEXT;
2463     PERL_UNUSED_ARG(sv);
2464     if (mg->mg_ptr) {
2465         Safefree(mg->mg_ptr);
2466         mg->mg_ptr = NULL;
2467         mg->mg_len = -1;
2468     }
2469     return 0;
2470 }
2471 #endif /* USE_LOCALE_COLLATE */
2472
2473 /* Just clear the UTF-8 cache data. */
2474 int
2475 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2476 {
2477     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2478     PERL_UNUSED_CONTEXT;
2479     PERL_UNUSED_ARG(sv);
2480     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2481     mg->mg_ptr = NULL;
2482     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2483     return 0;
2484 }
2485
2486 int
2487 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2488 {
2489     const char *bad = NULL;
2490     PERL_ARGS_ASSERT_MAGIC_SETLVREF;
2491     if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
2492     switch (mg->mg_private & OPpLVREF_TYPE) {
2493     case OPpLVREF_SV:
2494         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2495             bad = " SCALAR";
2496         break;
2497     case OPpLVREF_AV:
2498         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2499             bad = "n ARRAY";
2500         break;
2501     case OPpLVREF_HV:
2502         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2503             bad = " HASH";
2504         break;
2505     case OPpLVREF_CV:
2506         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2507             bad = " CODE";
2508     }
2509     if (bad)
2510         /* diag_listed_as: Assigned value is not %s reference */
2511         Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
2512     switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2513     case 0:
2514     {
2515         SV * const old = PAD_SV(mg->mg_len);
2516         PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2517         SvREFCNT_dec(old);
2518         break;
2519     }
2520     case SVt_PVGV:
2521         gv_setref(mg->mg_obj, sv);
2522         SvSETMAGIC(mg->mg_obj);
2523         break;
2524     case SVt_PVAV:
2525         av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2526                  SvREFCNT_inc_simple_NN(SvRV(sv)));
2527         break;
2528     case SVt_PVHV:
2529         (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
2530                            SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
2531     }
2532     if (mg->mg_flags & MGf_PERSIST)
2533         NOOP; /* This sv is in use as an iterator var and will be reused,
2534                  so we must leave the magic.  */
2535     else
2536         /* This sv could be returned by the assignment op, so clear the
2537            magic, as lvrefs are an implementation detail that must not be
2538            leaked to the user.  */
2539         sv_unmagic(sv, PERL_MAGIC_lvref);
2540     return 0;
2541 }
2542
2543 static void
2544 S_set_dollarzero(pTHX_ SV *sv)
2545     PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2546 {
2547 #ifdef USE_ITHREADS
2548     dVAR;
2549 #endif
2550     const char *s;
2551     STRLEN len;
2552 #ifdef HAS_SETPROCTITLE
2553     /* The BSDs don't show the argv[] in ps(1) output, they
2554      * show a string from the process struct and provide
2555      * the setproctitle() routine to manipulate that. */
2556     if (PL_origalen != 1) {
2557         s = SvPV_const(sv, len);
2558 #   if __FreeBSD_version > 410001
2559         /* The leading "-" removes the "perl: " prefix,
2560          * but not the "(perl) suffix from the ps(1)
2561          * output, because that's what ps(1) shows if the
2562          * argv[] is modified. */
2563         setproctitle("-%s", s);
2564 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2565         /* This doesn't really work if you assume that
2566          * $0 = 'foobar'; will wipe out 'perl' from the $0
2567          * because in ps(1) output the result will be like
2568          * sprintf("perl: %s (perl)", s)
2569          * I guess this is a security feature:
2570          * one (a user process) cannot get rid of the original name.
2571          * --jhi */
2572         setproctitle("%s", s);
2573 #   endif
2574     }
2575 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2576     if (PL_origalen != 1) {
2577         union pstun un;
2578         s = SvPV_const(sv, len);
2579         un.pst_command = (char *)s;
2580         pstat(PSTAT_SETCMD, un, len, 0, 0);
2581     }
2582 #else
2583     if (PL_origalen > 1) {
2584         I32 i;
2585         /* PL_origalen is set in perl_parse(). */
2586         s = SvPV_force(sv,len);
2587         if (len >= (STRLEN)PL_origalen-1) {
2588             /* Longer than original, will be truncated. We assume that
2589              * PL_origalen bytes are available. */
2590             Copy(s, PL_origargv[0], PL_origalen-1, char);
2591         }
2592         else {
2593             /* Shorter than original, will be padded. */
2594 #ifdef PERL_DARWIN
2595             /* Special case for Mac OS X: see [perl #38868] */
2596             const int pad = 0;
2597 #else
2598             /* Is the space counterintuitive?  Yes.
2599              * (You were expecting \0?)
2600              * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2601              * --jhi */
2602             const int pad = ' ';
2603 #endif
2604             Copy(s, PL_origargv[0], len, char);
2605             PL_origargv[0][len] = 0;
2606             memset(PL_origargv[0] + len + 1,
2607                    pad,  PL_origalen - len - 1);
2608         }
2609         PL_origargv[0][PL_origalen-1] = 0;
2610         for (i = 1; i < PL_origargc; i++)
2611             PL_origargv[i] = 0;
2612 #ifdef HAS_PRCTL_SET_NAME
2613         /* Set the legacy process name in addition to the POSIX name on Linux */
2614         if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2615             /* diag_listed_as: SKIPME */
2616             Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2617         }
2618 #endif
2619     }
2620 #endif
2621 }
2622
2623 int
2624 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2625 {
2626 #ifdef USE_ITHREADS
2627     dVAR;
2628 #endif
2629     I32 paren;
2630     const REGEXP * rx;
2631     I32 i;
2632     STRLEN len;
2633     MAGIC *tmg;
2634
2635     PERL_ARGS_ASSERT_MAGIC_SET;
2636
2637     if (!mg->mg_ptr) {
2638         paren = mg->mg_len;
2639         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2640           setparen_got_rx:
2641             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2642         } else {
2643             /* Croak with a READONLY error when a numbered match var is
2644              * set without a previous pattern match. Unless it's C<local $1>
2645              */
2646           croakparen:
2647             if (!PL_localizing) {
2648                 Perl_croak_no_modify();
2649             }
2650         }
2651         return 0;
2652     }
2653
2654     switch (*mg->mg_ptr) {
2655     case '\001':        /* ^A */
2656         if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2657         else SvOK_off(PL_bodytarget);
2658         FmLINES(PL_bodytarget) = 0;
2659         if (SvPOK(PL_bodytarget)) {
2660             char *s = SvPVX(PL_bodytarget);
2661             while ( ((s = strchr(s, '\n'))) ) {
2662                 FmLINES(PL_bodytarget)++;
2663                 s++;
2664             }
2665         }
2666         /* mg_set() has temporarily made sv non-magical */
2667         if (TAINTING_get) {
2668             if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2669                 SvTAINTED_on(PL_bodytarget);
2670             else
2671                 SvTAINTED_off(PL_bodytarget);
2672         }
2673         break;
2674     case '\003':        /* ^C */
2675         PL_minus_c = cBOOL(SvIV(sv));
2676         break;
2677
2678     case '\004':        /* ^D */
2679 #ifdef DEBUGGING
2680         {
2681             const char *s = SvPV_nolen_const(sv);
2682             PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2683             if (DEBUG_x_TEST || DEBUG_B_TEST)
2684                 dump_all_perl(!DEBUG_B_TEST);
2685         }
2686 #else
2687         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2688 #endif
2689         break;
2690     case '\005':  /* ^E */
2691         if (*(mg->mg_ptr+1) == '\0') {
2692 #ifdef VMS
2693             set_vaxc_errno(SvIV(sv));
2694 #else
2695 #  ifdef WIN32
2696             SetLastError( SvIV(sv) );
2697 #  else
2698 #    ifdef OS2
2699             os2_setsyserrno(SvIV(sv));
2700 #    else
2701             /* will anyone ever use this? */
2702             SETERRNO(SvIV(sv), 4);
2703 #    endif
2704 #  endif
2705 #endif
2706         }
2707         else {
2708             if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
2709                         if (PL_localizing != 2) {
2710                             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2711                                     "${^ENCODING} is no longer supported");
2712                         }
2713         }
2714         break;
2715     case '\006':        /* ^F */
2716         PL_maxsysfd = SvIV(sv);
2717         break;
2718     case '\010':        /* ^H */
2719         PL_hints = SvIV(sv);
2720         break;
2721     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2722         Safefree(PL_inplace);
2723         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2724         break;
2725     case '\016':        /* ^N */
2726         if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2727          && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2728         goto croakparen;
2729     case '\017':        /* ^O */
2730         if (*(mg->mg_ptr+1) == '\0') {
2731             Safefree(PL_osname);
2732             PL_osname = NULL;
2733             if (SvOK(sv)) {
2734                 TAINT_PROPER("assigning to $^O");
2735                 PL_osname = savesvpv(sv);
2736             }
2737         }
2738         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2739             STRLEN len;
2740             const char *const start = SvPV(sv, len);
2741             const char *out = (const char*)memchr(start, '\0', len);
2742             SV *tmp;
2743
2744
2745             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2746             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2747
2748             /* Opening for input is more common than opening for output, so
2749                ensure that hints for input are sooner on linked list.  */
2750             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2751                                        SvUTF8(sv))
2752                 : newSVpvs_flags("", SvUTF8(sv));
2753             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2754             mg_set(tmp);
2755
2756             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2757                                         SvUTF8(sv));
2758             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2759             mg_set(tmp);
2760         }
2761         break;
2762     case '\020':        /* ^P */
2763           PL_perldb = SvIV(sv);
2764           if (PL_perldb && !PL_DBsingle)
2765               init_debugger();
2766       break;
2767     case '\024':        /* ^T */
2768 #ifdef BIG_TIME
2769         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2770 #else
2771         PL_basetime = (Time_t)SvIV(sv);
2772 #endif
2773         break;
2774     case '\025':        /* ^UTF8CACHE */
2775          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2776              PL_utf8cache = (signed char) sv_2iv(sv);
2777          }
2778          break;
2779     case '\027':        /* ^W & $^WARNING_BITS */
2780         if (*(mg->mg_ptr+1) == '\0') {
2781             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2782                 i = SvIV(sv);
2783                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2784                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2785             }
2786         }
2787         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2788             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2789                 if (!SvPOK(sv)) {
2790                     PL_compiling.cop_warnings = pWARN_STD;
2791                     break;
2792                 }
2793                 {
2794                     STRLEN len, i;
2795                     int accumulate = 0 ;
2796                     int any_fatals = 0 ;
2797                     const char * const ptr = SvPV_const(sv, len) ;
2798                     for (i = 0 ; i < len ; ++i) {
2799                         accumulate |= ptr[i] ;
2800                         any_fatals |= (ptr[i] & 0xAA) ;
2801                     }
2802                     if (!accumulate) {
2803                         if (!specialWARN(PL_compiling.cop_warnings))
2804                             PerlMemShared_free(PL_compiling.cop_warnings);
2805                         PL_compiling.cop_warnings = pWARN_NONE;
2806                     }
2807                     /* Yuck. I can't see how to abstract this:  */
2808                     else if (isWARN_on(
2809                                 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2810                                 WARN_ALL)
2811                             && !any_fatals)
2812                     {
2813                         if (!specialWARN(PL_compiling.cop_warnings))
2814                             PerlMemShared_free(PL_compiling.cop_warnings);
2815                         PL_compiling.cop_warnings = pWARN_ALL;
2816                         PL_dowarn |= G_WARN_ONCE ;
2817                     }
2818                     else {
2819                         STRLEN len;
2820                         const char *const p = SvPV_const(sv, len);
2821
2822                         PL_compiling.cop_warnings
2823                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2824                                                          p, len);
2825
2826                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2827                             PL_dowarn |= G_WARN_ONCE ;
2828                     }
2829
2830                 }
2831             }
2832         }
2833 #ifdef WIN32
2834         else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
2835             w32_sloppystat = (bool)sv_true(sv);
2836         }
2837 #endif
2838         break;
2839     case '.':
2840         if (PL_localizing) {
2841             if (PL_localizing == 1)
2842                 SAVESPTR(PL_last_in_gv);
2843         }
2844         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2845             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2846         break;
2847     case '^':
2848         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2849         IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2850         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2851         break;
2852     case '~':
2853         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2854         IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2855         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2856         break;
2857     case '=':
2858         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2859         break;
2860     case '-':
2861         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2862         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2863                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2864         break;
2865     case '%':
2866         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2867         break;
2868     case '|':
2869         {
2870             IO * const io = GvIO(PL_defoutgv);
2871             if(!io)
2872               break;
2873             if ((SvIV(sv)) == 0)
2874                 IoFLAGS(io) &= ~IOf_FLUSH;
2875             else {
2876                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2877                     PerlIO *ofp = IoOFP(io);
2878                     if (ofp)
2879                         (void)PerlIO_flush(ofp);
2880                     IoFLAGS(io) |= IOf_FLUSH;
2881                 }
2882             }
2883         }
2884         break;
2885     case '/':
2886         {
2887             SV *tmpsv= sv;
2888             if (SvROK(sv)) {
2889                 SV *referent= SvRV(sv);
2890                 const char *reftype= sv_reftype(referent, 0);
2891                 /* XXX: dodgy type check: This leaves me feeling dirty, but the alternative
2892                  * is to copy pretty much the entire sv_reftype() into this routine, or to do
2893                  * a full string comparison on the return of sv_reftype() both of which
2894                  * make me feel worse! NOTE, do not modify this comment without reviewing the
2895                  * corresponding comment in sv_reftype(). - Yves */
2896                 if (reftype[0] == 'S' || reftype[0] == 'L') {
2897                     IV val= SvIV(referent);
2898                     if (val <= 0) {
2899                         tmpsv= &PL_sv_undef;
2900                         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2901                             "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef",
2902                             SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
2903                         );
2904                     }
2905                 } else {
2906                     sv_setsv(sv, PL_rs);
2907               /* diag_listed_as: Setting $/ to %s reference is forbidden */
2908                     Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
2909                                       *reftype == 'A' ? "n" : "", reftype);
2910                 }
2911             }
2912             SvREFCNT_dec(PL_rs);
2913             PL_rs = newSVsv(tmpsv);
2914         }
2915         break;
2916     case '\\':
2917         SvREFCNT_dec(PL_ors_sv);
2918         if (SvOK(sv)) {
2919             PL_ors_sv = newSVsv(sv);
2920         }
2921         else {
2922             PL_ors_sv = NULL;
2923         }
2924         break;
2925     case '[':
2926         if (SvIV(sv) != 0)
2927             Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2928         break;
2929     case '?':
2930 #ifdef COMPLEX_STATUS
2931         if (PL_localizing == 2) {
2932             SvUPGRADE(sv, SVt_PVLV);
2933             PL_statusvalue = LvTARGOFF(sv);
2934             PL_statusvalue_vms = LvTARGLEN(sv);
2935         }
2936         else
2937 #endif
2938 #ifdef VMSISH_STATUS
2939         if (VMSISH_STATUS)
2940             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2941         else
2942 #endif
2943             STATUS_UNIX_EXIT_SET(SvIV(sv));
2944         break;
2945     case '!':
2946         {
2947 #ifdef VMS
2948 #   define PERL_VMS_BANG vaxc$errno
2949 #else
2950 #   define PERL_VMS_BANG 0
2951 #endif
2952 #if defined(WIN32) && ! defined(UNDER_CE)
2953         SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
2954                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2955 #else
2956         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2957                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2958 #endif
2959         }
2960         break;
2961     case '<':
2962         {
2963         /* XXX $< currently silently ignores failures */
2964         const Uid_t new_uid = SvUID(sv);
2965         PL_delaymagic_uid = new_uid;
2966         if (PL_delaymagic) {
2967             PL_delaymagic |= DM_RUID;
2968             break;                              /* don't do magic till later */
2969         }
2970 #ifdef HAS_SETRUID
2971         PERL_UNUSED_RESULT(setruid(new_uid));
2972 #else
2973 #ifdef HAS_SETREUID
2974         PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
2975 #else
2976 #ifdef HAS_SETRESUID
2977         PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
2978 #else
2979         if (new_uid == PerlProc_geteuid()) {            /* special case $< = $> */
2980 #ifdef PERL_DARWIN
2981             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2982             if (new_uid != 0 && PerlProc_getuid() == 0)
2983                 PERL_UNUSED_RESULT(PerlProc_setuid(0));
2984 #endif
2985             PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
2986         } else {
2987             Perl_croak(aTHX_ "setruid() not implemented");
2988         }
2989 #endif
2990 #endif
2991 #endif
2992         break;
2993         }
2994     case '>':
2995         {
2996         /* XXX $> currently silently ignores failures */
2997         const Uid_t new_euid = SvUID(sv);
2998         PL_delaymagic_euid = new_euid;
2999         if (PL_delaymagic) {
3000             PL_delaymagic |= DM_EUID;
3001             break;                              /* don't do magic till later */
3002         }
3003 #ifdef HAS_SETEUID
3004         PERL_UNUSED_RESULT(seteuid(new_euid));
3005 #else
3006 #ifdef HAS_SETREUID
3007         PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3008 #else
3009 #ifdef HAS_SETRESUID
3010         PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3011 #else
3012         if (new_euid == PerlProc_getuid())              /* special case $> = $< */
3013             PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3014         else {
3015             Perl_croak(aTHX_ "seteuid() not implemented");
3016         }
3017 #endif
3018 #endif
3019 #endif
3020         break;
3021         }
3022     case '(':
3023         {
3024         /* XXX $( currently silently ignores failures */
3025         const Gid_t new_gid = SvGID(sv);
3026         PL_delaymagic_gid = new_gid;
3027         if (PL_delaymagic) {
3028             PL_delaymagic |= DM_RGID;
3029             break;                              /* don't do magic till later */
3030         }
3031 #ifdef HAS_SETRGID
3032         PERL_UNUSED_RESULT(setrgid(new_gid));
3033 #else
3034 #ifdef HAS_SETREGID
3035         PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3036 #else
3037 #ifdef HAS_SETRESGID
3038         PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3039 #else
3040         if (new_gid == PerlProc_getegid())                      /* special case $( = $) */
3041             PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3042         else {
3043             Perl_croak(aTHX_ "setrgid() not implemented");
3044         }
3045 #endif
3046 #endif
3047 #endif
3048         break;
3049         }
3050     case ')':
3051         {
3052 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3053  * but you can override it if you need to.
3054  */
3055 #ifndef INVALID_GID
3056 #define INVALID_GID ((Gid_t)-1)
3057 #endif
3058         /* XXX $) currently silently ignores failures */
3059         Gid_t new_egid;
3060 #ifdef HAS_SETGROUPS
3061         {
3062             const char *p = SvPV_const(sv, len);
3063             Groups_t *gary = NULL;
3064             const char* endptr;
3065             UV uv;
3066 #ifdef _SC_NGROUPS_MAX
3067            int maxgrp = sysconf(_SC_NGROUPS_MAX);
3068
3069            if (maxgrp < 0)
3070                maxgrp = NGROUPS;
3071 #else
3072            int maxgrp = NGROUPS;
3073 #endif
3074
3075             while (isSPACE(*p))
3076                 ++p;
3077             if (grok_atoUV(p, &uv, &endptr))
3078                 new_egid = (Gid_t)uv;
3079             else {
3080                 new_egid = INVALID_GID;
3081                 endptr = NULL;
3082             }
3083             for (i = 0; i < maxgrp; ++i) {
3084                 if (endptr == NULL)
3085                     break;
3086                 p = endptr;
3087                 while (isSPACE(*p))
3088                     ++p;
3089                 if (!*p)
3090                     break;
3091                 if (!gary)
3092                     Newx(gary, i + 1, Groups_t);
3093                 else
3094                     Renew(gary, i + 1, Groups_t);
3095                 if (grok_atoUV(p, &uv, &endptr))
3096                     gary[i] = (Groups_t)uv;
3097                 else {
3098                     gary[i] = INVALID_GID;
3099                     endptr = NULL;
3100                 }
3101             }
3102             if (i)
3103                 PERL_UNUSED_RESULT(setgroups(i, gary));
3104             Safefree(gary);
3105         }
3106 #else  /* HAS_SETGROUPS */
3107         new_egid = SvGID(sv);
3108 #endif /* HAS_SETGROUPS */
3109         PL_delaymagic_egid = new_egid;
3110         if (PL_delaymagic) {
3111             PL_delaymagic |= DM_EGID;
3112             break;                              /* don't do magic till later */
3113         }
3114 #ifdef HAS_SETEGID
3115         PERL_UNUSED_RESULT(setegid(new_egid));
3116 #else
3117 #ifdef HAS_SETREGID
3118         PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3119 #else
3120 #ifdef HAS_SETRESGID
3121         PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3122 #else
3123         if (new_egid == PerlProc_getgid())                      /* special case $) = $( */
3124             PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3125         else {
3126             Perl_croak(aTHX_ "setegid() not implemented");
3127         }
3128 #endif
3129 #endif
3130 #endif
3131         break;
3132         }
3133     case ':':
3134         PL_chopset = SvPV_force(sv,len);
3135         break;
3136     case '$': /* $$ */
3137         /* Store the pid in mg->mg_obj so we can tell when a fork has
3138            occurred.  mg->mg_obj points to *$ by default, so clear it. */
3139         if (isGV(mg->mg_obj)) {
3140             if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3141                 SvREFCNT_dec(mg->mg_obj);
3142             mg->mg_flags |= MGf_REFCOUNTED;
3143             mg->mg_obj = newSViv((IV)PerlProc_getpid());
3144         }
3145         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3146         break;
3147     case '0':
3148         LOCK_DOLLARZERO_MUTEX;
3149         S_set_dollarzero(aTHX_ sv);
3150         UNLOCK_DOLLARZERO_MUTEX;
3151         break;
3152     }
3153     return 0;
3154 }
3155
3156 I32
3157 Perl_whichsig_sv(pTHX_ SV *sigsv)
3158 {
3159     const char *sigpv;
3160     STRLEN siglen;
3161     PERL_ARGS_ASSERT_WHICHSIG_SV;
3162     sigpv = SvPV_const(sigsv, siglen);
3163     return whichsig_pvn(sigpv, siglen);
3164 }
3165
3166 I32
3167 Perl_whichsig_pv(pTHX_ const char *sig)
3168 {
3169     PERL_ARGS_ASSERT_WHICHSIG_PV;
3170     return whichsig_pvn(sig, strlen(sig));
3171 }
3172
3173 I32
3174 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3175 {
3176     char* const* sigv;
3177
3178     PERL_ARGS_ASSERT_WHICHSIG_PVN;
3179     PERL_UNUSED_CONTEXT;
3180
3181     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3182         if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3183             return PL_sig_num[sigv - (char* const*)PL_sig_name];
3184 #ifdef SIGCLD
3185     if (memEQs(sig, len, "CHLD"))
3186         return SIGCLD;
3187 #endif
3188 #ifdef SIGCHLD
3189     if (memEQs(sig, len, "CLD"))
3190         return SIGCHLD;
3191 #endif
3192     return -1;
3193 }
3194
3195 Signal_t
3196 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3197 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3198 #else
3199 Perl_sighandler(int sig)
3200 #endif
3201 {
3202 #ifdef PERL_GET_SIG_CONTEXT
3203     dTHXa(PERL_GET_SIG_CONTEXT);
3204 #else
3205     dTHX;
3206 #endif
3207     dSP;
3208     GV *gv = NULL;
3209     SV *sv = NULL;
3210     SV * const tSv = PL_Sv;
3211     CV *cv = NULL;
3212     OP *myop = PL_op;
3213     U32 flags = 0;
3214     XPV * const tXpv = PL_Xpv;
3215     I32 old_ss_ix = PL_savestack_ix;
3216     SV *errsv_save = NULL;
3217
3218
3219     if (!PL_psig_ptr[sig]) {
3220                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3221                                  PL_sig_name[sig]);
3222                 exit(sig);
3223         }
3224
3225     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3226         /* Max number of items pushed there is 3*n or 4. We cannot fix
3227            infinity, so we fix 4 (in fact 5): */
3228         if (PL_savestack_ix + 15 <= PL_savestack_max) {
3229             flags |= 1;
3230             PL_savestack_ix += 5;               /* Protect save in progress. */
3231             SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3232         }
3233     }
3234     /* sv_2cv is too complicated, try a simpler variant first: */
3235     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3236         || SvTYPE(cv) != SVt_PVCV) {
3237         HV *st;
3238         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3239     }
3240
3241     if (!cv || !CvROOT(cv)) {
3242         const HEK * const hek = gv
3243                         ? GvENAME_HEK(gv)
3244                         : cv && CvNAMED(cv)
3245                            ? CvNAME_HEK(cv)
3246                            : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3247         if (hek)
3248             Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3249                                 "SIG%s handler \"%"HEKf"\" not defined.\n",
3250                                  PL_sig_name[sig], HEKfARG(hek));
3251              /* diag_listed_as: SIG%s handler "%s" not defined */
3252         else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3253                            "SIG%s handler \"__ANON__\" not defined.\n",
3254                             PL_sig_name[sig]);
3255         goto cleanup;
3256     }
3257
3258     sv = PL_psig_name[sig]
3259             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3260             : newSVpv(PL_sig_name[sig],0);
3261     flags |= 8;
3262     SAVEFREESV(sv);
3263
3264     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3265         /* make sure our assumption about the size of the SAVEs are correct:
3266          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3267         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3268     }
3269
3270     PUSHSTACKi(PERLSI_SIGNAL);
3271     PUSHMARK(SP);
3272     PUSHs(sv);
3273 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3274     {
3275          struct sigaction oact;
3276
3277          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3278               if (sip) {
3279                    HV *sih = newHV();
3280                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3281                    /* The siginfo fields signo, code, errno, pid, uid,
3282                     * addr, status, and band are defined by POSIX/SUSv3. */
3283                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3284                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3285 #ifdef HAS_SIGINFO_SI_ERRNO
3286                    (void)hv_stores(sih, "errno",      newSViv(sip->si_errno));
3287 #endif
3288 #ifdef HAS_SIGINFO_SI_STATUS
3289                    (void)hv_stores(sih, "status",     newSViv(sip->si_status));
3290 #endif
3291 #ifdef HAS_SIGINFO_SI_UID
3292                    {
3293                         SV *uid = newSV(0);
3294                         sv_setuid(uid, sip->si_uid);
3295                         (void)hv_stores(sih, "uid", uid);
3296                    }
3297 #endif
3298 #ifdef HAS_SIGINFO_SI_PID
3299                    (void)hv_stores(sih, "pid",        newSViv(sip->si_pid));
3300 #endif
3301 #ifdef HAS_SIGINFO_SI_ADDR
3302                    (void)hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3303 #endif
3304 #ifdef HAS_SIGINFO_SI_BAND
3305                    (void)hv_stores(sih, "band",       newSViv(sip->si_band));
3306 #endif
3307                    EXTEND(SP, 2);
3308                    PUSHs(rv);
3309                    mPUSHp((char *)sip, sizeof(*sip));
3310               }
3311
3312          }
3313     }
3314 #endif
3315     PUTBACK;
3316
3317     errsv_save = newSVsv(ERRSV);
3318
3319     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3320
3321     POPSTACK;
3322     {
3323         SV * const errsv = ERRSV;
3324         if (SvTRUE_NN(errsv)) {
3325             SvREFCNT_dec(errsv_save);
3326 #ifndef PERL_MICRO
3327         /* Handler "died", for example to get out of a restart-able read().
3328          * Before we re-do that on its behalf re-enable the signal which was
3329          * blocked by the system when we entered.
3330          */
3331 #ifdef HAS_SIGPROCMASK
3332 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3333             if (sip || uap)
3334 #endif
3335             {
3336                 sigset_t set;
3337                 sigemptyset(&set);
3338                 sigaddset(&set,sig);
3339                 sigprocmask(SIG_UNBLOCK, &set, NULL);
3340             }
3341 #else
3342             /* Not clear if this will work */
3343             (void)rsignal(sig, SIG_IGN);
3344             (void)rsignal(sig, PL_csighandlerp);
3345 #endif
3346 #endif /* !PERL_MICRO */
3347             die_sv(errsv);
3348         }
3349         else {
3350             sv_setsv(errsv, errsv_save);
3351             SvREFCNT_dec(errsv_save);
3352         }
3353     }
3354
3355   cleanup:
3356     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3357     PL_savestack_ix = old_ss_ix;
3358     if (flags & 8)
3359         SvREFCNT_dec_NN(sv);
3360     PL_op = myop;                       /* Apparently not needed... */
3361
3362     PL_Sv = tSv;                        /* Restore global temporaries. */
3363     PL_Xpv = tXpv;
3364     return;
3365 }
3366
3367
3368 static void
3369 S_restore_magic(pTHX_ const void *p)
3370 {
3371     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3372     SV* const sv = mgs->mgs_sv;
3373     bool bumped;
3374
3375     if (!sv)
3376         return;
3377
3378     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3379         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3380         if (mgs->mgs_flags)
3381             SvFLAGS(sv) |= mgs->mgs_flags;
3382         else
3383             mg_magical(sv);
3384     }
3385
3386     bumped = mgs->mgs_bumped;
3387     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3388
3389     /* If we're still on top of the stack, pop us off.  (That condition
3390      * will be satisfied if restore_magic was called explicitly, but *not*
3391      * if it's being called via leave_scope.)
3392      * The reason for doing this is that otherwise, things like sv_2cv()
3393      * may leave alloc gunk on the savestack, and some code
3394      * (e.g. sighandler) doesn't expect that...
3395      */
3396     if (PL_savestack_ix == mgs->mgs_ss_ix)
3397     {
3398         UV popval = SSPOPUV;
3399         assert(popval == SAVEt_DESTRUCTOR_X);
3400         PL_savestack_ix -= 2;
3401         popval = SSPOPUV;
3402         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3403         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3404     }
3405     if (bumped) {
3406         if (SvREFCNT(sv) == 1) {
3407             /* We hold the last reference to this SV, which implies that the
3408                SV was deleted as a side effect of the routines we called.
3409                So artificially keep it alive a bit longer.
3410                We avoid turning on the TEMP flag, which can cause the SV's
3411                buffer to get stolen (and maybe other stuff). */
3412             sv_2mortal(sv);
3413             SvTEMP_off(sv);
3414         }
3415         else
3416             SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3417     }
3418 }
3419
3420 /* clean up the mess created by Perl_sighandler().
3421  * Note that this is only called during an exit in a signal handler;
3422  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3423  * skipped over. */
3424
3425 static void
3426 S_unwind_handler_stack(pTHX_ const void *p)
3427 {
3428     PERL_UNUSED_ARG(p);
3429
3430     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3431 }
3432
3433 /*
3434 =for apidoc magic_sethint
3435
3436 Triggered by a store to C<%^H>, records the key/value pair to
3437 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3438 anything that would need a deep copy.  Maybe we should warn if we find a
3439 reference.
3440
3441 =cut
3442 */
3443 int
3444 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3445 {
3446     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3447         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3448
3449     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3450
3451     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3452        an alternative leaf in there, with PL_compiling.cop_hints being used if
3453        it's NULL. If needed for threads, the alternative could lock a mutex,
3454        or take other more complex action.  */
3455
3456     /* Something changed in %^H, so it will need to be restored on scope exit.
3457        Doing this here saves a lot of doing it manually in perl code (and
3458        forgetting to do it, and consequent subtle errors.  */
3459     PL_hints |= HINT_LOCALIZE_HH;
3460     CopHINTHASH_set(&PL_compiling,
3461         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3462     return 0;
3463 }
3464
3465 /*
3466 =for apidoc magic_clearhint
3467
3468 Triggered by a delete from C<%^H>, records the key to
3469 C<PL_compiling.cop_hints_hash>.
3470
3471 =cut
3472 */
3473 int
3474 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3475 {
3476     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3477     PERL_UNUSED_ARG(sv);
3478
3479     PL_hints |= HINT_LOCALIZE_HH;
3480     CopHINTHASH_set(&PL_compiling,
3481         mg->mg_len == HEf_SVKEY
3482          ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3483                                  MUTABLE_SV(mg->mg_ptr), 0, 0)
3484          : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3485                                  mg->mg_ptr, mg->mg_len, 0, 0));
3486     return 0;
3487 }
3488
3489 /*
3490 =for apidoc magic_clearhints
3491
3492 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3493
3494 =cut
3495 */
3496 int
3497 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3498 {
3499     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3500     PERL_UNUSED_ARG(sv);
3501     PERL_UNUSED_ARG(mg);
3502     cophh_free(CopHINTHASH_get(&PL_compiling));
3503     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3504     return 0;
3505 }
3506
3507 int
3508 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3509                                  const char *name, I32 namlen)
3510 {
3511     MAGIC *nmg;
3512
3513     PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3514     PERL_UNUSED_ARG(sv);
3515     PERL_UNUSED_ARG(name);
3516     PERL_UNUSED_ARG(namlen);
3517
3518     sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3519     nmg = mg_find(nsv, mg->mg_type);
3520     assert(nmg);
3521     if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3522     nmg->mg_ptr = mg->mg_ptr;
3523     nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3524     nmg->mg_flags |= MGf_REFCOUNTED;
3525     return 1;
3526 }
3527
3528 int
3529 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3530     PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3531
3532 #if DBVARMG_SINGLE != 0
3533     assert(mg->mg_private >= DBVARMG_SINGLE);
3534 #endif
3535     assert(mg->mg_private < DBVARMG_COUNT);
3536
3537     PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3538
3539     return 1;
3540 }
3541
3542 int
3543 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3544     PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3545
3546 #if DBVARMG_SINGLE != 0
3547     assert(mg->mg_private >= DBVARMG_SINGLE);
3548 #endif
3549     assert(mg->mg_private < DBVARMG_COUNT);
3550     sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3551
3552     return 0;
3553 }
3554
3555 /*
3556  * ex: set ts=8 sts=4 sw=4 et:
3557  */