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