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