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