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

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