X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=69c31f159029b35649f312fc321917c1c9ac7391;hb=25ff0154ccf606eb5512a8cde622caf50e20fba3;hp=7cbaaf7e4859a30b179a7a4c0ebc7d7dcb9c34c5;hpb=cbc021f9c76c5db718d993d3cc885284fbbff80f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/universal.c b/universal.c index 7cbaaf7..69c31f1 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, by Larry Wall and others + * 2005, 2006, 2007 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. @@ -32,7 +32,7 @@ */ STATIC bool -S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, +S_isa_lookup(pTHX_ HV *stash, const char *name, const HV* const name_stash, int len, int level) { dVAR; @@ -45,7 +45,7 @@ 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)) + if (name_stash && ((const HV *)stash == name_stash)) return TRUE; hvname = HvNAME_get(stash); @@ -62,15 +62,18 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE); - if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) + if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (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) ); + 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); } } @@ -84,7 +87,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); - if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { + if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) { if (!hv || !subgen) { gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE); @@ -106,12 +109,12 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, I32 items = AvFILLp(av) + 1; while (items--) { SV* const sv = *svp++; - HV* const basestash = gv_stashsv(sv, FALSE); + HV* const basestash = gv_stashsv(sv, 0); if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", - (void*)sv, hvname); + SVfARG(sv), hvname); continue; } if (isa_lookup(basestash, name, name_stash, len, level + 1)) { @@ -154,11 +157,11 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name) stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL; } else { - stash = gv_stashsv(sv, FALSE); + stash = gv_stashsv(sv, 0); } if (stash) { - HV * const name_stash = gv_stashpv(name, FALSE); + HV * const name_stash = gv_stashpv(name, 0); return isa_lookup(stash, name, name_stash, strlen(name), 0); } else @@ -217,6 +220,26 @@ Perl_sv_does(pTHX_ SV *sv, const char *name) return does_it; } +regexp * +Perl_get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) { + MAGIC *mg; + if (sv) { + if (SvMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv) && + (sv = (SV*)SvRV(sv)) && /* assign deliberate */ + SvTYPE(sv) == SVt_PVMG && + (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */ + { + if (mgp) *mgp = mg; + return (regexp *)mg->mg_obj; + } + } + if (mgp) *mgp = NULL; + return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL); +} + + 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); @@ -251,6 +274,12 @@ 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); +XS(XS_re_regnames_iterinit); +XS(XS_re_regnames_iternext); +XS(XS_re_regnames_count); void Perl_boot_core_UNIVERSAL(pTHX) @@ -303,6 +332,12 @@ Perl_boot_core_UNIVERSAL(pTHX) newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%"); newXSproto("Internals::inc_sub_generation",XS_Internals_inc_sub_generation, file, ""); + newXSproto("re::is_regexp", XS_re_is_regexp, file, "$"); + newXSproto("re::regname", XS_re_regname, file, ";$$$"); + newXSproto("re::regnames", XS_re_regnames, file, ";$$"); + newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, ";$"); + newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$$"); + newXSproto("re::regnames_count", XS_re_regnames_count, file, ";$"); } @@ -310,6 +345,7 @@ XS(XS_UNIVERSAL_isa) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 2) Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)"); @@ -338,6 +374,7 @@ XS(XS_UNIVERSAL_can) const char *name; SV *rv; HV *pkg = NULL; + PERL_UNUSED_ARG(cv); if (items != 2) Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)"); @@ -359,7 +396,7 @@ XS(XS_UNIVERSAL_can) pkg = SvSTASH(sv); } else { - pkg = gv_stashsv(sv, FALSE); + pkg = gv_stashsv(sv, 0); } if (pkg) { @@ -376,6 +413,7 @@ XS(XS_UNIVERSAL_DOES) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 2) Perl_croak(aTHX_ "Usage: invocant->does(kind)"); @@ -400,6 +438,7 @@ XS(XS_UNIVERSAL_VERSION) GV *gv; SV *sv; const char *undef; + PERL_UNUSED_ARG(cv); if (SvROK(ST(0))) { sv = (SV*)SvRV(ST(0)); @@ -408,7 +447,7 @@ XS(XS_UNIVERSAL_VERSION) pkg = SvSTASH(sv); } else { - pkg = gv_stashsv(ST(0), FALSE); + pkg = gv_stashsv(ST(0), 0); } gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL; @@ -453,10 +492,10 @@ 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), - (void*)vnumify(req), - (void*)vnormal(req), - (void*)vnumify(sv), - (void*)vnormal(sv)); + SVfARG(vnumify(req)), + SVfARG(vnormal(req)), + SVfARG(vnumify(sv)), + SVfARG(vnormal(sv))); } if ( SvOK(sv) && sv_derived_from(sv, "version") ) { @@ -472,6 +511,7 @@ XS(XS_version_new) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items > 3) Perl_croak(aTHX_ "Usage: version::new(class, version)"); SP -= items; @@ -495,7 +535,7 @@ XS(XS_version_new) rv = new_version(vs); if ( strcmp(classname,"version") != 0 ) /* inherited new() */ - sv_bless(rv, gv_stashpv(classname,TRUE)); + sv_bless(rv, gv_stashpv(classname, GV_ADD)); PUSHs(sv_2mortal(rv)); PUTBACK; @@ -507,6 +547,7 @@ XS(XS_version_stringify) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)"); SP -= items; @@ -530,6 +571,7 @@ XS(XS_version_numify) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)"); SP -= items; @@ -553,6 +595,7 @@ XS(XS_version_normal) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)"); SP -= items; @@ -576,6 +619,7 @@ XS(XS_version_vcmp) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)"); SP -= items; @@ -621,6 +665,7 @@ XS(XS_version_boolean) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)"); SP -= items; @@ -639,6 +684,7 @@ XS(XS_version_noop) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)"); if (sv_derived_from(ST(0), "version")) @@ -654,6 +700,7 @@ XS(XS_version_is_alpha) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)"); SP -= items; @@ -674,6 +721,7 @@ XS(XS_version_qv) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: version::qv(ver)"); SP -= items; @@ -685,7 +733,14 @@ XS(XS_version_qv) if ( SvNOK(ver) ) /* may get too much accuracy */ { char tbuf[64]; - const STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver)); +#ifdef USE_LOCALE_NUMERIC + char *loc = setlocale(LC_NUMERIC, "C"); +#endif + STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver)); +#ifdef USE_LOCALE_NUMERIC + setlocale(LC_NUMERIC, loc); +#endif + while (tbuf[len-1] == '0' && len > 0) len--; version = savepvn(tbuf, len); } else @@ -711,6 +766,7 @@ XS(XS_utf8_is_utf8) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); else { @@ -727,6 +783,7 @@ XS(XS_utf8_valid) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); else { @@ -745,6 +802,7 @@ XS(XS_utf8_encode) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::encode(sv)"); sv_utf8_encode(ST(0)); @@ -755,6 +813,7 @@ XS(XS_utf8_decode) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::decode(sv)"); else { @@ -770,6 +829,7 @@ XS(XS_utf8_upgrade) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); else { @@ -787,6 +847,7 @@ XS(XS_utf8_downgrade) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1 || items > 2) Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)"); else { @@ -805,6 +866,7 @@ XS(XS_utf8_native_to_unicode) dVAR; dXSARGS; const UV uv = SvUV(ST(0)); + PERL_UNUSED_ARG(cv); if (items > 1) Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)"); @@ -818,6 +880,7 @@ XS(XS_utf8_unicode_to_native) dVAR; dXSARGS; const UV uv = SvUV(ST(0)); + PERL_UNUSED_ARG(cv); if (items > 1) Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)"); @@ -831,6 +894,7 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ dVAR; dXSARGS; SV * const sv = SvRV(ST(0)); + PERL_UNUSED_ARG(cv); if (items == 1) { if (SvREADONLY(sv)) @@ -857,6 +921,7 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ dVAR; dXSARGS; SV * const sv = SvRV(ST(0)); + PERL_UNUSED_ARG(cv); if (items == 1) XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ @@ -872,6 +937,7 @@ XS(XS_Internals_hv_clear_placehold) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)"); @@ -892,6 +958,7 @@ XS(XS_PerlIO_get_layers) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1 || items % 2 == 0) Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])"); #ifdef USE_PERLIO @@ -983,11 +1050,11 @@ XS(XS_PerlIO_get_layers) else { if (namok && argok) XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", - (void*)*namsvp, - (void*)*argsvp)); + SVfARG(*namsvp), + SVfARG(*argsvp))); else if (namok) XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, - (void*)*namsvp)); + SVfARG(*namsvp))); else XPUSHs(&PL_sv_undef); nitem++; @@ -1038,6 +1105,7 @@ XS(XS_Internals_HvREHASH) /* Subject to change */ { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (SvROK(ST(0))) { const HV * const hv = (HV *) SvRV(ST(0)); if (items == 1 && SvTYPE(hv) == SVt_PVHV) { @@ -1062,6 +1130,271 @@ XS(XS_Internals_inc_sub_generation) XSRETURN_EMPTY; } +XS(XS_re_is_regexp) +{ + dVAR; + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + SV * sv = ST(0); + if ( Perl_get_re_arg( aTHX_ sv, 0, NULL ) ) + { + XSRETURN_YES; + } else { + XSRETURN_NO; + } + /* NOTREACHED */ + PUTBACK; + return; + } +} + +XS(XS_re_regname) +{ + + dVAR; + dXSARGS; + if (items < 1 || items > 3) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "sv, qr = NULL, all = NULL"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + SV * sv = ST(0); + SV * qr; + SV * all; + regexp *re = NULL; + SV *bufs = NULL; + + if (items < 2) + qr = NULL; + else { + qr = ST(1); + } + + if (items < 3) + all = NULL; + else { + all = ST(2); + } + { + re = Perl_get_re_arg( aTHX_ qr, 1, NULL); + if (SvPOK(sv) && re && re->paren_names) { + bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all)); + if (bufs) { + if (all && SvTRUE(all)) + XPUSHs(newRV(bufs)); + else + XPUSHs(SvREFCNT_inc(bufs)); + XSRETURN(1); + } + } + XSRETURN_UNDEF; + } + PUTBACK; + return; + } +} + +XS(XS_re_regnames) +{ + dVAR; + dXSARGS; + if (items < 0 || items > 2) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "sv = NULL, all = NULL"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + SV * sv; + SV * all; + regexp *re = NULL; + IV count = 0; + + if (items < 1) + sv = NULL; + else { + sv = ST(0); + } + + if (items < 2) + all = NULL; + else { + all = ST(1); + } + { + re = Perl_get_re_arg( aTHX_ sv, 1, NULL ); + if (re && re->paren_names) { + HV *hv= re->paren_names; + (void)hv_iterinit(hv); + while (1) { + HE *temphe = hv_iternext_flags(hv,0); + if (temphe) { + IV i; + IV parno = 0; + SV* sv_dat = HeVAL(temphe); + I32 *nums = (I32*)SvPVX(sv_dat); + for ( i = 0; i < SvIVX(sv_dat); i++ ) { + if ((I32)(re->lastcloseparen) >= nums[i] && + re->startp[nums[i]] != -1 && + re->endp[nums[i]] != -1) + { + parno = nums[i]; + break; + } + } + if (parno || (all && SvTRUE(all))) { + STRLEN len; + char *pv = HePV(temphe, len); + if ( GIMME_V == G_ARRAY ) + XPUSHs(newSVpvn(pv,len)); + count++; + } + } else { + break; + } + } + } + if ( GIMME_V == G_ARRAY ) + XSRETURN(count); + else + XSRETURN_UNDEF; + } + PUTBACK; + return; + } +} + + +XS(XS_re_regnames_iterinit) +{ + dVAR; + dXSARGS; + if (items < 0 || items > 1) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iterinit", "sv = NULL"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + SV * sv; + regexp *re = NULL; + + if (items < 1) + sv = NULL; + else { + sv = ST(0); + } + { + re = Perl_get_re_arg( aTHX_ sv, 1, NULL ); + if (re && re->paren_names) { + (void)hv_iterinit(re->paren_names); + XPUSHs(newSViv(HvTOTALKEYS(re->paren_names))); + } else { + XSRETURN_UNDEF; + } + } + PUTBACK; + return; + } +} + + +XS(XS_re_regnames_iternext) +{ + dVAR; + dXSARGS; + if (items < 0 || items > 2) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "sv = NULL, all = NULL"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + SV * sv; + SV * all; + regexp *re; + + if (items < 1) + sv = NULL; + else { + sv = ST(0); + } + + if (items < 2) + all = NULL; + else { + all = ST(1); + } + { + re = Perl_get_re_arg( aTHX_ sv, 1, NULL ); + if (re && re->paren_names) { + HV *hv= re->paren_names; + while (1) { + HE *temphe = hv_iternext_flags(hv,0); + if (temphe) { + IV i; + IV parno = 0; + SV* sv_dat = HeVAL(temphe); + I32 *nums = (I32*)SvPVX(sv_dat); + for ( i = 0; i < SvIVX(sv_dat); i++ ) { + if ((I32)(re->lastcloseparen) >= nums[i] && + re->startp[nums[i]] != -1 && + re->endp[nums[i]] != -1) + { + parno = nums[i]; + break; + } + } + if (parno || (all && SvTRUE(all))) { + STRLEN len; + char *pv = HePV(temphe, len); + XPUSHs(newSVpvn(pv,len)); + XSRETURN(1); + } + } else { + break; + } + } + } + XSRETURN_UNDEF; + } + PUTBACK; + return; + } +} + + +XS(XS_re_regnames_count) +{ + SV * sv; + regexp *re = NULL; + dVAR; + dXSARGS; + + if (items < 0 || items > 1) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "sv = NULL"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + if (items < 1) + sv = NULL; + else { + sv = ST(0); + } + re = Perl_get_re_arg( aTHX_ sv, 1, NULL ); + if (re && re->paren_names) { + XPUSHs(newSViv(HvTOTALKEYS(re->paren_names))); + } else { + XSRETURN_UNDEF; + } + PUTBACK; + return; +} + + /* * Local variables: * c-indentation-style: bsd