X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=9e9b2235b6a897cbdaa412d4356156f9798c3535;hb=a146a244ce1425446618620fe96b3481b5463a4f;hp=ad80a21bee605dbdfe45d4c91db3f420e8332e94;hpb=ec3bab8e3bf51c4a5f1cb8ab2f17c1c54f83967b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/universal.c b/universal.c index ad80a21..9e9b223 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. @@ -35,11 +35,12 @@ STATIC SV * 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 @@ -66,7 +67,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, { if (SvIV(subgen) == (IV)PL_sub_generation) { SV* sv; - SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); + SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE); if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", name, hvname) ); @@ -104,8 +105,8 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, /* NOTE: No support for tied ISA */ I32 items = AvFILLp(av) + 1; while (items--) { - SV* sv = *svp++; - HV* basestash = gv_stashsv(sv, FALSE); + SV* const sv = *svp++; + HV* const basestash = gv_stashsv(sv, FALSE); if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), @@ -140,30 +141,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; - if (SvGMAGICAL(sv)) - mg_get(sv) ; + 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) == &PL_sv_yes; + } + 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" @@ -200,10 +201,12 @@ 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) { + dVAR; const char file[] = __FILE__; newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); @@ -248,35 +251,38 @@ 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; - SV *sv; - const char *name; if (items != 2) Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)"); + else { + SV * const sv = ST(0); + const char *name; - sv = ST(0); - - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); - if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) - || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) - XSRETURN_UNDEF; + if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) + || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) + XSRETURN_UNDEF; - name = SvPV_nolen_const(ST(1)); + name = SvPV_nolen_const(ST(1)); - ST(0) = boolSV(sv_derived_from(sv, name)); - XSRETURN(1); + ST(0) = boolSV(sv_derived_from(sv, name)); + XSRETURN(1); + } } XS(XS_UNIVERSAL_can) { + dVAR; dXSARGS; SV *sv; const char *name; @@ -288,8 +294,7 @@ XS(XS_UNIVERSAL_can) sv = ST(0); - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) @@ -308,7 +313,7 @@ XS(XS_UNIVERSAL_can) } if (pkg) { - GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE); + GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE); if (gv && isGV(gv)) rv = sv_2mortal(newRV((SV*)GvCV(gv))); } @@ -319,6 +324,7 @@ XS(XS_UNIVERSAL_can) XS(XS_UNIVERSAL_VERSION) { + dVAR; dXSARGS; HV *pkg; GV **gvp; @@ -338,13 +344,13 @@ XS(XS_UNIVERSAL_VERSION) gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); - if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) { - SV *nsv = sv_newmortal(); + if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) { + SV * const nsv = sv_newmortal(); sv_setsv(nsv, sv); sv = nsv; if ( !sv_derived_from(sv, "version")) upg_version(sv); - undef = Nullch; + undef = NULL; } else { sv = (SV*)&PL_sv_undef; @@ -356,7 +362,7 @@ XS(XS_UNIVERSAL_VERSION) if (undef) { if (pkg) { - const char *name = HvNAME_get(pkg); + const char * const name = HvNAME_get(pkg); Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed", name, name); @@ -369,7 +375,7 @@ XS(XS_UNIVERSAL_VERSION) if ( !sv_derived_from(req, "version")) { /* req may very well be R/O, so create a new object */ - SV *nsv = sv_newmortal(); + SV * const nsv = sv_newmortal(); sv_setsv(nsv, req); req = nsv; upg_version(req); @@ -392,6 +398,7 @@ XS(XS_UNIVERSAL_VERSION) XS(XS_version_new) { + dVAR; dXSARGS; if (items > 3) Perl_croak(aTHX_ "Usage: version::new(class, version)"); @@ -399,15 +406,10 @@ XS(XS_version_new) { SV *vs = ST(1); SV *rv; - const char *classname; - - /* get the class if called as an object method */ - if ( sv_isobject(ST(0)) ) { - classname = HvNAME(SvSTASH(SvRV(ST(0)))); - } - else { - classname = (char *)SvPV_nolen(ST(0)); - } + const char * const classname = + sv_isobject(ST(0)) /* get the class if called as an object method */ + ? HvNAME(SvSTASH(SvRV(ST(0)))) + : (char *)SvPV_nolen(ST(0)); if ( items == 1 ) { /* no parameter provided */ @@ -418,7 +420,7 @@ XS(XS_version_new) else { /* create empty object */ vs = sv_newmortal(); - sv_setpv(vs,""); + sv_setpvn(vs,"",0); } } else if ( items == 3 ) { @@ -438,12 +440,13 @@ XS(XS_version_new) XS(XS_version_stringify) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)"); SP -= items; { - SV * lobj = Nullsv; + SV * lobj; if (sv_derived_from(ST(0), "version")) { lobj = SvRV(ST(0)); @@ -460,12 +463,13 @@ XS(XS_version_stringify) XS(XS_version_numify) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)"); SP -= items; { - SV * lobj = Nullsv; + SV * lobj; if (sv_derived_from(ST(0), "version")) { lobj = SvRV(ST(0)); @@ -482,12 +486,13 @@ XS(XS_version_numify) XS(XS_version_normal) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)"); SP -= items; { - SV * lobj = Nullsv; + SV * lobj; if (sv_derived_from(ST(0), "version")) { lobj = SvRV(ST(0)); @@ -504,12 +509,13 @@ XS(XS_version_normal) XS(XS_version_vcmp) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)"); SP -= items; { - SV * lobj = Nullsv; + SV * lobj; if (sv_derived_from(ST(0), "version")) { lobj = SvRV(ST(0)); @@ -521,7 +527,7 @@ XS(XS_version_vcmp) SV *rs; SV *rvs; SV * robj = ST(1); - IV swap = (IV)SvIV(ST(2)); + const IV swap = (IV)SvIV(ST(2)); if ( ! sv_derived_from(robj, "version") ) { @@ -548,32 +554,25 @@ XS(XS_version_vcmp) XS(XS_version_boolean) { - dXSARGS; - if (items < 1) - Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)"); - SP -= items; - { - SV * lobj = Nullsv; - - if (sv_derived_from(ST(0), "version")) { - lobj = SvRV(ST(0)); - } - else - Perl_croak(aTHX_ "lobj is not of type version"); - - { - SV *rs; - rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) ); - PUSHs(sv_2mortal(rs)); - } - - PUTBACK; - return; - } + 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(newSVpvs("0"))) ); + PUSHs(sv_2mortal(rs)); + PUTBACK; + return; + } + else + Perl_croak(aTHX_ "lobj is not of type version"); } XS(XS_version_noop) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)"); @@ -588,45 +587,41 @@ XS(XS_version_noop) XS(XS_version_is_alpha) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)"); SP -= items; - { - SV * lobj = Nullsv; - - if (sv_derived_from(ST(0), "version")) - lobj = ST(0); - else - Perl_croak(aTHX_ "lobj is not of type version"); -{ - if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) ) - XSRETURN_YES; - else - XSRETURN_NO; -} + if (sv_derived_from(ST(0), "version")) { + SV * const lobj = ST(0); + if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) ) + XSRETURN_YES; + else + XSRETURN_NO; PUTBACK; return; } + else + Perl_croak(aTHX_ "lobj is not of type version"); } XS(XS_version_qv) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: version::qv(ver)"); SP -= items; { SV * ver = ST(0); - if ( !SvVOK(ver) ) /* only need to do with if not already v-string */ - { - SV *vs = sv_newmortal(); + if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */ + SV * const vs = sv_newmortal(); char *version; if ( SvNOK(ver) ) /* may get too much accuracy */ { char tbuf[64]; - sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); - version = savepv(tbuf); + const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); + version = savepvn(tbuf, len); } else { @@ -649,60 +644,56 @@ XS(XS_version_qv) XS(XS_utf8_is_utf8) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); - { - const SV *sv = ST(0); - { - if (SvUTF8(sv)) - XSRETURN_YES; - else - XSRETURN_NO; - } + else { + const SV * const sv = ST(0); + if (SvUTF8(sv)) + XSRETURN_YES; + else + XSRETURN_NO; } XSRETURN_EMPTY; } XS(XS_utf8_valid) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); - { - SV * sv = ST(0); - { - STRLEN len; - const char *s = SvPV_const(sv,len); - if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len)) - XSRETURN_YES; - else - XSRETURN_NO; - } - } + else { + SV * const sv = ST(0); + STRLEN len; + const char * const s = SvPV_const(sv,len); + if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len)) + XSRETURN_YES; + else + XSRETURN_NO; + } XSRETURN_EMPTY; } XS(XS_utf8_encode) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::encode(sv)"); - { - SV * sv = ST(0); - - sv_utf8_encode(sv); - } + sv_utf8_encode(ST(0)); XSRETURN_EMPTY; } XS(XS_utf8_decode) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::decode(sv)"); - { - SV * sv = ST(0); + else { + SV * const sv = ST(0); const bool RETVAL = sv_utf8_decode(sv); ST(0) = boolSV(RETVAL); sv_2mortal(ST(0)); @@ -712,11 +703,12 @@ XS(XS_utf8_decode) XS(XS_utf8_upgrade) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); - { - SV * sv = ST(0); + else { + SV * const sv = ST(0); STRLEN RETVAL; dXSTARG; @@ -728,11 +720,12 @@ XS(XS_utf8_upgrade) XS(XS_utf8_downgrade) { + dVAR; dXSARGS; if (items < 1 || items > 2) Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)"); - { - SV * sv = ST(0); + else { + SV * const sv = ST(0); const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1)); const bool RETVAL = sv_utf8_downgrade(sv, failok); @@ -744,6 +737,7 @@ XS(XS_utf8_downgrade) XS(XS_utf8_native_to_unicode) { + dVAR; dXSARGS; const UV uv = SvUV(ST(0)); @@ -756,6 +750,7 @@ XS(XS_utf8_native_to_unicode) XS(XS_utf8_unicode_to_native) { + dVAR; dXSARGS; const UV uv = SvUV(ST(0)); @@ -768,8 +763,9 @@ XS(XS_utf8_unicode_to_native) XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ { + dVAR; dXSARGS; - SV *sv = SvRV(ST(0)); + SV * const sv = SvRV(ST(0)); if (items == 1) { if (SvREADONLY(sv)) @@ -793,8 +789,9 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ { + dVAR; dXSARGS; - SV *sv = SvRV(ST(0)); + SV * const sv = SvRV(ST(0)); if (items == 1) XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ @@ -808,13 +805,16 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ XS(XS_Internals_hv_clear_placehold) { + dVAR; dXSARGS; - HV *hv = (HV *) SvRV(ST(0)); if (items != 1) Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)"); - hv_clear_placeholders(hv); - XSRETURN(0); + else { + HV * const hv = (HV *) SvRV(ST(0)); + hv_clear_placeholders(hv); + XSRETURN(0); + } } XS(XS_Regexp_DESTROY) @@ -824,6 +824,7 @@ XS(XS_Regexp_DESTROY) XS(XS_PerlIO_get_layers) { + dVAR; dXSARGS; if (items < 1 || items % 2 == 0) Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])"); @@ -836,13 +837,12 @@ XS(XS_PerlIO_get_layers) bool details = FALSE; if (items > 1) { - SV **svp; - + SV * const *svp; for (svp = MARK + 2; svp <= SP; svp += 2) { - SV **varp = svp; - SV **valp = svp + 1; + SV * const * const varp = svp; + SV * const * const valp = svp + 1; STRLEN klen; - const char *key = SvPV_const(*varp, klen); + const char * const key = SvPV_const(*varp, klen); switch (*key) { case 'i': @@ -880,31 +880,26 @@ XS(XS_PerlIO_get_layers) if (!isGV(sv)) { if (SvROK(sv) && isGV(SvRV(sv))) gv = (GV*)SvRV(sv); - else - gv = gv_fetchsv(sv, FALSE, SVt_PVIO); + else if (SvPOKp(sv)) + gv = gv_fetchsv(sv, 0, SVt_PVIO); } if (gv && (io = GvIO(gv))) { dTARGET; - AV* av = PerlIO_get_layers(aTHX_ input ? + AV* const av = PerlIO_get_layers(aTHX_ input ? IoIFP(io) : IoOFP(io)); I32 i; - I32 last = av_len(av); + const I32 last = av_len(av); I32 nitem = 0; for (i = last; i >= 0; i -= 3) { - SV **namsvp; - SV **argsvp; - SV **flgsvp; - bool namok, argok, flgok; - - namsvp = av_fetch(av, i - 2, FALSE); - argsvp = av_fetch(av, i - 1, FALSE); - flgsvp = av_fetch(av, i, FALSE); + SV * const * const namsvp = av_fetch(av, i - 2, FALSE); + SV * const * const argsvp = av_fetch(av, i - 1, FALSE); + SV * const * const flgsvp = av_fetch(av, i, FALSE); - namok = namsvp && *namsvp && SvPOK(*namsvp); - argok = argsvp && *argsvp && SvPOK(*argsvp); - flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); + const bool namok = namsvp && *namsvp && SvPOK(*namsvp); + const bool argok = argsvp && *argsvp && SvPOK(*argsvp); + const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); if (details) { XPUSHs(namok @@ -929,10 +924,10 @@ XS(XS_PerlIO_get_layers) XPUSHs(&PL_sv_undef); nitem++; if (flgok) { - IV flags = SvIVX(*flgsvp); + const IV flags = SvIVX(*flgsvp); if (flags & PERLIO_F_UTF8) { - XPUSHs(newSVpvn("utf8", 4)); + XPUSHs(newSVpvs("utf8")); nitem++; } } @@ -951,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; @@ -961,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; @@ -971,9 +968,10 @@ XS(XS_Internals_rehash_seed) XS(XS_Internals_HvREHASH) /* Subject to change */ { + dVAR; dXSARGS; if (SvROK(ST(0))) { - const HV *hv = (HV *) SvRV(ST(0)); + const HV * const hv = (HV *) SvRV(ST(0)); if (items == 1 && SvTYPE(hv) == SVt_PVHV) { if (HvREHASH(hv)) XSRETURN_YES; @@ -984,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