This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
af52790175190433017fc958bb96aea577c1bd26
[perl5.git] / mg.c
1 /*    mg.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005 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
16 /*
17 =head1 Magical Functions
18
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties.  When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
28
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
34 tie.
35
36 */
37
38 #include "EXTERN.h"
39 #define PERL_IN_MG_C
40 #include "perl.h"
41
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
43 #  ifndef NGROUPS
44 #    define NGROUPS 32
45 #  endif
46 #  ifdef I_GRP
47 #    include <grp.h>
48 #  endif
49 #endif
50
51 #ifdef __hpux
52 #  include <sys/pstat.h>
53 #endif
54
55 Signal_t Perl_csighandler(int sig);
56
57 /* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */
58 #if !defined(HAS_SIGACTION) && defined(VMS)
59 #  define  FAKE_PERSISTENT_SIGNAL_HANDLERS
60 #endif
61 /* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */
62 #if defined(KILL_BY_SIGPRC)
63 #  define  FAKE_DEFAULT_SIGNAL_HANDLERS
64 #endif
65
66 static void restore_magic(pTHX_ const void *p);
67 static void unwind_handler_stack(pTHX_ const void *p);
68
69 #ifdef __Lynx__
70 /* Missing protos on LynxOS */
71 void setruid(uid_t id);
72 void seteuid(uid_t id);
73 void setrgid(uid_t id);
74 void setegid(uid_t id);
75 #endif
76
77 /*
78  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
79  */
80
81 struct magic_state {
82     SV* mgs_sv;
83     U32 mgs_flags;
84     I32 mgs_ss_ix;
85 };
86 /* MGS is typedef'ed to struct magic_state in perl.h */
87
88 STATIC void
89 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
90 {
91     MGS* mgs;
92     assert(SvMAGICAL(sv));
93 #ifdef PERL_COPY_ON_WRITE
94     /* Turning READONLY off for a copy-on-write scalar is a bad idea.  */
95     if (SvIsCOW(sv))
96       sv_force_normal(sv);
97 #endif
98
99     SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
100
101     mgs = SSPTR(mgs_ix, MGS*);
102     mgs->mgs_sv = sv;
103     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
104     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
105
106     SvMAGICAL_off(sv);
107     SvREADONLY_off(sv);
108     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
109 }
110
111 /*
112 =for apidoc mg_magical
113
114 Turns on the magical status of an SV.  See C<sv_magic>.
115
116 =cut
117 */
118
119 void
120 Perl_mg_magical(pTHX_ SV *sv)
121 {
122     const MAGIC* mg;
123     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
124         const MGVTBL* const vtbl = mg->mg_virtual;
125         if (vtbl) {
126             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
127                 SvGMAGICAL_on(sv);
128             if (vtbl->svt_set)
129                 SvSMAGICAL_on(sv);
130             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
131                 SvRMAGICAL_on(sv);
132         }
133     }
134 }
135
136 /*
137 =for apidoc mg_get
138
139 Do magic after a value is retrieved from the SV.  See C<sv_magic>.
140
141 =cut
142 */
143
144 int
145 Perl_mg_get(pTHX_ SV *sv)
146 {
147     const I32 mgs_ix = SSNEW(sizeof(MGS));
148     const bool was_temp = (bool)SvTEMP(sv);
149     int have_new = 0;
150     MAGIC *newmg, *head, *cur, *mg;
151     /* guard against sv having being freed midway by holding a private
152        reference. */
153
154     /* sv_2mortal has this side effect of turning on the TEMP flag, which can
155        cause the SV's buffer to get stolen (and maybe other stuff).
156        So restore it.
157     */
158     sv_2mortal(SvREFCNT_inc(sv));
159     if (!was_temp) {
160         SvTEMP_off(sv);
161     }
162
163     save_magic(mgs_ix, sv);
164
165     /* We must call svt_get(sv, mg) for each valid entry in the linked
166        list of magic. svt_get() may delete the current entry, add new
167        magic to the head of the list, or upgrade the SV. AMS 20010810 */
168
169     newmg = cur = head = mg = SvMAGIC(sv);
170     while (mg) {
171         const MGVTBL * const vtbl = mg->mg_virtual;
172
173         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
174             CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
175
176             /* guard against magic having been deleted - eg FETCH calling
177              * untie */
178             if (!SvMAGIC(sv))
179                 break;
180
181             /* Don't restore the flags for this entry if it was deleted. */
182             if (mg->mg_flags & MGf_GSKIP)
183                 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
184         }
185
186         mg = mg->mg_moremagic;
187
188         if (have_new) {
189             /* Have we finished with the new entries we saw? Start again
190                where we left off (unless there are more new entries). */
191             if (mg == head) {
192                 have_new = 0;
193                 mg   = cur;
194                 head = newmg;
195             }
196         }
197
198         /* Were any new entries added? */
199         if (!have_new && (newmg = SvMAGIC(sv)) != head) {
200             have_new = 1;
201             cur = mg;
202             mg  = newmg;
203         }
204     }
205
206     restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
207
208     if (SvREFCNT(sv) == 1) {
209         /* We hold the last reference to this SV, which implies that the
210            SV was deleted as a side effect of the routines we called.  */
211         SvOK_off(sv);
212     }
213     return 0;
214 }
215
216 /*
217 =for apidoc mg_set
218
219 Do magic after a value is assigned to the SV.  See C<sv_magic>.
220
221 =cut
222 */
223
224 int
225 Perl_mg_set(pTHX_ SV *sv)
226 {
227     const I32 mgs_ix = SSNEW(sizeof(MGS));
228     MAGIC* mg;
229     MAGIC* nextmg;
230
231     save_magic(mgs_ix, sv);
232
233     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
234         const MGVTBL* vtbl = mg->mg_virtual;
235         nextmg = mg->mg_moremagic;      /* it may delete itself */
236         if (mg->mg_flags & MGf_GSKIP) {
237             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
238             (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
239         }
240         if (vtbl && vtbl->svt_set)
241             CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
242     }
243
244     restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
245     return 0;
246 }
247
248 /*
249 =for apidoc mg_length
250
251 Report on the SV's length.  See C<sv_magic>.
252
253 =cut
254 */
255
256 U32
257 Perl_mg_length(pTHX_ SV *sv)
258 {
259     MAGIC* mg;
260     STRLEN len;
261
262     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
263         const MGVTBL * const vtbl = mg->mg_virtual;
264         if (vtbl && vtbl->svt_len) {
265             const I32 mgs_ix = SSNEW(sizeof(MGS));
266             save_magic(mgs_ix, sv);
267             /* omit MGf_GSKIP -- not changed here */
268             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
269             restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
270             return len;
271         }
272     }
273
274     if (DO_UTF8(sv)) {
275         U8 *s = (U8*)SvPV(sv, len);
276         len = Perl_utf8_length(aTHX_ s, s + len);
277     }
278     else
279         (void)SvPV(sv, len);
280     return len;
281 }
282
283 I32
284 Perl_mg_size(pTHX_ SV *sv)
285 {
286     MAGIC* mg;
287
288     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
289         const MGVTBL* const vtbl = mg->mg_virtual;
290         if (vtbl && vtbl->svt_len) {
291             const I32 mgs_ix = SSNEW(sizeof(MGS));
292             I32 len;
293             save_magic(mgs_ix, sv);
294             /* omit MGf_GSKIP -- not changed here */
295             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
296             restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
297             return len;
298         }
299     }
300
301     switch(SvTYPE(sv)) {
302         case SVt_PVAV:
303             return AvFILLp((AV *) sv); /* Fallback to non-tied array */
304         case SVt_PVHV:
305             /* FIXME */
306         default:
307             Perl_croak(aTHX_ "Size magic not implemented");
308             break;
309     }
310     return 0;
311 }
312
313 /*
314 =for apidoc mg_clear
315
316 Clear something magical that the SV represents.  See C<sv_magic>.
317
318 =cut
319 */
320
321 int
322 Perl_mg_clear(pTHX_ SV *sv)
323 {
324     const I32 mgs_ix = SSNEW(sizeof(MGS));
325     MAGIC* mg;
326
327     save_magic(mgs_ix, sv);
328
329     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
330         const MGVTBL* const vtbl = mg->mg_virtual;
331         /* omit GSKIP -- never set here */
332
333         if (vtbl && vtbl->svt_clear)
334             CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
335     }
336
337     restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
338     return 0;
339 }
340
341 /*
342 =for apidoc mg_find
343
344 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
345
346 =cut
347 */
348
349 MAGIC*
350 Perl_mg_find(pTHX_ const SV *sv, int type)
351 {
352     if (sv) {
353         MAGIC *mg;
354         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
355             if (mg->mg_type == type)
356                 return mg;
357         }
358     }
359     return 0;
360 }
361
362 /*
363 =for apidoc mg_copy
364
365 Copies the magic from one SV to another.  See C<sv_magic>.
366
367 =cut
368 */
369
370 int
371 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
372 {
373     int count = 0;
374     MAGIC* mg;
375     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
376         const MGVTBL* const vtbl = mg->mg_virtual;
377         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
378             count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
379         }
380         else if (isUPPER(mg->mg_type)) {
381             sv_magic(nsv,
382                      mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
383                      (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
384                                                         ? sv : mg->mg_obj,
385                      toLOWER(mg->mg_type), key, klen);
386             count++;
387         }
388     }
389     return count;
390 }
391
392 /*
393 =for apidoc mg_free
394
395 Free any magic storage used by the SV.  See C<sv_magic>.
396
397 =cut
398 */
399
400 int
401 Perl_mg_free(pTHX_ SV *sv)
402 {
403     MAGIC* mg;
404     MAGIC* moremagic;
405     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
406         const MGVTBL* const vtbl = mg->mg_virtual;
407         moremagic = mg->mg_moremagic;
408         if (vtbl && vtbl->svt_free)
409             CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
410         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
411             if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
412                 Safefree(mg->mg_ptr);
413             else if (mg->mg_len == HEf_SVKEY)
414                 SvREFCNT_dec((SV*)mg->mg_ptr);
415         }
416         if (mg->mg_flags & MGf_REFCOUNTED)
417             SvREFCNT_dec(mg->mg_obj);
418         Safefree(mg);
419     }
420     SvMAGIC_set(sv, NULL);
421     return 0;
422 }
423
424 #include <signal.h>
425
426 U32
427 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
428 {
429     register const REGEXP *rx;
430     (void)sv;
431
432     if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
433         if (mg->mg_obj)         /* @+ */
434             return rx->nparens;
435         else                    /* @- */
436             return rx->lastparen;
437     }
438
439     return (U32)-1;
440 }
441
442 int
443 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
444 {
445     register REGEXP *rx;
446
447     if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
448         register const I32 paren = mg->mg_len;
449         register I32 s;
450         register I32 t;
451         if (paren < 0)
452             return 0;
453         if (paren <= (I32)rx->nparens &&
454             (s = rx->startp[paren]) != -1 &&
455             (t = rx->endp[paren]) != -1)
456             {
457                 register I32 i;
458                 if (mg->mg_obj)         /* @+ */
459                     i = t;
460                 else                    /* @- */
461                     i = s;
462
463                 if (i > 0 && RX_MATCH_UTF8(rx)) {
464                     char *b = rx->subbeg;
465                     if (b)
466                         i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
467                 }
468
469                 sv_setiv(sv, i);
470             }
471     }
472     return 0;
473 }
474
475 int
476 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
477 {
478     (void)sv; (void)mg;
479     Perl_croak(aTHX_ PL_no_modify);
480     /* NOT REACHED */
481 #ifndef HASATTRIBUTE
482     /* No __attribute__, so the compiler doesn't know that croak never returns
483      */
484     return 0;
485 #endif
486 }
487
488 U32
489 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
490 {
491     register I32 paren;
492     register I32 i;
493     register const REGEXP *rx;
494     I32 s1, t1;
495
496     switch (*mg->mg_ptr) {
497     case '1': case '2': case '3': case '4':
498     case '5': case '6': case '7': case '8': case '9': case '&':
499         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
500
501             paren = atoi(mg->mg_ptr); /* $& is in [0] */
502           getparen:
503             if (paren <= (I32)rx->nparens &&
504                 (s1 = rx->startp[paren]) != -1 &&
505                 (t1 = rx->endp[paren]) != -1)
506             {
507                 i = t1 - s1;
508               getlen:
509                 if (i > 0 && RX_MATCH_UTF8(rx)) {
510                     char *s    = rx->subbeg + s1;
511                     char *send = rx->subbeg + t1;
512
513                     i = t1 - s1;
514                     if (is_utf8_string((U8*)s, i))
515                         i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
516                 }
517                 if (i < 0)
518                     Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
519                 return i;
520             }
521             else {
522                 if (ckWARN(WARN_UNINITIALIZED))
523                     report_uninit(sv);
524             }
525         }
526         else {
527             if (ckWARN(WARN_UNINITIALIZED))
528                 report_uninit(sv);
529         }
530         return 0;
531     case '+':
532         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
533             paren = rx->lastparen;
534             if (paren)
535                 goto getparen;
536         }
537         return 0;
538     case '\016': /* ^N */
539         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
540             paren = rx->lastcloseparen;
541             if (paren)
542                 goto getparen;
543         }
544         return 0;
545     case '`':
546         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
547             if (rx->startp[0] != -1) {
548                 i = rx->startp[0];
549                 if (i > 0) {
550                     s1 = 0;
551                     t1 = i;
552                     goto getlen;
553                 }
554             }
555         }
556         return 0;
557     case '\'':
558         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
559             if (rx->endp[0] != -1) {
560                 i = rx->sublen - rx->endp[0];
561                 if (i > 0) {
562                     s1 = rx->endp[0];
563                     t1 = rx->sublen;
564                     goto getlen;
565                 }
566             }
567         }
568         return 0;
569     }
570     magic_get(sv,mg);
571     if (!SvPOK(sv) && SvNIOK(sv)) {
572         STRLEN n_a;
573         sv_2pv(sv, &n_a);
574     }
575     if (SvPOK(sv))
576         return SvCUR(sv);
577     return 0;
578 }
579
580 int
581 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
582 {
583     register I32 paren;
584     register char *s = NULL;
585     register I32 i;
586     register REGEXP *rx;
587
588     switch (*mg->mg_ptr) {
589     case '\001':                /* ^A */
590         sv_setsv(sv, PL_bodytarget);
591         break;
592     case '\003':                /* ^C */
593         sv_setiv(sv, (IV)PL_minus_c);
594         break;
595
596     case '\004':                /* ^D */
597         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
598         break;
599     case '\005':  /* ^E */
600          if (*(mg->mg_ptr+1) == '\0') {
601 #ifdef MACOS_TRADITIONAL
602              {
603                   char msg[256];
604
605                   sv_setnv(sv,(double)gMacPerl_OSErr);
606                   sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
607              }
608 #else
609 #ifdef VMS
610              {
611 #                 include <descrip.h>
612 #                 include <starlet.h>
613                   char msg[255];
614                   $DESCRIPTOR(msgdsc,msg);
615                   sv_setnv(sv,(NV) vaxc$errno);
616                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
617                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
618                   else
619                        sv_setpv(sv,"");
620              }
621 #else
622 #ifdef OS2
623              if (!(_emx_env & 0x200)) { /* Under DOS */
624                   sv_setnv(sv, (NV)errno);
625                   sv_setpv(sv, errno ? Strerror(errno) : "");
626              } else {
627                   if (errno != errno_isOS2) {
628                        int tmp = _syserrno();
629                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
630                             Perl_rc = tmp;
631                   }
632                   sv_setnv(sv, (NV)Perl_rc);
633                   sv_setpv(sv, os2error(Perl_rc));
634              }
635 #else
636 #ifdef WIN32
637              {
638                   DWORD dwErr = GetLastError();
639                   sv_setnv(sv, (NV)dwErr);
640                   if (dwErr)
641                   {
642                        PerlProc_GetOSError(sv, dwErr);
643                   }
644                   else
645                        sv_setpv(sv, "");
646                   SetLastError(dwErr);
647              }
648 #else
649              {
650                  int saveerrno = errno;
651                  sv_setnv(sv, (NV)errno);
652                  sv_setpv(sv, errno ? Strerror(errno) : "");
653                  errno = saveerrno;
654              }
655 #endif
656 #endif
657 #endif
658 #endif
659              SvNOK_on(sv);      /* what a wonderful hack! */
660          }
661          else if (strEQ(mg->mg_ptr+1, "NCODING"))
662               sv_setsv(sv, PL_encoding);
663          break;
664     case '\006':                /* ^F */
665         sv_setiv(sv, (IV)PL_maxsysfd);
666         break;
667     case '\010':                /* ^H */
668         sv_setiv(sv, (IV)PL_hints);
669         break;
670     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
671         if (PL_inplace)
672             sv_setpv(sv, PL_inplace);
673         else
674             sv_setsv(sv, &PL_sv_undef);
675         break;
676     case '\017':                /* ^O & ^OPEN */
677         if (*(mg->mg_ptr+1) == '\0') {
678             sv_setpv(sv, PL_osname);
679             SvTAINTED_off(sv);
680         }
681         else if (strEQ(mg->mg_ptr, "\017PEN")) {
682             if (!PL_compiling.cop_io)
683                 sv_setsv(sv, &PL_sv_undef);
684             else {
685                 sv_setsv(sv, PL_compiling.cop_io);
686             }
687         }
688         break;
689     case '\020':                /* ^P */
690         sv_setiv(sv, (IV)PL_perldb);
691         break;
692     case '\023':                /* ^S */
693         if (*(mg->mg_ptr+1) == '\0') {
694             if (PL_lex_state != LEX_NOTPARSING)
695                 SvOK_off(sv);
696             else if (PL_in_eval)
697                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
698             else
699                 sv_setiv(sv, 0);
700         }
701         break;
702     case '\024':                /* ^T */
703         if (*(mg->mg_ptr+1) == '\0') {
704 #ifdef BIG_TIME
705             sv_setnv(sv, PL_basetime);
706 #else
707             sv_setiv(sv, (IV)PL_basetime);
708 #endif
709         }
710         else if (strEQ(mg->mg_ptr, "\024AINT"))
711             sv_setiv(sv, PL_tainting
712                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
713                     : 0);
714         break;
715     case '\025':                /* $^UNICODE, $^UTF8LOCALE */
716         if (strEQ(mg->mg_ptr, "\025NICODE"))
717             sv_setuv(sv, (UV) PL_unicode);
718         else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
719             sv_setuv(sv, (UV) PL_utf8locale);
720         break;
721     case '\027':                /* ^W  & $^WARNING_BITS */
722         if (*(mg->mg_ptr+1) == '\0')
723             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
724         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
725             if (PL_compiling.cop_warnings == pWARN_NONE ||
726                 PL_compiling.cop_warnings == pWARN_STD)
727             {
728                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
729             }
730             else if (PL_compiling.cop_warnings == pWARN_ALL) {
731                 /* Get the bit mask for $warnings::Bits{all}, because
732                  * it could have been extended by warnings::register */
733                 SV **bits_all;
734                 HV *bits=get_hv("warnings::Bits", FALSE);
735                 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
736                     sv_setsv(sv, *bits_all);
737                 }
738                 else {
739                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
740                 }
741             }
742             else {
743                 sv_setsv(sv, PL_compiling.cop_warnings);
744             }
745             SvPOK_only(sv);
746         }
747         break;
748     case '1': case '2': case '3': case '4':
749     case '5': case '6': case '7': case '8': case '9': case '&':
750         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
751             I32 s1, t1;
752
753             /*
754              * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
755              * XXX Does the new way break anything?
756              */
757             paren = atoi(mg->mg_ptr); /* $& is in [0] */
758           getparen:
759             if (paren <= (I32)rx->nparens &&
760                 (s1 = rx->startp[paren]) != -1 &&
761                 (t1 = rx->endp[paren]) != -1)
762             {
763                 i = t1 - s1;
764                 s = rx->subbeg + s1;
765                 if (!rx->subbeg)
766                     break;
767
768               getrx:
769                 if (i >= 0) {
770                     sv_setpvn(sv, s, i);
771                     if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
772                         SvUTF8_on(sv);
773                     else
774                         SvUTF8_off(sv);
775                     if (PL_tainting) {
776                         if (RX_MATCH_TAINTED(rx)) {
777                             MAGIC* mg = SvMAGIC(sv);
778                             MAGIC* mgt;
779                             PL_tainted = 1;
780                             SvMAGIC_set(sv, mg->mg_moremagic);
781                             SvTAINT(sv);
782                             if ((mgt = SvMAGIC(sv))) {
783                                 mg->mg_moremagic = mgt;
784                                 SvMAGIC_set(sv, mg);
785                             }
786                         } else
787                             SvTAINTED_off(sv);
788                     }
789                     break;
790                 }
791             }
792         }
793         sv_setsv(sv,&PL_sv_undef);
794         break;
795     case '+':
796         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
797             paren = rx->lastparen;
798             if (paren)
799                 goto getparen;
800         }
801         sv_setsv(sv,&PL_sv_undef);
802         break;
803     case '\016':                /* ^N */
804         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
805             paren = rx->lastcloseparen;
806             if (paren)
807                 goto getparen;
808         }
809         sv_setsv(sv,&PL_sv_undef);
810         break;
811     case '`':
812         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
813             if ((s = rx->subbeg) && rx->startp[0] != -1) {
814                 i = rx->startp[0];
815                 goto getrx;
816             }
817         }
818         sv_setsv(sv,&PL_sv_undef);
819         break;
820     case '\'':
821         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
822             if (rx->subbeg && rx->endp[0] != -1) {
823                 s = rx->subbeg + rx->endp[0];
824                 i = rx->sublen - rx->endp[0];
825                 goto getrx;
826             }
827         }
828         sv_setsv(sv,&PL_sv_undef);
829         break;
830     case '.':
831 #ifndef lint
832         if (GvIO(PL_last_in_gv)) {
833             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
834         }
835 #endif
836         break;
837     case '?':
838         {
839             sv_setiv(sv, (IV)STATUS_CURRENT);
840 #ifdef COMPLEX_STATUS
841             LvTARGOFF(sv) = PL_statusvalue;
842             LvTARGLEN(sv) = PL_statusvalue_vms;
843 #endif
844         }
845         break;
846     case '^':
847         if (GvIOp(PL_defoutgv))
848             s = IoTOP_NAME(GvIOp(PL_defoutgv));
849         if (s)
850             sv_setpv(sv,s);
851         else {
852             sv_setpv(sv,GvENAME(PL_defoutgv));
853             sv_catpv(sv,"_TOP");
854         }
855         break;
856     case '~':
857         if (GvIOp(PL_defoutgv))
858             s = IoFMT_NAME(GvIOp(PL_defoutgv));
859         if (!s)
860             s = GvENAME(PL_defoutgv);
861         sv_setpv(sv,s);
862         break;
863 #ifndef lint
864     case '=':
865         if (GvIOp(PL_defoutgv))
866             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
867         break;
868     case '-':
869         if (GvIOp(PL_defoutgv))
870             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
871         break;
872     case '%':
873         if (GvIOp(PL_defoutgv))
874             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
875         break;
876 #endif
877     case ':':
878         break;
879     case '/':
880         break;
881     case '[':
882         WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
883         break;
884     case '|':
885         if (GvIOp(PL_defoutgv))
886             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
887         break;
888     case ',':
889         break;
890     case '\\':
891         if (PL_ors_sv)
892             sv_copypv(sv, PL_ors_sv);
893         break;
894     case '#':
895         sv_setpv(sv,PL_ofmt);
896         break;
897     case '!':
898 #ifdef VMS
899         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
900         sv_setpv(sv, errno ? Strerror(errno) : "");
901 #else
902         {
903         int saveerrno = errno;
904         sv_setnv(sv, (NV)errno);
905 #ifdef OS2
906         if (errno == errno_isOS2 || errno == errno_isOS2_set)
907             sv_setpv(sv, os2error(Perl_rc));
908         else
909 #endif
910         sv_setpv(sv, errno ? Strerror(errno) : "");
911         errno = saveerrno;
912         }
913 #endif
914         SvNOK_on(sv);   /* what a wonderful hack! */
915         break;
916     case '<':
917         sv_setiv(sv, (IV)PL_uid);
918         break;
919     case '>':
920         sv_setiv(sv, (IV)PL_euid);
921         break;
922     case '(':
923         sv_setiv(sv, (IV)PL_gid);
924 #ifdef HAS_GETGROUPS
925         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
926 #endif
927         goto add_groups;
928     case ')':
929         sv_setiv(sv, (IV)PL_egid);
930 #ifdef HAS_GETGROUPS
931         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
932 #endif
933       add_groups:
934 #ifdef HAS_GETGROUPS
935         {
936             Groups_t gary[NGROUPS];
937             i = getgroups(NGROUPS,gary);
938             while (--i >= 0)
939                 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
940         }
941 #endif
942         (void)SvIOK_on(sv);     /* what a wonderful hack! */
943         break;
944 #ifndef MACOS_TRADITIONAL
945     case '0':
946         break;
947 #endif
948     }
949     return 0;
950 }
951
952 int
953 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
954 {
955     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
956
957     if (uf && uf->uf_val)
958         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
959     return 0;
960 }
961
962 int
963 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
964 {
965     register char *s;
966     char *ptr;
967     STRLEN len, klen;
968
969     s = SvPV(sv,len);
970     ptr = MgPV(mg,klen);
971     my_setenv(ptr, s);
972
973 #ifdef DYNAMIC_ENV_FETCH
974      /* We just undefd an environment var.  Is a replacement */
975      /* waiting in the wings? */
976     if (!len) {
977         SV **valp;
978         if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
979             s = SvPV(*valp, len);
980     }
981 #endif
982
983 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
984                             /* And you'll never guess what the dog had */
985                             /*   in its mouth... */
986     if (PL_tainting) {
987         MgTAINTEDDIR_off(mg);
988 #ifdef VMS
989         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
990             char pathbuf[256], eltbuf[256], *cp, *elt = s;
991             Stat_t sbuf;
992             int i = 0, j = 0;
993
994             do {          /* DCL$PATH may be a search list */
995                 while (1) {   /* as may dev portion of any element */
996                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
997                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
998                              cando_by_name(S_IWUSR,0,elt) ) {
999                             MgTAINTEDDIR_on(mg);
1000                             return 0;
1001                         }
1002                     }
1003                     if ((cp = strchr(elt, ':')) != Nullch)
1004                         *cp = '\0';
1005                     if (my_trnlnm(elt, eltbuf, j++))
1006                         elt = eltbuf;
1007                     else
1008                         break;
1009                 }
1010                 j = 0;
1011             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1012         }
1013 #endif /* VMS */
1014         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1015             char *strend = s + len;
1016
1017             while (s < strend) {
1018                 char tmpbuf[256];
1019                 Stat_t st;
1020                 I32 i;
1021                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1022                              s, strend, ':', &i);
1023                 s++;
1024                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
1025                       || *tmpbuf != '/'
1026                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1027                     MgTAINTEDDIR_on(mg);
1028                     return 0;
1029                 }
1030             }
1031         }
1032     }
1033 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1034
1035     return 0;
1036 }
1037
1038 int
1039 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1040 {
1041     STRLEN n_a;
1042     (void)sv;
1043     my_setenv(MgPV(mg,n_a),Nullch);
1044     return 0;
1045 }
1046
1047 int
1048 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1049 {
1050 #if defined(VMS)
1051     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1052 #else
1053     if (PL_localizing) {
1054         HE* entry;
1055         STRLEN n_a;
1056         magic_clear_all_env(sv,mg);
1057         hv_iterinit((HV*)sv);
1058         while ((entry = hv_iternext((HV*)sv))) {
1059             I32 keylen;
1060             my_setenv(hv_iterkey(entry, &keylen),
1061                       SvPV(hv_iterval((HV*)sv, entry), n_a));
1062         }
1063     }
1064 #endif
1065     return 0;
1066 }
1067
1068 int
1069 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1070 {
1071 #ifndef PERL_MICRO
1072 #if defined(VMS) || defined(EPOC)
1073     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1074 #else
1075 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1076     PerlEnv_clearenv();
1077 #  else
1078 #    ifdef USE_ENVIRON_ARRAY
1079 #      if defined(USE_ITHREADS)
1080     /* only the parent thread can clobber the process environment */
1081     if (PL_curinterp == aTHX)
1082 #      endif
1083     {
1084 #      ifndef PERL_USE_SAFE_PUTENV
1085     if (!PL_use_safe_putenv) {
1086     I32 i;
1087
1088     if (environ == PL_origenviron)
1089         environ = (char**)safesysmalloc(sizeof(char*));
1090     else
1091         for (i = 0; environ[i]; i++)
1092             safesysfree(environ[i]);
1093     }
1094 #      endif /* PERL_USE_SAFE_PUTENV */
1095
1096     environ[0] = Nullch;
1097     }
1098 #    endif /* USE_ENVIRON_ARRAY */
1099 #   endif /* PERL_IMPLICIT_SYS || WIN32 */
1100 #endif /* VMS || EPOC */
1101 #endif /* !PERL_MICRO */
1102     (void)sv;
1103     (void)mg;
1104     return 0;
1105 }
1106
1107 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1108 static int sig_handlers_initted = 0;
1109 #endif
1110 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1111 static int sig_ignoring[SIG_SIZE];      /* which signals we are ignoring */
1112 #endif
1113 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1114 static int sig_defaulting[SIG_SIZE];
1115 #endif
1116
1117 #ifndef PERL_MICRO
1118 #ifdef HAS_SIGPROCMASK
1119 static void
1120 restore_sigmask(pTHX_ SV *save_sv)
1121 {
1122     sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1123     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1124 }
1125 #endif
1126 int
1127 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1128 {
1129     I32 i;
1130     STRLEN n_a;
1131     /* Are we fetching a signal entry? */
1132     i = whichsig(MgPV(mg,n_a));
1133     if (i > 0) {
1134         if(PL_psig_ptr[i])
1135             sv_setsv(sv,PL_psig_ptr[i]);
1136         else {
1137             Sighandler_t sigstate;
1138             sigstate = rsignal_state(i);
1139 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1140             if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1141 #endif
1142 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1143             if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
1144 #endif
1145             /* cache state so we don't fetch it again */
1146             if(sigstate == SIG_IGN)
1147                 sv_setpv(sv,"IGNORE");
1148             else
1149                 sv_setsv(sv,&PL_sv_undef);
1150             PL_psig_ptr[i] = SvREFCNT_inc(sv);
1151             SvTEMP_off(sv);
1152         }
1153     }
1154     return 0;
1155 }
1156 int
1157 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1158 {
1159     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1160      * refactoring might be in order.
1161      */
1162     STRLEN n_a;
1163     register const char *s = MgPV(mg,n_a);
1164     (void)sv;
1165     if (*s == '_') {
1166         SV** svp;
1167         if (strEQ(s,"__DIE__"))
1168             svp = &PL_diehook;
1169         else if (strEQ(s,"__WARN__"))
1170             svp = &PL_warnhook;
1171         else
1172             Perl_croak(aTHX_ "No such hook: %s", s);
1173         if (*svp) {
1174             SV *to_dec = *svp;
1175             *svp = 0;
1176             SvREFCNT_dec(to_dec);
1177         }
1178     }
1179     else {
1180         I32 i;
1181         /* Are we clearing a signal entry? */
1182         i = whichsig(s);
1183         if (i > 0) {
1184 #ifdef HAS_SIGPROCMASK
1185             sigset_t set, save;
1186             SV* save_sv;
1187             /* Avoid having the signal arrive at a bad time, if possible. */
1188             sigemptyset(&set);
1189             sigaddset(&set,i);
1190             sigprocmask(SIG_BLOCK, &set, &save);
1191             ENTER;
1192             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1193             SAVEFREESV(save_sv);
1194             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1195 #endif
1196             PERL_ASYNC_CHECK();
1197 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1198             if (!sig_handlers_initted) Perl_csighandler_init();
1199 #endif
1200 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1201             sig_defaulting[i] = 1;
1202             (void)rsignal(i, PL_csighandlerp);
1203 #else
1204             (void)rsignal(i, SIG_DFL);
1205 #endif
1206             if(PL_psig_name[i]) {
1207                 SvREFCNT_dec(PL_psig_name[i]);
1208                 PL_psig_name[i]=0;
1209             }
1210             if(PL_psig_ptr[i]) {
1211                 SV *to_dec=PL_psig_ptr[i];
1212                 PL_psig_ptr[i]=0;
1213                 LEAVE;
1214                 SvREFCNT_dec(to_dec);
1215             }
1216             else
1217                 LEAVE;
1218         }
1219     }
1220     return 0;
1221 }
1222
1223 static void
1224 S_raise_signal(pTHX_ int sig)
1225 {
1226     /* Set a flag to say this signal is pending */
1227     PL_psig_pend[sig]++;
1228     /* And one to say _a_ signal is pending */
1229     PL_sig_pending = 1;
1230 }
1231
1232 Signal_t
1233 Perl_csighandler(int sig)
1234 {
1235 #ifdef PERL_GET_SIG_CONTEXT
1236     dTHXa(PERL_GET_SIG_CONTEXT);
1237 #else
1238     dTHX;
1239 #endif
1240 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1241     (void) rsignal(sig, PL_csighandlerp);
1242     if (sig_ignoring[sig]) return;
1243 #endif
1244 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1245     if (sig_defaulting[sig])
1246 #ifdef KILL_BY_SIGPRC
1247             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1248 #else
1249             exit(1);
1250 #endif
1251 #endif
1252    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1253         /* Call the perl level handler now--
1254          * with risk we may be in malloc() etc. */
1255         (*PL_sighandlerp)(sig);
1256    else
1257         S_raise_signal(aTHX_ sig);
1258 }
1259
1260 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1261 void
1262 Perl_csighandler_init(void)
1263 {
1264     int sig;
1265     if (sig_handlers_initted) return;
1266
1267     for (sig = 1; sig < SIG_SIZE; sig++) {
1268 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1269         dTHX;
1270         sig_defaulting[sig] = 1;
1271         (void) rsignal(sig, PL_csighandlerp);
1272 #endif
1273 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1274         sig_ignoring[sig] = 0;
1275 #endif
1276     }
1277     sig_handlers_initted = 1;
1278 }
1279 #endif
1280
1281 void
1282 Perl_despatch_signals(pTHX)
1283 {
1284     int sig;
1285     PL_sig_pending = 0;
1286     for (sig = 1; sig < SIG_SIZE; sig++) {
1287         if (PL_psig_pend[sig]) {
1288             PERL_BLOCKSIG_ADD(set, sig);
1289             PL_psig_pend[sig] = 0;
1290             PERL_BLOCKSIG_BLOCK(set);
1291             (*PL_sighandlerp)(sig);
1292             PERL_BLOCKSIG_UNBLOCK(set);
1293         }
1294     }
1295 }
1296
1297 int
1298 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1299 {
1300     I32 i;
1301     SV** svp = 0;
1302     /* Need to be careful with SvREFCNT_dec(), because that can have side
1303      * effects (due to closures). We must make sure that the new disposition
1304      * is in place before it is called.
1305      */
1306     SV* to_dec = 0;
1307     STRLEN len;
1308 #ifdef HAS_SIGPROCMASK
1309     sigset_t set, save;
1310     SV* save_sv;
1311 #endif
1312
1313     register const char *s = MgPV(mg,len);
1314     if (*s == '_') {
1315         if (strEQ(s,"__DIE__"))
1316             svp = &PL_diehook;
1317         else if (strEQ(s,"__WARN__"))
1318             svp = &PL_warnhook;
1319         else
1320             Perl_croak(aTHX_ "No such hook: %s", s);
1321         i = 0;
1322         if (*svp) {
1323             to_dec = *svp;
1324             *svp = 0;
1325         }
1326     }
1327     else {
1328         i = whichsig(s);        /* ...no, a brick */
1329         if (i < 0) {
1330             if (ckWARN(WARN_SIGNAL))
1331                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1332             return 0;
1333         }
1334 #ifdef HAS_SIGPROCMASK
1335         /* Avoid having the signal arrive at a bad time, if possible. */
1336         sigemptyset(&set);
1337         sigaddset(&set,i);
1338         sigprocmask(SIG_BLOCK, &set, &save);
1339         ENTER;
1340         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1341         SAVEFREESV(save_sv);
1342         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1343 #endif
1344         PERL_ASYNC_CHECK();
1345 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1346         if (!sig_handlers_initted) Perl_csighandler_init();
1347 #endif
1348 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1349         sig_ignoring[i] = 0;
1350 #endif
1351 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1352         sig_defaulting[i] = 0;
1353 #endif
1354         SvREFCNT_dec(PL_psig_name[i]);
1355         to_dec = PL_psig_ptr[i];
1356         PL_psig_ptr[i] = SvREFCNT_inc(sv);
1357         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1358         PL_psig_name[i] = newSVpvn(s, len);
1359         SvREADONLY_on(PL_psig_name[i]);
1360     }
1361     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1362         if (i) {
1363             (void)rsignal(i, PL_csighandlerp);
1364 #ifdef HAS_SIGPROCMASK
1365             LEAVE;
1366 #endif
1367         }
1368         else
1369             *svp = SvREFCNT_inc(sv);
1370         if(to_dec)
1371             SvREFCNT_dec(to_dec);
1372         return 0;
1373     }
1374     s = SvPV_force(sv,len);
1375     if (strEQ(s,"IGNORE")) {
1376         if (i) {
1377 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1378             sig_ignoring[i] = 1;
1379             (void)rsignal(i, PL_csighandlerp);
1380 #else
1381             (void)rsignal(i, SIG_IGN);
1382 #endif
1383         }
1384     }
1385     else if (strEQ(s,"DEFAULT") || !*s) {
1386         if (i)
1387 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1388           {
1389             sig_defaulting[i] = 1;
1390             (void)rsignal(i, PL_csighandlerp);
1391           }
1392 #else
1393             (void)rsignal(i, SIG_DFL);
1394 #endif
1395     }
1396     else {
1397         /*
1398          * We should warn if HINT_STRICT_REFS, but without
1399          * access to a known hint bit in a known OP, we can't
1400          * tell whether HINT_STRICT_REFS is in force or not.
1401          */
1402         if (!strchr(s,':') && !strchr(s,'\''))
1403             sv_insert(sv, 0, 0, "main::", 6);
1404         if (i)
1405             (void)rsignal(i, PL_csighandlerp);
1406         else
1407             *svp = SvREFCNT_inc(sv);
1408     }
1409 #ifdef HAS_SIGPROCMASK
1410     if(i)
1411         LEAVE;
1412 #endif
1413     if(to_dec)
1414         SvREFCNT_dec(to_dec);
1415     return 0;
1416 }
1417 #endif /* !PERL_MICRO */
1418
1419 int
1420 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1421 {
1422     (void)sv;
1423     (void)mg;
1424     PL_sub_generation++;
1425     return 0;
1426 }
1427
1428 int
1429 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1430 {
1431     (void)sv;
1432     (void)mg;
1433     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1434     PL_amagic_generation++;
1435
1436     return 0;
1437 }
1438
1439 int
1440 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1441 {
1442     HV * const hv = (HV*)LvTARG(sv);
1443     I32 i = 0;
1444     (void)mg;
1445
1446     if (hv) {
1447          (void) hv_iterinit(hv);
1448          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1449              i = HvKEYS(hv);
1450          else {
1451              while (hv_iternext(hv))
1452                  i++;
1453          }
1454     }
1455
1456     sv_setiv(sv, (IV)i);
1457     return 0;
1458 }
1459
1460 int
1461 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1462 {
1463     (void)mg;
1464     if (LvTARG(sv)) {
1465         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1466     }
1467     return 0;
1468 }
1469
1470 /* caller is responsible for stack switching/cleanup */
1471 STATIC int
1472 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1473 {
1474     dSP;
1475
1476     PUSHMARK(SP);
1477     EXTEND(SP, n);
1478     PUSHs(SvTIED_obj(sv, mg));
1479     if (n > 1) {
1480         if (mg->mg_ptr) {
1481             if (mg->mg_len >= 0)
1482                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1483             else if (mg->mg_len == HEf_SVKEY)
1484                 PUSHs((SV*)mg->mg_ptr);
1485         }
1486         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1487             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1488         }
1489     }
1490     if (n > 2) {
1491         PUSHs(val);
1492     }
1493     PUTBACK;
1494
1495     return call_method(meth, flags);
1496 }
1497
1498 STATIC int
1499 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1500 {
1501     dSP;
1502
1503     ENTER;
1504     SAVETMPS;
1505     PUSHSTACKi(PERLSI_MAGIC);
1506
1507     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1508         sv_setsv(sv, *PL_stack_sp--);
1509     }
1510
1511     POPSTACK;
1512     FREETMPS;
1513     LEAVE;
1514     return 0;
1515 }
1516
1517 int
1518 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1519 {
1520     if (mg->mg_ptr)
1521         mg->mg_flags |= MGf_GSKIP;
1522     magic_methpack(sv,mg,"FETCH");
1523     return 0;
1524 }
1525
1526 int
1527 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1528 {
1529     dSP;
1530     ENTER;
1531     PUSHSTACKi(PERLSI_MAGIC);
1532     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1533     POPSTACK;
1534     LEAVE;
1535     return 0;
1536 }
1537
1538 int
1539 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1540 {
1541     return magic_methpack(sv,mg,"DELETE");
1542 }
1543
1544
1545 U32
1546 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1547 {
1548     dSP;
1549     U32 retval = 0;
1550
1551     ENTER;
1552     SAVETMPS;
1553     PUSHSTACKi(PERLSI_MAGIC);
1554     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1555         sv = *PL_stack_sp--;
1556         retval = (U32) SvIV(sv)-1;
1557     }
1558     POPSTACK;
1559     FREETMPS;
1560     LEAVE;
1561     return retval;
1562 }
1563
1564 int
1565 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1566 {
1567     dSP;
1568
1569     ENTER;
1570     PUSHSTACKi(PERLSI_MAGIC);
1571     PUSHMARK(SP);
1572     XPUSHs(SvTIED_obj(sv, mg));
1573     PUTBACK;
1574     call_method("CLEAR", G_SCALAR|G_DISCARD);
1575     POPSTACK;
1576     LEAVE;
1577
1578     return 0;
1579 }
1580
1581 int
1582 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1583 {
1584     dSP;
1585     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1586
1587     ENTER;
1588     SAVETMPS;
1589     PUSHSTACKi(PERLSI_MAGIC);
1590     PUSHMARK(SP);
1591     EXTEND(SP, 2);
1592     PUSHs(SvTIED_obj(sv, mg));
1593     if (SvOK(key))
1594         PUSHs(key);
1595     PUTBACK;
1596
1597     if (call_method(meth, G_SCALAR))
1598         sv_setsv(key, *PL_stack_sp--);
1599
1600     POPSTACK;
1601     FREETMPS;
1602     LEAVE;
1603     return 0;
1604 }
1605
1606 int
1607 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1608 {
1609     return magic_methpack(sv,mg,"EXISTS");
1610 }
1611
1612 SV *
1613 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1614 {
1615     dSP;
1616     SV *retval = &PL_sv_undef;
1617     SV *tied = SvTIED_obj((SV*)hv, mg);
1618     HV *pkg = SvSTASH((SV*)SvRV(tied));
1619    
1620     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1621         SV *key;
1622         if (HvEITER(hv))
1623             /* we are in an iteration so the hash cannot be empty */
1624             return &PL_sv_yes;
1625         /* no xhv_eiter so now use FIRSTKEY */
1626         key = sv_newmortal();
1627         magic_nextpack((SV*)hv, mg, key);
1628         HvEITER(hv) = NULL;     /* need to reset iterator */
1629         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1630     }
1631    
1632     /* there is a SCALAR method that we can call */
1633     ENTER;
1634     PUSHSTACKi(PERLSI_MAGIC);
1635     PUSHMARK(SP);
1636     EXTEND(SP, 1);
1637     PUSHs(tied);
1638     PUTBACK;
1639
1640     if (call_method("SCALAR", G_SCALAR))
1641         retval = *PL_stack_sp--; 
1642     POPSTACK;
1643     LEAVE;
1644     return retval;
1645 }
1646
1647 int
1648 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1649 {
1650     OP *o;
1651     I32 i;
1652     GV* gv;
1653     SV** svp;
1654     STRLEN n_a;
1655
1656     gv = PL_DBline;
1657     i = SvTRUE(sv);
1658     svp = av_fetch(GvAV(gv),
1659                      atoi(MgPV(mg,n_a)), FALSE);
1660     if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1661         /* set or clear breakpoint in the relevant control op */
1662         if (i)
1663             o->op_flags |= OPf_SPECIAL;
1664         else
1665             o->op_flags &= ~OPf_SPECIAL;
1666     }
1667     return 0;
1668 }
1669
1670 int
1671 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1672 {
1673     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1674     return 0;
1675 }
1676
1677 int
1678 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1679 {
1680     av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1681     return 0;
1682 }
1683
1684 int
1685 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1686 {
1687     SV* lsv = LvTARG(sv);
1688
1689     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1690         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1691         if (mg && mg->mg_len >= 0) {
1692             I32 i = mg->mg_len;
1693             if (DO_UTF8(lsv))
1694                 sv_pos_b2u(lsv, &i);
1695             sv_setiv(sv, i + PL_curcop->cop_arybase);
1696             return 0;
1697         }
1698     }
1699     SvOK_off(sv);
1700     return 0;
1701 }
1702
1703 int
1704 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1705 {
1706     SV* lsv = LvTARG(sv);
1707     SSize_t pos;
1708     STRLEN len;
1709     STRLEN ulen = 0;
1710
1711     mg = 0;
1712
1713     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1714         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1715     if (!mg) {
1716         if (!SvOK(sv))
1717             return 0;
1718         sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1719         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1720     }
1721     else if (!SvOK(sv)) {
1722         mg->mg_len = -1;
1723         return 0;
1724     }
1725     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1726
1727     pos = SvIV(sv) - PL_curcop->cop_arybase;
1728
1729     if (DO_UTF8(lsv)) {
1730         ulen = sv_len_utf8(lsv);
1731         if (ulen)
1732             len = ulen;
1733     }
1734
1735     if (pos < 0) {
1736         pos += len;
1737         if (pos < 0)
1738             pos = 0;
1739     }
1740     else if (pos > (SSize_t)len)
1741         pos = len;
1742
1743     if (ulen) {
1744         I32 p = pos;
1745         sv_pos_u2b(lsv, &p, 0);
1746         pos = p;
1747     }
1748
1749     mg->mg_len = pos;
1750     mg->mg_flags &= ~MGf_MINMATCH;
1751
1752     return 0;
1753 }
1754
1755 int
1756 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1757 {
1758     (void)mg;
1759     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1760         SvFAKE_off(sv);
1761         gv_efullname3(sv,((GV*)sv), "*");
1762         SvFAKE_on(sv);
1763     }
1764     else
1765         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1766     return 0;
1767 }
1768
1769 int
1770 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1771 {
1772     GV* gv;
1773     (void)mg;
1774  
1775     if (!SvOK(sv))
1776         return 0;
1777     gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1778     if (sv == (SV*)gv)
1779         return 0;
1780     if (GvGP(sv))
1781         gp_free((GV*)sv);
1782     GvGP(sv) = gp_ref(GvGP(gv));
1783     return 0;
1784 }
1785
1786 int
1787 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1788 {
1789     STRLEN len;
1790     SV * const lsv = LvTARG(sv);
1791     const char * const tmps = SvPV(lsv,len);
1792     I32 offs = LvTARGOFF(sv);
1793     I32 rem = LvTARGLEN(sv);
1794     (void)mg;
1795
1796     if (SvUTF8(lsv))
1797         sv_pos_u2b(lsv, &offs, &rem);
1798     if (offs > (I32)len)
1799         offs = len;
1800     if (rem + offs > (I32)len)
1801         rem = len - offs;
1802     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1803     if (SvUTF8(lsv))
1804         SvUTF8_on(sv);
1805     return 0;
1806 }
1807
1808 int
1809 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1810 {
1811     STRLEN len;
1812     char *tmps = SvPV(sv, len);
1813     SV * const lsv = LvTARG(sv);
1814     I32 lvoff = LvTARGOFF(sv);
1815     I32 lvlen = LvTARGLEN(sv);
1816     (void)mg;
1817
1818     if (DO_UTF8(sv)) {
1819         sv_utf8_upgrade(lsv);
1820         sv_pos_u2b(lsv, &lvoff, &lvlen);
1821         sv_insert(lsv, lvoff, lvlen, tmps, len);
1822         LvTARGLEN(sv) = sv_len_utf8(sv);
1823         SvUTF8_on(lsv);
1824     }
1825     else if (lsv && SvUTF8(lsv)) {
1826         sv_pos_u2b(lsv, &lvoff, &lvlen);
1827         LvTARGLEN(sv) = len;
1828         tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1829         sv_insert(lsv, lvoff, lvlen, tmps, len);
1830         Safefree(tmps);
1831     }
1832     else {
1833         sv_insert(lsv, lvoff, lvlen, tmps, len);
1834         LvTARGLEN(sv) = len;
1835     }
1836
1837
1838     return 0;
1839 }
1840
1841 int
1842 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1843 {
1844     TAINT_IF((mg->mg_len & 1) ||
1845              ((mg->mg_len & 2) && mg->mg_obj == sv));   /* kludge */
1846     return 0;
1847 }
1848
1849 int
1850 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1851 {
1852     (void)sv;
1853     if (PL_localizing) {
1854         if (PL_localizing == 1)
1855             mg->mg_len <<= 1;
1856         else
1857             mg->mg_len >>= 1;
1858     }
1859     else if (PL_tainted)
1860         mg->mg_len |= 1;
1861     else
1862         mg->mg_len &= ~1;
1863     return 0;
1864 }
1865
1866 int
1867 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1868 {
1869     SV * const lsv = LvTARG(sv);
1870     (void)mg;
1871
1872     if (!lsv) {
1873         SvOK_off(sv);
1874         return 0;
1875     }
1876
1877     sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1878     return 0;
1879 }
1880
1881 int
1882 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1883 {
1884     (void)mg;
1885     do_vecset(sv);      /* XXX slurp this routine */
1886     return 0;
1887 }
1888
1889 int
1890 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1891 {
1892     SV *targ = Nullsv;
1893     if (LvTARGLEN(sv)) {
1894         if (mg->mg_obj) {
1895             SV *ahv = LvTARG(sv);
1896             HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1897             if (he)
1898                 targ = HeVAL(he);
1899         }
1900         else {
1901             AV* av = (AV*)LvTARG(sv);
1902             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1903                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1904         }
1905         if (targ && targ != &PL_sv_undef) {
1906             /* somebody else defined it for us */
1907             SvREFCNT_dec(LvTARG(sv));
1908             LvTARG(sv) = SvREFCNT_inc(targ);
1909             LvTARGLEN(sv) = 0;
1910             SvREFCNT_dec(mg->mg_obj);
1911             mg->mg_obj = Nullsv;
1912             mg->mg_flags &= ~MGf_REFCOUNTED;
1913         }
1914     }
1915     else
1916         targ = LvTARG(sv);
1917     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1918     return 0;
1919 }
1920
1921 int
1922 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1923 {
1924     (void)mg;
1925     if (LvTARGLEN(sv))
1926         vivify_defelem(sv);
1927     if (LvTARG(sv)) {
1928         sv_setsv(LvTARG(sv), sv);
1929         SvSETMAGIC(LvTARG(sv));
1930     }
1931     return 0;
1932 }
1933
1934 void
1935 Perl_vivify_defelem(pTHX_ SV *sv)
1936 {
1937     MAGIC *mg;
1938     SV *value = Nullsv;
1939
1940     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1941         return;
1942     if (mg->mg_obj) {
1943         SV *ahv = LvTARG(sv);
1944         STRLEN n_a;
1945         HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1946         if (he)
1947             value = HeVAL(he);
1948         if (!value || value == &PL_sv_undef)
1949             Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
1950     }
1951     else {
1952         AV* av = (AV*)LvTARG(sv);
1953         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1954             LvTARG(sv) = Nullsv;        /* array can't be extended */
1955         else {
1956             SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1957             if (!svp || (value = *svp) == &PL_sv_undef)
1958                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1959         }
1960     }
1961     (void)SvREFCNT_inc(value);
1962     SvREFCNT_dec(LvTARG(sv));
1963     LvTARG(sv) = value;
1964     LvTARGLEN(sv) = 0;
1965     SvREFCNT_dec(mg->mg_obj);
1966     mg->mg_obj = Nullsv;
1967     mg->mg_flags &= ~MGf_REFCOUNTED;
1968 }
1969
1970 int
1971 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1972 {
1973     AV *av = (AV*)mg->mg_obj;
1974     SV **svp = AvARRAY(av);
1975     I32 i = AvFILLp(av);
1976     (void)sv;
1977
1978     while (i >= 0) {
1979         if (svp[i]) {
1980             if (!SvWEAKREF(svp[i]))
1981                 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1982             /* XXX Should we check that it hasn't changed? */
1983             SvRV_set(svp[i], 0);
1984             SvOK_off(svp[i]);
1985             SvWEAKREF_off(svp[i]);
1986             svp[i] = Nullsv;
1987         }
1988         i--;
1989     }
1990     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1991     return 0;
1992 }
1993
1994 int
1995 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1996 {
1997     mg->mg_len = -1;
1998     SvSCREAM_off(sv);
1999     return 0;
2000 }
2001
2002 int
2003 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2004 {
2005     (void)mg;
2006     sv_unmagic(sv, PERL_MAGIC_bm);
2007     SvVALID_off(sv);
2008     return 0;
2009 }
2010
2011 int
2012 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2013 {
2014     (void)mg;
2015     sv_unmagic(sv, PERL_MAGIC_fm);
2016     SvCOMPILED_off(sv);
2017     return 0;
2018 }
2019
2020 int
2021 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2022 {
2023     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2024
2025     if (uf && uf->uf_set)
2026         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2027     return 0;
2028 }
2029
2030 int
2031 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2032 {
2033     (void)mg;
2034     sv_unmagic(sv, PERL_MAGIC_qr);
2035     return 0;
2036 }
2037
2038 int
2039 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2040 {
2041     regexp *re = (regexp *)mg->mg_obj;
2042     ReREFCNT_dec(re);
2043     (void)sv;
2044     return 0;
2045 }
2046
2047 #ifdef USE_LOCALE_COLLATE
2048 int
2049 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2050 {
2051     /*
2052      * RenE<eacute> Descartes said "I think not."
2053      * and vanished with a faint plop.
2054      */
2055     (void)sv;
2056     if (mg->mg_ptr) {
2057         Safefree(mg->mg_ptr);
2058         mg->mg_ptr = NULL;
2059         mg->mg_len = -1;
2060     }
2061     return 0;
2062 }
2063 #endif /* USE_LOCALE_COLLATE */
2064
2065 /* Just clear the UTF-8 cache data. */
2066 int
2067 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2068 {
2069     (void)sv;
2070     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2071     mg->mg_ptr = 0;
2072     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2073     return 0;
2074 }
2075
2076 int
2077 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2078 {
2079     register const char *s;
2080     I32 i;
2081     STRLEN len;
2082     switch (*mg->mg_ptr) {
2083     case '\001':        /* ^A */
2084         sv_setsv(PL_bodytarget, sv);
2085         break;
2086     case '\003':        /* ^C */
2087         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2088         break;
2089
2090     case '\004':        /* ^D */
2091 #ifdef DEBUGGING
2092         s = SvPV_nolen(sv);
2093         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2094         DEBUG_x(dump_all());
2095 #else
2096         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2097 #endif
2098         break;
2099     case '\005':  /* ^E */
2100         if (*(mg->mg_ptr+1) == '\0') {
2101 #ifdef MACOS_TRADITIONAL
2102             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2103 #else
2104 #  ifdef VMS
2105             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2106 #  else
2107 #    ifdef WIN32
2108             SetLastError( SvIV(sv) );
2109 #    else
2110 #      ifdef OS2
2111             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2112 #      else
2113             /* will anyone ever use this? */
2114             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2115 #      endif
2116 #    endif
2117 #  endif
2118 #endif
2119         }
2120         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2121             if (PL_encoding)
2122                 SvREFCNT_dec(PL_encoding);
2123             if (SvOK(sv) || SvGMAGICAL(sv)) {
2124                 PL_encoding = newSVsv(sv);
2125             }
2126             else {
2127                 PL_encoding = Nullsv;
2128             }
2129         }
2130         break;
2131     case '\006':        /* ^F */
2132         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2133         break;
2134     case '\010':        /* ^H */
2135         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2136         break;
2137     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2138         if (PL_inplace)
2139             Safefree(PL_inplace);
2140         if (SvOK(sv))
2141             PL_inplace = savesvpv(sv);
2142         else
2143             PL_inplace = Nullch;
2144         break;
2145     case '\017':        /* ^O */
2146         if (*(mg->mg_ptr+1) == '\0') {
2147             if (PL_osname) {
2148                 Safefree(PL_osname);
2149                 PL_osname = Nullch;
2150             }
2151             if (SvOK(sv)) {
2152                 TAINT_PROPER("assigning to $^O");
2153                 PL_osname = savesvpv(sv);
2154             }
2155         }
2156         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2157             if (!PL_compiling.cop_io)
2158                 PL_compiling.cop_io = newSVsv(sv);
2159             else
2160                 sv_setsv(PL_compiling.cop_io,sv);
2161         }
2162         break;
2163     case '\020':        /* ^P */
2164         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2165         if (PL_perldb && !PL_DBsingle)
2166             init_debugger();
2167         break;
2168     case '\024':        /* ^T */
2169 #ifdef BIG_TIME
2170         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2171 #else
2172         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2173 #endif
2174         break;
2175     case '\027':        /* ^W & $^WARNING_BITS */
2176         if (*(mg->mg_ptr+1) == '\0') {
2177             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2178                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2179                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2180                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2181             }
2182         }
2183         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2184             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2185                 if (!SvPOK(sv) && PL_localizing) {
2186                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2187                     PL_compiling.cop_warnings = pWARN_NONE;
2188                     break;
2189                 }
2190                 {
2191                     STRLEN len, i;
2192                     int accumulate = 0 ;
2193                     int any_fatals = 0 ;
2194                     const char * const ptr = (char*)SvPV(sv, len) ;
2195                     for (i = 0 ; i < len ; ++i) {
2196                         accumulate |= ptr[i] ;
2197                         any_fatals |= (ptr[i] & 0xAA) ;
2198                     }
2199                     if (!accumulate)
2200                         PL_compiling.cop_warnings = pWARN_NONE;
2201                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2202                         PL_compiling.cop_warnings = pWARN_ALL;
2203                         PL_dowarn |= G_WARN_ONCE ;
2204                     }
2205                     else {
2206                         if (specialWARN(PL_compiling.cop_warnings))
2207                             PL_compiling.cop_warnings = newSVsv(sv) ;
2208                         else
2209                             sv_setsv(PL_compiling.cop_warnings, sv);
2210                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2211                             PL_dowarn |= G_WARN_ONCE ;
2212                     }
2213
2214                 }
2215             }
2216         }
2217         break;
2218     case '.':
2219         if (PL_localizing) {
2220             if (PL_localizing == 1)
2221                 SAVESPTR(PL_last_in_gv);
2222         }
2223         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2224             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2225         break;
2226     case '^':
2227         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2228         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2229         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2230         break;
2231     case '~':
2232         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2233         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2234         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2235         break;
2236     case '=':
2237         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2238         break;
2239     case '-':
2240         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2241         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2242             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2243         break;
2244     case '%':
2245         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2246         break;
2247     case '|':
2248         {
2249             IO *io = GvIOp(PL_defoutgv);
2250             if(!io)
2251               break;
2252             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2253                 IoFLAGS(io) &= ~IOf_FLUSH;
2254             else {
2255                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2256                     PerlIO *ofp = IoOFP(io);
2257                     if (ofp)
2258                         (void)PerlIO_flush(ofp);
2259                     IoFLAGS(io) |= IOf_FLUSH;
2260                 }
2261             }
2262         }
2263         break;
2264     case '/':
2265         SvREFCNT_dec(PL_rs);
2266         PL_rs = newSVsv(sv);
2267         break;
2268     case '\\':
2269         if (PL_ors_sv)
2270             SvREFCNT_dec(PL_ors_sv);
2271         if (SvOK(sv) || SvGMAGICAL(sv)) {
2272             PL_ors_sv = newSVsv(sv);
2273         }
2274         else {
2275             PL_ors_sv = Nullsv;
2276         }
2277         break;
2278     case ',':
2279         if (PL_ofs_sv)
2280             SvREFCNT_dec(PL_ofs_sv);
2281         if (SvOK(sv) || SvGMAGICAL(sv)) {
2282             PL_ofs_sv = newSVsv(sv);
2283         }
2284         else {
2285             PL_ofs_sv = Nullsv;
2286         }
2287         break;
2288     case '#':
2289         if (PL_ofmt)
2290             Safefree(PL_ofmt);
2291         PL_ofmt = savesvpv(sv);
2292         break;
2293     case '[':
2294         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2295         break;
2296     case '?':
2297 #ifdef COMPLEX_STATUS
2298         if (PL_localizing == 2) {
2299             PL_statusvalue = LvTARGOFF(sv);
2300             PL_statusvalue_vms = LvTARGLEN(sv);
2301         }
2302         else
2303 #endif
2304 #ifdef VMSISH_STATUS
2305         if (VMSISH_STATUS)
2306             STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2307         else
2308 #endif
2309             STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2310         break;
2311     case '!':
2312         {
2313 #ifdef VMS
2314 #   define PERL_VMS_BANG vaxc$errno
2315 #else
2316 #   define PERL_VMS_BANG 0
2317 #endif
2318         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2319                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2320         }
2321         break;
2322     case '<':
2323         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2324         if (PL_delaymagic) {
2325             PL_delaymagic |= DM_RUID;
2326             break;                              /* don't do magic till later */
2327         }
2328 #ifdef HAS_SETRUID
2329         (void)setruid((Uid_t)PL_uid);
2330 #else
2331 #ifdef HAS_SETREUID
2332         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2333 #else
2334 #ifdef HAS_SETRESUID
2335       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2336 #else
2337         if (PL_uid == PL_euid) {                /* special case $< = $> */
2338 #ifdef PERL_DARWIN
2339             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2340             if (PL_uid != 0 && PerlProc_getuid() == 0)
2341                 (void)PerlProc_setuid(0);
2342 #endif
2343             (void)PerlProc_setuid(PL_uid);
2344         } else {
2345             PL_uid = PerlProc_getuid();
2346             Perl_croak(aTHX_ "setruid() not implemented");
2347         }
2348 #endif
2349 #endif
2350 #endif
2351         PL_uid = PerlProc_getuid();
2352         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2353         break;
2354     case '>':
2355         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2356         if (PL_delaymagic) {
2357             PL_delaymagic |= DM_EUID;
2358             break;                              /* don't do magic till later */
2359         }
2360 #ifdef HAS_SETEUID
2361         (void)seteuid((Uid_t)PL_euid);
2362 #else
2363 #ifdef HAS_SETREUID
2364         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2365 #else
2366 #ifdef HAS_SETRESUID
2367         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2368 #else
2369         if (PL_euid == PL_uid)          /* special case $> = $< */
2370             PerlProc_setuid(PL_euid);
2371         else {
2372             PL_euid = PerlProc_geteuid();
2373             Perl_croak(aTHX_ "seteuid() not implemented");
2374         }
2375 #endif
2376 #endif
2377 #endif
2378         PL_euid = PerlProc_geteuid();
2379         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2380         break;
2381     case '(':
2382         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2383         if (PL_delaymagic) {
2384             PL_delaymagic |= DM_RGID;
2385             break;                              /* don't do magic till later */
2386         }
2387 #ifdef HAS_SETRGID
2388         (void)setrgid((Gid_t)PL_gid);
2389 #else
2390 #ifdef HAS_SETREGID
2391         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2392 #else
2393 #ifdef HAS_SETRESGID
2394       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2395 #else
2396         if (PL_gid == PL_egid)                  /* special case $( = $) */
2397             (void)PerlProc_setgid(PL_gid);
2398         else {
2399             PL_gid = PerlProc_getgid();
2400             Perl_croak(aTHX_ "setrgid() not implemented");
2401         }
2402 #endif
2403 #endif
2404 #endif
2405         PL_gid = PerlProc_getgid();
2406         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2407         break;
2408     case ')':
2409 #ifdef HAS_SETGROUPS
2410         {
2411             const char *p = SvPV(sv, len);
2412             Groups_t gary[NGROUPS];
2413
2414             while (isSPACE(*p))
2415                 ++p;
2416             PL_egid = Atol(p);
2417             for (i = 0; i < NGROUPS; ++i) {
2418                 while (*p && !isSPACE(*p))
2419                     ++p;
2420                 while (isSPACE(*p))
2421                     ++p;
2422                 if (!*p)
2423                     break;
2424                 gary[i] = Atol(p);
2425             }
2426             if (i)
2427                 (void)setgroups(i, gary);
2428         }
2429 #else  /* HAS_SETGROUPS */
2430         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2431 #endif /* HAS_SETGROUPS */
2432         if (PL_delaymagic) {
2433             PL_delaymagic |= DM_EGID;
2434             break;                              /* don't do magic till later */
2435         }
2436 #ifdef HAS_SETEGID
2437         (void)setegid((Gid_t)PL_egid);
2438 #else
2439 #ifdef HAS_SETREGID
2440         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2441 #else
2442 #ifdef HAS_SETRESGID
2443         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2444 #else
2445         if (PL_egid == PL_gid)                  /* special case $) = $( */
2446             (void)PerlProc_setgid(PL_egid);
2447         else {
2448             PL_egid = PerlProc_getegid();
2449             Perl_croak(aTHX_ "setegid() not implemented");
2450         }
2451 #endif
2452 #endif
2453 #endif
2454         PL_egid = PerlProc_getegid();
2455         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2456         break;
2457     case ':':
2458         PL_chopset = SvPV_force(sv,len);
2459         break;
2460 #ifndef MACOS_TRADITIONAL
2461     case '0':
2462         LOCK_DOLLARZERO_MUTEX;
2463 #ifdef HAS_SETPROCTITLE
2464         /* The BSDs don't show the argv[] in ps(1) output, they
2465          * show a string from the process struct and provide
2466          * the setproctitle() routine to manipulate that. */
2467         {
2468             s = SvPV(sv, len);
2469 #   if __FreeBSD_version > 410001
2470             /* The leading "-" removes the "perl: " prefix,
2471              * but not the "(perl) suffix from the ps(1)
2472              * output, because that's what ps(1) shows if the
2473              * argv[] is modified. */
2474             setproctitle("-%s", s);
2475 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2476             /* This doesn't really work if you assume that
2477              * $0 = 'foobar'; will wipe out 'perl' from the $0
2478              * because in ps(1) output the result will be like
2479              * sprintf("perl: %s (perl)", s)
2480              * I guess this is a security feature:
2481              * one (a user process) cannot get rid of the original name.
2482              * --jhi */
2483             setproctitle("%s", s);
2484 #   endif
2485         }
2486 #endif
2487 #if defined(__hpux) && defined(PSTAT_SETCMD)
2488         {
2489              union pstun un;
2490              s = SvPV(sv, len);
2491              un.pst_command = (char *)s;
2492              pstat(PSTAT_SETCMD, un, len, 0, 0);
2493         }
2494 #endif
2495         /* PL_origalen is set in perl_parse(). */
2496         s = SvPV_force(sv,len);
2497         if (len >= (STRLEN)PL_origalen-1) {
2498             /* Longer than original, will be truncated. We assume that
2499              * PL_origalen bytes are available. */
2500             Copy(s, PL_origargv[0], PL_origalen-1, char);
2501         }
2502         else {
2503             /* Shorter than original, will be padded. */
2504             Copy(s, PL_origargv[0], len, char);
2505             PL_origargv[0][len] = 0;
2506             memset(PL_origargv[0] + len + 1,
2507                    /* Is the space counterintuitive?  Yes.
2508                     * (You were expecting \0?)  
2509                     * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2510                     * --jhi */
2511                    (int)' ',
2512                    PL_origalen - len - 1);
2513         }
2514         PL_origargv[0][PL_origalen-1] = 0;
2515         for (i = 1; i < PL_origargc; i++)
2516             PL_origargv[i] = 0;
2517         UNLOCK_DOLLARZERO_MUTEX;
2518         break;
2519 #endif
2520     }
2521     return 0;
2522 }
2523
2524 I32
2525 Perl_whichsig(pTHX_ const char *sig)
2526 {
2527     register const char **sigv;
2528
2529     for (sigv = PL_sig_name; *sigv; sigv++)
2530         if (strEQ(sig,*sigv))
2531             return PL_sig_num[sigv - PL_sig_name];
2532 #ifdef SIGCLD
2533     if (strEQ(sig,"CHLD"))
2534         return SIGCLD;
2535 #endif
2536 #ifdef SIGCHLD
2537     if (strEQ(sig,"CLD"))
2538         return SIGCHLD;
2539 #endif
2540     return -1;
2541 }
2542
2543 #if !defined(PERL_IMPLICIT_CONTEXT)
2544 static SV* sig_sv;
2545 #endif
2546
2547 Signal_t
2548 Perl_sighandler(int sig)
2549 {
2550 #ifdef PERL_GET_SIG_CONTEXT
2551     dTHXa(PERL_GET_SIG_CONTEXT);
2552 #else
2553     dTHX;
2554 #endif
2555     dSP;
2556     GV *gv = Nullgv;
2557     HV *st;
2558     SV *sv = Nullsv, *tSv = PL_Sv;
2559     CV *cv = Nullcv;
2560     OP *myop = PL_op;
2561     U32 flags = 0;
2562     XPV *tXpv = PL_Xpv;
2563
2564     if (PL_savestack_ix + 15 <= PL_savestack_max)
2565         flags |= 1;
2566     if (PL_markstack_ptr < PL_markstack_max - 2)
2567         flags |= 4;
2568     if (PL_scopestack_ix < PL_scopestack_max - 3)
2569         flags |= 16;
2570
2571     if (!PL_psig_ptr[sig]) {
2572                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2573                                  PL_sig_name[sig]);
2574                 exit(sig);
2575         }
2576
2577     /* Max number of items pushed there is 3*n or 4. We cannot fix
2578        infinity, so we fix 4 (in fact 5): */
2579     if (flags & 1) {
2580         PL_savestack_ix += 5;           /* Protect save in progress. */
2581         SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2582     }
2583     if (flags & 4)
2584         PL_markstack_ptr++;             /* Protect mark. */
2585     if (flags & 16)
2586         PL_scopestack_ix += 1;
2587     /* sv_2cv is too complicated, try a simpler variant first: */
2588     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2589         || SvTYPE(cv) != SVt_PVCV)
2590         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2591
2592     if (!cv || !CvROOT(cv)) {
2593         if (ckWARN(WARN_SIGNAL))
2594             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2595                 PL_sig_name[sig], (gv ? GvENAME(gv)
2596                                 : ((cv && CvGV(cv))
2597                                    ? GvENAME(CvGV(cv))
2598                                    : "__ANON__")));
2599         goto cleanup;
2600     }
2601
2602     if(PL_psig_name[sig]) {
2603         sv = SvREFCNT_inc(PL_psig_name[sig]);
2604         flags |= 64;
2605 #if !defined(PERL_IMPLICIT_CONTEXT)
2606         sig_sv = sv;
2607 #endif
2608     } else {
2609         sv = sv_newmortal();
2610         sv_setpv(sv,PL_sig_name[sig]);
2611     }
2612
2613     PUSHSTACKi(PERLSI_SIGNAL);
2614     PUSHMARK(SP);
2615     PUSHs(sv);
2616     PUTBACK;
2617
2618     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2619
2620     POPSTACK;
2621     if (SvTRUE(ERRSV)) {
2622 #ifndef PERL_MICRO
2623 #ifdef HAS_SIGPROCMASK
2624         /* Handler "died", for example to get out of a restart-able read().
2625          * Before we re-do that on its behalf re-enable the signal which was
2626          * blocked by the system when we entered.
2627          */
2628         sigset_t set;
2629         sigemptyset(&set);
2630         sigaddset(&set,sig);
2631         sigprocmask(SIG_UNBLOCK, &set, NULL);
2632 #else
2633         /* Not clear if this will work */
2634         (void)rsignal(sig, SIG_IGN);
2635         (void)rsignal(sig, PL_csighandlerp);
2636 #endif
2637 #endif /* !PERL_MICRO */
2638         DieNull;
2639     }
2640 cleanup:
2641     if (flags & 1)
2642         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2643     if (flags & 4)
2644         PL_markstack_ptr--;
2645     if (flags & 16)
2646         PL_scopestack_ix -= 1;
2647     if (flags & 64)
2648         SvREFCNT_dec(sv);
2649     PL_op = myop;                       /* Apparently not needed... */
2650
2651     PL_Sv = tSv;                        /* Restore global temporaries. */
2652     PL_Xpv = tXpv;
2653     return;
2654 }
2655
2656
2657 static void
2658 restore_magic(pTHX_ const void *p)
2659 {
2660     MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2661     SV* sv = mgs->mgs_sv;
2662
2663     if (!sv)
2664         return;
2665
2666     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2667     {
2668 #ifdef PERL_COPY_ON_WRITE
2669         /* While magic was saved (and off) sv_setsv may well have seen
2670            this SV as a prime candidate for COW.  */
2671         if (SvIsCOW(sv))
2672             sv_force_normal(sv);
2673 #endif
2674
2675         if (mgs->mgs_flags)
2676             SvFLAGS(sv) |= mgs->mgs_flags;
2677         else
2678             mg_magical(sv);
2679         if (SvGMAGICAL(sv))
2680             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2681     }
2682
2683     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2684
2685     /* If we're still on top of the stack, pop us off.  (That condition
2686      * will be satisfied if restore_magic was called explicitly, but *not*
2687      * if it's being called via leave_scope.)
2688      * The reason for doing this is that otherwise, things like sv_2cv()
2689      * may leave alloc gunk on the savestack, and some code
2690      * (e.g. sighandler) doesn't expect that...
2691      */
2692     if (PL_savestack_ix == mgs->mgs_ss_ix)
2693     {
2694         I32 popval = SSPOPINT;
2695         assert(popval == SAVEt_DESTRUCTOR_X);
2696         PL_savestack_ix -= 2;
2697         popval = SSPOPINT;
2698         assert(popval == SAVEt_ALLOC);
2699         popval = SSPOPINT;
2700         PL_savestack_ix -= popval;
2701     }
2702
2703 }
2704
2705 static void
2706 unwind_handler_stack(pTHX_ const void *p)
2707 {
2708     const U32 flags = *(const U32*)p;
2709
2710     if (flags & 1)
2711         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2712     /* cxstack_ix-- Not needed, die already unwound it. */
2713 #if !defined(PERL_IMPLICIT_CONTEXT)
2714     if (flags & 64)
2715         SvREFCNT_dec(sig_sv);
2716 #endif
2717 }
2718
2719