/* mg.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 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.
/*
=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"
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. It's not possible to make this sv mortal without failing
- several tests -
- looks like it's important that it can get DESTROYed before the next
- FREETMPS
- Also it's not possible to wrap this function in a SAVETMPS/FREETMPS
- pair. We need drop our reference if croak() is called, but we also
- can't simply make it mortal and wait for the next FREETMPS, because
- other tests rely on the sv being freed earlier. Hence this hack.
- We create an extra reference on the caller's sv, owned by the rv,
- which is mortal. If croak is called the RV cleans up for us.
- If we reach the end of the function we change it to point at
- PL_sv_undef, and clean up manually. */
- SV *temp_rv = sv_2mortal(newRV_inc(sv));
-
+ 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);
/* We must call svt_get(sv, mg) for each valid entry in the linked
}
restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
- SvRV(temp_rv) = &PL_sv_undef;
- SvREFCNT_dec(sv);
+
+ 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;
}
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
? (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')
# endif
{
# ifndef PERL_USE_SAFE_PUTENV
+ if (!PL_use_safe_putenv) {
I32 i;
if (environ == PL_origenviron)
else
for (i = 0; environ[i]; i++)
safesysfree(environ[i]);
+ }
# endif /* PERL_USE_SAFE_PUTENV */
environ[0] = Nullch;
return 0;
}
}
- (void)SvOK_off(sv);
+ SvOK_off(sv);
return 0;
}
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))
SV *lsv = LvTARG(sv);
if (!lsv) {
- (void)SvOK_off(sv);
+ SvOK_off(sv);
return 0;
}
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] = Nullsv;
}
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;
if (PL_inplace)
Safefree(PL_inplace);
if (SvOK(sv))
- PL_inplace = savepv(SvPV(sv,len));
+ PL_inplace = savesvpv(sv);
else
PL_inplace = Nullch;
break;
}
if (SvOK(sv)) {
TAINT_PROPER("assigning to $^O");
- PL_osname = savepv(SvPV(sv,len));
+ PL_osname = savesvpv(sv);
}
}
else if (strEQ(mg->mg_ptr, "\017PEN")) {
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));
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);
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;
}
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: */
(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)