/* gv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
- * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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.
static const char S_autoload[] = "AUTOLOAD";
static const STRLEN S_autolen = sizeof(S_autoload)-1;
-
-#ifdef PERL_DONT_CREATE_GVSV
-GV *
-Perl_gv_SVadd(pTHX_ GV *gv)
-{
- PERL_ARGS_ASSERT_GV_SVADD;
-
- if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV)
- Perl_croak(aTHX_ "Bad symbol for scalar");
- if (!GvSV(gv))
- GvSV(gv) = newSV(0);
- return gv;
-}
-#endif
-
-GV *
-Perl_gv_AVadd(pTHX_ register GV *gv)
-{
- PERL_ARGS_ASSERT_GV_AVADD;
-
- if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV)
- Perl_croak(aTHX_ "Bad symbol for array");
- if (!GvAV(gv))
- GvAV(gv) = newAV();
- return gv;
-}
-
-GV *
-Perl_gv_HVadd(pTHX_ register GV *gv)
-{
- PERL_ARGS_ASSERT_GV_HVADD;
-
- if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV)
- Perl_croak(aTHX_ "Bad symbol for hash");
- if (!GvHV(gv))
- GvHV(gv) = newHV();
- return gv;
-}
-
GV *
-Perl_gv_IOadd(pTHX_ register GV *gv)
+Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
{
- dVAR;
-
- PERL_ARGS_ASSERT_GV_IOADD;
+ SV **where;
if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) {
-
- /*
- * if it walks like a dirhandle, then let's assume that
- * this is a dirhandle.
- */
- const char * const fh =
- PL_op->op_type == OP_READDIR ||
- PL_op->op_type == OP_TELLDIR ||
- PL_op->op_type == OP_SEEKDIR ||
- PL_op->op_type == OP_REWINDDIR ||
- PL_op->op_type == OP_CLOSEDIR ?
- "dirhandle" : "filehandle";
- Perl_croak(aTHX_ "Bad symbol for %s", fh);
+ const char *what;
+ if (type == SVt_PVIO) {
+ /*
+ * if it walks like a dirhandle, then let's assume that
+ * this is a dirhandle.
+ */
+ what = PL_op->op_type == OP_READDIR ||
+ PL_op->op_type == OP_TELLDIR ||
+ PL_op->op_type == OP_SEEKDIR ||
+ PL_op->op_type == OP_REWINDDIR ||
+ PL_op->op_type == OP_CLOSEDIR ?
+ "dirhandle" : "filehandle";
+ /* diag_listed_as: Bad symbol for filehandle */
+ } else if (type == SVt_PVHV) {
+ what = "hash";
+ } else {
+ what = type == SVt_PVAV ? "array" : "scalar";
+ }
+ Perl_croak(aTHX_ "Bad symbol for %s", what);
}
- if (!GvIOp(gv)) {
-#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE(gv)) {
- Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
- }
-#endif
- GvIOp(gv) = newIO();
+ if (type == SVt_PVHV) {
+ where = (SV **)&GvHV(gv);
+ } else if (type == SVt_PVAV) {
+ where = (SV **)&GvAV(gv);
+ } else if (type == SVt_PVIO) {
+ where = (SV **)&GvIOp(gv);
+ } else {
+ where = &GvSV(gv);
}
+
+ if (!*where)
+ *where = newSV_type(type);
return gv;
}
char *tmpbuf;
HV *stash;
GV *tmpgv;
+ U32 tmplen = namelen + 2;
PERL_ARGS_ASSERT_GV_STASHPVN;
- if (namelen + 2 <= sizeof smallbuf)
+ if (tmplen <= sizeof smallbuf)
tmpbuf = smallbuf;
else
- Newx(tmpbuf, namelen + 2, char);
- Copy(name,tmpbuf,namelen,char);
- tmpbuf[namelen++] = ':';
- tmpbuf[namelen++] = ':';
- tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, flags, SVt_PVHV);
+ Newx(tmpbuf, tmplen, char);
+ Copy(name, tmpbuf, namelen, char);
+ tmpbuf[namelen] = ':';
+ tmpbuf[namelen+1] = ':';
+ tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
if (!tmpgv)
(sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
(sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
{
+ /* diag_listed_as: Variable "%s" is not imported%s */
Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
sv_type == SVt_PVAV ? '@' :
sv_type == SVt_PVHV ? '%' : '$',
if (strEQ(name2, "IG")) {
HV *hv;
I32 i;
- if (!PL_psig_ptr) {
- Newxz(PL_psig_ptr, SIG_SIZE, SV*);
- Newxz(PL_psig_name, SIG_SIZE, SV*);
+ if (!PL_psig_name) {
+ Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
Newxz(PL_psig_pend, SIG_SIZE, int);
+ PL_psig_ptr = PL_psig_name + SIG_SIZE;
+ } else {
+ /* I think that the only way to get here is to re-use an
+ embedded perl interpreter, where the previous
+ use didn't clean up fully because
+ PL_perl_destruct_level was 0. I'm not sure that we
+ "support" that, in that I suspect in that scenario
+ there are sufficient other garbage values left in the
+ interpreter structure that something else will crash
+ before we get here. I suspect that this is one of
+ those "doctor, it hurts when I do this" bugs. */
+ Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
+ Zero(PL_psig_pend, SIG_SIZE, int);
}
GvMULTI_on(gv);
hv = GvHVn(gv);
SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
if (init)
sv_setsv(*init, &PL_sv_undef);
- PL_psig_ptr[i] = 0;
- PL_psig_name[i] = 0;
- PL_psig_pend[i] = 0;
}
}
break;
ro_magicalize:
SvREADONLY_on(GvSVn(gv));
/* FALL THROUGH */
+ case '0':
case '1':
case '2':
case '3':
gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
}
-IO *
-Perl_newIO(pTHX)
-{
- dVAR;
- GV *iogv;
- IO * const io = MUTABLE_IO(newSV_type(SVt_PVIO));
- /* This used to read SvREFCNT(io) = 1;
- It's not clear why the reference count needed an explicit reset. NWC
- */
- assert (SvREFCNT(io) == 1);
- SvOBJECT_on(io);
- /* Clear the stashcache because a new IO could overrule a package name */
- hv_clear(PL_stashcache);
- iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
- /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
- if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
- iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
- SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
- return io;
-}
-
void
Perl_gv_check(pTHX_ const HV *stash)
{
}
/* Updates and caches the CV's */
+/* Returns:
+ * 1 on success and there is some overload
+ * 0 if there is no overload
+ * -1 if some error occurred and it couldn't croak
+ */
-bool
-Perl_Gv_AMupdate(pTHX_ HV *stash)
+int
+Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
{
dVAR;
MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
const AMT * const amtp = (AMT*)mg->mg_ptr;
if (amtp->was_ok_am == PL_amagic_generation
&& amtp->was_ok_sub == newgen) {
- return (bool)AMT_OVERLOADED(amtp);
+ return AMT_OVERLOADED(amtp) ? 1 : 0;
}
sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
}
FALSE)))
{
/* Can be an import stub (created by "can"). */
- const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
- Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
- "in package \"%.256s\"",
- (GvCVGEN(gv) ? "Stub found while resolving"
- : "Can't resolve"),
- name, cp, hvname);
+ if (destructing) {
+ return -1;
+ }
+ else {
+ const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
+ Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
+ "in package \"%.256s\"",
+ (GvCVGEN(gv) ? "Stub found while resolving"
+ : "Can't resolve"),
+ name, cp, hvname);
+ }
}
cv = GvCV(gv = ngv);
}
AMT_AMAGIC_off(&amt);
sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
(char*)&amt, sizeof(AMTS));
- return FALSE;
+ return 0;
}
mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
if (!mg) {
do_update:
- Gv_AMupdate(stash);
+ /* If we're looking up a destructor to invoke, we must avoid
+ * that Gv_AMupdate croaks, because we might be dying already */
+ if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) {
+ /* and if it didn't found a destructor, we fall back
+ * to a simpler method that will only look for the
+ * destructor instead of the whole magic */
+ if (id == DESTROY_amg) {
+ GV * const gv = gv_fetchmethod(stash, "DESTROY");
+ if (gv)
+ return GvCV(gv);
+ }
+ return NULL;
+ }
mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
}
assert(mg);
PERL_ARGS_ASSERT_AMAGIC_CALL;
+ if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
+ SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
+ 0, "overloading", 11, 0, 0);
+
+ if ( !lex_mask || !SvOK(lex_mask) )
+ /* overloading lexically disabled */
+ return NULL;
+ else if ( lex_mask && SvPOK(lex_mask) ) {
+ /* we have an entry in the hints hash, check if method has been
+ * masked by overloading.pm */
+ STRLEN len;
+ const int offset = method / 8;
+ const int bit = method % 8;
+ char *pv = SvPV(lex_mask, len);
+
+ /* Bit set, so this overloading operator is disabled */
+ if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
+ return NULL;
+ }
+ }
+
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
&& (stash = SvSTASH(SvRV(left)))
&& (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
break;
case int_amg:
case iter_amg: /* XXXX Eventually should do to_gv. */
+ case ftest_amg: /* XXXX Eventually should do to_gv. */
/* FAIL safe */
return NULL; /* Delegate operation to standard mechanisms. */
break;
/*
=for apidoc is_gv_magical_sv
-Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
-
-=cut
-*/
-
-bool
-Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
-{
- STRLEN len;
- const char * const temp = SvPV_const(name, len);
-
- PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
-
- return is_gv_magical(temp, len, flags);
-}
-
-/*
-=for apidoc is_gv_magical
-
Returns C<TRUE> if given the name of a magical GV.
Currently only useful internally when determining if a GV should be
=cut
*/
+
bool
-Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
+Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
{
- PERL_UNUSED_CONTEXT;
- PERL_UNUSED_ARG(flags);
+ STRLEN len;
+ const char *const name = SvPV_const(name_sv, len);
- PERL_ARGS_ASSERT_IS_GV_MAGICAL;
+ PERL_UNUSED_ARG(flags);
+ PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
if (len > 1) {
const char * const name1 = name + 1;