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