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