source: trunk/third/perl/mg.c @ 14545

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