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