This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
76da1b4b849dc7d94bf1a6cd18ff4a1e191bcf23
[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 = end + strlen(end+1)+2;
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 int
1044 magic_setamagic(SV *sv, MAGIC *mg)
1045 {
1046     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1047     PL_amagic_generation++;
1048
1049     return 0;
1050 }
1051
1052 int
1053 magic_getnkeys(SV *sv, MAGIC *mg)
1054 {
1055     HV *hv = (HV*)LvTARG(sv);
1056     HE *entry;
1057     I32 i = 0;
1058
1059     if (hv) {
1060         (void) hv_iterinit(hv);
1061         if (! SvTIED_mg((SV*)hv, 'P'))
1062             i = HvKEYS(hv);
1063         else {
1064             /*SUPPRESS 560*/
1065             while (entry = hv_iternext(hv)) {
1066                 i++;
1067             }
1068         }
1069     }
1070
1071     sv_setiv(sv, (IV)i);
1072     return 0;
1073 }
1074
1075 int
1076 magic_setnkeys(SV *sv, MAGIC *mg)
1077 {
1078     if (LvTARG(sv)) {
1079         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1080     }
1081     return 0;
1082 }          
1083
1084 /* caller is responsible for stack switching/cleanup */
1085 STATIC int
1086 magic_methcall(SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
1087 {
1088     dSP;
1089
1090     PUSHMARK(SP);
1091     EXTEND(SP, n);
1092     PUSHs(SvTIED_obj(sv, mg));
1093     if (n > 1) { 
1094         if (mg->mg_ptr) {
1095             if (mg->mg_len >= 0)
1096                 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
1097             else if (mg->mg_len == HEf_SVKEY)
1098                 PUSHs((SV*)mg->mg_ptr);
1099         }
1100         else if (mg->mg_type == 'p') {
1101             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1102         }
1103     }
1104     if (n > 2) {
1105         PUSHs(val);
1106     }
1107     PUTBACK;
1108
1109     return perl_call_method(meth, flags);
1110 }
1111
1112 STATIC int
1113 magic_methpack(SV *sv, MAGIC *mg, char *meth)
1114 {
1115     dSP;
1116
1117     ENTER;
1118     SAVETMPS;
1119     PUSHSTACKi(PERLSI_MAGIC);
1120
1121     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1122         sv_setsv(sv, *PL_stack_sp--);
1123     }
1124
1125     POPSTACK;
1126     FREETMPS;
1127     LEAVE;
1128     return 0;
1129 }
1130
1131 int
1132 magic_getpack(SV *sv, MAGIC *mg)
1133 {
1134     magic_methpack(sv,mg,"FETCH");
1135     if (mg->mg_ptr)
1136         mg->mg_flags |= MGf_GSKIP;
1137     return 0;
1138 }
1139
1140 int
1141 magic_setpack(SV *sv, MAGIC *mg)
1142 {
1143     dSP;
1144     ENTER;
1145     PUSHSTACKi(PERLSI_MAGIC);
1146     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1147     POPSTACK;
1148     LEAVE;
1149     return 0;
1150 }
1151
1152 int
1153 magic_clearpack(SV *sv, MAGIC *mg)
1154 {
1155     return magic_methpack(sv,mg,"DELETE");
1156 }
1157
1158
1159 U32
1160 magic_sizepack(SV *sv, MAGIC *mg)
1161 {         
1162     dSP;
1163     U32 retval = 0;
1164
1165     ENTER;
1166     SAVETMPS;
1167     PUSHSTACKi(PERLSI_MAGIC);
1168     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1169         sv = *PL_stack_sp--;
1170         retval = (U32) SvIV(sv)-1;
1171     }
1172     POPSTACK;
1173     FREETMPS;
1174     LEAVE;
1175     return retval;
1176 }
1177
1178 int magic_wipepack(SV *sv, MAGIC *mg)
1179 {
1180     dSP;
1181
1182     ENTER;
1183     PUSHSTACKi(PERLSI_MAGIC);
1184     PUSHMARK(SP);
1185     XPUSHs(SvTIED_obj(sv, mg));
1186     PUTBACK;
1187     perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
1188     POPSTACK;
1189     LEAVE;
1190     return 0;
1191 }
1192
1193 int
1194 magic_nextpack(SV *sv, MAGIC *mg, SV *key)
1195 {
1196     dSP;
1197     char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1198
1199     ENTER;
1200     SAVETMPS;
1201     PUSHSTACKi(PERLSI_MAGIC);
1202     PUSHMARK(SP);
1203     EXTEND(SP, 2);
1204     PUSHs(SvTIED_obj(sv, mg));
1205     if (SvOK(key))
1206         PUSHs(key);
1207     PUTBACK;
1208
1209     if (perl_call_method(meth, G_SCALAR))
1210         sv_setsv(key, *PL_stack_sp--);
1211
1212     POPSTACK;
1213     FREETMPS;
1214     LEAVE;
1215     return 0;
1216 }
1217
1218 int
1219 magic_existspack(SV *sv, MAGIC *mg)
1220 {
1221     return magic_methpack(sv,mg,"EXISTS");
1222
1223
1224 int
1225 magic_setdbline(SV *sv, MAGIC *mg)
1226 {
1227     dTHR;
1228     OP *o;
1229     I32 i;
1230     GV* gv;
1231     SV** svp;
1232     STRLEN n_a;
1233
1234     gv = PL_DBline;
1235     i = SvTRUE(sv);
1236     svp = av_fetch(GvAV(gv),
1237                      atoi(MgPV(mg,n_a)), FALSE);
1238     if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
1239         o->op_private = i;
1240     else
1241         warn("Can't break at that line\n");
1242     return 0;
1243 }
1244
1245 int
1246 magic_getarylen(SV *sv, MAGIC *mg)
1247 {
1248     dTHR;
1249     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1250     return 0;
1251 }
1252
1253 int
1254 magic_setarylen(SV *sv, MAGIC *mg)
1255 {
1256     dTHR;
1257     av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1258     return 0;
1259 }
1260
1261 int
1262 magic_getpos(SV *sv, MAGIC *mg)
1263 {
1264     SV* lsv = LvTARG(sv);
1265     
1266     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1267         mg = mg_find(lsv, 'g');
1268         if (mg && mg->mg_len >= 0) {
1269             dTHR;
1270             I32 i = mg->mg_len;
1271             if (IN_UTF8)
1272                 sv_pos_b2u(lsv, &i);
1273             sv_setiv(sv, i + PL_curcop->cop_arybase);
1274             return 0;
1275         }
1276     }
1277     (void)SvOK_off(sv);
1278     return 0;
1279 }
1280
1281 int
1282 magic_setpos(SV *sv, MAGIC *mg)
1283 {
1284     SV* lsv = LvTARG(sv);
1285     SSize_t pos;
1286     STRLEN len;
1287     STRLEN ulen;
1288     dTHR;
1289
1290     mg = 0;
1291     
1292     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1293         mg = mg_find(lsv, 'g');
1294     if (!mg) {
1295         if (!SvOK(sv))
1296             return 0;
1297         sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
1298         mg = mg_find(lsv, 'g');
1299     }
1300     else if (!SvOK(sv)) {
1301         mg->mg_len = -1;
1302         return 0;
1303     }
1304     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1305
1306     pos = SvIV(sv) - PL_curcop->cop_arybase;
1307
1308     if (IN_UTF8) {
1309         ulen = sv_len_utf8(lsv);
1310         if (ulen)
1311             len = ulen;
1312         else
1313             ulen = 0;
1314     }
1315
1316     if (pos < 0) {
1317         pos += len;
1318         if (pos < 0)
1319             pos = 0;
1320     }
1321     else if (pos > len)
1322         pos = len;
1323
1324     if (ulen) {
1325         I32 p = pos;
1326         sv_pos_u2b(lsv, &p, 0);
1327         pos = p;
1328     }
1329         
1330     mg->mg_len = pos;
1331     mg->mg_flags &= ~MGf_MINMATCH;
1332
1333     return 0;
1334 }
1335
1336 int
1337 magic_getglob(SV *sv, MAGIC *mg)
1338 {
1339     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1340         SvFAKE_off(sv);
1341         gv_efullname3(sv,((GV*)sv), "*");
1342         SvFAKE_on(sv);
1343     }
1344     else
1345         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1346     return 0;
1347 }
1348
1349 int
1350 magic_setglob(SV *sv, MAGIC *mg)
1351 {
1352     register char *s;
1353     GV* gv;
1354     STRLEN n_a;
1355
1356     if (!SvOK(sv))
1357         return 0;
1358     s = SvPV(sv, n_a);
1359     if (*s == '*' && s[1])
1360         s++;
1361     gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1362     if (sv == (SV*)gv)
1363         return 0;
1364     if (GvGP(sv))
1365         gp_free((GV*)sv);
1366     GvGP(sv) = gp_ref(GvGP(gv));
1367     return 0;
1368 }
1369
1370 int
1371 magic_getsubstr(SV *sv, MAGIC *mg)
1372 {
1373     STRLEN len;
1374     SV *lsv = LvTARG(sv);
1375     char *tmps = SvPV(lsv,len);
1376     I32 offs = LvTARGOFF(sv);
1377     I32 rem = LvTARGLEN(sv);
1378
1379     if (offs > len)
1380         offs = len;
1381     if (rem + offs > len)
1382         rem = len - offs;
1383     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1384     return 0;
1385 }
1386
1387 int
1388 magic_setsubstr(SV *sv, MAGIC *mg)
1389 {
1390     STRLEN len;
1391     char *tmps = SvPV(sv,len);
1392     sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
1393     return 0;
1394 }
1395
1396 int
1397 magic_gettaint(SV *sv, MAGIC *mg)
1398 {
1399     dTHR;
1400     TAINT_IF((mg->mg_len & 1) ||
1401              (mg->mg_len & 2) && mg->mg_obj == sv);     /* kludge */
1402     return 0;
1403 }
1404
1405 int
1406 magic_settaint(SV *sv, MAGIC *mg)
1407 {
1408     dTHR;
1409     if (PL_localizing) {
1410         if (PL_localizing == 1)
1411             mg->mg_len <<= 1;
1412         else
1413             mg->mg_len >>= 1;
1414     }
1415     else if (PL_tainted)
1416         mg->mg_len |= 1;
1417     else
1418         mg->mg_len &= ~1;
1419     return 0;
1420 }
1421
1422 int
1423 magic_getvec(SV *sv, MAGIC *mg)
1424 {
1425     SV *lsv = LvTARG(sv);
1426     unsigned char *s;
1427     unsigned long retnum;
1428     STRLEN lsvlen;
1429     I32 len;
1430     I32 offset;
1431     I32 size;
1432
1433     if (!lsv) {
1434         SvOK_off(sv);
1435         return 0;
1436     }
1437     s = (unsigned char *) SvPV(lsv, lsvlen);
1438     offset = LvTARGOFF(sv);
1439     size = LvTARGLEN(sv);
1440     len = (offset + size + 7) / 8;
1441
1442     /* Copied from pp_vec() */
1443
1444     if (len > lsvlen) {
1445         if (size <= 8)
1446             retnum = 0;
1447         else {
1448             offset >>= 3;
1449             if (size == 16) {
1450                 if (offset >= lsvlen)
1451                     retnum = 0;
1452                 else
1453                     retnum = (unsigned long) s[offset] << 8;
1454             }
1455             else if (size == 32) {
1456                 if (offset >= lsvlen)
1457                     retnum = 0;
1458                 else if (offset + 1 >= lsvlen)
1459                     retnum = (unsigned long) s[offset] << 24;
1460                 else if (offset + 2 >= lsvlen)
1461                     retnum = ((unsigned long) s[offset] << 24) +
1462                         ((unsigned long) s[offset + 1] << 16);
1463                 else
1464                     retnum = ((unsigned long) s[offset] << 24) +
1465                         ((unsigned long) s[offset + 1] << 16) +
1466                         (s[offset + 2] << 8);
1467             }
1468         }
1469     }
1470     else if (size < 8)
1471         retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1472     else {
1473         offset >>= 3;
1474         if (size == 8)
1475             retnum = s[offset];
1476         else if (size == 16)
1477             retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1478         else if (size == 32)
1479             retnum = ((unsigned long) s[offset] << 24) +
1480                 ((unsigned long) s[offset + 1] << 16) +
1481                 (s[offset + 2] << 8) + s[offset+3];
1482     }
1483
1484     sv_setuv(sv, (UV)retnum);
1485     return 0;
1486 }
1487
1488 int
1489 magic_setvec(SV *sv, MAGIC *mg)
1490 {
1491     do_vecset(sv);      /* XXX slurp this routine */
1492     return 0;
1493 }
1494
1495 int
1496 magic_getdefelem(SV *sv, MAGIC *mg)
1497 {
1498     SV *targ = Nullsv;
1499     if (LvTARGLEN(sv)) {
1500         if (mg->mg_obj) {
1501             SV *ahv = LvTARG(sv);
1502             if (SvTYPE(ahv) == SVt_PVHV) {
1503                 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1504                 if (he)
1505                     targ = HeVAL(he);
1506             }
1507             else {
1508                 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0);
1509                 if (svp)
1510                     targ = *svp;
1511             }
1512         }
1513         else {
1514             AV* av = (AV*)LvTARG(sv);
1515             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1516                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1517         }
1518         if (targ && targ != &PL_sv_undef) {
1519             dTHR;               /* just for SvREFCNT_dec */
1520             /* somebody else defined it for us */
1521             SvREFCNT_dec(LvTARG(sv));
1522             LvTARG(sv) = SvREFCNT_inc(targ);
1523             LvTARGLEN(sv) = 0;
1524             SvREFCNT_dec(mg->mg_obj);
1525             mg->mg_obj = Nullsv;
1526             mg->mg_flags &= ~MGf_REFCOUNTED;
1527         }
1528     }
1529     else
1530         targ = LvTARG(sv);
1531     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1532     return 0;
1533 }
1534
1535 int
1536 magic_setdefelem(SV *sv, MAGIC *mg)
1537 {
1538     if (LvTARGLEN(sv))
1539         vivify_defelem(sv);
1540     if (LvTARG(sv)) {
1541         sv_setsv(LvTARG(sv), sv);
1542         SvSETMAGIC(LvTARG(sv));
1543     }
1544     return 0;
1545 }
1546
1547 void
1548 vivify_defelem(SV *sv)
1549 {
1550     dTHR;                       /* just for SvREFCNT_inc and SvREFCNT_dec*/
1551     MAGIC *mg;
1552     SV *value = Nullsv;
1553
1554     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
1555         return;
1556     if (mg->mg_obj) {
1557         SV *ahv = LvTARG(sv);
1558         STRLEN n_a;
1559         if (SvTYPE(ahv) == SVt_PVHV) {
1560             HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1561             if (he)
1562                 value = HeVAL(he);
1563         }
1564         else {
1565             SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0);
1566             if (svp)
1567                 value = *svp;
1568         }
1569         if (!value || value == &PL_sv_undef)
1570             croak(PL_no_helem, SvPV(mg->mg_obj, n_a));
1571     }
1572     else {
1573         AV* av = (AV*)LvTARG(sv);
1574         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1575             LvTARG(sv) = Nullsv;        /* array can't be extended */
1576         else {
1577             SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1578             if (!svp || (value = *svp) == &PL_sv_undef)
1579                 croak(PL_no_aelem, (I32)LvTARGOFF(sv));
1580         }
1581     }
1582     (void)SvREFCNT_inc(value);
1583     SvREFCNT_dec(LvTARG(sv));
1584     LvTARG(sv) = value;
1585     LvTARGLEN(sv) = 0;
1586     SvREFCNT_dec(mg->mg_obj);
1587     mg->mg_obj = Nullsv;
1588     mg->mg_flags &= ~MGf_REFCOUNTED;
1589 }
1590
1591 int
1592 magic_setmglob(SV *sv, MAGIC *mg)
1593 {
1594     mg->mg_len = -1;
1595     SvSCREAM_off(sv);
1596     return 0;
1597 }
1598
1599 int
1600 magic_setbm(SV *sv, MAGIC *mg)
1601 {
1602     sv_unmagic(sv, 'B');
1603     SvVALID_off(sv);
1604     return 0;
1605 }
1606
1607 int
1608 magic_setfm(SV *sv, MAGIC *mg)
1609 {
1610     sv_unmagic(sv, 'f');
1611     SvCOMPILED_off(sv);
1612     return 0;
1613 }
1614
1615 int
1616 magic_setuvar(SV *sv, MAGIC *mg)
1617 {
1618     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1619
1620     if (uf && uf->uf_set)
1621         (*uf->uf_set)(uf->uf_index, sv);
1622     return 0;
1623 }
1624
1625 int
1626 magic_freeregexp(SV *sv, MAGIC *mg)
1627 {
1628     regexp *re = (regexp *)mg->mg_obj;
1629     ReREFCNT_dec(re);
1630     return 0;
1631 }
1632
1633 #ifdef USE_LOCALE_COLLATE
1634 int
1635 magic_setcollxfrm(SV *sv, MAGIC *mg)
1636 {
1637     /*
1638      * RenE<eacute> Descartes said "I think not."
1639      * and vanished with a faint plop.
1640      */
1641     if (mg->mg_ptr) {
1642         Safefree(mg->mg_ptr);
1643         mg->mg_ptr = NULL;
1644         mg->mg_len = -1;
1645     }
1646     return 0;
1647 }
1648 #endif /* USE_LOCALE_COLLATE */
1649
1650 int
1651 magic_set(SV *sv, MAGIC *mg)
1652 {
1653     dTHR;
1654     register char *s;
1655     I32 i;
1656     STRLEN len;
1657     switch (*mg->mg_ptr) {
1658     case '\001':        /* ^A */
1659         sv_setsv(PL_bodytarget, sv);
1660         break;
1661     case '\002':        /* ^B */
1662         if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1663             if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize))
1664                 PL_compiling.cop_warnings = WARN_ALL;
1665             else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize))
1666                 PL_compiling.cop_warnings = WARN_NONE;
1667             else {
1668                 if (PL_compiling.cop_warnings != WARN_NONE && 
1669                     PL_compiling.cop_warnings != WARN_ALL)
1670                     sv_setsv(PL_compiling.cop_warnings, sv);
1671                 else
1672                     PL_compiling.cop_warnings = newSVsv(sv) ;
1673             }
1674         }
1675         break;
1676
1677     case '\003':        /* ^C */
1678         PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1679         break;
1680
1681     case '\004':        /* ^D */
1682         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
1683         DEBUG_x(dump_all());
1684         break;
1685     case '\005':  /* ^E */
1686 #ifdef VMS
1687         set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1688 #else
1689 #ifdef WIN32
1690         SetLastError( SvIV(sv) );
1691 #else
1692         /* will anyone ever use this? */
1693         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
1694 #endif
1695 #endif
1696         break;
1697     case '\006':        /* ^F */
1698         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1699         break;
1700     case '\010':        /* ^H */
1701         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1702         break;
1703     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
1704         if (PL_inplace)
1705             Safefree(PL_inplace);
1706         if (SvOK(sv))
1707             PL_inplace = savepv(SvPV(sv,len));
1708         else
1709             PL_inplace = Nullch;
1710         break;
1711     case '\017':        /* ^O */
1712         if (PL_osname)
1713             Safefree(PL_osname);
1714         if (SvOK(sv))
1715             PL_osname = savepv(SvPV(sv,len));
1716         else
1717             PL_osname = Nullch;
1718         break;
1719     case '\020':        /* ^P */
1720         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1721         break;
1722     case '\024':        /* ^T */
1723 #ifdef BIG_TIME
1724         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
1725 #else
1726         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1727 #endif
1728         break;
1729     case '\027':        /* ^W */
1730         if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1731             i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1732             PL_dowarn = (i ? G_WARN_ON : G_WARN_OFF) ;
1733         }
1734         break;
1735     case '.':
1736         if (PL_localizing) {
1737             if (PL_localizing == 1)
1738                 save_sptr((SV**)&PL_last_in_gv);
1739         }
1740         else if (SvOK(sv) && GvIO(PL_last_in_gv))
1741             IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv);
1742         break;
1743     case '^':
1744         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
1745         IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
1746         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1747         break;
1748     case '~':
1749         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
1750         IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
1751         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1752         break;
1753     case '=':
1754         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1755         break;
1756     case '-':
1757         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1758         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
1759             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
1760         break;
1761     case '%':
1762         IoPAGE(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1763         break;
1764     case '|':
1765         {
1766             IO *io = GvIOp(PL_defoutgv);
1767             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
1768                 IoFLAGS(io) &= ~IOf_FLUSH;
1769             else {
1770                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
1771                     PerlIO *ofp = IoOFP(io);
1772                     if (ofp)
1773                         (void)PerlIO_flush(ofp);
1774                     IoFLAGS(io) |= IOf_FLUSH;
1775                 }
1776             }
1777         }
1778         break;
1779     case '*':
1780         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1781         PL_multiline = (i != 0);
1782         break;
1783     case '/':
1784         SvREFCNT_dec(PL_nrs);
1785         PL_nrs = newSVsv(sv);
1786         SvREFCNT_dec(PL_rs);
1787         PL_rs = SvREFCNT_inc(PL_nrs);
1788         break;
1789     case '\\':
1790         if (PL_ors)
1791             Safefree(PL_ors);
1792         if (SvOK(sv) || SvGMAGICAL(sv))
1793             PL_ors = savepv(SvPV(sv,PL_orslen));
1794         else {
1795             PL_ors = Nullch;
1796             PL_orslen = 0;
1797         }
1798         break;
1799     case ',':
1800         if (PL_ofs)
1801             Safefree(PL_ofs);
1802         PL_ofs = savepv(SvPV(sv, PL_ofslen));
1803         break;
1804     case '#':
1805         if (PL_ofmt)
1806             Safefree(PL_ofmt);
1807         PL_ofmt = savepv(SvPV(sv,len));
1808         break;
1809     case '[':
1810         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1811         break;
1812     case '?':
1813 #ifdef COMPLEX_STATUS
1814         if (PL_localizing == 2) {
1815             PL_statusvalue = LvTARGOFF(sv);
1816             PL_statusvalue_vms = LvTARGLEN(sv);
1817         }
1818         else
1819 #endif
1820 #ifdef VMSISH_STATUS
1821         if (VMSISH_STATUS)
1822             STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
1823         else
1824 #endif
1825             STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1826         break;
1827     case '!':
1828         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
1829                  (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
1830         break;
1831     case '<':
1832         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1833         if (PL_delaymagic) {
1834             PL_delaymagic |= DM_RUID;
1835             break;                              /* don't do magic till later */
1836         }
1837 #ifdef HAS_SETRUID
1838         (void)setruid((Uid_t)PL_uid);
1839 #else
1840 #ifdef HAS_SETREUID
1841         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
1842 #else
1843 #ifdef HAS_SETRESUID
1844       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
1845 #else
1846         if (PL_uid == PL_euid)          /* special case $< = $> */
1847             (void)PerlProc_setuid(PL_uid);
1848         else {
1849             PL_uid = (I32)PerlProc_getuid();
1850             croak("setruid() not implemented");
1851         }
1852 #endif
1853 #endif
1854 #endif
1855         PL_uid = (I32)PerlProc_getuid();
1856         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1857         break;
1858     case '>':
1859         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1860         if (PL_delaymagic) {
1861             PL_delaymagic |= DM_EUID;
1862             break;                              /* don't do magic till later */
1863         }
1864 #ifdef HAS_SETEUID
1865         (void)seteuid((Uid_t)PL_euid);
1866 #else
1867 #ifdef HAS_SETREUID
1868         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
1869 #else
1870 #ifdef HAS_SETRESUID
1871         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
1872 #else
1873         if (PL_euid == PL_uid)          /* special case $> = $< */
1874             PerlProc_setuid(PL_euid);
1875         else {
1876             PL_euid = (I32)PerlProc_geteuid();
1877             croak("seteuid() not implemented");
1878         }
1879 #endif
1880 #endif
1881 #endif
1882         PL_euid = (I32)PerlProc_geteuid();
1883         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1884         break;
1885     case '(':
1886         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1887         if (PL_delaymagic) {
1888             PL_delaymagic |= DM_RGID;
1889             break;                              /* don't do magic till later */
1890         }
1891 #ifdef HAS_SETRGID
1892         (void)setrgid((Gid_t)PL_gid);
1893 #else
1894 #ifdef HAS_SETREGID
1895         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
1896 #else
1897 #ifdef HAS_SETRESGID
1898       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
1899 #else
1900         if (PL_gid == PL_egid)                  /* special case $( = $) */
1901             (void)PerlProc_setgid(PL_gid);
1902         else {
1903             PL_gid = (I32)PerlProc_getgid();
1904             croak("setrgid() not implemented");
1905         }
1906 #endif
1907 #endif
1908 #endif
1909         PL_gid = (I32)PerlProc_getgid();
1910         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1911         break;
1912     case ')':
1913 #ifdef HAS_SETGROUPS
1914         {
1915             char *p = SvPV(sv, len);
1916             Groups_t gary[NGROUPS];
1917
1918             SET_NUMERIC_STANDARD();
1919             while (isSPACE(*p))
1920                 ++p;
1921             PL_egid = I_V(atof(p));
1922             for (i = 0; i < NGROUPS; ++i) {
1923                 while (*p && !isSPACE(*p))
1924                     ++p;
1925                 while (isSPACE(*p))
1926                     ++p;
1927                 if (!*p)
1928                     break;
1929                 gary[i] = I_V(atof(p));
1930             }
1931             if (i)
1932                 (void)setgroups(i, gary);
1933         }
1934 #else  /* HAS_SETGROUPS */
1935         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1936 #endif /* HAS_SETGROUPS */
1937         if (PL_delaymagic) {
1938             PL_delaymagic |= DM_EGID;
1939             break;                              /* don't do magic till later */
1940         }
1941 #ifdef HAS_SETEGID
1942         (void)setegid((Gid_t)PL_egid);
1943 #else
1944 #ifdef HAS_SETREGID
1945         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
1946 #else
1947 #ifdef HAS_SETRESGID
1948         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
1949 #else
1950         if (PL_egid == PL_gid)                  /* special case $) = $( */
1951             (void)PerlProc_setgid(PL_egid);
1952         else {
1953             PL_egid = (I32)PerlProc_getegid();
1954             croak("setegid() not implemented");
1955         }
1956 #endif
1957 #endif
1958 #endif
1959         PL_egid = (I32)PerlProc_getegid();
1960         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1961         break;
1962     case ':':
1963         PL_chopset = SvPV_force(sv,len);
1964         break;
1965     case '0':
1966         if (!PL_origalen) {
1967             s = PL_origargv[0];
1968             s += strlen(s);
1969             /* See if all the arguments are contiguous in memory */
1970             for (i = 1; i < PL_origargc; i++) {
1971                 if (PL_origargv[i] == s + 1
1972 #ifdef OS2
1973                     || PL_origargv[i] == s + 2
1974 #endif 
1975                    )
1976                 {
1977                     ++s;
1978                     s += strlen(s);     /* this one is ok too */
1979                 }
1980                 else
1981                     break;
1982             }
1983             /* can grab env area too? */
1984             if (PL_origenviron && (PL_origenviron[0] == s + 1
1985 #ifdef OS2
1986                                 || (PL_origenviron[0] == s + 9 && (s += 8))
1987 #endif 
1988                )) {
1989                 my_setenv("NoNe  SuCh", Nullch);
1990                                             /* force copy of environment */
1991                 for (i = 0; PL_origenviron[i]; i++)
1992                     if (PL_origenviron[i] == s + 1) {
1993                         ++s;
1994                         s += strlen(s);
1995                     }
1996                     else
1997                         break;
1998             }
1999             PL_origalen = s - PL_origargv[0];
2000         }
2001         s = SvPV_force(sv,len);
2002         i = len;
2003         if (i >= PL_origalen) {
2004             i = PL_origalen;
2005             /* don't allow system to limit $0 seen by script */
2006             /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
2007             Copy(s, PL_origargv[0], i, char);
2008             s = PL_origargv[0]+i;
2009             *s = '\0';
2010         }
2011         else {
2012             Copy(s, PL_origargv[0], i, char);
2013             s = PL_origargv[0]+i;
2014             *s++ = '\0';
2015             while (++i < PL_origalen)
2016                 *s++ = ' ';
2017             s = PL_origargv[0]+i;
2018             for (i = 1; i < PL_origargc; i++)
2019                 PL_origargv[i] = Nullch;
2020         }
2021         break;
2022 #ifdef USE_THREADS
2023     case '@':
2024         sv_setsv(thr->errsv, sv);
2025         break;
2026 #endif /* USE_THREADS */
2027     }
2028     return 0;
2029 }
2030
2031 #ifdef USE_THREADS
2032 int
2033 magic_mutexfree(SV *sv, MAGIC *mg)
2034 {
2035     dTHR;
2036     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n",
2037                           (unsigned long)thr, (unsigned long)sv);)
2038     if (MgOWNER(mg))
2039         croak("panic: magic_mutexfree");
2040     MUTEX_DESTROY(MgMUTEXP(mg));
2041     COND_DESTROY(MgCONDP(mg));
2042     return 0;
2043 }
2044 #endif /* USE_THREADS */
2045
2046 I32
2047 whichsig(char *sig)
2048 {
2049     register char **sigv;
2050
2051     for (sigv = PL_sig_name+1; *sigv; sigv++)
2052         if (strEQ(sig,*sigv))
2053             return PL_sig_num[sigv - PL_sig_name];
2054 #ifdef SIGCLD
2055     if (strEQ(sig,"CHLD"))
2056         return SIGCLD;
2057 #endif
2058 #ifdef SIGCHLD
2059     if (strEQ(sig,"CLD"))
2060         return SIGCHLD;
2061 #endif
2062     return 0;
2063 }
2064
2065 static SV* sig_sv;
2066
2067 STATIC void
2068 unwind_handler_stack(void *p)
2069 {
2070     dTHR;
2071     U32 flags = *(U32*)p;
2072
2073     if (flags & 1)
2074         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2075     /* cxstack_ix-- Not needed, die already unwound it. */
2076     if (flags & 64)
2077         SvREFCNT_dec(sig_sv);
2078 }
2079
2080 Signal_t
2081 sighandler(int sig)
2082 {
2083     dSP;
2084     GV *gv = Nullgv;
2085     HV *st;
2086     SV *sv, *tSv = PL_Sv;
2087     CV *cv = Nullcv;
2088     OP *myop = PL_op;
2089     U32 flags = 0;
2090     I32 o_save_i = PL_savestack_ix, type;
2091     XPV *tXpv = PL_Xpv;
2092     
2093     if (PL_savestack_ix + 15 <= PL_savestack_max)
2094         flags |= 1;
2095     if (PL_markstack_ptr < PL_markstack_max - 2)
2096         flags |= 4;
2097     if (PL_retstack_ix < PL_retstack_max - 2)
2098         flags |= 8;
2099     if (PL_scopestack_ix < PL_scopestack_max - 3)
2100         flags |= 16;
2101
2102     if (!PL_psig_ptr[sig])
2103         die("Signal SIG%s received, but no signal handler set.\n",
2104             PL_sig_name[sig]);
2105
2106     /* Max number of items pushed there is 3*n or 4. We cannot fix
2107        infinity, so we fix 4 (in fact 5): */
2108     if (flags & 1) {
2109         PL_savestack_ix += 5;           /* Protect save in progress. */
2110         o_save_i = PL_savestack_ix;
2111         SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags);
2112     }
2113     if (flags & 4) 
2114         PL_markstack_ptr++;             /* Protect mark. */
2115     if (flags & 8) {
2116         PL_retstack_ix++;
2117         PL_retstack[PL_retstack_ix] = NULL;
2118     }
2119     if (flags & 16)
2120         PL_scopestack_ix += 1;
2121     /* sv_2cv is too complicated, try a simpler variant first: */
2122     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) 
2123         || SvTYPE(cv) != SVt_PVCV)
2124         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2125
2126     if (!cv || !CvROOT(cv)) {
2127         if (ckWARN(WARN_SIGNAL))
2128             warner(WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n",
2129                 PL_sig_name[sig], (gv ? GvENAME(gv)
2130                                 : ((cv && CvGV(cv))
2131                                    ? GvENAME(CvGV(cv))
2132                                    : "__ANON__")));
2133         goto cleanup;
2134     }
2135
2136     if(PL_psig_name[sig]) {
2137         sv = SvREFCNT_inc(PL_psig_name[sig]);
2138         flags |= 64;
2139         sig_sv = sv;
2140     } else {
2141         sv = sv_newmortal();
2142         sv_setpv(sv,PL_sig_name[sig]);
2143     }
2144
2145     PUSHSTACKi(PERLSI_SIGNAL);
2146     PUSHMARK(SP);
2147     PUSHs(sv);
2148     PUTBACK;
2149
2150     perl_call_sv((SV*)cv, G_DISCARD);
2151
2152     POPSTACK;
2153 cleanup:
2154     if (flags & 1)
2155         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2156     if (flags & 4) 
2157         PL_markstack_ptr--;
2158     if (flags & 8) 
2159         PL_retstack_ix--;
2160     if (flags & 16)
2161         PL_scopestack_ix -= 1;
2162     if (flags & 64)
2163         SvREFCNT_dec(sv);
2164     PL_op = myop;                       /* Apparently not needed... */
2165     
2166     PL_Sv = tSv;                        /* Restore global temporaries. */
2167     PL_Xpv = tXpv;
2168     return;
2169 }
2170
2171