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