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