X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/731e259481f36b35d27c7bcbf1cb5cbfc834ed90..65980d9413eea8415cdea4a9a608257b175e4fb6:/mg.c diff --git a/mg.c b/mg.c index d98a6d5..c24bf6d 100644 --- a/mg.c +++ b/mg.c @@ -1,7 +1,7 @@ /* mg.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -15,6 +15,24 @@ /* =head1 Magical Functions + +"Magic" is special data attached to SV structures in order to give them +"magical" properties. When any Perl code tries to read from, or assign to, +an SV marked as magical, it calls the 'get' or 'set' function associated +with that SV's magic. A get is called prior to reading an SV, in order to +give it a chance to update its internal value (get on $. writes the line +number of the last read filehandle into to the SV's IV slot), while +set is called after an SV has been written to, in order to allow it to make +use of its changed value (set on $/ copies the SV's new value to the +PL_rs global variable). + +Magic is implemented as a linked list of MAGIC structures attached to the +SV. Each MAGIC struct holds the type of the magic, a pointer to an array +of functions that implement the get(), set(), length() etc functions, +plus space for some flags and pointers. For example, a tied variable has +a MAGIC structure that contains a pointer to the object associated with the +tie. + */ #include "EXTERN.h" @@ -129,6 +147,18 @@ Perl_mg_get(pTHX_ SV *sv) int new = 0; MAGIC *newmg, *head, *cur, *mg; I32 mgs_ix = SSNEW(sizeof(MGS)); + int was_temp = SvTEMP(sv); + /* guard against sv having being freed midway by holding a private + reference. */ + + /* sv_2mortal has this side effect of turning on the TEMP flag, which can + cause the SV's buffer to get stolen (and maybe other stuff). + So restore it. + */ + sv_2mortal(SvREFCNT_inc(sv)); + if (!was_temp) { + SvTEMP_off(sv); + } save_magic(mgs_ix, sv); @@ -143,10 +173,6 @@ Perl_mg_get(pTHX_ SV *sv) if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg); - /* guard against sv having been freed */ - if (SvTYPE(sv) == SVTYPEMASK) { - Perl_croak(aTHX_ "Tied variable freed while still in use"); - } /* guard against magic having been deleted - eg FETCH calling * untie */ if (!SvMAGIC(sv)) @@ -178,6 +204,12 @@ Perl_mg_get(pTHX_ SV *sv) } restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix)); + + if (SvREFCNT(sv) == 1) { + /* We hold the last reference to this SV, which implies that the + SV was deleted as a side effect of the routines we called. */ + SvOK_off(sv); + } return 0; } @@ -491,12 +523,12 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) } else { if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(); + report_uninit(sv); } } else { if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(); + report_uninit(sv); } return 0; case '+': @@ -566,9 +598,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\004': /* ^D */ sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK)); -#if defined(YYDEBUG) && defined(DEBUGGING) - PL_yydebug = DEBUG_p_TEST; -#endif break; case '\005': /* ^E */ if (*(mg->mg_ptr+1) == '\0') { @@ -648,8 +677,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setsv(sv, &PL_sv_undef); break; case '\017': /* ^O & ^OPEN */ - if (*(mg->mg_ptr+1) == '\0') + if (*(mg->mg_ptr+1) == '\0') { sv_setpv(sv, PL_osname); + SvTAINTED_off(sv); + } else if (strEQ(mg->mg_ptr, "\017PEN")) { if (!PL_compiling.cop_io) sv_setsv(sv, &PL_sv_undef); @@ -664,7 +695,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\023': /* ^S */ if (*(mg->mg_ptr+1) == '\0') { if (PL_lex_state != LEX_NOTPARSING) - (void)SvOK_off(sv); + SvOK_off(sv); else if (PL_in_eval) sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); else @@ -684,9 +715,11 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) ? (PL_taint_warn || PL_unsafe ? -1 : 1) : 0); break; - case '\025': /* $^UNICODE */ + case '\025': /* $^UNICODE, $^UTF8LOCALE */ if (strEQ(mg->mg_ptr, "\025NICODE")) sv_setuv(sv, (UV) PL_unicode); + else if (strEQ(mg->mg_ptr, "\025TF8LOCALE")) + sv_setuv(sv, (UV) PL_utf8locale); break; case '\027': /* ^W & $^WARNING_BITS */ if (*(mg->mg_ptr+1) == '\0') @@ -1051,6 +1084,7 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) # endif { # ifndef PERL_USE_SAFE_PUTENV + if (!PL_use_safe_putenv) { I32 i; if (environ == PL_origenviron) @@ -1058,6 +1092,7 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) else for (i = 0; environ[i]; i++) safesysfree(environ[i]); + } # endif /* PERL_USE_SAFE_PUTENV */ environ[0] = Nullch; @@ -1657,7 +1692,7 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) return 0; } } - (void)SvOK_off(sv); + SvOK_off(sv); return 0; } @@ -1729,16 +1764,11 @@ Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg) { - register char *s; GV* gv; - STRLEN n_a; - + if (!SvOK(sv)) return 0; - s = SvPV(sv, n_a); - if (*s == '*' && s[1]) - s++; - gv = gv_fetchpv(s,TRUE, SVt_PVGV); + gv = gv_fetchsv(sv,TRUE, SVt_PVGV); if (sv == (SV*)gv) return 0; if (GvGP(sv)) @@ -1781,16 +1811,21 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) sv_utf8_upgrade(lsv); sv_pos_u2b(lsv, &lvoff, &lvlen); sv_insert(lsv, lvoff, lvlen, tmps, len); + LvTARGLEN(sv) = sv_len_utf8(sv); SvUTF8_on(lsv); } else if (lsv && SvUTF8(lsv)) { sv_pos_u2b(lsv, &lvoff, &lvlen); + LvTARGLEN(sv) = len; tmps = (char*)bytes_to_utf8((U8*)tmps, &len); sv_insert(lsv, lvoff, lvlen, tmps, len); Safefree(tmps); } - else - sv_insert(lsv, lvoff, lvlen, tmps, len); + else { + sv_insert(lsv, lvoff, lvlen, tmps, len); + LvTARGLEN(sv) = len; + } + return 0; } @@ -1825,7 +1860,7 @@ Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) SV *lsv = LvTARG(sv); if (!lsv) { - (void)SvOK_off(sv); + SvOK_off(sv); return 0; } @@ -1927,14 +1962,14 @@ Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) SV **svp = AvARRAY(av); I32 i = AvFILLp(av); while (i >= 0) { - if (svp[i] && svp[i] != &PL_sv_undef) { + if (svp[i]) { if (!SvWEAKREF(svp[i])) Perl_croak(aTHX_ "panic: magic_killbackrefs"); /* XXX Should we check that it hasn't changed? */ SvRV(svp[i]) = 0; - (void)SvOK_off(svp[i]); + SvOK_off(svp[i]); SvWEAKREF_off(svp[i]); - svp[i] = &PL_sv_undef; + svp[i] = Nullsv; } i--; } @@ -2035,7 +2070,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) case '\004': /* ^D */ #ifdef DEBUGGING s = SvPV_nolen(sv); - PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG; + PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG; DEBUG_x(dump_all()); #else PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG; @@ -2083,18 +2118,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (PL_inplace) Safefree(PL_inplace); if (SvOK(sv)) - PL_inplace = savepv(SvPV(sv,len)); + PL_inplace = savesvpv(sv); else PL_inplace = Nullch; break; case '\017': /* ^O */ if (*(mg->mg_ptr+1) == '\0') { - if (PL_osname) + if (PL_osname) { Safefree(PL_osname); - if (SvOK(sv)) - PL_osname = savepv(SvPV(sv,len)); - else PL_osname = Nullch; + } + if (SvOK(sv)) { + TAINT_PROPER("assigning to $^O"); + PL_osname = savesvpv(sv); + } } else if (strEQ(mg->mg_ptr, "\017PEN")) { if (!PL_compiling.cop_io) @@ -2169,13 +2206,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '^': Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); - IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len)); - IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); + IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savesvpv(sv); + IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO); break; case '~': Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); - IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len)); - IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); + IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savesvpv(sv); + IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO); break; case '=': IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); @@ -2232,7 +2269,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) case '#': if (PL_ofmt) Safefree(PL_ofmt); - PL_ofmt = savepv(SvPV(sv,len)); + PL_ofmt = savesvpv(sv); break; case '[': PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -2509,8 +2546,6 @@ Perl_sighandler(int sig) flags |= 1; if (PL_markstack_ptr < PL_markstack_max - 2) flags |= 4; - if (PL_retstack_ix < PL_retstack_max - 2) - flags |= 8; if (PL_scopestack_ix < PL_scopestack_max - 3) flags |= 16; @@ -2528,10 +2563,6 @@ Perl_sighandler(int sig) } if (flags & 4) PL_markstack_ptr++; /* Protect mark. */ - if (flags & 8) { - PL_retstack_ix++; - PL_retstack[PL_retstack_ix] = NULL; - } if (flags & 16) PL_scopestack_ix += 1; /* sv_2cv is too complicated, try a simpler variant first: */ @@ -2585,15 +2616,13 @@ Perl_sighandler(int sig) (void)rsignal(sig, PL_csighandlerp); #endif #endif /* !PERL_MICRO */ - Perl_die(aTHX_ Nullformat); + DieNull; } cleanup: if (flags & 1) PL_savestack_ix -= 8; /* Unprotect save in progress. */ if (flags & 4) PL_markstack_ptr--; - if (flags & 8) - PL_retstack_ix--; if (flags & 16) PL_scopestack_ix -= 1; if (flags & 64)