X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/93c512172a58c199c03358764753a650e33707e2..d7ea0f564236f32602d243bb09a5b87a94681e97:/universal.c diff --git a/universal.c b/universal.c index 84d13fc..4da6fc5 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, 2006, 2007 by Larry Wall and others + * 2005, 2006, 2007, 2008 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. @@ -9,9 +9,11 @@ */ /* - * "The roots of those mountains must be roots indeed; there must be - * great secrets buried there which have not been discovered since the - * beginning." --Gandalf, relating Gollum's story + * '"The roots of those mountains must be roots indeed; there must be + * great secrets buried there which have not been discovered since the + * beginning."' --Gandalf, relating Gollum's history + * + * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"] */ /* This file contains the code that implements the functions in Perl's @@ -31,50 +33,76 @@ #include "perliol.h" /* For the PERLIO_F_XXX */ #endif +static HV * +S_get_isa_hash(pTHX_ HV *const stash) +{ + dVAR; + struct mro_meta *const meta = HvMROMETA(stash); + + PERL_ARGS_ASSERT_GET_ISA_HASH; + + if (!meta->isa) { + AV *const isa = mro_get_linear_isa(stash); + if (!meta->isa) { + HV *const isa_hash = newHV(); + /* Linearisation didn't build it for us, so do it here. */ + SV *const *svp = AvARRAY(isa); + SV *const *const svp_end = svp + AvFILLp(isa) + 1; + const HEK *const canon_name = HvNAME_HEK(stash); + + while (svp < svp_end) { + (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0); + } + + (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name), + HEK_LEN(canon_name), HEK_FLAGS(canon_name), + HV_FETCH_ISSTORE, &PL_sv_undef, + HEK_HASH(canon_name)); + (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0); + + SvREADONLY_on(isa_hash); + + meta->isa = isa_hash; + } + } + return meta->isa; +} + /* * Contributed by Graham Barr * The main guts of traverse_isa was actually copied from gv_fetchmeth */ STATIC bool -S_isa_lookup(pTHX_ HV *stash, const char * const name, const HV* const name_stash) +S_isa_lookup(pTHX_ HV *stash, const char * const name) { dVAR; - AV* stash_linear_isa; - SV** svp; - const char *hvname; - I32 items; + const struct mro_meta *const meta = HvMROMETA(stash); + HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash); + STRLEN len = strlen(name); + const HV *our_stash; PERL_ARGS_ASSERT_ISA_LOOKUP; - /* A stash/class can go by many names (ie. User == main::User), so - we compare the stash itself just in case */ - if (name_stash && ((const HV *)stash == name_stash)) - return TRUE; - - hvname = HvNAME_get(stash); - - if (strEQ(hvname, name)) + if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only + a char * argument*/, + HV_FETCH_ISEXISTS, NULL, 0)) { + /* Direct name lookup worked. */ return TRUE; + } - if (strEQ(name, "UNIVERSAL")) - return TRUE; + /* A stash/class can go by many names (ie. User == main::User), so + we use the name in the stash itself, which is canonical. */ + our_stash = gv_stashpvn(name, len, 0); - stash_linear_isa = mro_get_linear_isa(stash); - svp = AvARRAY(stash_linear_isa) + 1; - items = AvFILLp(stash_linear_isa); - while (items--) { - SV* const basename_sv = *svp++; - HV* const basestash = gv_stashsv(basename_sv, 0); - if (!basestash) { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %"SVf" for the parents of %s", - SVfARG(basename_sv), hvname); - continue; - } - if(name_stash == basestash || strEQ(name, SvPVX(basename_sv))) + if (our_stash) { + HEK *const canon_name = HvNAME_HEK(our_stash); + + if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name), + HEK_FLAGS(canon_name), + HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) { return TRUE; + } } return FALSE; @@ -114,13 +142,7 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *const name) stash = gv_stashsv(sv, 0); } - if (stash) { - HV * const name_stash = gv_stashpv(name, 0); - return isa_lookup(stash, name, name_stash); - } - else - return FALSE; - + return stash ? isa_lookup(stash, name) : FALSE; } /* @@ -199,6 +221,7 @@ XS(XS_version_noop); #endif XS(XS_version_is_alpha); XS(XS_version_qv); +XS(XS_version_is_qv); XS(XS_utf8_is_utf8); XS(XS_utf8_valid); XS(XS_utf8_encode); @@ -211,11 +234,9 @@ XS(XS_Internals_SvREADONLY); XS(XS_Internals_SvREFCNT); XS(XS_Internals_hv_clear_placehold); XS(XS_PerlIO_get_layers); -XS(XS_Regexp_DESTROY); XS(XS_Internals_hash_seed); XS(XS_Internals_rehash_seed); XS(XS_Internals_HvREHASH); -XS(XS_Internals_inc_sub_generation); XS(XS_re_is_regexp); XS(XS_re_regname); XS(XS_re_regnames); @@ -247,6 +268,7 @@ Perl_boot_core_UNIVERSAL(pTHX) /* Make it findable via fetchmethod */ newXS("version::()", XS_version_noop, file); newXS("version::new", XS_version_new, file); + newXS("version::parse", XS_version_new, file); newXS("version::(\"\"", XS_version_stringify, file); newXS("version::stringify", XS_version_stringify, file); newXS("version::(0+", XS_version_numify, file); @@ -261,6 +283,8 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("version::noop", XS_version_noop, file); newXS("version::is_alpha", XS_version_is_alpha, file); newXS("version::qv", XS_version_qv, file); + newXS("version::declare", XS_version_qv, file); + newXS("version::is_qv", XS_version_is_qv, file); } newXS("utf8::is_utf8", XS_utf8_is_utf8, file); newXS("utf8::valid", XS_utf8_valid, file); @@ -276,7 +300,9 @@ Perl_boot_core_UNIVERSAL(pTHX) XS_Internals_hv_clear_placehold, file, "\\%"); newXSproto("PerlIO::get_layers", XS_PerlIO_get_layers, file, "*;@"); - newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file); + /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */ + CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL)) + = (char *)file; 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, "\\%"); @@ -381,7 +407,7 @@ XS(XS_UNIVERSAL_can) rv = &PL_sv_undef; if (SvROK(sv)) { - sv = (SV*)SvRV(sv); + sv = MUTABLE_SV(SvRV(sv)); if (SvOBJECT(sv)) pkg = SvSTASH(sv); } @@ -392,7 +418,7 @@ XS(XS_UNIVERSAL_can) if (pkg) { GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE); if (gv && isGV(gv)) - rv = sv_2mortal(newRV((SV*)GvCV(gv))); + rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv)))); } ST(0) = rv; @@ -431,7 +457,7 @@ XS(XS_UNIVERSAL_VERSION) PERL_UNUSED_ARG(cv); if (SvROK(ST(0))) { - sv = (SV*)SvRV(ST(0)); + sv = MUTABLE_SV(SvRV(ST(0))); if (!SvOBJECT(sv)) Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); pkg = SvSTASH(sv); @@ -451,7 +477,7 @@ XS(XS_UNIVERSAL_VERSION) undef = NULL; } else { - sv = (SV*)&PL_sv_undef; + sv = &PL_sv_undef; undef = "(undef)"; } @@ -477,7 +503,7 @@ XS(XS_UNIVERSAL_VERSION) } if ( vcmp( req, sv ) > 0 ) { - if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) { + if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) { Perl_croak(aTHX_ "%s version %"SVf" required--" "this is only version %"SVf"", HvNAME_get(pkg), SVfARG(vnormal(req)), @@ -519,7 +545,7 @@ XS(XS_version_new) if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */ /* create empty object */ vs = sv_newmortal(); - sv_setpvn(vs,"",0); + sv_setpvs(vs,""); } else if ( items == 3 ) { vs = sv_newmortal(); @@ -692,7 +718,7 @@ XS(XS_version_is_alpha) SP -= items; if (sv_derived_from(ST(0), "version")) { SV * const lobj = ST(0); - if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) ) + if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) ) XSRETURN_YES; else XSRETURN_NO; @@ -707,25 +733,54 @@ XS(XS_version_qv) { dVAR; dXSARGS; - if (items != 1) - croak_xs_usage(cv, "ver"); + PERL_UNUSED_ARG(cv); SP -= items; { - SV * ver = ST(0); - if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */ - SV * const rv = sv_newmortal(); + SV * ver = ST(0); + SV * rv; + const char * classname = ""; + if ( items == 2 && (ST(1)) != &PL_sv_undef ) { + /* getting called as object or class method */ + ver = ST(1); + classname = + sv_isobject(ST(0)) /* class called as an object method */ + ? HvNAME_get(SvSTASH(SvRV(ST(0)))) + : (char *)SvPV_nolen(ST(0)); + } + if ( !SvVOK(ver) ) { /* not already a v-string */ + rv = sv_newmortal(); sv_setsv(rv,ver); /* make a duplicate */ upg_version(rv, TRUE); - PUSHs(rv); + } else { + rv = sv_2mortal(new_version(ver)); } - else - { - mPUSHs(new_version(ver)); + if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */ + sv_bless(rv, gv_stashpv(classname, GV_ADD)); } + PUSHs(rv); + } + PUTBACK; + return; +} +XS(XS_version_is_qv) +{ + dVAR; + dXSARGS; + if (items != 1) + croak_xs_usage(cv, "lobj"); + SP -= items; + if (sv_derived_from(ST(0), "version")) { + SV * const lobj = ST(0); + if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) ) + XSRETURN_YES; + else + XSRETURN_NO; PUTBACK; return; } + else + Perl_croak(aTHX_ "lobj is not of type version"); } XS(XS_utf8_is_utf8) @@ -899,18 +954,12 @@ XS(XS_Internals_hv_clear_placehold) if (items != 1) croak_xs_usage(cv, "hv"); else { - HV * const hv = (HV *) SvRV(ST(0)); + HV * const hv = MUTABLE_HV(SvRV(ST(0))); hv_clear_placeholders(hv); XSRETURN(0); } } -XS(XS_Regexp_DESTROY) -{ - PERL_UNUSED_CONTEXT; - PERL_UNUSED_ARG(cv); -} - XS(XS_PerlIO_get_layers) { dVAR; @@ -964,11 +1013,11 @@ XS(XS_PerlIO_get_layers) } sv = POPs; - gv = (GV*)sv; + gv = MUTABLE_GV(sv); if (!isGV(sv)) { if (SvROK(sv) && isGV(SvRV(sv))) - gv = (GV*)SvRV(sv); + gv = MUTABLE_GV(SvRV(sv)); else if (SvPOKp(sv)) gv = gv_fetchsv(sv, 0, SVt_PVIO); } @@ -1003,7 +1052,7 @@ XS(XS_PerlIO_get_layers) (SvUTF8(*argsvp) ? SVf_UTF8 : 0) | SVs_TEMP) : &PL_sv_undef); - XPUSHs(namok + XPUSHs(flgok ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp)) : &PL_sv_undef); nitem += 3; @@ -1067,7 +1116,7 @@ XS(XS_Internals_HvREHASH) /* Subject to change */ dXSARGS; PERL_UNUSED_ARG(cv); if (SvROK(ST(0))) { - const HV * const hv = (HV *) SvRV(ST(0)); + const HV * const hv = (const HV *) SvRV(ST(0)); if (items == 1 && SvTYPE(hv) == SVt_PVHV) { if (HvREHASH(hv)) XSRETURN_YES; @@ -1116,7 +1165,7 @@ XS(XS_re_regnames_count) SPAGAIN; if (ret) { - XPUSHs(ret); + mXPUSHs(ret); PUTBACK; return; } else { @@ -1150,10 +1199,7 @@ XS(XS_re_regname) ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME)); if (ret) { - if (SvROK(ret)) - XPUSHs(ret); - else - XPUSHs(SvREFCNT_inc(ret)); + mXPUSHs(ret); XSRETURN(1); } XSRETURN_UNDEF; @@ -1197,7 +1243,7 @@ XS(XS_re_regnames) if (!ret) XSRETURN_UNDEF; - av = (AV*)SvRV(ret); + av = MUTABLE_AV(SvRV(ret)); length = av_len(av); for (i = 0; i <= length; i++) { @@ -1206,8 +1252,11 @@ XS(XS_re_regnames) if (!entry) Perl_croak(aTHX_ "NULL array element in re::regnames()"); - XPUSHs(*entry); + mXPUSHs(SvREFCNT_inc_simple_NN(*entry)); } + + SvREFCNT_dec(ret); + PUTBACK; return; } @@ -1271,7 +1320,7 @@ XS(XS_re_regexp_pattern) /* Scalar, so use the string that Perl would return */ /* return the pattern in (?msix:..) format */ #if PERL_VERSION >= 11 - pattern = sv_2mortal(newSVsv((SV*)re)); + pattern = sv_2mortal(newSVsv(MUTABLE_SV(re))); #else pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re), (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); @@ -1320,16 +1369,13 @@ XS(XS_Tie_Hash_NamedCapture_FETCH) SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags); SPAGAIN; if (ret) { - if (SvROK(ret)) - XPUSHs(ret); - else - XPUSHs(SvREFCNT_inc(ret)); + mXPUSHs(ret); PUTBACK; return; } @@ -1350,14 +1396,14 @@ XS(XS_Tie_Hash_NamedCapture_STORE) if (!rx) { if (!PL_localizing) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); else XSRETURN_UNDEF; } SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags); } @@ -1372,11 +1418,11 @@ XS(XS_Tie_Hash_NamedCapture_DELETE) croak_xs_usage(cv, "$key, $flags"); if (!rx) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags); } @@ -1393,11 +1439,11 @@ XS(XS_Tie_Hash_NamedCapture_CLEAR) rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; if (!rx) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); CALLREG_NAMED_BUFF_CLEAR(rx, flags); } @@ -1419,7 +1465,7 @@ XS(XS_Tie_Hash_NamedCapture_EXISTS) SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags); SPAGAIN; @@ -1447,13 +1493,13 @@ XS(XS_Tie_Hash_NamedCapture_FIRSTK) SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags); SPAGAIN; if (ret) { - XPUSHs(SvREFCNT_inc(ret)); + mXPUSHs(ret); PUTBACK; } else { XSRETURN_UNDEF; @@ -1479,13 +1525,13 @@ XS(XS_Tie_Hash_NamedCapture_NEXTK) SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags); SPAGAIN; if (ret) { - XPUSHs(ret); + mXPUSHs(ret); } else { XSRETURN_UNDEF; } @@ -1510,13 +1556,13 @@ XS(XS_Tie_Hash_NamedCapture_SCALAR) SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags); SPAGAIN; if (ret) { - XPUSHs(ret); + mXPUSHs(ret); PUTBACK; return; } else {