X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/242f8760e6ec383f070c854a602d038abeaf355a..e0ee75a6976f08f9bc3868227f1cd11ab6507895:/gv.c diff --git a/gv.c b/gv.c index ca8e7a7..3df4e27 100644 --- a/gv.c +++ b/gv.c @@ -40,72 +40,45 @@ Perl stores its global variables. 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"; - /* diag_listed_as: Bad symbol for 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)) { - 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; } @@ -882,17 +855,18 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) 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) @@ -1503,27 +1477,6 @@ Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain 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) { @@ -1664,8 +1617,13 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) } /* 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 +int Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) { dVAR; @@ -1681,7 +1639,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) 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); } @@ -1758,7 +1716,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) { /* Can be an import stub (created by "can"). */ if (destructing) { - return FALSE; + return -1; } else { const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???"; @@ -1797,7 +1755,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) AMT_AMAGIC_off(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMTS)); - return FALSE; + return 0; } @@ -1821,7 +1779,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) do_update: /* 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)) { + 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 */