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