X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/979f29225180f8c09f4adec52f850ae45694fd81..878305029f3dfbd9e56219891ad218e5edbb3c02:/universal.c diff --git a/universal.c b/universal.c index 10dddb5..8802cb2 100644 --- a/universal.c +++ b/universal.c @@ -1,7 +1,7 @@ /* universal.c * * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, - * 2005, by Larry Wall and others + * 2005, 2006, 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. @@ -31,35 +31,36 @@ * The main guts of traverse_isa was actually copied from gv_fetchmeth */ -STATIC SV * +STATIC bool S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, int len, int level) { + dVAR; AV* av; GV* gv; GV** gvp; - HV* hv = Nullhv; - SV* subgen = Nullsv; + HV* hv = NULL; + SV* subgen = NULL; const char *hvname; /* A stash/class can go by many names (ie. User == main::User), so we compare the stash itself just in case */ if (name_stash && (stash == name_stash)) - return &PL_sv_yes; + return TRUE; hvname = HvNAME_get(stash); if (strEQ(hvname, name)) - return &PL_sv_yes; + return TRUE; if (strEQ(name, "UNIVERSAL")) - return &PL_sv_yes; + return TRUE; if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", hvname); - gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); + gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) && (hv = GvHV(gv))) @@ -70,7 +71,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", name, hvname) ); - return sv; + return (sv == &PL_sv_yes); } } else { @@ -81,11 +82,11 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, } } - gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); + gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { if (!hv || !subgen) { - gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); + gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE); gv = *gvp; @@ -113,16 +114,15 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, sv, hvname); continue; } - if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, - len, level + 1)) { + if (isa_lookup(basestash, name, name_stash, len, level + 1)) { (void)hv_store(hv,name,len,&PL_sv_yes,0); - return &PL_sv_yes; + return TRUE; } } (void)hv_store(hv,name,len,&PL_sv_no,0); } } - return &PL_sv_no; + return FALSE; } /* @@ -140,29 +140,30 @@ for class names as well as for objects. bool Perl_sv_derived_from(pTHX_ SV *sv, const char *name) { - const char *type = Nullch; - HV *stash = Nullhv; - HV *name_stash; + dVAR; + HV *stash; SvGETMAGIC(sv); if (SvROK(sv)) { + const char *type; sv = SvRV(sv); type = sv_reftype(sv,0); - if (SvOBJECT(sv)) - stash = SvSTASH(sv); + if (type && strEQ(type,name)) + return TRUE; + stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL; } else { stash = gv_stashsv(sv, FALSE); } - name_stash = gv_stashpv(name, FALSE); + if (stash) { + HV * const name_stash = gv_stashpv(name, FALSE); + return isa_lookup(stash, name, name_stash, strlen(name), 0); + } + else + return FALSE; - return (type && strEQ(type,name)) || - (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) - == &PL_sv_yes) - ? TRUE - : FALSE ; } #include "XSUB.h" @@ -199,11 +200,13 @@ XS(XS_Regexp_DESTROY); XS(XS_Internals_hash_seed); XS(XS_Internals_rehash_seed); XS(XS_Internals_HvREHASH); +XS(XS_Internals_inc_sub_generation); void Perl_boot_core_UNIVERSAL(pTHX) { - const char file[] = __FILE__; + dVAR; + static const char file[] = __FILE__; newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); @@ -247,11 +250,14 @@ Perl_boot_core_UNIVERSAL(pTHX) newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, ""); newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, ""); newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%"); + newXSproto("Internals::inc_sub_generation",XS_Internals_inc_sub_generation, + file, ""); } XS(XS_UNIVERSAL_isa) { + dVAR; dXSARGS; if (items != 2) @@ -275,6 +281,7 @@ XS(XS_UNIVERSAL_isa) XS(XS_UNIVERSAL_can) { + dVAR; dXSARGS; SV *sv; const char *name; @@ -316,6 +323,7 @@ XS(XS_UNIVERSAL_can) XS(XS_UNIVERSAL_VERSION) { + dVAR; dXSARGS; HV *pkg; GV **gvp; @@ -333,7 +341,7 @@ XS(XS_UNIVERSAL_VERSION) pkg = gv_stashsv(ST(0), FALSE); } - gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); + gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL; if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) { SV * const nsv = sv_newmortal(); @@ -341,7 +349,7 @@ XS(XS_UNIVERSAL_VERSION) sv = nsv; if ( !sv_derived_from(sv, "version")) upg_version(sv); - undef = Nullch; + undef = NULL; } else { sv = (SV*)&PL_sv_undef; @@ -389,6 +397,7 @@ XS(XS_UNIVERSAL_VERSION) XS(XS_version_new) { + dVAR; dXSARGS; if (items > 3) Perl_croak(aTHX_ "Usage: version::new(class, version)"); @@ -430,6 +439,7 @@ XS(XS_version_new) XS(XS_version_stringify) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)"); @@ -452,6 +462,7 @@ XS(XS_version_stringify) XS(XS_version_numify) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)"); @@ -474,6 +485,7 @@ XS(XS_version_numify) XS(XS_version_normal) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)"); @@ -496,6 +508,7 @@ XS(XS_version_normal) XS(XS_version_vcmp) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)"); @@ -540,13 +553,14 @@ XS(XS_version_vcmp) XS(XS_version_boolean) { - dXSARGS; - if (items < 1) - Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)"); - SP -= items; + dVAR; + dXSARGS; + if (items < 1) + Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)"); + SP -= items; if (sv_derived_from(ST(0), "version")) { SV * const lobj = SvRV(ST(0)); - SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) ); + SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) ); PUSHs(sv_2mortal(rs)); PUTBACK; return; @@ -557,6 +571,7 @@ XS(XS_version_boolean) XS(XS_version_noop) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)"); @@ -571,6 +586,7 @@ XS(XS_version_noop) XS(XS_version_is_alpha) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)"); @@ -590,6 +606,7 @@ XS(XS_version_is_alpha) XS(XS_version_qv) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: version::qv(ver)"); @@ -626,6 +643,7 @@ XS(XS_version_qv) XS(XS_utf8_is_utf8) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); @@ -641,6 +659,7 @@ XS(XS_utf8_is_utf8) XS(XS_utf8_valid) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); @@ -658,6 +677,7 @@ XS(XS_utf8_valid) XS(XS_utf8_encode) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::encode(sv)"); @@ -667,6 +687,7 @@ XS(XS_utf8_encode) XS(XS_utf8_decode) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::decode(sv)"); @@ -681,6 +702,7 @@ XS(XS_utf8_decode) XS(XS_utf8_upgrade) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); @@ -697,6 +719,7 @@ XS(XS_utf8_upgrade) XS(XS_utf8_downgrade) { + dVAR; dXSARGS; if (items < 1 || items > 2) Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)"); @@ -713,6 +736,7 @@ XS(XS_utf8_downgrade) XS(XS_utf8_native_to_unicode) { + dVAR; dXSARGS; const UV uv = SvUV(ST(0)); @@ -725,6 +749,7 @@ XS(XS_utf8_native_to_unicode) XS(XS_utf8_unicode_to_native) { + dVAR; dXSARGS; const UV uv = SvUV(ST(0)); @@ -737,6 +762,7 @@ XS(XS_utf8_unicode_to_native) XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ { + dVAR; dXSARGS; SV * const sv = SvRV(ST(0)); @@ -762,6 +788,7 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ { + dVAR; dXSARGS; SV * const sv = SvRV(ST(0)); @@ -777,6 +804,7 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ XS(XS_Internals_hv_clear_placehold) { + dVAR; dXSARGS; if (items != 1) @@ -790,11 +818,13 @@ XS(XS_Internals_hv_clear_placehold) XS(XS_Regexp_DESTROY) { + PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(cv); } XS(XS_PerlIO_get_layers) { + dVAR; dXSARGS; if (items < 1 || items % 2 == 0) Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])"); @@ -851,7 +881,7 @@ XS(XS_PerlIO_get_layers) if (SvROK(sv) && isGV(SvRV(sv))) gv = (GV*)SvRV(sv); else if (SvPOKp(sv)) - gv = gv_fetchsv(sv, FALSE, SVt_PVIO); + gv = gv_fetchsv(sv, 0, SVt_PVIO); } if (gv && (io = GvIO(gv))) { @@ -897,7 +927,7 @@ XS(XS_PerlIO_get_layers) const IV flags = SvIVX(*flgsvp); if (flags & PERLIO_F_UTF8) { - XPUSHs(newSVpvn("utf8", 4)); + XPUSHs(newSVpvs("utf8")); nitem++; } } @@ -916,6 +946,7 @@ XS(XS_PerlIO_get_layers) XS(XS_Internals_hash_seed) { + dVAR; /* Using dXSARGS would also have dITEM and dSP, * which define 2 unused local variables. */ dAXMARK; @@ -926,6 +957,7 @@ XS(XS_Internals_hash_seed) XS(XS_Internals_rehash_seed) { + dVAR; /* Using dXSARGS would also have dITEM and dSP, * which define 2 unused local variables. */ dAXMARK; @@ -936,6 +968,7 @@ XS(XS_Internals_rehash_seed) XS(XS_Internals_HvREHASH) /* Subject to change */ { + dVAR; dXSARGS; if (SvROK(ST(0))) { const HV * const hv = (HV *) SvRV(ST(0)); @@ -949,6 +982,18 @@ XS(XS_Internals_HvREHASH) /* Subject to change */ Perl_croak(aTHX_ "Internals::HvREHASH $hashref"); } +XS(XS_Internals_inc_sub_generation) +{ + dVAR; + /* Using dXSARGS would also have dITEM and dSP, + * which define 2 unused local variables. */ + dAXMARK; + PERL_UNUSED_ARG(cv); + PERL_UNUSED_VAR(mark); + ++PL_sub_generation; + XSRETURN_EMPTY; +} + /* * Local variables: * c-indentation-style: bsd