This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fixes for bugs in C<use warnings qw(FATAL all)> (from Paul Marquess)
[perl5.git] / mg.c
1 /*    mg.c
2  *
3  *    Copyright (c) 1991-2000, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  */
9
10 /*
11  * "Sam sat on the ground and put his head in his hands.  'I wish I had never
12  * come here, and I don't want to see no more magic,' he said, and fell silent."
13  */
14
15 #include "EXTERN.h"
16 #define PERL_IN_MG_C
17 #include "perl.h"
18
19 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
20 #ifdef I_UNISTD
21 # include <unistd.h>
22 #endif
23
24 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
25 #  ifndef NGROUPS
26 #    define NGROUPS 32
27 #  endif
28 #endif
29
30 static void restore_magic(pTHXo_ void *p);
31 static void unwind_handler_stack(pTHXo_ void *p);
32
33 /*
34  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
35  */
36
37 struct magic_state {
38     SV* mgs_sv;
39     U32 mgs_flags;
40     I32 mgs_ss_ix;
41 };
42 /* MGS is typedef'ed to struct magic_state in perl.h */
43
44 STATIC void
45 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
46 {
47     dTHR;
48     MGS* mgs;
49     assert(SvMAGICAL(sv));
50
51     SAVEDESTRUCTOR_X(restore_magic, (void*)mgs_ix);
52
53     mgs = SSPTR(mgs_ix, MGS*);
54     mgs->mgs_sv = sv;
55     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
56     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
57
58     SvMAGICAL_off(sv);
59     SvREADONLY_off(sv);
60     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
61 }
62
63 /*
64 =for apidoc mg_magical
65
66 Turns on the magical status of an SV.  See C<sv_magic>.
67
68 =cut
69 */
70
71 void
72 Perl_mg_magical(pTHX_ SV *sv)
73 {
74     MAGIC* mg;
75     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
76         MGVTBL* vtbl = mg->mg_virtual;
77         if (vtbl) {
78             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
79                 SvGMAGICAL_on(sv);
80             if (vtbl->svt_set)
81                 SvSMAGICAL_on(sv);
82             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
83                 SvRMAGICAL_on(sv);
84         }
85     }
86 }
87
88 /*
89 =for apidoc mg_get
90
91 Do magic after a value is retrieved from the SV.  See C<sv_magic>.
92
93 =cut
94 */
95
96 int
97 Perl_mg_get(pTHX_ SV *sv)
98 {
99     dTHR;
100     I32 mgs_ix;
101     MAGIC* mg;
102     MAGIC** mgp;
103     int mgp_valid = 0;
104
105     mgs_ix = SSNEW(sizeof(MGS));
106     save_magic(mgs_ix, sv);
107
108     mgp = &SvMAGIC(sv);
109     while ((mg = *mgp) != 0) {
110         MGVTBL* vtbl = mg->mg_virtual;
111         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
112             CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
113             /* Ignore this magic if it's been deleted */
114             if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) &&
115                   (mg->mg_flags & MGf_GSKIP))
116                 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
117         }
118         /* Advance to next magic (complicated by possible deletion) */
119         if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) {
120             mgp = &mg->mg_moremagic;
121             mgp_valid = 1;
122         }
123         else
124             mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */
125     }
126
127     restore_magic(aTHXo_ (void*)mgs_ix);
128     return 0;
129 }
130
131 /*
132 =for apidoc mg_set
133
134 Do magic after a value is assigned to the SV.  See C<sv_magic>.
135
136 =cut
137 */
138
139 int
140 Perl_mg_set(pTHX_ SV *sv)
141 {
142     dTHR;
143     I32 mgs_ix;
144     MAGIC* mg;
145     MAGIC* nextmg;
146
147     mgs_ix = SSNEW(sizeof(MGS));
148     save_magic(mgs_ix, sv);
149
150     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
151         MGVTBL* vtbl = mg->mg_virtual;
152         nextmg = mg->mg_moremagic;      /* it may delete itself */
153         if (mg->mg_flags & MGf_GSKIP) {
154             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
155             (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
156         }
157         if (vtbl && vtbl->svt_set)
158             CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
159     }
160
161     restore_magic(aTHXo_ (void*)mgs_ix);
162     return 0;
163 }
164
165 /*
166 =for apidoc mg_length
167
168 Report on the SV's length.  See C<sv_magic>.
169
170 =cut
171 */
172
173 U32
174 Perl_mg_length(pTHX_ SV *sv)
175 {
176     MAGIC* mg;
177     char *junk;
178     STRLEN len;
179
180     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
181         MGVTBL* vtbl = mg->mg_virtual;
182         if (vtbl && vtbl->svt_len) {
183             I32 mgs_ix;
184
185             mgs_ix = SSNEW(sizeof(MGS));
186             save_magic(mgs_ix, sv);
187             /* omit MGf_GSKIP -- not changed here */
188             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
189             restore_magic(aTHXo_ (void*)mgs_ix);
190             return len;
191         }
192     }
193
194     junk = SvPV(sv, len);
195     return len;
196 }
197
198 I32
199 Perl_mg_size(pTHX_ SV *sv)
200 {
201     MAGIC* mg;
202     I32 len;
203     
204     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
205         MGVTBL* vtbl = mg->mg_virtual;
206         if (vtbl && vtbl->svt_len) {
207             I32 mgs_ix;
208
209             mgs_ix = SSNEW(sizeof(MGS));
210             save_magic(mgs_ix, sv);
211             /* omit MGf_GSKIP -- not changed here */
212             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
213             restore_magic(aTHXo_ (void*)mgs_ix);
214             return len;
215         }
216     }
217
218     switch(SvTYPE(sv)) {
219         case SVt_PVAV:
220             len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
221             return len;
222         case SVt_PVHV:
223             /* FIXME */
224         default:
225             Perl_croak(aTHX_ "Size magic not implemented");
226             break;
227     }
228     return 0;
229 }
230
231 /*
232 =for apidoc mg_clear
233
234 Clear something magical that the SV represents.  See C<sv_magic>.
235
236 =cut
237 */
238
239 int
240 Perl_mg_clear(pTHX_ SV *sv)
241 {
242     I32 mgs_ix;
243     MAGIC* mg;
244
245     mgs_ix = SSNEW(sizeof(MGS));
246     save_magic(mgs_ix, sv);
247
248     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
249         MGVTBL* vtbl = mg->mg_virtual;
250         /* omit GSKIP -- never set here */
251         
252         if (vtbl && vtbl->svt_clear)
253             CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
254     }
255
256     restore_magic(aTHXo_ (void*)mgs_ix);
257     return 0;
258 }
259
260 /*
261 =for apidoc mg_find
262
263 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
264
265 =cut
266 */
267
268 MAGIC*
269 Perl_mg_find(pTHX_ SV *sv, int type)
270 {
271     MAGIC* mg;
272     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
273         if (mg->mg_type == type)
274             return mg;
275     }
276     return 0;
277 }
278
279 /*
280 =for apidoc mg_copy
281
282 Copies the magic from one SV to another.  See C<sv_magic>.
283
284 =cut
285 */
286
287 int
288 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
289 {
290     int count = 0;
291     MAGIC* mg;
292     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
293         if (isUPPER(mg->mg_type)) {
294             sv_magic(nsv,
295                      mg->mg_type == 'P' ? SvTIED_obj(sv, mg) : mg->mg_obj,
296                      toLOWER(mg->mg_type), key, klen);
297             count++;
298         }
299     }
300     return count;
301 }
302
303 /*
304 =for apidoc mg_free
305
306 Free any magic storage used by the SV.  See C<sv_magic>.
307
308 =cut
309 */
310
311 int
312 Perl_mg_free(pTHX_ SV *sv)
313 {
314     MAGIC* mg;
315     MAGIC* moremagic;
316     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
317         MGVTBL* vtbl = mg->mg_virtual;
318         moremagic = mg->mg_moremagic;
319         if (vtbl && vtbl->svt_free)
320             CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
321         if (mg->mg_ptr && mg->mg_type != 'g')
322             if (mg->mg_len >= 0)
323                 Safefree(mg->mg_ptr);
324             else if (mg->mg_len == HEf_SVKEY)
325                 SvREFCNT_dec((SV*)mg->mg_ptr);
326         if (mg->mg_flags & MGf_REFCOUNTED)
327             SvREFCNT_dec(mg->mg_obj);
328         Safefree(mg);
329     }
330     SvMAGIC(sv) = 0;
331     return 0;
332 }
333
334 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
335 #include <signal.h>
336 #endif
337
338 U32
339 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
340 {
341     dTHR;
342     register REGEXP *rx;
343
344     if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
345         if (mg->mg_obj)         /* @+ */
346             return rx->nparens;
347         else                    /* @- */
348             return rx->lastparen;
349     }
350     
351     return (U32)-1;
352 }
353
354 int
355 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
356 {
357     dTHR;
358     register I32 paren;
359     register I32 s;
360     register I32 i;
361     register REGEXP *rx;
362     I32 t;
363
364     if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
365         paren = mg->mg_len;
366         if (paren < 0)
367             return 0;
368         if (paren <= rx->nparens &&
369             (s = rx->startp[paren]) != -1 &&
370             (t = rx->endp[paren]) != -1)
371             {
372                 if (mg->mg_obj)         /* @+ */
373                     i = t;
374                 else                    /* @- */
375                     i = s;
376                 sv_setiv(sv,i);
377             }
378     }
379     return 0;
380 }
381
382 U32
383 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
384 {
385     dTHR;
386     register I32 paren;
387     register I32 i;
388     register REGEXP *rx;
389     I32 s1, t1;
390
391     switch (*mg->mg_ptr) {
392     case '1': case '2': case '3': case '4':
393     case '5': case '6': case '7': case '8': case '9': case '&':
394         if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
395
396             paren = atoi(mg->mg_ptr);
397           getparen:
398             if (paren <= rx->nparens &&
399                 (s1 = rx->startp[paren]) != -1 &&
400                 (t1 = rx->endp[paren]) != -1)
401             {
402                 i = t1 - s1;
403               getlen:
404                 if (i > 0 && (PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) {
405                     char *s = rx->subbeg + s1;
406                     char *send = rx->subbeg + t1;
407                     i = 0;
408                     while (s < send) {
409                         s += UTF8SKIP(s);
410                         i++;
411                     }
412                 }
413                 if (i >= 0)
414                     return i;
415             }
416         }
417         return 0;
418     case '+':
419         if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
420             paren = rx->lastparen;
421             if (paren)
422                 goto getparen;
423         }
424         return 0;
425     case '`':
426         if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
427             if (rx->startp[0] != -1) {
428                 i = rx->startp[0];
429                 if (i > 0) {
430                     s1 = 0;
431                     t1 = i;
432                     goto getlen;
433                 }
434             }
435         }
436         return 0;
437     case '\'':
438         if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
439             if (rx->endp[0] != -1) {
440                 i = rx->sublen - rx->endp[0];
441                 if (i > 0) {
442                     s1 = rx->endp[0];
443                     t1 = rx->sublen;
444                     goto getlen;
445                 }
446             }
447         }
448         return 0;
449     case ',':
450         return (STRLEN)PL_ofslen;
451     case '\\':
452         return (STRLEN)PL_orslen;
453     }
454     magic_get(sv,mg);
455     if (!SvPOK(sv) && SvNIOK(sv)) {
456         STRLEN n_a;
457         sv_2pv(sv, &n_a);
458     }
459     if (SvPOK(sv))
460         return SvCUR(sv);
461     return 0;
462 }
463
464 int
465 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
466 {
467     dTHR;
468     register I32 paren;
469     register char *s;
470     register I32 i;
471     register REGEXP *rx;
472
473     switch (*mg->mg_ptr) {
474     case '\001':                /* ^A */
475         sv_setsv(sv, PL_bodytarget);
476         break;
477     case '\003':                /* ^C */
478         sv_setiv(sv, (IV)PL_minus_c);
479         break;
480
481     case '\004':                /* ^D */
482         sv_setiv(sv, (IV)(PL_debug & 32767));
483 #if defined(YYDEBUG) && defined(DEBUGGING)
484         PL_yydebug = (PL_debug & 1);
485 #endif
486         break;
487     case '\005':  /* ^E */
488 #ifdef MACOS_TRADITIONAL
489         {
490             char msg[256];
491             
492             sv_setnv(sv,(double)gLastMacOSErr);
493             sv_setpv(sv, gLastMacOSErr ? GetSysErrText(gLastMacOSErr, msg) : "");       
494         }
495 #else   
496 #ifdef VMS
497         {
498 #           include <descrip.h>
499 #           include <starlet.h>
500             char msg[255];
501             $DESCRIPTOR(msgdsc,msg);
502             sv_setnv(sv,(NV) vaxc$errno);
503             if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
504                 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
505             else
506                 sv_setpv(sv,"");
507         }
508 #else
509 #ifdef OS2
510         if (!(_emx_env & 0x200)) {      /* Under DOS */
511             sv_setnv(sv, (NV)errno);
512             sv_setpv(sv, errno ? Strerror(errno) : "");
513         } else {
514             if (errno != errno_isOS2) {
515                 int tmp = _syserrno();
516                 if (tmp)        /* 2nd call to _syserrno() makes it 0 */
517                     Perl_rc = tmp;
518             }
519             sv_setnv(sv, (NV)Perl_rc);
520             sv_setpv(sv, os2error(Perl_rc));
521         }
522 #else
523 #ifdef WIN32
524         {
525             DWORD dwErr = GetLastError();
526             sv_setnv(sv, (NV)dwErr);
527             if (dwErr)
528             {
529                 PerlProc_GetOSError(sv, dwErr);
530             }
531             else
532                 sv_setpv(sv, "");
533             SetLastError(dwErr);
534         }
535 #else
536         sv_setnv(sv, (NV)errno);
537         sv_setpv(sv, errno ? Strerror(errno) : "");
538 #endif
539 #endif
540 #endif
541 #endif
542         SvNOK_on(sv);   /* what a wonderful hack! */
543         break;
544     case '\006':                /* ^F */
545         sv_setiv(sv, (IV)PL_maxsysfd);
546         break;
547     case '\010':                /* ^H */
548         sv_setiv(sv, (IV)PL_hints);
549         break;
550     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
551         if (PL_inplace)
552             sv_setpv(sv, PL_inplace);
553         else
554             sv_setsv(sv, &PL_sv_undef);
555         break;
556     case '\017':                /* ^O */
557         sv_setpv(sv, PL_osname);
558         break;
559     case '\020':                /* ^P */
560         sv_setiv(sv, (IV)PL_perldb);
561         break;
562     case '\023':                /* ^S */
563         {
564             dTHR;
565             if (PL_lex_state != LEX_NOTPARSING)
566                 (void)SvOK_off(sv);
567             else if (PL_in_eval)
568                 sv_setiv(sv, 1);
569             else
570                 sv_setiv(sv, 0);
571         }
572         break;
573     case '\024':                /* ^T */
574 #ifdef BIG_TIME
575         sv_setnv(sv, PL_basetime);
576 #else
577         sv_setiv(sv, (IV)PL_basetime);
578 #endif
579         break;
580     case '\027':                /* ^W  & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
581         if (*(mg->mg_ptr+1) == '\0')
582             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
583         else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) {
584             if (PL_compiling.cop_warnings == pWARN_NONE ||
585                 PL_compiling.cop_warnings == pWARN_STD)
586             {
587                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
588             }
589             else if (PL_compiling.cop_warnings == pWARN_ALL) {
590                 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
591             }    
592             else {
593                 sv_setsv(sv, PL_compiling.cop_warnings);
594             }    
595             SvPOK_only(sv);
596         }
597         else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS"))
598             sv_setiv(sv, (IV)PL_widesyscalls);
599         break;
600     case '1': case '2': case '3': case '4':
601     case '5': case '6': case '7': case '8': case '9': case '&':
602         if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
603             I32 s1, t1;
604
605             /*
606              * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
607              * XXX Does the new way break anything?
608              */
609             paren = atoi(mg->mg_ptr);
610           getparen:
611             if (paren <= rx->nparens &&
612                 (s1 = rx->startp[paren]) != -1 &&
613                 (t1 = rx->endp[paren]) != -1)
614             {
615                 i = t1 - s1;
616                 s = rx->subbeg + s1;
617               getrx:
618                 if (i >= 0) {
619                     bool was_tainted;
620                     if (PL_tainting) {
621                         was_tainted = PL_tainted;
622                         PL_tainted = FALSE;
623                     }
624                     sv_setpvn(sv, s, i);
625                     if ((PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE)
626                         SvUTF8_on(sv);
627                     else
628                         SvUTF8_off(sv);
629                     if (PL_tainting)
630                         PL_tainted = (was_tainted || RX_MATCH_TAINTED(rx));
631                     break;
632                 }
633             }
634         }
635         sv_setsv(sv,&PL_sv_undef);
636         break;
637     case '+':
638         if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
639             paren = rx->lastparen;
640             if (paren)
641                 goto getparen;
642         }
643         sv_setsv(sv,&PL_sv_undef);
644         break;
645     case '`':
646         if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
647             if ((s = rx->subbeg) && rx->startp[0] != -1) {
648                 i = rx->startp[0];
649                 goto getrx;
650             }
651         }
652         sv_setsv(sv,&PL_sv_undef);
653         break;
654     case '\'':
655         if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
656             if (rx->subbeg && rx->endp[0] != -1) {
657                 s = rx->subbeg + rx->endp[0];
658                 i = rx->sublen - rx->endp[0];
659                 goto getrx;
660             }
661         }
662         sv_setsv(sv,&PL_sv_undef);
663         break;
664     case '.':
665 #ifndef lint
666         if (GvIO(PL_last_in_gv)) {
667             sv_setiv(sv, (IV)IoLINES(GvIO(PL_last_in_gv)));
668         }
669 #endif
670         break;
671     case '?':
672         {
673             sv_setiv(sv, (IV)STATUS_CURRENT);
674 #ifdef COMPLEX_STATUS
675             LvTARGOFF(sv) = PL_statusvalue;
676             LvTARGLEN(sv) = PL_statusvalue_vms;
677 #endif
678         }
679         break;
680     case '^':
681         s = IoTOP_NAME(GvIOp(PL_defoutgv));
682         if (s)
683             sv_setpv(sv,s);
684         else {
685             sv_setpv(sv,GvENAME(PL_defoutgv));
686             sv_catpv(sv,"_TOP");
687         }
688         break;
689     case '~':
690         s = IoFMT_NAME(GvIOp(PL_defoutgv));
691         if (!s)
692             s = GvENAME(PL_defoutgv);
693         sv_setpv(sv,s);
694         break;
695 #ifndef lint
696     case '=':
697         sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
698         break;
699     case '-':
700         sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
701         break;
702     case '%':
703         sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
704         break;
705 #endif
706     case ':':
707         break;
708     case '/':
709         break;
710     case '[':
711         WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
712         break;
713     case '|':
714         sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
715         break;
716     case ',':
717         sv_setpvn(sv,PL_ofs,PL_ofslen);
718         break;
719     case '\\':
720         sv_setpvn(sv,PL_ors,PL_orslen);
721         break;
722     case '#':
723         sv_setpv(sv,PL_ofmt);
724         break;
725     case '!':
726 #ifdef VMS
727         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
728         sv_setpv(sv, errno ? Strerror(errno) : "");
729 #else
730         {
731         int saveerrno = errno;
732         sv_setnv(sv, (NV)errno);
733 #ifdef OS2
734         if (errno == errno_isOS2 || errno == errno_isOS2_set)
735             sv_setpv(sv, os2error(Perl_rc));
736         else
737 #endif
738         sv_setpv(sv, errno ? Strerror(errno) : "");
739         errno = saveerrno;
740         }
741 #endif
742         SvNOK_on(sv);   /* what a wonderful hack! */
743         break;
744     case '<':
745         sv_setiv(sv, (IV)PL_uid);
746         break;
747     case '>':
748         sv_setiv(sv, (IV)PL_euid);
749         break;
750     case '(':
751         sv_setiv(sv, (IV)PL_gid);
752 #ifdef HAS_GETGROUPS
753         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
754 #endif
755         goto add_groups;
756     case ')':
757         sv_setiv(sv, (IV)PL_egid);
758 #ifdef HAS_GETGROUPS
759         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
760 #endif
761       add_groups:
762 #ifdef HAS_GETGROUPS
763         {
764             Groups_t gary[NGROUPS];
765             i = getgroups(NGROUPS,gary);
766             while (--i >= 0)
767                 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
768         }
769 #endif
770         (void)SvIOK_on(sv);     /* what a wonderful hack! */
771         break;
772     case '*':
773         break;
774 #ifndef MACOS_TRADITIONAL
775     case '0':
776         break;
777 #endif
778 #ifdef USE_THREADS
779     case '@':
780         sv_setsv(sv, thr->errsv);
781         break;
782 #endif /* USE_THREADS */
783     }
784     return 0;
785 }
786
787 int
788 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
789 {
790     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
791
792     if (uf && uf->uf_val)
793         (*uf->uf_val)(uf->uf_index, sv);
794     return 0;
795 }
796
797 int
798 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
799 {
800     register char *s;
801     char *ptr;
802     STRLEN len, klen;
803     I32 i;
804
805     s = SvPV(sv,len);
806     ptr = MgPV(mg,klen);
807     my_setenv(ptr, s);
808
809 #ifdef DYNAMIC_ENV_FETCH
810      /* We just undefd an environment var.  Is a replacement */
811      /* waiting in the wings? */
812     if (!len) {
813         SV **valp;
814         if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
815             s = SvPV(*valp, len);
816     }
817 #endif
818
819 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
820                             /* And you'll never guess what the dog had */
821                             /*   in its mouth... */
822     if (PL_tainting) {
823         MgTAINTEDDIR_off(mg);
824 #ifdef VMS
825         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
826             char pathbuf[256], eltbuf[256], *cp, *elt = s;
827             struct stat sbuf;
828             int i = 0, j = 0;
829
830             do {          /* DCL$PATH may be a search list */
831                 while (1) {   /* as may dev portion of any element */
832                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
833                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
834                              cando_by_name(S_IWUSR,0,elt) ) {
835                             MgTAINTEDDIR_on(mg);
836                             return 0;
837                         }
838                     }
839                     if ((cp = strchr(elt, ':')) != Nullch)
840                         *cp = '\0';
841                     if (my_trnlnm(elt, eltbuf, j++))
842                         elt = eltbuf;
843                     else
844                         break;
845                 }
846                 j = 0;
847             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
848         }
849 #endif /* VMS */
850         if (s && klen == 4 && strEQ(ptr,"PATH")) {
851             char *strend = s + len;
852
853             while (s < strend) {
854                 char tmpbuf[256];
855                 struct stat st;
856                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
857                              s, strend, ':', &i);
858                 s++;
859                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
860                       || *tmpbuf != '/'
861                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
862                     MgTAINTEDDIR_on(mg);
863                     return 0;
864                 }
865             }
866         }
867     }
868 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
869
870     return 0;
871 }
872
873 int
874 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
875 {
876     STRLEN n_a;
877     my_setenv(MgPV(mg,n_a),Nullch);
878     return 0;
879 }
880
881 int
882 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
883 {
884 #if defined(VMS)
885     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
886 #else
887     dTHR;
888     if (PL_localizing) {
889         HE* entry;
890         STRLEN n_a;
891         magic_clear_all_env(sv,mg);
892         hv_iterinit((HV*)sv);
893         while ((entry = hv_iternext((HV*)sv))) {
894             I32 keylen;
895             my_setenv(hv_iterkey(entry, &keylen),
896                       SvPV(hv_iterval((HV*)sv, entry), n_a));
897         }
898     }
899 #endif
900     return 0;
901 }
902
903 int
904 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
905 {
906 #if defined(VMS)
907     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
908 #else
909 #   ifdef PERL_IMPLICIT_SYS
910     PerlEnv_clearenv();
911 #   else
912 #       ifdef WIN32
913     char *envv = GetEnvironmentStrings();
914     char *cur = envv;
915     STRLEN len;
916     while (*cur) {
917         char *end = strchr(cur,'=');
918         if (end && end != cur) {
919             *end = '\0';
920             my_setenv(cur,Nullch);
921             *end = '=';
922             cur = end + strlen(end+1)+2;
923         }
924         else if ((len = strlen(cur)))
925             cur += len+1;
926     }
927     FreeEnvironmentStrings(envv);
928 #   else
929 #       ifdef __CYGWIN__
930     I32 i;
931     for (i = 0; environ[i]; i++)
932        safesysfree(environ[i]);
933 #       else
934 #           ifndef PERL_USE_SAFE_PUTENV
935     I32 i;
936
937     if (environ == PL_origenviron)
938         environ = (char**)safesysmalloc(sizeof(char*));
939     else
940         for (i = 0; environ[i]; i++)
941             safesysfree(environ[i]);
942 #           endif /* PERL_USE_SAFE_PUTENV */
943 #       endif /* __CYGWIN__ */
944
945     environ[0] = Nullch;
946
947 #       endif /* WIN32 */
948 #   endif /* PERL_IMPLICIT_SYS */
949 #endif /* VMS */
950     return 0;
951 }
952
953 int
954 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
955 {
956     I32 i;
957     STRLEN n_a;
958     /* Are we fetching a signal entry? */
959     i = whichsig(MgPV(mg,n_a));
960     if (i) {
961         if(PL_psig_ptr[i])
962             sv_setsv(sv,PL_psig_ptr[i]);
963         else {
964             Sighandler_t sigstate = rsignal_state(i);
965
966             /* cache state so we don't fetch it again */
967             if(sigstate == SIG_IGN)
968                 sv_setpv(sv,"IGNORE");
969             else
970                 sv_setsv(sv,&PL_sv_undef);
971             PL_psig_ptr[i] = SvREFCNT_inc(sv);
972             SvTEMP_off(sv);
973         }
974     }
975     return 0;
976 }
977 int
978 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
979 {
980     I32 i;
981     STRLEN n_a;
982     /* Are we clearing a signal entry? */
983     i = whichsig(MgPV(mg,n_a));
984     if (i) {
985         if(PL_psig_ptr[i]) {
986             SvREFCNT_dec(PL_psig_ptr[i]);
987             PL_psig_ptr[i]=0;
988         }
989         if(PL_psig_name[i]) {
990             SvREFCNT_dec(PL_psig_name[i]);
991             PL_psig_name[i]=0;
992         }
993     }
994     return 0;
995 }
996
997 int
998 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
999 {
1000     dTHR;
1001     register char *s;
1002     I32 i;
1003     SV** svp;
1004     STRLEN len;
1005
1006     s = MgPV(mg,len);
1007     if (*s == '_') {
1008         if (strEQ(s,"__DIE__"))
1009             svp = &PL_diehook;
1010         else if (strEQ(s,"__WARN__"))
1011             svp = &PL_warnhook;
1012         else
1013             Perl_croak(aTHX_ "No such hook: %s", s);
1014         i = 0;
1015         if (*svp) {
1016             SvREFCNT_dec(*svp);
1017             *svp = 0;
1018         }
1019     }
1020     else {
1021         i = whichsig(s);        /* ...no, a brick */
1022         if (!i) {
1023             if (ckWARN(WARN_SIGNAL))
1024                 Perl_warner(aTHX_ WARN_SIGNAL, "No such signal: SIG%s", s);
1025             return 0;
1026         }
1027         SvREFCNT_dec(PL_psig_name[i]);
1028         SvREFCNT_dec(PL_psig_ptr[i]);
1029         PL_psig_ptr[i] = SvREFCNT_inc(sv);
1030         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1031         PL_psig_name[i] = newSVpvn(s, len);
1032         SvREADONLY_on(PL_psig_name[i]);
1033     }
1034     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1035         if (i)
1036             (void)rsignal(i, PL_sighandlerp);
1037         else
1038             *svp = SvREFCNT_inc(sv);
1039         return 0;
1040     }
1041     s = SvPV_force(sv,len);
1042     if (strEQ(s,"IGNORE")) {
1043         if (i)
1044             (void)rsignal(i, SIG_IGN);
1045         else
1046             *svp = 0;
1047     }
1048     else if (strEQ(s,"DEFAULT") || !*s) {
1049         if (i)
1050             (void)rsignal(i, SIG_DFL);
1051         else
1052             *svp = 0;
1053     }
1054     else {
1055         /*
1056          * We should warn if HINT_STRICT_REFS, but without
1057          * access to a known hint bit in a known OP, we can't
1058          * tell whether HINT_STRICT_REFS is in force or not.
1059          */
1060         if (!strchr(s,':') && !strchr(s,'\''))
1061             sv_insert(sv, 0, 0, "main::", 6);
1062         if (i)
1063             (void)rsignal(i, PL_sighandlerp);
1064         else
1065             *svp = SvREFCNT_inc(sv);
1066     }
1067     return 0;
1068 }
1069
1070 int
1071 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1072 {
1073     PL_sub_generation++;
1074     return 0;
1075 }
1076
1077 int
1078 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1079 {
1080     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1081     PL_amagic_generation++;
1082
1083     return 0;
1084 }
1085
1086 int
1087 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1088 {
1089     HV *hv = (HV*)LvTARG(sv);
1090     HE *entry;
1091     I32 i = 0;
1092
1093     if (hv) {
1094         (void) hv_iterinit(hv);
1095         if (! SvTIED_mg((SV*)hv, 'P'))
1096             i = HvKEYS(hv);
1097         else {
1098             /*SUPPRESS 560*/
1099             while ((entry = hv_iternext(hv))) {
1100                 i++;
1101             }
1102         }
1103     }
1104
1105     sv_setiv(sv, (IV)i);
1106     return 0;
1107 }
1108
1109 int
1110 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1111 {
1112     if (LvTARG(sv)) {
1113         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1114     }
1115     return 0;
1116 }          
1117
1118 /* caller is responsible for stack switching/cleanup */
1119 STATIC int
1120 S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
1121 {
1122     dSP;
1123
1124     PUSHMARK(SP);
1125     EXTEND(SP, n);
1126     PUSHs(SvTIED_obj(sv, mg));
1127     if (n > 1) { 
1128         if (mg->mg_ptr) {
1129             if (mg->mg_len >= 0)
1130                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1131             else if (mg->mg_len == HEf_SVKEY)
1132                 PUSHs((SV*)mg->mg_ptr);
1133         }
1134         else if (mg->mg_type == 'p') {
1135             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1136         }
1137     }
1138     if (n > 2) {
1139         PUSHs(val);
1140     }
1141     PUTBACK;
1142
1143     return call_method(meth, flags);
1144 }
1145
1146 STATIC int
1147 S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
1148 {
1149     dSP;
1150
1151     ENTER;
1152     SAVETMPS;
1153     PUSHSTACKi(PERLSI_MAGIC);
1154
1155     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1156         sv_setsv(sv, *PL_stack_sp--);
1157     }
1158
1159     POPSTACK;
1160     FREETMPS;
1161     LEAVE;
1162     return 0;
1163 }
1164
1165 int
1166 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1167 {
1168     magic_methpack(sv,mg,"FETCH");
1169     if (mg->mg_ptr)
1170         mg->mg_flags |= MGf_GSKIP;
1171     return 0;
1172 }
1173
1174 int
1175 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1176 {
1177     dSP;
1178     ENTER;
1179     PUSHSTACKi(PERLSI_MAGIC);
1180     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1181     POPSTACK;
1182     LEAVE;
1183     return 0;
1184 }
1185
1186 int
1187 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1188 {
1189     return magic_methpack(sv,mg,"DELETE");
1190 }
1191
1192
1193 U32
1194 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1195 {         
1196     dSP;
1197     U32 retval = 0;
1198
1199     ENTER;
1200     SAVETMPS;
1201     PUSHSTACKi(PERLSI_MAGIC);
1202     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1203         sv = *PL_stack_sp--;
1204         retval = (U32) SvIV(sv)-1;
1205     }
1206     POPSTACK;
1207     FREETMPS;
1208     LEAVE;
1209     return retval;
1210 }
1211
1212 int
1213 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1214 {
1215     dSP;
1216
1217     ENTER;
1218     PUSHSTACKi(PERLSI_MAGIC);
1219     PUSHMARK(SP);
1220     XPUSHs(SvTIED_obj(sv, mg));
1221     PUTBACK;
1222     call_method("CLEAR", G_SCALAR|G_DISCARD);
1223     POPSTACK;
1224     LEAVE;
1225     return 0;
1226 }
1227
1228 int
1229 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1230 {
1231     dSP;
1232     const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1233
1234     ENTER;
1235     SAVETMPS;
1236     PUSHSTACKi(PERLSI_MAGIC);
1237     PUSHMARK(SP);
1238     EXTEND(SP, 2);
1239     PUSHs(SvTIED_obj(sv, mg));
1240     if (SvOK(key))
1241         PUSHs(key);
1242     PUTBACK;
1243
1244     if (call_method(meth, G_SCALAR))
1245         sv_setsv(key, *PL_stack_sp--);
1246
1247     POPSTACK;
1248     FREETMPS;
1249     LEAVE;
1250     return 0;
1251 }
1252
1253 int
1254 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1255 {
1256     return magic_methpack(sv,mg,"EXISTS");
1257
1258
1259 int
1260 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1261 {
1262     dTHR;
1263     OP *o;
1264     I32 i;
1265     GV* gv;
1266     SV** svp;
1267     STRLEN n_a;
1268
1269     gv = PL_DBline;
1270     i = SvTRUE(sv);
1271     svp = av_fetch(GvAV(gv),
1272                      atoi(MgPV(mg,n_a)), FALSE);
1273     if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp))))
1274         o->op_private = i;
1275     else if (ckWARN_d(WARN_INTERNAL))
1276         Perl_warner(aTHX_ WARN_INTERNAL, "Can't break at that line\n");
1277     return 0;
1278 }
1279
1280 int
1281 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1282 {
1283     dTHR;
1284     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1285     return 0;
1286 }
1287
1288 int
1289 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1290 {
1291     dTHR;
1292     av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1293     return 0;
1294 }
1295
1296 int
1297 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1298 {
1299     SV* lsv = LvTARG(sv);
1300     
1301     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1302         mg = mg_find(lsv, 'g');
1303         if (mg && mg->mg_len >= 0) {
1304             dTHR;
1305             I32 i = mg->mg_len;
1306             if (DO_UTF8(lsv))
1307                 sv_pos_b2u(lsv, &i);
1308             sv_setiv(sv, i + PL_curcop->cop_arybase);
1309             return 0;
1310         }
1311     }
1312     (void)SvOK_off(sv);
1313     return 0;
1314 }
1315
1316 int
1317 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1318 {
1319     SV* lsv = LvTARG(sv);
1320     SSize_t pos;
1321     STRLEN len;
1322     STRLEN ulen = 0;
1323     dTHR;
1324
1325     mg = 0;
1326     
1327     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1328         mg = mg_find(lsv, 'g');
1329     if (!mg) {
1330         if (!SvOK(sv))
1331             return 0;
1332         sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
1333         mg = mg_find(lsv, 'g');
1334     }
1335     else if (!SvOK(sv)) {
1336         mg->mg_len = -1;
1337         return 0;
1338     }
1339     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1340
1341     pos = SvIV(sv) - PL_curcop->cop_arybase;
1342
1343     if (DO_UTF8(lsv)) {
1344         ulen = sv_len_utf8(lsv);
1345         if (ulen)
1346             len = ulen;
1347     }
1348
1349     if (pos < 0) {
1350         pos += len;
1351         if (pos < 0)
1352             pos = 0;
1353     }
1354     else if (pos > len)
1355         pos = len;
1356
1357     if (ulen) {
1358         I32 p = pos;
1359         sv_pos_u2b(lsv, &p, 0);
1360         pos = p;
1361     }
1362         
1363     mg->mg_len = pos;
1364     mg->mg_flags &= ~MGf_MINMATCH;
1365
1366     return 0;
1367 }
1368
1369 int
1370 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1371 {
1372     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1373         SvFAKE_off(sv);
1374         gv_efullname3(sv,((GV*)sv), "*");
1375         SvFAKE_on(sv);
1376     }
1377     else
1378         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1379     return 0;
1380 }
1381
1382 int
1383 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1384 {
1385     register char *s;
1386     GV* gv;
1387     STRLEN n_a;
1388
1389     if (!SvOK(sv))
1390         return 0;
1391     s = SvPV(sv, n_a);
1392     if (*s == '*' && s[1])
1393         s++;
1394     gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1395     if (sv == (SV*)gv)
1396         return 0;
1397     if (GvGP(sv))
1398         gp_free((GV*)sv);
1399     GvGP(sv) = gp_ref(GvGP(gv));
1400     return 0;
1401 }
1402
1403 int
1404 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1405 {
1406     STRLEN len;
1407     SV *lsv = LvTARG(sv);
1408     char *tmps = SvPV(lsv,len);
1409     I32 offs = LvTARGOFF(sv);
1410     I32 rem = LvTARGLEN(sv);
1411
1412     if (offs > len)
1413         offs = len;
1414     if (rem + offs > len)
1415         rem = len - offs;
1416     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1417     return 0;
1418 }
1419
1420 int
1421 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1422 {
1423     STRLEN len;
1424     char *tmps = SvPV(sv,len);
1425     sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
1426     return 0;
1427 }
1428
1429 int
1430 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1431 {
1432     dTHR;
1433     TAINT_IF((mg->mg_len & 1) ||
1434              ((mg->mg_len & 2) && mg->mg_obj == sv));   /* kludge */
1435     return 0;
1436 }
1437
1438 int
1439 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1440 {
1441     dTHR;
1442     if (PL_localizing) {
1443         if (PL_localizing == 1)
1444             mg->mg_len <<= 1;
1445         else
1446             mg->mg_len >>= 1;
1447     }
1448     else if (PL_tainted)
1449         mg->mg_len |= 1;
1450     else
1451         mg->mg_len &= ~1;
1452     return 0;
1453 }
1454
1455 int
1456 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1457 {
1458     SV *lsv = LvTARG(sv);
1459
1460     if (!lsv) {
1461         (void)SvOK_off(sv);
1462         return 0;
1463     }
1464
1465     sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1466     return 0;
1467 }
1468
1469 int
1470 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1471 {
1472     do_vecset(sv);      /* XXX slurp this routine */
1473     return 0;
1474 }
1475
1476 int
1477 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1478 {
1479     SV *targ = Nullsv;
1480     if (LvTARGLEN(sv)) {
1481         if (mg->mg_obj) {
1482             SV *ahv = LvTARG(sv);
1483             if (SvTYPE(ahv) == SVt_PVHV) {
1484                 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1485                 if (he)
1486                     targ = HeVAL(he);
1487             }
1488             else {
1489                 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0);
1490                 if (svp)
1491                     targ = *svp;
1492             }
1493         }
1494         else {
1495             AV* av = (AV*)LvTARG(sv);
1496             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1497                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1498         }
1499         if (targ && targ != &PL_sv_undef) {
1500             dTHR;               /* just for SvREFCNT_dec */
1501             /* somebody else defined it for us */
1502             SvREFCNT_dec(LvTARG(sv));
1503             LvTARG(sv) = SvREFCNT_inc(targ);
1504             LvTARGLEN(sv) = 0;
1505             SvREFCNT_dec(mg->mg_obj);
1506             mg->mg_obj = Nullsv;
1507             mg->mg_flags &= ~MGf_REFCOUNTED;
1508         }
1509     }
1510     else
1511         targ = LvTARG(sv);
1512     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1513     return 0;
1514 }
1515
1516 int
1517 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1518 {
1519     if (LvTARGLEN(sv))
1520         vivify_defelem(sv);
1521     if (LvTARG(sv)) {
1522         sv_setsv(LvTARG(sv), sv);
1523         SvSETMAGIC(LvTARG(sv));
1524     }
1525     return 0;
1526 }
1527
1528 void
1529 Perl_vivify_defelem(pTHX_ SV *sv)
1530 {
1531     dTHR;                       /* just for SvREFCNT_inc and SvREFCNT_dec*/
1532     MAGIC *mg;
1533     SV *value = Nullsv;
1534
1535     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
1536         return;
1537     if (mg->mg_obj) {
1538         SV *ahv = LvTARG(sv);
1539         STRLEN n_a;
1540         if (SvTYPE(ahv) == SVt_PVHV) {
1541             HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1542             if (he)
1543                 value = HeVAL(he);
1544         }
1545         else {
1546             SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0);
1547             if (svp)
1548                 value = *svp;
1549         }
1550         if (!value || value == &PL_sv_undef)
1551             Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
1552     }
1553     else {
1554         AV* av = (AV*)LvTARG(sv);
1555         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1556             LvTARG(sv) = Nullsv;        /* array can't be extended */
1557         else {
1558             SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1559             if (!svp || (value = *svp) == &PL_sv_undef)
1560                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1561         }
1562     }
1563     (void)SvREFCNT_inc(value);
1564     SvREFCNT_dec(LvTARG(sv));
1565     LvTARG(sv) = value;
1566     LvTARGLEN(sv) = 0;
1567     SvREFCNT_dec(mg->mg_obj);
1568     mg->mg_obj = Nullsv;
1569     mg->mg_flags &= ~MGf_REFCOUNTED;
1570 }
1571
1572 int
1573 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1574 {
1575     AV *av = (AV*)mg->mg_obj;
1576     SV **svp = AvARRAY(av);
1577     I32 i = AvFILLp(av);
1578     while (i >= 0) {
1579         if (svp[i] && svp[i] != &PL_sv_undef) {
1580             if (!SvWEAKREF(svp[i]))
1581                 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1582             /* XXX Should we check that it hasn't changed? */
1583             SvRV(svp[i]) = 0;
1584             (void)SvOK_off(svp[i]);
1585             SvWEAKREF_off(svp[i]);
1586             svp[i] = &PL_sv_undef;
1587         }
1588         i--;
1589     }
1590     return 0;
1591 }
1592
1593 int
1594 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1595 {
1596     mg->mg_len = -1;
1597     SvSCREAM_off(sv);
1598     return 0;
1599 }
1600
1601 int
1602 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1603 {
1604     sv_unmagic(sv, 'B');
1605     SvVALID_off(sv);
1606     return 0;
1607 }
1608
1609 int
1610 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
1611 {
1612     sv_unmagic(sv, 'f');
1613     SvCOMPILED_off(sv);
1614     return 0;
1615 }
1616
1617 int
1618 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
1619 {
1620     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1621
1622     if (uf && uf->uf_set)
1623         (*uf->uf_set)(uf->uf_index, sv);
1624     return 0;
1625 }
1626
1627 int
1628 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
1629 {
1630     regexp *re = (regexp *)mg->mg_obj;
1631     ReREFCNT_dec(re);
1632     return 0;
1633 }
1634
1635 #ifdef USE_LOCALE_COLLATE
1636 int
1637 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
1638 {
1639     /*
1640      * RenE<eacute> Descartes said "I think not."
1641      * and vanished with a faint plop.
1642      */
1643     if (mg->mg_ptr) {
1644         Safefree(mg->mg_ptr);
1645         mg->mg_ptr = NULL;
1646         mg->mg_len = -1;
1647     }
1648     return 0;
1649 }
1650 #endif /* USE_LOCALE_COLLATE */
1651
1652 int
1653 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
1654 {
1655     dTHR;
1656     register char *s;
1657     I32 i;
1658     STRLEN len;
1659     switch (*mg->mg_ptr) {
1660     case '\001':        /* ^A */
1661         sv_setsv(PL_bodytarget, sv);
1662         break;
1663     case '\003':        /* ^C */
1664         PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1665         break;
1666
1667     case '\004':        /* ^D */
1668         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
1669         DEBUG_x(dump_all());
1670         break;
1671     case '\005':  /* ^E */
1672 #ifdef MACOS_TRADITIONAL
1673         gLastMacOSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1674 #else
1675 #  ifdef VMS
1676         set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1677 #  else
1678 #    ifdef WIN32
1679         SetLastError( SvIV(sv) );
1680 #    else
1681 #      ifndef OS2
1682         /* will anyone ever use this? */
1683         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
1684 #      endif
1685 #    endif
1686 #  endif
1687 #endif
1688         break;
1689     case '\006':        /* ^F */
1690         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1691         break;
1692     case '\010':        /* ^H */
1693         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1694         break;
1695     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
1696         if (PL_inplace)
1697             Safefree(PL_inplace);
1698         if (SvOK(sv))
1699             PL_inplace = savepv(SvPV(sv,len));
1700         else
1701             PL_inplace = Nullch;
1702         break;
1703     case '\017':        /* ^O */
1704         if (PL_osname)
1705             Safefree(PL_osname);
1706         if (SvOK(sv))
1707             PL_osname = savepv(SvPV(sv,len));
1708         else
1709             PL_osname = Nullch;
1710         break;
1711     case '\020':        /* ^P */
1712         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1713         if (PL_perldb && !PL_DBsingle)
1714             init_debugger();
1715         break;
1716     case '\024':        /* ^T */
1717 #ifdef BIG_TIME
1718         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
1719 #else
1720         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1721 #endif
1722         break;
1723     case '\027':        /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
1724         if (*(mg->mg_ptr+1) == '\0') {
1725             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1726                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1727                 PL_dowarn = (PL_dowarn & ~G_WARN_ON) 
1728                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
1729             }
1730         }
1731         else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) {
1732             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1733                 if (!SvPOK(sv) && PL_localizing) {
1734                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
1735                     PL_compiling.cop_warnings = pWARN_NONE;
1736                     break;
1737                 }
1738                 if (isWARN_on(sv, WARN_ALL) && !isWARNf_on(sv, WARN_ALL)) {
1739                     PL_compiling.cop_warnings = pWARN_ALL;
1740                     PL_dowarn |= G_WARN_ONCE ;
1741                 }       
1742                 else {
1743                     STRLEN len, i;
1744                     int accumulate = 0 ;
1745                     char * ptr = (char*)SvPV(sv, len) ;
1746                     for (i = 0 ; i < len ; ++i) 
1747                         accumulate += ptr[i] ;
1748                     if (!accumulate)
1749                         PL_compiling.cop_warnings = pWARN_NONE;
1750                     else {
1751                         if (specialWARN(PL_compiling.cop_warnings))
1752                             PL_compiling.cop_warnings = newSVsv(sv) ;
1753                         else
1754                             sv_setsv(PL_compiling.cop_warnings, sv);
1755                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
1756                             PL_dowarn |= G_WARN_ONCE ;
1757                     }
1758                 }
1759             }
1760         }
1761         else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS"))
1762             PL_widesyscalls = SvTRUE(sv);
1763         break;
1764     case '.':
1765         if (PL_localizing) {
1766             if (PL_localizing == 1)
1767                 SAVESPTR(PL_last_in_gv);
1768         }
1769         else if (SvOK(sv) && GvIO(PL_last_in_gv))
1770             IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv);
1771         break;
1772     case '^':
1773         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
1774         IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
1775         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1776         break;
1777     case '~':
1778         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
1779         IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
1780         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1781         break;
1782     case '=':
1783         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1784         break;
1785     case '-':
1786         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1787         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
1788             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
1789         break;
1790     case '%':
1791         IoPAGE(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1792         break;
1793     case '|':
1794         {
1795             IO *io = GvIOp(PL_defoutgv);
1796             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
1797                 IoFLAGS(io) &= ~IOf_FLUSH;
1798             else {
1799                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
1800                     PerlIO *ofp = IoOFP(io);
1801                     if (ofp)
1802                         (void)PerlIO_flush(ofp);
1803                     IoFLAGS(io) |= IOf_FLUSH;
1804                 }
1805             }
1806         }
1807         break;
1808     case '*':
1809         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1810         PL_multiline = (i != 0);
1811         break;
1812     case '/':
1813         SvREFCNT_dec(PL_nrs);
1814         PL_nrs = newSVsv(sv);
1815         SvREFCNT_dec(PL_rs);
1816         PL_rs = SvREFCNT_inc(PL_nrs);
1817         break;
1818     case '\\':
1819         if (PL_ors)
1820             Safefree(PL_ors);
1821         if (SvOK(sv) || SvGMAGICAL(sv)) {
1822             s = SvPV(sv,PL_orslen);
1823             PL_ors = savepvn(s,PL_orslen);
1824         }
1825         else {
1826             PL_ors = Nullch;
1827             PL_orslen = 0;
1828         }
1829         break;
1830     case ',':
1831         if (PL_ofs)
1832             Safefree(PL_ofs);
1833         PL_ofs = savepv(SvPV(sv, PL_ofslen));
1834         break;
1835     case '#':
1836         if (PL_ofmt)
1837             Safefree(PL_ofmt);
1838         PL_ofmt = savepv(SvPV(sv,len));
1839         break;
1840     case '[':
1841         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1842         break;
1843     case '?':
1844 #ifdef COMPLEX_STATUS
1845         if (PL_localizing == 2) {
1846             PL_statusvalue = LvTARGOFF(sv);
1847             PL_statusvalue_vms = LvTARGLEN(sv);
1848         }
1849         else
1850 #endif
1851 #ifdef VMSISH_STATUS
1852         if (VMSISH_STATUS)
1853             STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
1854         else
1855 #endif
1856             STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1857         break;
1858     case '!':
1859         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
1860                  (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
1861         break;
1862     case '<':
1863         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1864         if (PL_delaymagic) {
1865             PL_delaymagic |= DM_RUID;
1866             break;                              /* don't do magic till later */
1867         }
1868 #ifdef HAS_SETRUID
1869         (void)setruid((Uid_t)PL_uid);
1870 #else
1871 #ifdef HAS_SETREUID
1872         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
1873 #else
1874 #ifdef HAS_SETRESUID
1875       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
1876 #else
1877         if (PL_uid == PL_euid)          /* special case $< = $> */
1878             (void)PerlProc_setuid(PL_uid);
1879         else {
1880             PL_uid = PerlProc_getuid();
1881             Perl_croak(aTHX_ "setruid() not implemented");
1882         }
1883 #endif
1884 #endif
1885 #endif
1886         PL_uid = PerlProc_getuid();
1887         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1888         break;
1889     case '>':
1890         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1891         if (PL_delaymagic) {
1892             PL_delaymagic |= DM_EUID;
1893             break;                              /* don't do magic till later */
1894         }
1895 #ifdef HAS_SETEUID
1896         (void)seteuid((Uid_t)PL_euid);
1897 #else
1898 #ifdef HAS_SETREUID
1899         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
1900 #else
1901 #ifdef HAS_SETRESUID
1902         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
1903 #else
1904         if (PL_euid == PL_uid)          /* special case $> = $< */
1905             PerlProc_setuid(PL_euid);
1906         else {
1907             PL_euid = PerlProc_geteuid();
1908             Perl_croak(aTHX_ "seteuid() not implemented");
1909         }
1910 #endif
1911 #endif
1912 #endif
1913         PL_euid = PerlProc_geteuid();
1914         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1915         break;
1916     case '(':
1917         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1918         if (PL_delaymagic) {
1919             PL_delaymagic |= DM_RGID;
1920             break;                              /* don't do magic till later */
1921         }
1922 #ifdef HAS_SETRGID
1923         (void)setrgid((Gid_t)PL_gid);
1924 #else
1925 #ifdef HAS_SETREGID
1926         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
1927 #else
1928 #ifdef HAS_SETRESGID
1929       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
1930 #else
1931         if (PL_gid == PL_egid)                  /* special case $( = $) */
1932             (void)PerlProc_setgid(PL_gid);
1933         else {
1934             PL_gid = PerlProc_getgid();
1935             Perl_croak(aTHX_ "setrgid() not implemented");
1936         }
1937 #endif
1938 #endif
1939 #endif
1940         PL_gid = PerlProc_getgid();
1941         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1942         break;
1943     case ')':
1944 #ifdef HAS_SETGROUPS
1945         {
1946             char *p = SvPV(sv, len);
1947             Groups_t gary[NGROUPS];
1948
1949             while (isSPACE(*p))
1950                 ++p;
1951             PL_egid = Atol(p);
1952             for (i = 0; i < NGROUPS; ++i) {
1953                 while (*p && !isSPACE(*p))
1954                     ++p;
1955                 while (isSPACE(*p))
1956                     ++p;
1957                 if (!*p)
1958                     break;
1959                 gary[i] = Atol(p);
1960             }
1961             if (i)
1962                 (void)setgroups(i, gary);
1963         }
1964 #else  /* HAS_SETGROUPS */
1965         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1966 #endif /* HAS_SETGROUPS */
1967         if (PL_delaymagic) {
1968             PL_delaymagic |= DM_EGID;
1969             break;                              /* don't do magic till later */
1970         }
1971 #ifdef HAS_SETEGID
1972         (void)setegid((Gid_t)PL_egid);
1973 #else
1974 #ifdef HAS_SETREGID
1975         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
1976 #else
1977 #ifdef HAS_SETRESGID
1978         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
1979 #else
1980         if (PL_egid == PL_gid)                  /* special case $) = $( */
1981             (void)PerlProc_setgid(PL_egid);
1982         else {
1983             PL_egid = PerlProc_getegid();
1984             Perl_croak(aTHX_ "setegid() not implemented");
1985         }
1986 #endif
1987 #endif
1988 #endif
1989         PL_egid = PerlProc_getegid();
1990         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1991         break;
1992     case ':':
1993         PL_chopset = SvPV_force(sv,len);
1994         break;
1995 #ifndef MACOS_TRADITIONAL
1996     case '0':
1997         if (!PL_origalen) {
1998             s = PL_origargv[0];
1999             s += strlen(s);
2000             /* See if all the arguments are contiguous in memory */
2001             for (i = 1; i < PL_origargc; i++) {
2002                 if (PL_origargv[i] == s + 1
2003 #ifdef OS2
2004                     || PL_origargv[i] == s + 2
2005 #endif 
2006                    )
2007                 {
2008                     ++s;
2009                     s += strlen(s);     /* this one is ok too */
2010                 }
2011                 else
2012                     break;
2013             }
2014             /* can grab env area too? */
2015             if (PL_origenviron && (PL_origenviron[0] == s + 1
2016 #ifdef OS2
2017                                 || (PL_origenviron[0] == s + 9 && (s += 8))
2018 #endif 
2019                )) {
2020                 my_setenv("NoNe  SuCh", Nullch);
2021                                             /* force copy of environment */
2022                 for (i = 0; PL_origenviron[i]; i++)
2023                     if (PL_origenviron[i] == s + 1) {
2024                         ++s;
2025                         s += strlen(s);
2026                     }
2027                     else
2028                         break;
2029             }
2030             PL_origalen = s - PL_origargv[0];
2031         }
2032         s = SvPV_force(sv,len);
2033         i = len;
2034         if (i >= PL_origalen) {
2035             i = PL_origalen;
2036             /* don't allow system to limit $0 seen by script */
2037             /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
2038             Copy(s, PL_origargv[0], i, char);
2039             s = PL_origargv[0]+i;
2040             *s = '\0';
2041         }
2042         else {
2043             Copy(s, PL_origargv[0], i, char);
2044             s = PL_origargv[0]+i;
2045             *s++ = '\0';
2046             while (++i < PL_origalen)
2047                 *s++ = ' ';
2048             s = PL_origargv[0]+i;
2049             for (i = 1; i < PL_origargc; i++)
2050                 PL_origargv[i] = Nullch;
2051         }
2052         break;
2053 #endif
2054 #ifdef USE_THREADS
2055     case '@':
2056         sv_setsv(thr->errsv, sv);
2057         break;
2058 #endif /* USE_THREADS */
2059     }
2060     return 0;
2061 }
2062
2063 #ifdef USE_THREADS
2064 int
2065 Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg)
2066 {
2067     dTHR;
2068     DEBUG_S(PerlIO_printf(Perl_debug_log,
2069                           "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n",
2070                           PTR2UV(thr), PTR2UV(sv));)
2071     if (MgOWNER(mg))
2072         Perl_croak(aTHX_ "panic: magic_mutexfree");
2073     MUTEX_DESTROY(MgMUTEXP(mg));
2074     COND_DESTROY(MgCONDP(mg));
2075     return 0;
2076 }
2077 #endif /* USE_THREADS */
2078
2079 I32
2080 Perl_whichsig(pTHX_ char *sig)
2081 {
2082     register char **sigv;
2083
2084     for (sigv = PL_sig_name+1; *sigv; sigv++)
2085         if (strEQ(sig,*sigv))
2086             return PL_sig_num[sigv - PL_sig_name];
2087 #ifdef SIGCLD
2088     if (strEQ(sig,"CHLD"))
2089         return SIGCLD;
2090 #endif
2091 #ifdef SIGCHLD
2092     if (strEQ(sig,"CLD"))
2093         return SIGCHLD;
2094 #endif
2095     return 0;
2096 }
2097
2098 static SV* sig_sv;
2099
2100 Signal_t
2101 Perl_sighandler(int sig)
2102 {
2103     dTHX;
2104     dSP;
2105     GV *gv = Nullgv;
2106     HV *st;
2107     SV *sv, *tSv = PL_Sv;
2108     CV *cv = Nullcv;
2109     OP *myop = PL_op;
2110     U32 flags = 0;
2111     I32 o_save_i = PL_savestack_ix;
2112     XPV *tXpv = PL_Xpv;
2113     
2114     if (PL_savestack_ix + 15 <= PL_savestack_max)
2115         flags |= 1;
2116     if (PL_markstack_ptr < PL_markstack_max - 2)
2117         flags |= 4;
2118     if (PL_retstack_ix < PL_retstack_max - 2)
2119         flags |= 8;
2120     if (PL_scopestack_ix < PL_scopestack_max - 3)
2121         flags |= 16;
2122
2123     if (!PL_psig_ptr[sig])
2124         Perl_die(aTHX_ "Signal SIG%s received, but no signal handler set.\n",
2125             PL_sig_name[sig]);
2126
2127     /* Max number of items pushed there is 3*n or 4. We cannot fix
2128        infinity, so we fix 4 (in fact 5): */
2129     if (flags & 1) {
2130         PL_savestack_ix += 5;           /* Protect save in progress. */
2131         o_save_i = PL_savestack_ix;
2132         SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2133     }
2134     if (flags & 4) 
2135         PL_markstack_ptr++;             /* Protect mark. */
2136     if (flags & 8) {
2137         PL_retstack_ix++;
2138         PL_retstack[PL_retstack_ix] = NULL;
2139     }
2140     if (flags & 16)
2141         PL_scopestack_ix += 1;
2142     /* sv_2cv is too complicated, try a simpler variant first: */
2143     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) 
2144         || SvTYPE(cv) != SVt_PVCV)
2145         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2146
2147     if (!cv || !CvROOT(cv)) {
2148         if (ckWARN(WARN_SIGNAL))
2149             Perl_warner(aTHX_ WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n",
2150                 PL_sig_name[sig], (gv ? GvENAME(gv)
2151                                 : ((cv && CvGV(cv))
2152                                    ? GvENAME(CvGV(cv))
2153                                    : "__ANON__")));
2154         goto cleanup;
2155     }
2156
2157     if(PL_psig_name[sig]) {
2158         sv = SvREFCNT_inc(PL_psig_name[sig]);
2159         flags |= 64;
2160         sig_sv = sv;
2161     } else {
2162         sv = sv_newmortal();
2163         sv_setpv(sv,PL_sig_name[sig]);
2164     }
2165
2166     PUSHSTACKi(PERLSI_SIGNAL);
2167     PUSHMARK(SP);
2168     PUSHs(sv);
2169     PUTBACK;
2170
2171     call_sv((SV*)cv, G_DISCARD);
2172
2173     POPSTACK;
2174 cleanup:
2175     if (flags & 1)
2176         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2177     if (flags & 4) 
2178         PL_markstack_ptr--;
2179     if (flags & 8) 
2180         PL_retstack_ix--;
2181     if (flags & 16)
2182         PL_scopestack_ix -= 1;
2183     if (flags & 64)
2184         SvREFCNT_dec(sv);
2185     PL_op = myop;                       /* Apparently not needed... */
2186     
2187     PL_Sv = tSv;                        /* Restore global temporaries. */
2188     PL_Xpv = tXpv;
2189     return;
2190 }
2191
2192
2193 #ifdef PERL_OBJECT
2194 #include "XSUB.h"
2195 #endif
2196
2197 static void
2198 restore_magic(pTHXo_ void *p)
2199 {
2200     dTHR;
2201     MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2202     SV* sv = mgs->mgs_sv;
2203
2204     if (!sv)
2205         return;
2206
2207     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2208     {
2209         if (mgs->mgs_flags)
2210             SvFLAGS(sv) |= mgs->mgs_flags;
2211         else
2212             mg_magical(sv);
2213         if (SvGMAGICAL(sv))
2214             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2215     }
2216
2217     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2218
2219     /* If we're still on top of the stack, pop us off.  (That condition
2220      * will be satisfied if restore_magic was called explicitly, but *not*
2221      * if it's being called via leave_scope.)
2222      * The reason for doing this is that otherwise, things like sv_2cv()
2223      * may leave alloc gunk on the savestack, and some code
2224      * (e.g. sighandler) doesn't expect that...
2225      */
2226     if (PL_savestack_ix == mgs->mgs_ss_ix)
2227     {
2228         I32 popval = SSPOPINT;
2229         assert(popval == SAVEt_DESTRUCTOR_X);
2230         PL_savestack_ix -= 2;
2231         popval = SSPOPINT;
2232         assert(popval == SAVEt_ALLOC);
2233         popval = SSPOPINT;
2234         PL_savestack_ix -= popval;
2235     }
2236
2237 }
2238
2239 static void
2240 unwind_handler_stack(pTHXo_ void *p)
2241 {
2242     dTHR;
2243     U32 flags = *(U32*)p;
2244
2245     if (flags & 1)
2246         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2247     /* cxstack_ix-- Not needed, die already unwound it. */
2248     if (flags & 64)
2249         SvREFCNT_dec(sig_sv);
2250 }