This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In vmsify, leave ../ path components alone.
[perl5.git] / mg.c
1 /*    mg.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *  Sam sat on the ground and put his head in his hands.  'I wish I had never
13  *  come here, and I don't want to see no more magic,' he said, and fell silent.
14  *
15  *     [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
16  */
17
18 /*
19 =head1 Magical Functions
20
21 "Magic" is special data attached to SV structures in order to give them
22 "magical" properties.  When any Perl code tries to read from, or assign to,
23 an SV marked as magical, it calls the 'get' or 'set' function associated
24 with that SV's magic. A get is called prior to reading an SV, in order to
25 give it a chance to update its internal value (get on $. writes the line
26 number of the last read filehandle into to the SV's IV slot), while
27 set is called after an SV has been written to, in order to allow it to make
28 use of its changed value (set on $/ copies the SV's new value to the
29 PL_rs global variable).
30
31 Magic is implemented as a linked list of MAGIC structures attached to the
32 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
33 of functions that implement the get(), set(), length() etc functions,
34 plus space for some flags and pointers. For example, a tied variable has
35 a MAGIC structure that contains a pointer to the object associated with the
36 tie.
37
38 */
39
40 #include "EXTERN.h"
41 #define PERL_IN_MG_C
42 #include "perl.h"
43
44 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
45 #  ifdef I_GRP
46 #    include <grp.h>
47 #  endif
48 #endif
49
50 #if defined(HAS_SETGROUPS)
51 #  ifndef NGROUPS
52 #    define NGROUPS 32
53 #  endif
54 #endif
55
56 #ifdef __hpux
57 #  include <sys/pstat.h>
58 #endif
59
60 #ifdef HAS_PRCTL_SET_NAME
61 #  include <sys/prctl.h>
62 #endif
63
64 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
65 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
66 #else
67 Signal_t Perl_csighandler(int sig);
68 #endif
69
70 #ifdef __Lynx__
71 /* Missing protos on LynxOS */
72 void setruid(uid_t id);
73 void seteuid(uid_t id);
74 void setrgid(uid_t id);
75 void setegid(uid_t id);
76 #endif
77
78 /*
79  * 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 int
793 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
794 {
795     dVAR;
796     register I32 paren;
797     register const char *s = NULL;
798     register REGEXP *rx;
799     const char * const remaining = mg->mg_ptr + 1;
800     const char nextchar = *remaining;
801
802     PERL_ARGS_ASSERT_MAGIC_GET;
803
804     switch (*mg->mg_ptr) {
805     case '\001':                /* ^A */
806         sv_setsv(sv, PL_bodytarget);
807         if (SvTAINTED(PL_bodytarget))
808             SvTAINTED_on(sv);
809         break;
810     case '\003':                /* ^C, ^CHILD_ERROR_NATIVE */
811         if (nextchar == '\0') {
812             sv_setiv(sv, (IV)PL_minus_c);
813         }
814         else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
815             sv_setiv(sv, (IV)STATUS_NATIVE);
816         }
817         break;
818
819     case '\004':                /* ^D */
820         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
821         break;
822     case '\005':  /* ^E */
823          if (nextchar == '\0') {
824 #if defined(VMS)
825              {
826 #                 include <descrip.h>
827 #                 include <starlet.h>
828                   char msg[255];
829                   $DESCRIPTOR(msgdsc,msg);
830                   sv_setnv(sv,(NV) vaxc$errno);
831                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
832                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
833                   else
834                        sv_setpvs(sv,"");
835              }
836 #elif defined(OS2)
837              if (!(_emx_env & 0x200)) { /* Under DOS */
838                   sv_setnv(sv, (NV)errno);
839                   sv_setpv(sv, errno ? Strerror(errno) : "");
840              } else {
841                   if (errno != errno_isOS2) {
842                        const int tmp = _syserrno();
843                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
844                             Perl_rc = tmp;
845                   }
846                   sv_setnv(sv, (NV)Perl_rc);
847                   sv_setpv(sv, os2error(Perl_rc));
848              }
849 #elif defined(WIN32)
850              {
851                   const DWORD dwErr = GetLastError();
852                   sv_setnv(sv, (NV)dwErr);
853                   if (dwErr) {
854                        PerlProc_GetOSError(sv, dwErr);
855                   }
856                   else
857                        sv_setpvs(sv, "");
858                   SetLastError(dwErr);
859              }
860 #else
861              {
862                  dSAVE_ERRNO;
863                  sv_setnv(sv, (NV)errno);
864                  sv_setpv(sv, errno ? Strerror(errno) : "");
865                  RESTORE_ERRNO;
866              }
867 #endif
868              SvRTRIM(sv);
869              SvNOK_on(sv);      /* what a wonderful hack! */
870          }
871          else if (strEQ(remaining, "NCODING"))
872               sv_setsv(sv, PL_encoding);
873          break;
874     case '\006':                /* ^F */
875         sv_setiv(sv, (IV)PL_maxsysfd);
876         break;
877     case '\007':                /* ^GLOBAL_PHASE */
878         if (strEQ(remaining, "LOBAL_PHASE")) {
879             sv_setpvn(sv, PL_phase_names[PL_phase],
880                       strlen(PL_phase_names[PL_phase]));
881         }
882         break;
883     case '\010':                /* ^H */
884         sv_setiv(sv, (IV)PL_hints);
885         break;
886     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
887         sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
888         break;
889     case '\017':                /* ^O & ^OPEN */
890         if (nextchar == '\0') {
891             sv_setpv(sv, PL_osname);
892             SvTAINTED_off(sv);
893         }
894         else if (strEQ(remaining, "PEN")) {
895             Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
896         }
897         break;
898     case '\020':
899         if (nextchar == '\0') {       /* ^P */
900             sv_setiv(sv, (IV)PL_perldb);
901         } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
902             goto do_prematch_fetch;
903         } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
904             goto do_postmatch_fetch;
905         }
906         break;
907     case '\023':                /* ^S */
908         if (nextchar == '\0') {
909             if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
910                 SvOK_off(sv);
911             else if (PL_in_eval)
912                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
913             else
914                 sv_setiv(sv, 0);
915         }
916         break;
917     case '\024':                /* ^T */
918         if (nextchar == '\0') {
919 #ifdef BIG_TIME
920             sv_setnv(sv, PL_basetime);
921 #else
922             sv_setiv(sv, (IV)PL_basetime);
923 #endif
924         }
925         else if (strEQ(remaining, "AINT"))
926             sv_setiv(sv, PL_tainting
927                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
928                     : 0);
929         break;
930     case '\025':                /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
931         if (strEQ(remaining, "NICODE"))
932             sv_setuv(sv, (UV) PL_unicode);
933         else if (strEQ(remaining, "TF8LOCALE"))
934             sv_setuv(sv, (UV) PL_utf8locale);
935         else if (strEQ(remaining, "TF8CACHE"))
936             sv_setiv(sv, (IV) PL_utf8cache);
937         break;
938     case '\027':                /* ^W  & $^WARNING_BITS */
939         if (nextchar == '\0')
940             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
941         else if (strEQ(remaining, "ARNING_BITS")) {
942             if (PL_compiling.cop_warnings == pWARN_NONE) {
943                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
944             }
945             else if (PL_compiling.cop_warnings == pWARN_STD) {
946                 sv_setpvn(
947                     sv, 
948                     (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
949                     WARNsize
950                 );
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             /* else a value has been assigned manually, so do nothing */
1089         }
1090         break;
1091
1092     case '!':
1093         {
1094         dSAVE_ERRNO;
1095 #ifdef VMS
1096         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1097 #else
1098         sv_setnv(sv, (NV)errno);
1099 #endif
1100 #ifdef OS2
1101         if (errno == errno_isOS2 || errno == errno_isOS2_set)
1102             sv_setpv(sv, os2error(Perl_rc));
1103         else
1104 #endif
1105         sv_setpv(sv, errno ? Strerror(errno) : "");
1106         if (SvPOKp(sv))
1107             SvPOK_on(sv);    /* may have got removed during taint processing */
1108         RESTORE_ERRNO;
1109         }
1110
1111         SvRTRIM(sv);
1112         SvNOK_on(sv);   /* what a wonderful hack! */
1113         break;
1114     case '<':
1115         sv_setiv(sv, (IV)PL_uid);
1116         break;
1117     case '>':
1118         sv_setiv(sv, (IV)PL_euid);
1119         break;
1120     case '(':
1121         sv_setiv(sv, (IV)PL_gid);
1122         goto add_groups;
1123     case ')':
1124         sv_setiv(sv, (IV)PL_egid);
1125       add_groups:
1126 #ifdef HAS_GETGROUPS
1127         {
1128             Groups_t *gary = NULL;
1129             I32 i, num_groups = getgroups(0, gary);
1130             Newx(gary, num_groups, Groups_t);
1131             num_groups = getgroups(num_groups, gary);
1132             for (i = 0; i < num_groups; i++)
1133                 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1134             Safefree(gary);
1135         }
1136         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1137 #endif
1138         break;
1139     case '0':
1140         break;
1141     }
1142     return 0;
1143 }
1144
1145 int
1146 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1147 {
1148     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1149
1150     PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1151
1152     if (uf && uf->uf_val)
1153         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1154     return 0;
1155 }
1156
1157 int
1158 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1159 {
1160     dVAR;
1161     STRLEN len = 0, klen;
1162     const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1163     const char * const ptr = MgPV_const(mg,klen);
1164     my_setenv(ptr, s);
1165
1166     PERL_ARGS_ASSERT_MAGIC_SETENV;
1167
1168 #ifdef DYNAMIC_ENV_FETCH
1169      /* We just undefd an environment var.  Is a replacement */
1170      /* waiting in the wings? */
1171     if (!len) {
1172         SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1173         if (valp)
1174             s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1175     }
1176 #endif
1177
1178 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1179                             /* And you'll never guess what the dog had */
1180                             /*   in its mouth... */
1181     if (PL_tainting) {
1182         MgTAINTEDDIR_off(mg);
1183 #ifdef VMS
1184         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1185             char pathbuf[256], eltbuf[256], *cp, *elt;
1186             int i = 0, j = 0;
1187
1188             my_strlcpy(eltbuf, s, sizeof(eltbuf));
1189             elt = eltbuf;
1190             do {          /* DCL$PATH may be a search list */
1191                 while (1) {   /* as may dev portion of any element */
1192                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1193                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1194                              cando_by_name(S_IWUSR,0,elt) ) {
1195                             MgTAINTEDDIR_on(mg);
1196                             return 0;
1197                         }
1198                     }
1199                     if ((cp = strchr(elt, ':')) != NULL)
1200                         *cp = '\0';
1201                     if (my_trnlnm(elt, eltbuf, j++))
1202                         elt = eltbuf;
1203                     else
1204                         break;
1205                 }
1206                 j = 0;
1207             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1208         }
1209 #endif /* VMS */
1210         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1211             const char * const strend = s + len;
1212
1213             while (s < strend) {
1214                 char tmpbuf[256];
1215                 Stat_t st;
1216                 I32 i;
1217 #ifdef VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
1218                 const char path_sep = '|';
1219 #else
1220                 const char path_sep = ':';
1221 #endif
1222                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1223                              s, strend, path_sep, &i);
1224                 s++;
1225                 if (i >= (I32)sizeof tmpbuf   /* too long -- assume the worst */
1226 #ifdef VMS
1227                       || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1228 #else
1229                       || *tmpbuf != '/'       /* no starting slash -- assume relative path */
1230 #endif
1231                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1232                     MgTAINTEDDIR_on(mg);
1233                     return 0;
1234                 }
1235             }
1236         }
1237     }
1238 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1239
1240     return 0;
1241 }
1242
1243 int
1244 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1245 {
1246     PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1247     PERL_UNUSED_ARG(sv);
1248     my_setenv(MgPV_nolen_const(mg),NULL);
1249     return 0;
1250 }
1251
1252 int
1253 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1254 {
1255     dVAR;
1256     PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1257     PERL_UNUSED_ARG(mg);
1258 #if defined(VMS)
1259     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1260 #else
1261     if (PL_localizing) {
1262         HE* entry;
1263         my_clearenv();
1264         hv_iterinit(MUTABLE_HV(sv));
1265         while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1266             I32 keylen;
1267             my_setenv(hv_iterkey(entry, &keylen),
1268                       SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1269         }
1270     }
1271 #endif
1272     return 0;
1273 }
1274
1275 int
1276 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1277 {
1278     dVAR;
1279     PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1280     PERL_UNUSED_ARG(sv);
1281     PERL_UNUSED_ARG(mg);
1282 #if defined(VMS)
1283     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1284 #else
1285     my_clearenv();
1286 #endif
1287     return 0;
1288 }
1289
1290 #ifndef PERL_MICRO
1291 #ifdef HAS_SIGPROCMASK
1292 static void
1293 restore_sigmask(pTHX_ SV *save_sv)
1294 {
1295     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1296     (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1297 }
1298 #endif
1299 int
1300 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1301 {
1302     dVAR;
1303     /* Are we fetching a signal entry? */
1304     int i = (I16)mg->mg_private;
1305
1306     PERL_ARGS_ASSERT_MAGIC_GETSIG;
1307
1308     if (!i) {
1309         STRLEN siglen;
1310         const char * sig = MgPV_const(mg, siglen);
1311         mg->mg_private = i = whichsig_pvn(sig, siglen);
1312     }
1313
1314     if (i > 0) {
1315         if(PL_psig_ptr[i])
1316             sv_setsv(sv,PL_psig_ptr[i]);
1317         else {
1318             Sighandler_t sigstate = rsignal_state(i);
1319 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1320             if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1321                 sigstate = SIG_IGN;
1322 #endif
1323 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1324             if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1325                 sigstate = SIG_DFL;
1326 #endif
1327             /* cache state so we don't fetch it again */
1328             if(sigstate == (Sighandler_t) SIG_IGN)
1329                 sv_setpvs(sv,"IGNORE");
1330             else
1331                 sv_setsv(sv,&PL_sv_undef);
1332             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1333             SvTEMP_off(sv);
1334         }
1335     }
1336     return 0;
1337 }
1338 int
1339 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1340 {
1341     PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1342
1343     magic_setsig(NULL, mg);
1344     return sv_unmagic(sv, mg->mg_type);
1345 }
1346
1347 Signal_t
1348 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1349 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1350 #else
1351 Perl_csighandler(int sig)
1352 #endif
1353 {
1354 #ifdef PERL_GET_SIG_CONTEXT
1355     dTHXa(PERL_GET_SIG_CONTEXT);
1356 #else
1357     dTHX;
1358 #endif
1359 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1360     (void) rsignal(sig, PL_csighandlerp);
1361     if (PL_sig_ignoring[sig]) return;
1362 #endif
1363 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1364     if (PL_sig_defaulting[sig])
1365 #ifdef KILL_BY_SIGPRC
1366             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1367 #else
1368             exit(1);
1369 #endif
1370 #endif
1371     if (
1372 #ifdef SIGILL
1373            sig == SIGILL ||
1374 #endif
1375 #ifdef SIGBUS
1376            sig == SIGBUS ||
1377 #endif
1378 #ifdef SIGSEGV
1379            sig == SIGSEGV ||
1380 #endif
1381            (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1382         /* Call the perl level handler now--
1383          * with risk we may be in malloc() or being destructed etc. */
1384 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1385         (*PL_sighandlerp)(sig, NULL, NULL);
1386 #else
1387         (*PL_sighandlerp)(sig);
1388 #endif
1389     else {
1390         if (!PL_psig_pend) return;
1391         /* Set a flag to say this signal is pending, that is awaiting delivery after
1392          * the current Perl opcode completes */
1393         PL_psig_pend[sig]++;
1394
1395 #ifndef SIG_PENDING_DIE_COUNT
1396 #  define SIG_PENDING_DIE_COUNT 120
1397 #endif
1398         /* Add one to say _a_ signal is pending */
1399         if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1400             Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1401                        (unsigned long)SIG_PENDING_DIE_COUNT);
1402     }
1403 }
1404
1405 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1406 void
1407 Perl_csighandler_init(void)
1408 {
1409     int sig;
1410     if (PL_sig_handlers_initted) return;
1411
1412     for (sig = 1; sig < SIG_SIZE; sig++) {
1413 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1414         dTHX;
1415         PL_sig_defaulting[sig] = 1;
1416         (void) rsignal(sig, PL_csighandlerp);
1417 #endif
1418 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1419         PL_sig_ignoring[sig] = 0;
1420 #endif
1421     }
1422     PL_sig_handlers_initted = 1;
1423 }
1424 #endif
1425
1426 #if defined HAS_SIGPROCMASK
1427 static void
1428 unblock_sigmask(pTHX_ void* newset)
1429 {
1430     sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1431 }
1432 #endif
1433
1434 void
1435 Perl_despatch_signals(pTHX)
1436 {
1437     dVAR;
1438     int sig;
1439     PL_sig_pending = 0;
1440     for (sig = 1; sig < SIG_SIZE; sig++) {
1441         if (PL_psig_pend[sig]) {
1442             dSAVE_ERRNO;
1443 #ifdef HAS_SIGPROCMASK
1444             /* From sigaction(2) (FreeBSD man page):
1445              * | Signal routines normally execute with the signal that
1446              * | caused their invocation blocked, but other signals may
1447              * | yet occur.
1448              * Emulation of this behavior (from within Perl) is enabled
1449              * using sigprocmask
1450              */
1451             int was_blocked;
1452             sigset_t newset, oldset;
1453
1454             sigemptyset(&newset);
1455             sigaddset(&newset, sig);
1456             sigprocmask(SIG_BLOCK, &newset, &oldset);
1457             was_blocked = sigismember(&oldset, sig);
1458             if (!was_blocked) {
1459                 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1460                 ENTER;
1461                 SAVEFREESV(save_sv);
1462                 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1463             }
1464 #endif
1465             PL_psig_pend[sig] = 0;
1466 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1467             (*PL_sighandlerp)(sig, NULL, NULL);
1468 #else
1469             (*PL_sighandlerp)(sig);
1470 #endif
1471 #ifdef HAS_SIGPROCMASK
1472             if (!was_blocked)
1473                 LEAVE;
1474 #endif
1475             RESTORE_ERRNO;
1476         }
1477     }
1478 }
1479
1480 /* sv of NULL signifies that we're acting as magic_clearsig.  */
1481 int
1482 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1483 {
1484     dVAR;
1485     I32 i;
1486     SV** svp = NULL;
1487     /* Need to be careful with SvREFCNT_dec(), because that can have side
1488      * effects (due to closures). We must make sure that the new disposition
1489      * is in place before it is called.
1490      */
1491     SV* to_dec = NULL;
1492     STRLEN len;
1493 #ifdef HAS_SIGPROCMASK
1494     sigset_t set, save;
1495     SV* save_sv;
1496 #endif
1497     register const char *s = MgPV_const(mg,len);
1498
1499     PERL_ARGS_ASSERT_MAGIC_SETSIG;
1500
1501     if (*s == '_') {
1502         if (memEQs(s, len, "__DIE__"))
1503             svp = &PL_diehook;
1504         else if (memEQs(s, len, "__WARN__")
1505                  && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1506             /* Merge the existing behaviours, which are as follows:
1507                magic_setsig, we always set svp to &PL_warnhook
1508                (hence we always change the warnings handler)
1509                For magic_clearsig, we don't change the warnings handler if it's
1510                set to the &PL_warnhook.  */
1511             svp = &PL_warnhook;
1512         } else if (sv) {
1513             SV *tmp = sv_newmortal();
1514             Perl_croak(aTHX_ "No such hook: %s",
1515                                 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1516         }
1517         i = 0;
1518         if (svp && *svp) {
1519             if (*svp != PERL_WARNHOOK_FATAL)
1520                 to_dec = *svp;
1521             *svp = NULL;
1522         }
1523     }
1524     else {
1525         i = (I16)mg->mg_private;
1526         if (!i) {
1527             i = whichsig_pvn(s, len);   /* ...no, a brick */
1528             mg->mg_private = (U16)i;
1529         }
1530         if (i <= 0) {
1531             if (sv) {
1532                 SV *tmp = sv_newmortal();
1533                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1534                                             pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1535             }
1536             return 0;
1537         }
1538 #ifdef HAS_SIGPROCMASK
1539         /* Avoid having the signal arrive at a bad time, if possible. */
1540         sigemptyset(&set);
1541         sigaddset(&set,i);
1542         sigprocmask(SIG_BLOCK, &set, &save);
1543         ENTER;
1544         save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1545         SAVEFREESV(save_sv);
1546         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1547 #endif
1548         PERL_ASYNC_CHECK();
1549 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1550         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1551 #endif
1552 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1553         PL_sig_ignoring[i] = 0;
1554 #endif
1555 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1556         PL_sig_defaulting[i] = 0;
1557 #endif
1558         to_dec = PL_psig_ptr[i];
1559         if (sv) {
1560             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1561             SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1562
1563             /* Signals don't change name during the program's execution, so once
1564                they're cached in the appropriate slot of PL_psig_name, they can
1565                stay there.
1566
1567                Ideally we'd find some way of making SVs at (C) compile time, or
1568                at least, doing most of the work.  */
1569             if (!PL_psig_name[i]) {
1570                 PL_psig_name[i] = newSVpvn(s, len);
1571                 SvREADONLY_on(PL_psig_name[i]);
1572             }
1573         } else {
1574             SvREFCNT_dec(PL_psig_name[i]);
1575             PL_psig_name[i] = NULL;
1576             PL_psig_ptr[i] = NULL;
1577         }
1578     }
1579     if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1580         if (i) {
1581             (void)rsignal(i, PL_csighandlerp);
1582         }
1583         else
1584             *svp = SvREFCNT_inc_simple_NN(sv);
1585     } else {
1586         if (sv && SvOK(sv)) {
1587             s = SvPV_force(sv, len);
1588         } else {
1589             sv = NULL;
1590         }
1591         if (sv && memEQs(s, len,"IGNORE")) {
1592             if (i) {
1593 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1594                 PL_sig_ignoring[i] = 1;
1595                 (void)rsignal(i, PL_csighandlerp);
1596 #else
1597                 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1598 #endif
1599             }
1600         }
1601         else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1602             if (i) {
1603 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1604                 PL_sig_defaulting[i] = 1;
1605                 (void)rsignal(i, PL_csighandlerp);
1606 #else
1607                 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1608 #endif
1609             }
1610         }
1611         else {
1612             /*
1613              * We should warn if HINT_STRICT_REFS, but without
1614              * access to a known hint bit in a known OP, we can't
1615              * tell whether HINT_STRICT_REFS is in force or not.
1616              */
1617             if (!strchr(s,':') && !strchr(s,'\''))
1618                 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1619                                      SV_GMAGIC);
1620             if (i)
1621                 (void)rsignal(i, PL_csighandlerp);
1622             else
1623                 *svp = SvREFCNT_inc_simple_NN(sv);
1624         }
1625     }
1626
1627 #ifdef HAS_SIGPROCMASK
1628     if(i)
1629         LEAVE;
1630 #endif
1631     SvREFCNT_dec(to_dec);
1632     return 0;
1633 }
1634 #endif /* !PERL_MICRO */
1635
1636 int
1637 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1638 {
1639     dVAR;
1640     PERL_ARGS_ASSERT_MAGIC_SETISA;
1641     PERL_UNUSED_ARG(sv);
1642
1643     /* Skip _isaelem because _isa will handle it shortly */
1644     if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1645         return 0;
1646
1647     return magic_clearisa(NULL, mg);
1648 }
1649
1650 /* sv of NULL signifies that we're acting as magic_setisa.  */
1651 int
1652 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1653 {
1654     dVAR;
1655     HV* stash;
1656
1657     PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1658
1659     /* Bail out if destruction is going on */
1660     if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1661
1662     if (sv)
1663         av_clear(MUTABLE_AV(sv));
1664
1665     if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1666         /* This occurs with setisa_elem magic, which calls this
1667            same function. */
1668         mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1669
1670     if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1671         SV **svp = AvARRAY((AV *)mg->mg_obj);
1672         I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1673         while (items--) {
1674             stash = GvSTASH((GV *)*svp++);
1675             if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1676         }
1677
1678         return 0;
1679     }
1680
1681     stash = GvSTASH(
1682         (const GV *)mg->mg_obj
1683     );
1684
1685     /* The stash may have been detached from the symbol table, so check its
1686        name before doing anything. */
1687     if (stash && HvENAME_get(stash))
1688         mro_isa_changed_in(stash);
1689
1690     return 0;
1691 }
1692
1693 int
1694 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1695 {
1696     dVAR;
1697     PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1698     PERL_UNUSED_ARG(sv);
1699     PERL_UNUSED_ARG(mg);
1700     PL_amagic_generation++;
1701
1702     return 0;
1703 }
1704
1705 int
1706 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1707 {
1708     HV * const hv = MUTABLE_HV(LvTARG(sv));
1709     I32 i = 0;
1710
1711     PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1712     PERL_UNUSED_ARG(mg);
1713
1714     if (hv) {
1715          (void) hv_iterinit(hv);
1716          if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1717              i = HvUSEDKEYS(hv);
1718          else {
1719              while (hv_iternext(hv))
1720                  i++;
1721          }
1722     }
1723
1724     sv_setiv(sv, (IV)i);
1725     return 0;
1726 }
1727
1728 int
1729 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1730 {
1731     PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1732     PERL_UNUSED_ARG(mg);
1733     if (LvTARG(sv)) {
1734         hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1735     }
1736     return 0;
1737 }
1738
1739 /*
1740 =for apidoc magic_methcall
1741
1742 Invoke a magic method (like FETCH).
1743
1744 C<sv> and C<mg> are the tied thingy and the tie magic.
1745
1746 C<meth> is the name of the method to call.
1747
1748 C<argc> is the number of args (in addition to $self) to pass to the method.
1749
1750 The C<flags> can be:
1751
1752     G_DISCARD     invoke method with G_DISCARD flag and don't
1753                   return a value
1754     G_UNDEF_FILL  fill the stack with argc pointers to
1755                   PL_sv_undef
1756
1757 The arguments themselves are any values following the C<flags> argument.
1758
1759 Returns the SV (if any) returned by the method, or NULL on failure.
1760
1761
1762 =cut
1763 */
1764
1765 SV*
1766 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1767                     U32 argc, ...)
1768 {
1769     dVAR;
1770     dSP;
1771     SV* ret = NULL;
1772
1773     PERL_ARGS_ASSERT_MAGIC_METHCALL;
1774
1775     ENTER;
1776
1777     if (flags & G_WRITING_TO_STDERR) {
1778         SAVETMPS;
1779
1780         save_re_context();
1781         SAVESPTR(PL_stderrgv);
1782         PL_stderrgv = NULL;
1783     }
1784
1785     PUSHSTACKi(PERLSI_MAGIC);
1786     PUSHMARK(SP);
1787
1788     EXTEND(SP, argc+1);
1789     PUSHs(SvTIED_obj(sv, mg));
1790     if (flags & G_UNDEF_FILL) {
1791         while (argc--) {
1792             PUSHs(&PL_sv_undef);
1793         }
1794     } else if (argc > 0) {
1795         va_list args;
1796         va_start(args, argc);
1797
1798         do {
1799             SV *const sv = va_arg(args, SV *);
1800             PUSHs(sv);
1801         } while (--argc);
1802
1803         va_end(args);
1804     }
1805     PUTBACK;
1806     if (flags & G_DISCARD) {
1807         call_method(meth, G_SCALAR|G_DISCARD);
1808     }
1809     else {
1810         if (call_method(meth, G_SCALAR))
1811             ret = *PL_stack_sp--;
1812     }
1813     POPSTACK;
1814     if (flags & G_WRITING_TO_STDERR)
1815         FREETMPS;
1816     LEAVE;
1817     return ret;
1818 }
1819
1820
1821 /* wrapper for magic_methcall that creates the first arg */
1822
1823 STATIC SV*
1824 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1825     int n, SV *val)
1826 {
1827     dVAR;
1828     SV* arg1 = NULL;
1829
1830     PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1831
1832     if (mg->mg_ptr) {
1833         if (mg->mg_len >= 0) {
1834             arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1835         }
1836         else if (mg->mg_len == HEf_SVKEY)
1837             arg1 = MUTABLE_SV(mg->mg_ptr);
1838     }
1839     else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1840         arg1 = newSViv((IV)(mg->mg_len));
1841         sv_2mortal(arg1);
1842     }
1843     if (!arg1) {
1844         return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1845     }
1846     return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1847 }
1848
1849 STATIC int
1850 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1851 {
1852     dVAR;
1853     SV* ret;
1854
1855     PERL_ARGS_ASSERT_MAGIC_METHPACK;
1856
1857     ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1858     if (ret)
1859         sv_setsv(sv, ret);
1860     return 0;
1861 }
1862
1863 int
1864 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1865 {
1866     PERL_ARGS_ASSERT_MAGIC_GETPACK;
1867
1868     if (mg->mg_type == PERL_MAGIC_tiedelem)
1869         mg->mg_flags |= MGf_GSKIP;
1870     magic_methpack(sv,mg,"FETCH");
1871     return 0;
1872 }
1873
1874 int
1875 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1876 {
1877     dVAR;
1878     MAGIC *tmg;
1879     SV    *val;
1880
1881     PERL_ARGS_ASSERT_MAGIC_SETPACK;
1882
1883     /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1884      * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1885      * public flags indicate its value based on copying from $val. Doing
1886      * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1887      * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1888      * wrong if $val happened to be tainted, as sv hasn't got magic
1889      * enabled, even though taint magic is in the chain. In which case,
1890      * fake up a temporary tainted value (this is easier than temporarily
1891      * re-enabling magic on sv). */
1892
1893     if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1894         && (tmg->mg_len & 1))
1895     {
1896         val = sv_mortalcopy(sv);
1897         SvTAINTED_on(val);
1898     }
1899     else
1900         val = sv;
1901
1902     magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1903     return 0;
1904 }
1905
1906 int
1907 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1908 {
1909     PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1910
1911     if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
1912     return magic_methpack(sv,mg,"DELETE");
1913 }
1914
1915
1916 U32
1917 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1918 {
1919     dVAR;
1920     I32 retval = 0;
1921     SV* retsv;
1922
1923     PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1924
1925     retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1926     if (retsv) {
1927         retval = SvIV(retsv)-1;
1928         if (retval < -1)
1929             Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1930     }
1931     return (U32) retval;
1932 }
1933
1934 int
1935 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1936 {
1937     dVAR;
1938
1939     PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1940
1941     Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1942     return 0;
1943 }
1944
1945 int
1946 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1947 {
1948     dVAR;
1949     SV* ret;
1950
1951     PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1952
1953     ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1954         : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1955     if (ret)
1956         sv_setsv(key,ret);
1957     return 0;
1958 }
1959
1960 int
1961 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1962 {
1963     PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1964
1965     return magic_methpack(sv,mg,"EXISTS");
1966 }
1967
1968 SV *
1969 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1970 {
1971     dVAR;
1972     SV *retval;
1973     SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1974     HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1975    
1976     PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1977
1978     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1979         SV *key;
1980         if (HvEITER_get(hv))
1981             /* we are in an iteration so the hash cannot be empty */
1982             return &PL_sv_yes;
1983         /* no xhv_eiter so now use FIRSTKEY */
1984         key = sv_newmortal();
1985         magic_nextpack(MUTABLE_SV(hv), mg, key);
1986         HvEITER_set(hv, NULL);     /* need to reset iterator */
1987         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1988     }
1989    
1990     /* there is a SCALAR method that we can call */
1991     retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1992     if (!retval)
1993         retval = &PL_sv_undef;
1994     return retval;
1995 }
1996
1997 int
1998 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1999 {
2000     dVAR;
2001     GV * const gv = PL_DBline;
2002     const I32 i = SvTRUE(sv);
2003     SV ** const svp = av_fetch(GvAV(gv),
2004                      atoi(MgPV_nolen_const(mg)), FALSE);
2005
2006     PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2007
2008     if (svp && SvIOKp(*svp)) {
2009         OP * const o = INT2PTR(OP*,SvIVX(*svp));
2010         if (o) {
2011             /* set or clear breakpoint in the relevant control op */
2012             if (i)
2013                 o->op_flags |= OPf_SPECIAL;
2014             else
2015                 o->op_flags &= ~OPf_SPECIAL;
2016         }
2017     }
2018     return 0;
2019 }
2020
2021 int
2022 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2023 {
2024     dVAR;
2025     AV * const obj = MUTABLE_AV(mg->mg_obj);
2026
2027     PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2028
2029     if (obj) {
2030         sv_setiv(sv, AvFILL(obj));
2031     } else {
2032         SvOK_off(sv);
2033     }
2034     return 0;
2035 }
2036
2037 int
2038 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2039 {
2040     dVAR;
2041     AV * const obj = MUTABLE_AV(mg->mg_obj);
2042
2043     PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2044
2045     if (obj) {
2046         av_fill(obj, SvIV(sv));
2047     } else {
2048         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2049                        "Attempt to set length of freed array");
2050     }
2051     return 0;
2052 }
2053
2054 int
2055 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2056 {
2057     dVAR;
2058
2059     PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2060     PERL_UNUSED_ARG(sv);
2061
2062     /* during global destruction, mg_obj may already have been freed */
2063     if (PL_in_clean_all)
2064         return 0;
2065
2066     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2067
2068     if (mg) {
2069         /* arylen scalar holds a pointer back to the array, but doesn't own a
2070            reference. Hence the we (the array) are about to go away with it
2071            still pointing at us. Clear its pointer, else it would be pointing
2072            at free memory. See the comment in sv_magic about reference loops,
2073            and why it can't own a reference to us.  */
2074         mg->mg_obj = 0;
2075     }
2076     return 0;
2077 }
2078
2079 int
2080 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2081 {
2082     dVAR;
2083     SV* const lsv = LvTARG(sv);
2084
2085     PERL_ARGS_ASSERT_MAGIC_GETPOS;
2086     PERL_UNUSED_ARG(mg);
2087
2088     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2089         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2090         if (found && found->mg_len >= 0) {
2091             I32 i = found->mg_len;
2092             if (DO_UTF8(lsv))
2093                 sv_pos_b2u(lsv, &i);
2094             sv_setiv(sv, i);
2095             return 0;
2096         }
2097     }
2098     SvOK_off(sv);
2099     return 0;
2100 }
2101
2102 int
2103 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2104 {
2105     dVAR;
2106     SV* const lsv = LvTARG(sv);
2107     SSize_t pos;
2108     STRLEN len;
2109     STRLEN ulen = 0;
2110     MAGIC* found;
2111
2112     PERL_ARGS_ASSERT_MAGIC_SETPOS;
2113     PERL_UNUSED_ARG(mg);
2114
2115     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2116         found = mg_find(lsv, PERL_MAGIC_regex_global);
2117     else
2118         found = NULL;
2119     if (!found) {
2120         if (!SvOK(sv))
2121             return 0;
2122 #ifdef PERL_OLD_COPY_ON_WRITE
2123     if (SvIsCOW(lsv))
2124         sv_force_normal_flags(lsv, 0);
2125 #endif
2126         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2127                             NULL, 0);
2128     }
2129     else if (!SvOK(sv)) {
2130         found->mg_len = -1;
2131         return 0;
2132     }
2133     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2134
2135     pos = SvIV(sv);
2136
2137     if (DO_UTF8(lsv)) {
2138         ulen = sv_len_utf8(lsv);
2139         if (ulen)
2140             len = ulen;
2141     }
2142
2143     if (pos < 0) {
2144         pos += len;
2145         if (pos < 0)
2146             pos = 0;
2147     }
2148     else if (pos > (SSize_t)len)
2149         pos = len;
2150
2151     if (ulen) {
2152         I32 p = pos;
2153         sv_pos_u2b(lsv, &p, 0);
2154         pos = p;
2155     }
2156
2157     found->mg_len = pos;
2158     found->mg_flags &= ~MGf_MINMATCH;
2159
2160     return 0;
2161 }
2162
2163 int
2164 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2165 {
2166     STRLEN len;
2167     SV * const lsv = LvTARG(sv);
2168     const char * const tmps = SvPV_const(lsv,len);
2169     STRLEN offs = LvTARGOFF(sv);
2170     STRLEN rem = LvTARGLEN(sv);
2171     const bool negoff = LvFLAGS(sv) & 1;
2172     const bool negrem = LvFLAGS(sv) & 2;
2173
2174     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2175     PERL_UNUSED_ARG(mg);
2176
2177     if (!translate_substr_offsets(
2178             SvUTF8(lsv) ? sv_len_utf8(lsv) : len,
2179             negoff ? -(IV)offs : (IV)offs, !negoff,
2180             negrem ? -(IV)rem  : (IV)rem,  !negrem, &offs, &rem
2181     )) {
2182         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2183         sv_setsv_nomg(sv, &PL_sv_undef);
2184         return 0;
2185     }
2186
2187     if (SvUTF8(lsv))
2188         offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2189     sv_setpvn(sv, tmps + offs, rem);
2190     if (SvUTF8(lsv))
2191         SvUTF8_on(sv);
2192     return 0;
2193 }
2194
2195 int
2196 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2197 {
2198     dVAR;
2199     STRLEN len, lsv_len, oldtarglen, newtarglen;
2200     const char * const tmps = SvPV_const(sv, len);
2201     SV * const lsv = LvTARG(sv);
2202     STRLEN lvoff = LvTARGOFF(sv);
2203     STRLEN lvlen = LvTARGLEN(sv);
2204     const bool negoff = LvFLAGS(sv) & 1;
2205     const bool neglen = LvFLAGS(sv) & 2;
2206
2207     PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2208     PERL_UNUSED_ARG(mg);
2209
2210     SvGETMAGIC(lsv);
2211     if (SvROK(lsv))
2212         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2213                             "Attempt to use reference as lvalue in substr"
2214         );
2215     if (SvUTF8(lsv)) lsv_len = sv_len_utf8(lsv);
2216     else (void)SvPV_nomg(lsv,lsv_len);
2217     if (!translate_substr_offsets(
2218             lsv_len,
2219             negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2220             neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2221     ))
2222         Perl_croak(aTHX_ "substr outside of string");
2223     oldtarglen = lvlen;
2224     if (DO_UTF8(sv)) {
2225         sv_utf8_upgrade(lsv);
2226         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2227         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2228         newtarglen = sv_len_utf8(sv);
2229         SvUTF8_on(lsv);
2230     }
2231     else if (lsv && SvUTF8(lsv)) {
2232         const char *utf8;
2233         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2234         newtarglen = len;
2235         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2236         sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2237         Safefree(utf8);
2238     }
2239     else {
2240         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2241         newtarglen = len;
2242     }
2243     if (!neglen) LvTARGLEN(sv) = newtarglen;
2244     if (negoff)  LvTARGOFF(sv) += newtarglen - oldtarglen;
2245
2246     return 0;
2247 }
2248
2249 int
2250 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2251 {
2252     dVAR;
2253
2254     PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2255     PERL_UNUSED_ARG(sv);
2256
2257     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2258     return 0;
2259 }
2260
2261 int
2262 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2263 {
2264     dVAR;
2265
2266     PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2267     PERL_UNUSED_ARG(sv);
2268
2269     /* update taint status */
2270     if (PL_tainted)
2271         mg->mg_len |= 1;
2272     else
2273         mg->mg_len &= ~1;
2274     return 0;
2275 }
2276
2277 int
2278 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2279 {
2280     SV * const lsv = LvTARG(sv);
2281
2282     PERL_ARGS_ASSERT_MAGIC_GETVEC;
2283     PERL_UNUSED_ARG(mg);
2284
2285     if (lsv)
2286         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2287     else
2288         SvOK_off(sv);
2289
2290     return 0;
2291 }
2292
2293 int
2294 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2295 {
2296     PERL_ARGS_ASSERT_MAGIC_SETVEC;
2297     PERL_UNUSED_ARG(mg);
2298     do_vecset(sv);      /* XXX slurp this routine */
2299     return 0;
2300 }
2301
2302 int
2303 Perl_magic_setvstring(pTHX_ SV *sv, MAGIC *mg)
2304 {
2305     PERL_ARGS_ASSERT_MAGIC_SETVSTRING;
2306
2307     if (SvPOKp(sv)) {
2308         SV * const vecsv = sv_newmortal();
2309         scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
2310         if (sv_eq_flags(vecsv, sv, 0 /*nomg*/)) return 0;
2311     }
2312     return sv_unmagic(sv, mg->mg_type);
2313 }
2314
2315 int
2316 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2317 {
2318     dVAR;
2319     SV *targ = NULL;
2320
2321     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2322
2323     if (LvTARGLEN(sv)) {
2324         if (mg->mg_obj) {
2325             SV * const ahv = LvTARG(sv);
2326             HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2327             if (he)
2328                 targ = HeVAL(he);
2329         }
2330         else {
2331             AV *const av = MUTABLE_AV(LvTARG(sv));
2332             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2333                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2334         }
2335         if (targ && (targ != &PL_sv_undef)) {
2336             /* somebody else defined it for us */
2337             SvREFCNT_dec(LvTARG(sv));
2338             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2339             LvTARGLEN(sv) = 0;
2340             SvREFCNT_dec(mg->mg_obj);
2341             mg->mg_obj = NULL;
2342             mg->mg_flags &= ~MGf_REFCOUNTED;
2343         }
2344     }
2345     else
2346         targ = LvTARG(sv);
2347     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2348     return 0;
2349 }
2350
2351 int
2352 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2353 {
2354     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2355     PERL_UNUSED_ARG(mg);
2356     if (LvTARGLEN(sv))
2357         vivify_defelem(sv);
2358     if (LvTARG(sv)) {
2359         sv_setsv(LvTARG(sv), sv);
2360         SvSETMAGIC(LvTARG(sv));
2361     }
2362     return 0;
2363 }
2364
2365 void
2366 Perl_vivify_defelem(pTHX_ SV *sv)
2367 {
2368     dVAR;
2369     MAGIC *mg;
2370     SV *value = NULL;
2371
2372     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2373
2374     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2375         return;
2376     if (mg->mg_obj) {
2377         SV * const ahv = LvTARG(sv);
2378         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2379         if (he)
2380             value = HeVAL(he);
2381         if (!value || value == &PL_sv_undef)
2382             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2383     }
2384     else {
2385         AV *const av = MUTABLE_AV(LvTARG(sv));
2386         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2387             LvTARG(sv) = NULL;  /* array can't be extended */
2388         else {
2389             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2390             if (!svp || (value = *svp) == &PL_sv_undef)
2391                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2392         }
2393     }
2394     SvREFCNT_inc_simple_void(value);
2395     SvREFCNT_dec(LvTARG(sv));
2396     LvTARG(sv) = value;
2397     LvTARGLEN(sv) = 0;
2398     SvREFCNT_dec(mg->mg_obj);
2399     mg->mg_obj = NULL;
2400     mg->mg_flags &= ~MGf_REFCOUNTED;
2401 }
2402
2403 int
2404 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2405 {
2406     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2407     Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2408     return 0;
2409 }
2410
2411 int
2412 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2413 {
2414     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2415     PERL_UNUSED_CONTEXT;
2416     PERL_UNUSED_ARG(sv);
2417     mg->mg_len = -1;
2418     return 0;
2419 }
2420
2421 int
2422 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2423 {
2424     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2425
2426     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2427
2428     if (uf && uf->uf_set)
2429         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2430     return 0;
2431 }
2432
2433 int
2434 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2435 {
2436     const char type = mg->mg_type;
2437
2438     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2439
2440     if (type == PERL_MAGIC_qr) {
2441     } else if (type == PERL_MAGIC_bm) {
2442         SvTAIL_off(sv);
2443         SvVALID_off(sv);
2444     } else if (type == PERL_MAGIC_study) {
2445         if (!isGV_with_GP(sv))
2446             SvSCREAM_off(sv);
2447     } else {
2448         assert(type == PERL_MAGIC_fm);
2449     }
2450     return sv_unmagic(sv, type);
2451 }
2452
2453 #ifdef USE_LOCALE_COLLATE
2454 int
2455 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2456 {
2457     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2458
2459     /*
2460      * RenE<eacute> Descartes said "I think not."
2461      * and vanished with a faint plop.
2462      */
2463     PERL_UNUSED_CONTEXT;
2464     PERL_UNUSED_ARG(sv);
2465     if (mg->mg_ptr) {
2466         Safefree(mg->mg_ptr);
2467         mg->mg_ptr = NULL;
2468         mg->mg_len = -1;
2469     }
2470     return 0;
2471 }
2472 #endif /* USE_LOCALE_COLLATE */
2473
2474 /* Just clear the UTF-8 cache data. */
2475 int
2476 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2477 {
2478     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2479     PERL_UNUSED_CONTEXT;
2480     PERL_UNUSED_ARG(sv);
2481     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2482     mg->mg_ptr = NULL;
2483     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2484     return 0;
2485 }
2486
2487 int
2488 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2489 {
2490     dVAR;
2491     register const char *s;
2492     register I32 paren;
2493     register const REGEXP * rx;
2494     const char * const remaining = mg->mg_ptr + 1;
2495     I32 i;
2496     STRLEN len;
2497     MAGIC *tmg;
2498
2499     PERL_ARGS_ASSERT_MAGIC_SET;
2500
2501     switch (*mg->mg_ptr) {
2502     case '\015': /* $^MATCH */
2503       if (strEQ(remaining, "ATCH"))
2504           goto do_match;
2505     case '`': /* ${^PREMATCH} caught below */
2506       do_prematch:
2507       paren = RX_BUFF_IDX_PREMATCH;
2508       goto setparen;
2509     case '\'': /* ${^POSTMATCH} caught below */
2510       do_postmatch:
2511       paren = RX_BUFF_IDX_POSTMATCH;
2512       goto setparen;
2513     case '&':
2514       do_match:
2515       paren = RX_BUFF_IDX_FULLMATCH;
2516       goto setparen;
2517     case '1': case '2': case '3': case '4':
2518     case '5': case '6': case '7': case '8': case '9':
2519       paren = atoi(mg->mg_ptr);
2520       setparen:
2521         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2522             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2523         } else {
2524             /* Croak with a READONLY error when a numbered match var is
2525              * set without a previous pattern match. Unless it's C<local $1>
2526              */
2527             if (!PL_localizing) {
2528                 Perl_croak_no_modify(aTHX);
2529             }
2530         }
2531         break;
2532     case '\001':        /* ^A */
2533         sv_setsv(PL_bodytarget, sv);
2534         FmLINES(PL_bodytarget) = 0;
2535         if (SvPOK(PL_bodytarget)) {
2536             char *s = SvPVX(PL_bodytarget);
2537             while ( ((s = strchr(s, '\n'))) ) {
2538                 FmLINES(PL_bodytarget)++;
2539                 s++;
2540             }
2541         }
2542         /* mg_set() has temporarily made sv non-magical */
2543         if (PL_tainting) {
2544             if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2545                 SvTAINTED_on(PL_bodytarget);
2546             else
2547                 SvTAINTED_off(PL_bodytarget);
2548         }
2549         break;
2550     case '\003':        /* ^C */
2551         PL_minus_c = cBOOL(SvIV(sv));
2552         break;
2553
2554     case '\004':        /* ^D */
2555 #ifdef DEBUGGING
2556         s = SvPV_nolen_const(sv);
2557         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2558         if (DEBUG_x_TEST || DEBUG_B_TEST)
2559             dump_all_perl(!DEBUG_B_TEST);
2560 #else
2561         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2562 #endif
2563         break;
2564     case '\005':  /* ^E */
2565         if (*(mg->mg_ptr+1) == '\0') {
2566 #ifdef VMS
2567             set_vaxc_errno(SvIV(sv));
2568 #else
2569 #  ifdef WIN32
2570             SetLastError( SvIV(sv) );
2571 #  else
2572 #    ifdef OS2
2573             os2_setsyserrno(SvIV(sv));
2574 #    else
2575             /* will anyone ever use this? */
2576             SETERRNO(SvIV(sv), 4);
2577 #    endif
2578 #  endif
2579 #endif
2580         }
2581         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2582             SvREFCNT_dec(PL_encoding);
2583             if (SvOK(sv) || SvGMAGICAL(sv)) {
2584                 PL_encoding = newSVsv(sv);
2585             }
2586             else {
2587                 PL_encoding = NULL;
2588             }
2589         }
2590         break;
2591     case '\006':        /* ^F */
2592         PL_maxsysfd = SvIV(sv);
2593         break;
2594     case '\010':        /* ^H */
2595         PL_hints = SvIV(sv);
2596         break;
2597     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2598         Safefree(PL_inplace);
2599         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2600         break;
2601     case '\017':        /* ^O */
2602         if (*(mg->mg_ptr+1) == '\0') {
2603             Safefree(PL_osname);
2604             PL_osname = NULL;
2605             if (SvOK(sv)) {
2606                 TAINT_PROPER("assigning to $^O");
2607                 PL_osname = savesvpv(sv);
2608             }
2609         }
2610         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2611             STRLEN len;
2612             const char *const start = SvPV(sv, len);
2613             const char *out = (const char*)memchr(start, '\0', len);
2614             SV *tmp;
2615
2616
2617             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2618             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2619
2620             /* Opening for input is more common than opening for output, so
2621                ensure that hints for input are sooner on linked list.  */
2622             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2623                                        SvUTF8(sv))
2624                 : newSVpvs_flags("", SvUTF8(sv));
2625             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2626             mg_set(tmp);
2627
2628             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2629                                         SvUTF8(sv));
2630             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2631             mg_set(tmp);
2632         }
2633         break;
2634     case '\020':        /* ^P */
2635       if (*remaining == '\0') { /* ^P */
2636           PL_perldb = SvIV(sv);
2637           if (PL_perldb && !PL_DBsingle)
2638               init_debugger();
2639           break;
2640       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2641           goto do_prematch;
2642       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2643           goto do_postmatch;
2644       }
2645       break;
2646     case '\024':        /* ^T */
2647 #ifdef BIG_TIME
2648         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2649 #else
2650         PL_basetime = (Time_t)SvIV(sv);
2651 #endif
2652         break;
2653     case '\025':        /* ^UTF8CACHE */
2654          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2655              PL_utf8cache = (signed char) sv_2iv(sv);
2656          }
2657          break;
2658     case '\027':        /* ^W & $^WARNING_BITS */
2659         if (*(mg->mg_ptr+1) == '\0') {
2660             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2661                 i = SvIV(sv);
2662                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2663                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2664             }
2665         }
2666         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2667             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2668                 if (!SvPOK(sv) && PL_localizing) {
2669                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2670                     PL_compiling.cop_warnings = pWARN_NONE;
2671                     break;
2672                 }
2673                 {
2674                     STRLEN len, i;
2675                     int accumulate = 0 ;
2676                     int any_fatals = 0 ;
2677                     const char * const ptr = SvPV_const(sv, len) ;
2678                     for (i = 0 ; i < len ; ++i) {
2679                         accumulate |= ptr[i] ;
2680                         any_fatals |= (ptr[i] & 0xAA) ;
2681                     }
2682                     if (!accumulate) {
2683                         if (!specialWARN(PL_compiling.cop_warnings))
2684                             PerlMemShared_free(PL_compiling.cop_warnings);
2685                         PL_compiling.cop_warnings = pWARN_NONE;
2686                     }
2687                     /* Yuck. I can't see how to abstract this:  */
2688                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2689                                        WARN_ALL) && !any_fatals) {
2690                         if (!specialWARN(PL_compiling.cop_warnings))
2691                             PerlMemShared_free(PL_compiling.cop_warnings);
2692                         PL_compiling.cop_warnings = pWARN_ALL;
2693                         PL_dowarn |= G_WARN_ONCE ;
2694                     }
2695                     else {
2696                         STRLEN len;
2697                         const char *const p = SvPV_const(sv, len);
2698
2699                         PL_compiling.cop_warnings
2700                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2701                                                          p, len);
2702
2703                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2704                             PL_dowarn |= G_WARN_ONCE ;
2705                     }
2706
2707                 }
2708             }
2709         }
2710         break;
2711     case '.':
2712         if (PL_localizing) {
2713             if (PL_localizing == 1)
2714                 SAVESPTR(PL_last_in_gv);
2715         }
2716         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2717             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2718         break;
2719     case '^':
2720         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2721         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2722         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2723         break;
2724     case '~':
2725         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2726         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2727         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2728         break;
2729     case '=':
2730         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2731         break;
2732     case '-':
2733         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2734         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2735                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2736         break;
2737     case '%':
2738         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2739         break;
2740     case '|':
2741         {
2742             IO * const io = GvIO(PL_defoutgv);
2743             if(!io)
2744               break;
2745             if ((SvIV(sv)) == 0)
2746                 IoFLAGS(io) &= ~IOf_FLUSH;
2747             else {
2748                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2749                     PerlIO *ofp = IoOFP(io);
2750                     if (ofp)
2751                         (void)PerlIO_flush(ofp);
2752                     IoFLAGS(io) |= IOf_FLUSH;
2753                 }
2754             }
2755         }
2756         break;
2757     case '/':
2758         SvREFCNT_dec(PL_rs);
2759         PL_rs = newSVsv(sv);
2760         break;
2761     case '\\':
2762         SvREFCNT_dec(PL_ors_sv);
2763         if (SvOK(sv) || SvGMAGICAL(sv)) {
2764             PL_ors_sv = newSVsv(sv);
2765         }
2766         else {
2767             PL_ors_sv = NULL;
2768         }
2769         break;
2770     case '[':
2771         if (SvIV(sv) != 0)
2772             Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2773         break;
2774     case '?':
2775 #ifdef COMPLEX_STATUS
2776         if (PL_localizing == 2) {
2777             SvUPGRADE(sv, SVt_PVLV);
2778             PL_statusvalue = LvTARGOFF(sv);
2779             PL_statusvalue_vms = LvTARGLEN(sv);
2780         }
2781         else
2782 #endif
2783 #ifdef VMSISH_STATUS
2784         if (VMSISH_STATUS)
2785             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2786         else
2787 #endif
2788             STATUS_UNIX_EXIT_SET(SvIV(sv));
2789         break;
2790     case '!':
2791         {
2792 #ifdef VMS
2793 #   define PERL_VMS_BANG vaxc$errno
2794 #else
2795 #   define PERL_VMS_BANG 0
2796 #endif
2797         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2798                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2799         }
2800         break;
2801     case '<':
2802         PL_uid = SvIV(sv);
2803         if (PL_delaymagic) {
2804             PL_delaymagic |= DM_RUID;
2805             break;                              /* don't do magic till later */
2806         }
2807 #ifdef HAS_SETRUID
2808         (void)setruid((Uid_t)PL_uid);
2809 #else
2810 #ifdef HAS_SETREUID
2811         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2812 #else
2813 #ifdef HAS_SETRESUID
2814       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2815 #else
2816         if (PL_uid == PL_euid) {                /* special case $< = $> */
2817 #ifdef PERL_DARWIN
2818             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2819             if (PL_uid != 0 && PerlProc_getuid() == 0)
2820                 (void)PerlProc_setuid(0);
2821 #endif
2822             (void)PerlProc_setuid(PL_uid);
2823         } else {
2824             PL_uid = PerlProc_getuid();
2825             Perl_croak(aTHX_ "setruid() not implemented");
2826         }
2827 #endif
2828 #endif
2829 #endif
2830         PL_uid = PerlProc_getuid();
2831         break;
2832     case '>':
2833         PL_euid = SvIV(sv);
2834         if (PL_delaymagic) {
2835             PL_delaymagic |= DM_EUID;
2836             break;                              /* don't do magic till later */
2837         }
2838 #ifdef HAS_SETEUID
2839         (void)seteuid((Uid_t)PL_euid);
2840 #else
2841 #ifdef HAS_SETREUID
2842         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2843 #else
2844 #ifdef HAS_SETRESUID
2845         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2846 #else
2847         if (PL_euid == PL_uid)          /* special case $> = $< */
2848             PerlProc_setuid(PL_euid);
2849         else {
2850             PL_euid = PerlProc_geteuid();
2851             Perl_croak(aTHX_ "seteuid() not implemented");
2852         }
2853 #endif
2854 #endif
2855 #endif
2856         PL_euid = PerlProc_geteuid();
2857         break;
2858     case '(':
2859         PL_gid = SvIV(sv);
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)PL_gid);
2866 #else
2867 #ifdef HAS_SETREGID
2868         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2869 #else
2870 #ifdef HAS_SETRESGID
2871       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) -1);
2872 #else
2873         if (PL_gid == PL_egid)                  /* special case $( = $) */
2874             (void)PerlProc_setgid(PL_gid);
2875         else {
2876             PL_gid = PerlProc_getgid();
2877             Perl_croak(aTHX_ "setrgid() not implemented");
2878         }
2879 #endif
2880 #endif
2881 #endif
2882         PL_gid = PerlProc_getgid();
2883         break;
2884     case ')':
2885 #ifdef HAS_SETGROUPS
2886         {
2887             const char *p = SvPV_const(sv, len);
2888             Groups_t *gary = NULL;
2889 #ifdef _SC_NGROUPS_MAX
2890            int maxgrp = sysconf(_SC_NGROUPS_MAX);
2891
2892            if (maxgrp < 0)
2893                maxgrp = NGROUPS;
2894 #else
2895            int maxgrp = NGROUPS;
2896 #endif
2897
2898             while (isSPACE(*p))
2899                 ++p;
2900             PL_egid = Atol(p);
2901             for (i = 0; i < maxgrp; ++i) {
2902                 while (*p && !isSPACE(*p))
2903                     ++p;
2904                 while (isSPACE(*p))
2905                     ++p;
2906                 if (!*p)
2907                     break;
2908                 if(!gary)
2909                     Newx(gary, i + 1, Groups_t);
2910                 else
2911                     Renew(gary, i + 1, Groups_t);
2912                 gary[i] = Atol(p);
2913             }
2914             if (i)
2915                 (void)setgroups(i, gary);
2916             Safefree(gary);
2917         }
2918 #else  /* HAS_SETGROUPS */
2919         PL_egid = SvIV(sv);
2920 #endif /* HAS_SETGROUPS */
2921         if (PL_delaymagic) {
2922             PL_delaymagic |= DM_EGID;
2923             break;                              /* don't do magic till later */
2924         }
2925 #ifdef HAS_SETEGID
2926         (void)setegid((Gid_t)PL_egid);
2927 #else
2928 #ifdef HAS_SETREGID
2929         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2930 #else
2931 #ifdef HAS_SETRESGID
2932         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2933 #else
2934         if (PL_egid == PL_gid)                  /* special case $) = $( */
2935             (void)PerlProc_setgid(PL_egid);
2936         else {
2937             PL_egid = PerlProc_getegid();
2938             Perl_croak(aTHX_ "setegid() not implemented");
2939         }
2940 #endif
2941 #endif
2942 #endif
2943         PL_egid = PerlProc_getegid();
2944         break;
2945     case ':':
2946         PL_chopset = SvPV_force(sv,len);
2947         break;
2948     case '$': /* $$ */
2949         /* Store the pid in mg->mg_obj so we can tell when a fork has
2950            occurred.  mg->mg_obj points to *$ by default, so clear it. */
2951         if (isGV(mg->mg_obj)) {
2952             if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2953                 SvREFCNT_dec(mg->mg_obj);
2954             mg->mg_flags |= MGf_REFCOUNTED;
2955             mg->mg_obj = newSViv((IV)PerlProc_getpid());
2956         }
2957         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2958         break;
2959     case '0':
2960         LOCK_DOLLARZERO_MUTEX;
2961 #ifdef HAS_SETPROCTITLE
2962         /* The BSDs don't show the argv[] in ps(1) output, they
2963          * show a string from the process struct and provide
2964          * the setproctitle() routine to manipulate that. */
2965         if (PL_origalen != 1) {
2966             s = SvPV_const(sv, len);
2967 #   if __FreeBSD_version > 410001
2968             /* The leading "-" removes the "perl: " prefix,
2969              * but not the "(perl) suffix from the ps(1)
2970              * output, because that's what ps(1) shows if the
2971              * argv[] is modified. */
2972             setproctitle("-%s", s);
2973 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2974             /* This doesn't really work if you assume that
2975              * $0 = 'foobar'; will wipe out 'perl' from the $0
2976              * because in ps(1) output the result will be like
2977              * sprintf("perl: %s (perl)", s)
2978              * I guess this is a security feature:
2979              * one (a user process) cannot get rid of the original name.
2980              * --jhi */
2981             setproctitle("%s", s);
2982 #   endif
2983         }
2984 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2985         if (PL_origalen != 1) {
2986              union pstun un;
2987              s = SvPV_const(sv, len);
2988              un.pst_command = (char *)s;
2989              pstat(PSTAT_SETCMD, un, len, 0, 0);
2990         }
2991 #else
2992         if (PL_origalen > 1) {
2993             /* PL_origalen is set in perl_parse(). */
2994             s = SvPV_force(sv,len);
2995             if (len >= (STRLEN)PL_origalen-1) {
2996                 /* Longer than original, will be truncated. We assume that
2997                  * PL_origalen bytes are available. */
2998                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2999             }
3000             else {
3001                 /* Shorter than original, will be padded. */
3002 #ifdef PERL_DARWIN
3003                 /* Special case for Mac OS X: see [perl #38868] */
3004                 const int pad = 0;
3005 #else
3006                 /* Is the space counterintuitive?  Yes.
3007                  * (You were expecting \0?)
3008                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
3009                  * --jhi */
3010                 const int pad = ' ';
3011 #endif
3012                 Copy(s, PL_origargv[0], len, char);
3013                 PL_origargv[0][len] = 0;
3014                 memset(PL_origargv[0] + len + 1,
3015                        pad,  PL_origalen - len - 1);
3016             }
3017             PL_origargv[0][PL_origalen-1] = 0;
3018             for (i = 1; i < PL_origargc; i++)
3019                 PL_origargv[i] = 0;
3020 #ifdef HAS_PRCTL_SET_NAME
3021             /* Set the legacy process name in addition to the POSIX name on Linux */
3022             if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3023                 /* diag_listed_as: SKIPME */
3024                 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3025             }
3026 #endif
3027         }
3028 #endif
3029         UNLOCK_DOLLARZERO_MUTEX;
3030         break;
3031     }
3032     return 0;
3033 }
3034
3035 I32
3036 Perl_whichsig_sv(pTHX_ SV *sigsv)
3037 {
3038     const char *sigpv;
3039     STRLEN siglen;
3040     PERL_ARGS_ASSERT_WHICHSIG_SV;
3041     PERL_UNUSED_CONTEXT;
3042     sigpv = SvPV_const(sigsv, siglen);
3043     return whichsig_pvn(sigpv, siglen);
3044 }
3045
3046 I32
3047 Perl_whichsig_pv(pTHX_ const char *sig)
3048 {
3049     PERL_ARGS_ASSERT_WHICHSIG_PV;
3050     PERL_UNUSED_CONTEXT;
3051     return whichsig_pvn(sig, strlen(sig));
3052 }
3053
3054 I32
3055 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3056 {
3057     register char* const* sigv;
3058
3059     PERL_ARGS_ASSERT_WHICHSIG_PVN;
3060     PERL_UNUSED_CONTEXT;
3061
3062     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3063         if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3064             return PL_sig_num[sigv - (char* const*)PL_sig_name];
3065 #ifdef SIGCLD
3066     if (memEQs(sig, len, "CHLD"))
3067         return SIGCLD;
3068 #endif
3069 #ifdef SIGCHLD
3070     if (memEQs(sig, len, "CLD"))
3071         return SIGCHLD;
3072 #endif
3073     return -1;
3074 }
3075
3076 Signal_t
3077 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3078 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3079 #else
3080 Perl_sighandler(int sig)
3081 #endif
3082 {
3083 #ifdef PERL_GET_SIG_CONTEXT
3084     dTHXa(PERL_GET_SIG_CONTEXT);
3085 #else
3086     dTHX;
3087 #endif
3088     dSP;
3089     GV *gv = NULL;
3090     SV *sv = NULL;
3091     SV * const tSv = PL_Sv;
3092     CV *cv = NULL;
3093     OP *myop = PL_op;
3094     U32 flags = 0;
3095     XPV * const tXpv = PL_Xpv;
3096     I32 old_ss_ix = PL_savestack_ix;
3097
3098
3099     if (!PL_psig_ptr[sig]) {
3100                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3101                                  PL_sig_name[sig]);
3102                 exit(sig);
3103         }
3104
3105     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3106         /* Max number of items pushed there is 3*n or 4. We cannot fix
3107            infinity, so we fix 4 (in fact 5): */
3108         if (PL_savestack_ix + 15 <= PL_savestack_max) {
3109             flags |= 1;
3110             PL_savestack_ix += 5;               /* Protect save in progress. */
3111             SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3112         }
3113     }
3114     /* sv_2cv is too complicated, try a simpler variant first: */
3115     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3116         || SvTYPE(cv) != SVt_PVCV) {
3117         HV *st;
3118         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3119     }
3120
3121     if (!cv || !CvROOT(cv)) {
3122         Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3123                        PL_sig_name[sig], (gv ? GvENAME(gv)
3124                                           : ((cv && CvGV(cv))
3125                                              ? GvENAME(CvGV(cv))
3126                                              : "__ANON__")));
3127         goto cleanup;
3128     }
3129
3130     sv = PL_psig_name[sig]
3131             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3132             : newSVpv(PL_sig_name[sig],0);
3133     flags |= 8;
3134     SAVEFREESV(sv);
3135
3136     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3137         /* make sure our assumption about the size of the SAVEs are correct:
3138          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3139         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3140     }
3141
3142     PUSHSTACKi(PERLSI_SIGNAL);
3143     PUSHMARK(SP);
3144     PUSHs(sv);
3145 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3146     {
3147          struct sigaction oact;
3148
3149          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3150               if (sip) {
3151                    HV *sih = newHV();
3152                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3153                    /* The siginfo fields signo, code, errno, pid, uid,
3154                     * addr, status, and band are defined by POSIX/SUSv3. */
3155                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3156                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3157 #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. */
3158                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
3159                    hv_stores(sih, "status",     newSViv(sip->si_status));
3160                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
3161                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
3162                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3163                    hv_stores(sih, "band",       newSViv(sip->si_band));
3164 #endif
3165                    EXTEND(SP, 2);
3166                    PUSHs(rv);
3167                    mPUSHp((char *)sip, sizeof(*sip));
3168               }
3169
3170          }
3171     }
3172 #endif
3173     PUTBACK;
3174
3175     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3176
3177     POPSTACK;
3178     if (SvTRUE(ERRSV)) {
3179 #ifndef PERL_MICRO
3180         /* Handler "died", for example to get out of a restart-able read().
3181          * Before we re-do that on its behalf re-enable the signal which was
3182          * blocked by the system when we entered.
3183          */
3184 #ifdef HAS_SIGPROCMASK
3185 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3186        if (sip || uap)
3187 #endif
3188         {
3189             sigset_t set;
3190             sigemptyset(&set);
3191             sigaddset(&set,sig);
3192             sigprocmask(SIG_UNBLOCK, &set, NULL);
3193         }
3194 #else
3195         /* Not clear if this will work */
3196         (void)rsignal(sig, SIG_IGN);
3197         (void)rsignal(sig, PL_csighandlerp);
3198 #endif
3199 #endif /* !PERL_MICRO */
3200         die_sv(ERRSV);
3201     }
3202 cleanup:
3203     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3204     PL_savestack_ix = old_ss_ix;
3205     if (flags & 8)
3206         SvREFCNT_dec(sv);
3207     PL_op = myop;                       /* Apparently not needed... */
3208
3209     PL_Sv = tSv;                        /* Restore global temporaries. */
3210     PL_Xpv = tXpv;
3211     return;
3212 }
3213
3214
3215 static void
3216 S_restore_magic(pTHX_ const void *p)
3217 {
3218     dVAR;
3219     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3220     SV* const sv = mgs->mgs_sv;
3221     bool bumped;
3222
3223     if (!sv)
3224         return;
3225
3226     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3227     {
3228 #ifdef PERL_OLD_COPY_ON_WRITE
3229         /* While magic was saved (and off) sv_setsv may well have seen
3230            this SV as a prime candidate for COW.  */
3231         if (SvIsCOW(sv))
3232             sv_force_normal_flags(sv, 0);
3233 #endif
3234
3235         if (mgs->mgs_readonly)
3236             SvREADONLY_on(sv);
3237         if (mgs->mgs_magical)
3238             SvFLAGS(sv) |= mgs->mgs_magical;
3239         else
3240             mg_magical(sv);
3241         if (SvGMAGICAL(sv)) {
3242             /* downgrade public flags to private,
3243                and discard any other private flags */
3244
3245             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3246             if (pubflags) {
3247                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3248                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3249             }
3250         }
3251     }
3252
3253     bumped = mgs->mgs_bumped;
3254     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3255
3256     /* If we're still on top of the stack, pop us off.  (That condition
3257      * will be satisfied if restore_magic was called explicitly, but *not*
3258      * if it's being called via leave_scope.)
3259      * The reason for doing this is that otherwise, things like sv_2cv()
3260      * may leave alloc gunk on the savestack, and some code
3261      * (e.g. sighandler) doesn't expect that...
3262      */
3263     if (PL_savestack_ix == mgs->mgs_ss_ix)
3264     {
3265         UV popval = SSPOPUV;
3266         assert(popval == SAVEt_DESTRUCTOR_X);
3267         PL_savestack_ix -= 2;
3268         popval = SSPOPUV;
3269         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3270         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3271     }
3272     if (bumped) {
3273         if (SvREFCNT(sv) == 1) {
3274             /* We hold the last reference to this SV, which implies that the
3275                SV was deleted as a side effect of the routines we called.
3276                So artificially keep it alive a bit longer.
3277                We avoid turning on the TEMP flag, which can cause the SV's
3278                buffer to get stolen (and maybe other stuff). */
3279             int was_temp = SvTEMP(sv);
3280             sv_2mortal(sv);
3281             if (!was_temp) {
3282                 SvTEMP_off(sv);
3283             }
3284             SvOK_off(sv);
3285         }
3286         else
3287             SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3288     }
3289 }
3290
3291 /* clean up the mess created by Perl_sighandler().
3292  * Note that this is only called during an exit in a signal handler;
3293  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3294  * skipped over. */
3295
3296 static void
3297 S_unwind_handler_stack(pTHX_ const void *p)
3298 {
3299     dVAR;
3300     PERL_UNUSED_ARG(p);
3301
3302     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3303 }
3304
3305 /*
3306 =for apidoc magic_sethint
3307
3308 Triggered by a store to %^H, records the key/value pair to
3309 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3310 anything that would need a deep copy.  Maybe we should warn if we find a
3311 reference.
3312
3313 =cut
3314 */
3315 int
3316 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3317 {
3318     dVAR;
3319     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3320         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3321
3322     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3323
3324     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3325        an alternative leaf in there, with PL_compiling.cop_hints being used if
3326        it's NULL. If needed for threads, the alternative could lock a mutex,
3327        or take other more complex action.  */
3328
3329     /* Something changed in %^H, so it will need to be restored on scope exit.
3330        Doing this here saves a lot of doing it manually in perl code (and
3331        forgetting to do it, and consequent subtle errors.  */
3332     PL_hints |= HINT_LOCALIZE_HH;
3333     CopHINTHASH_set(&PL_compiling,
3334         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3335     return 0;
3336 }
3337
3338 /*
3339 =for apidoc magic_clearhint
3340
3341 Triggered by a delete from %^H, records the key to
3342 C<PL_compiling.cop_hints_hash>.
3343
3344 =cut
3345 */
3346 int
3347 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3348 {
3349     dVAR;
3350
3351     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3352     PERL_UNUSED_ARG(sv);
3353
3354     assert(mg->mg_len == HEf_SVKEY);
3355
3356     PERL_UNUSED_ARG(sv);
3357
3358     PL_hints |= HINT_LOCALIZE_HH;
3359     CopHINTHASH_set(&PL_compiling,
3360         cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3361                                  MUTABLE_SV(mg->mg_ptr), 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 /*
3384  * Local variables:
3385  * c-indentation-style: bsd
3386  * c-basic-offset: 4
3387  * indent-tabs-mode: t
3388  * End:
3389  *
3390  * ex: set ts=8 sts=4 sw=4 noet:
3391  */