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