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