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