X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/396482e1e4786de2b4c8ab57cb613dc0f110b931..17bcfd59e475bc04ce8413d24f07dfe2b5f2ce1c:/universal.c diff --git a/universal.c b/universal.c index fe76f81..7bbcbdb 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,10 +31,11 @@ * The main guts of traverse_isa was actually copied from gv_fetchmeth */ -STATIC SV * -S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, +STATIC bool +S_isa_lookup(pTHX_ HV *stash, const char *name, const HV* const name_stash, int len, int level) { + dVAR; AV* av; GV* gv; GV** gvp; @@ -44,33 +45,36 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, /* 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; + if (name_stash && ((const HV *)stash == name_stash)) + 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))) { if (SvIV(subgen) == (IV)PL_sub_generation) { - SV* sv; 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) ); - return sv; + if (svp) { + SV * const sv = *svp; +#ifdef DEBUGGING + if (sv != &PL_sv_undef) + DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", + name, hvname) ); +#endif + return (sv == &PL_sv_yes); } } else { @@ -81,11 +85,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; @@ -110,19 +114,18 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", - sv, hvname); + (void*)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; } /* @@ -130,9 +133,9 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, =for apidoc sv_derived_from -Returns a boolean indicating whether the SV is derived from the specified -class. This is the function that implements C. It works -for class names as well as for objects. +Returns a boolean indicating whether the SV is derived from the specified class +I. To check derivation at the Perl level, call C as a +normal Perl method. =cut */ @@ -140,6 +143,7 @@ for class names as well as for objects. bool Perl_sv_derived_from(pTHX_ SV *sv, const char *name) { + dVAR; HV *stash; SvGETMAGIC(sv); @@ -158,17 +162,67 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name) if (stash) { HV * const name_stash = gv_stashpv(name, FALSE); - return isa_lookup(stash, name, name_stash, strlen(name), 0) == &PL_sv_yes; + return isa_lookup(stash, name, name_stash, strlen(name), 0); } else return FALSE; } +/* +=for apidoc sv_does + +Returns a boolean indicating whether the SV performs a specific, named role. +The SV can be a Perl object or the name of a Perl class. + +=cut +*/ + #include "XSUB.h" +bool +Perl_sv_does(pTHX_ SV *sv, const char *name) +{ + const char *classname; + bool does_it; + + dSP; + ENTER; + SAVETMPS; + + SvGETMAGIC(sv); + + if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) + || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) + return FALSE; + + if (sv_isobject(sv)) { + classname = sv_reftype(SvRV(sv),TRUE); + } else { + classname = SvPV(sv,PL_na); + } + + if (strEQ(name,classname)) + return TRUE; + + PUSHMARK(SP); + XPUSHs(sv); + XPUSHs(sv_2mortal(newSVpv(name, 0))); + PUTBACK; + + call_method("isa", G_SCALAR); + SPAGAIN; + + does_it = SvTRUE( TOPs ); + FREETMPS; + LEAVE; + + return does_it; +} + PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv); PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv); +PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv); PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); XS(XS_version_new); XS(XS_version_stringify); @@ -204,10 +258,12 @@ 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); + newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file); newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); { /* register the overloading (type 'A') magic */ @@ -255,6 +311,7 @@ Perl_boot_core_UNIVERSAL(pTHX) XS(XS_UNIVERSAL_isa) { + dVAR; dXSARGS; if (items != 2) @@ -278,6 +335,7 @@ XS(XS_UNIVERSAL_isa) XS(XS_UNIVERSAL_can) { + dVAR; dXSARGS; SV *sv; const char *name; @@ -317,8 +375,28 @@ XS(XS_UNIVERSAL_can) XSRETURN(1); } +XS(XS_UNIVERSAL_DOES) +{ + dVAR; + dXSARGS; + + if (items != 2) + Perl_croak(aTHX_ "Usage: invocant->does(kind)"); + else { + SV * const sv = ST(0); + const char *name; + + name = SvPV_nolen_const(ST(1)); + if (sv_does( sv, name )) + XSRETURN_YES; + + XSRETURN_NO; + } +} + XS(XS_UNIVERSAL_VERSION) { + dVAR; dXSARGS; HV *pkg; GV **gvp; @@ -336,7 +414,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(); @@ -377,8 +455,11 @@ XS(XS_UNIVERSAL_VERSION) if ( vcmp( req, sv ) > 0 ) Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--" - "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg), - vnumify(req),vnormal(req),vnumify(sv),vnormal(sv)); + "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg), + (void*)vnumify(req), + (void*)vnormal(req), + (void*)vnumify(sv), + (void*)vnormal(sv)); } if ( SvOK(sv) && sv_derived_from(sv, "version") ) { @@ -392,6 +473,7 @@ XS(XS_UNIVERSAL_VERSION) XS(XS_version_new) { + dVAR; dXSARGS; if (items > 3) Perl_croak(aTHX_ "Usage: version::new(class, version)"); @@ -404,17 +486,10 @@ XS(XS_version_new) ? HvNAME(SvSTASH(SvRV(ST(0)))) : (char *)SvPV_nolen(ST(0)); - if ( items == 1 ) { - /* no parameter provided */ - if ( sv_isobject(ST(0)) ) { - /* copy existing object */ - vs = ST(0); - } - else { - /* create empty object */ - vs = sv_newmortal(); - sv_setpvn(vs,"",0); - } + if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */ + /* create empty object */ + vs = sv_newmortal(); + sv_setpvn(vs,"",0); } else if ( items == 3 ) { vs = sv_newmortal(); @@ -433,6 +508,7 @@ XS(XS_version_new) XS(XS_version_stringify) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)"); @@ -455,6 +531,7 @@ XS(XS_version_stringify) XS(XS_version_numify) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)"); @@ -477,6 +554,7 @@ XS(XS_version_numify) XS(XS_version_normal) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)"); @@ -499,6 +577,7 @@ XS(XS_version_normal) XS(XS_version_vcmp) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)"); @@ -543,10 +622,11 @@ 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(newSVpvs("0"))) ); @@ -560,6 +640,7 @@ XS(XS_version_boolean) XS(XS_version_noop) { + dVAR; dXSARGS; if (items < 1) Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)"); @@ -574,6 +655,7 @@ XS(XS_version_noop) XS(XS_version_is_alpha) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)"); @@ -593,6 +675,7 @@ XS(XS_version_is_alpha) XS(XS_version_qv) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: version::qv(ver)"); @@ -605,7 +688,7 @@ XS(XS_version_qv) if ( SvNOK(ver) ) /* may get too much accuracy */ { char tbuf[64]; - const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); + const STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver)); version = savepvn(tbuf, len); } else @@ -629,6 +712,7 @@ XS(XS_version_qv) XS(XS_utf8_is_utf8) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); @@ -644,6 +728,7 @@ XS(XS_utf8_is_utf8) XS(XS_utf8_valid) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); @@ -661,6 +746,7 @@ XS(XS_utf8_valid) XS(XS_utf8_encode) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::encode(sv)"); @@ -670,6 +756,7 @@ XS(XS_utf8_encode) XS(XS_utf8_decode) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::decode(sv)"); @@ -684,6 +771,7 @@ XS(XS_utf8_decode) XS(XS_utf8_upgrade) { + dVAR; dXSARGS; if (items != 1) Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); @@ -700,6 +788,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)"); @@ -716,6 +805,7 @@ XS(XS_utf8_downgrade) XS(XS_utf8_native_to_unicode) { + dVAR; dXSARGS; const UV uv = SvUV(ST(0)); @@ -728,6 +818,7 @@ XS(XS_utf8_native_to_unicode) XS(XS_utf8_unicode_to_native) { + dVAR; dXSARGS; const UV uv = SvUV(ST(0)); @@ -740,6 +831,7 @@ XS(XS_utf8_unicode_to_native) XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ { + dVAR; dXSARGS; SV * const sv = SvRV(ST(0)); @@ -765,6 +857,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)); @@ -780,6 +873,7 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ XS(XS_Internals_hv_clear_placehold) { + dVAR; dXSARGS; if (items != 1) @@ -793,11 +887,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])"); @@ -890,9 +986,11 @@ XS(XS_PerlIO_get_layers) else { if (namok && argok) XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", - *namsvp, *argsvp)); + (void*)*namsvp, + (void*)*argsvp)); else if (namok) - XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp)); + XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, + (void*)*namsvp)); else XPUSHs(&PL_sv_undef); nitem++; @@ -919,6 +1017,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; @@ -929,6 +1028,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; @@ -939,6 +1039,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)); @@ -954,6 +1055,7 @@ XS(XS_Internals_HvREHASH) /* Subject to change */ XS(XS_Internals_inc_sub_generation) { + dVAR; /* Using dXSARGS would also have dITEM and dSP, * which define 2 unused local variables. */ dAXMARK;