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

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