X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4a818d86735b88cd762faade9872a9c2e89ab057..eba1666137b7e1350d666a934a5e99ced3f50088:/universal.c diff --git a/universal.c b/universal.c index 4d44aa7..fa0ccd3 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, 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. @@ -16,6 +16,11 @@ /* This file contains the code that implements the functions in Perl's * UNIVERSAL package, such as UNIVERSAL->can(). + * + * It is also used to store XS functions that need to be present in + * miniperl for a lack of a better place to put them. It might be + * clever to move them to seperate XS files which would then be pulled + * in by some to-be-written build process. */ #include "EXTERN.h" @@ -31,98 +36,46 @@ * 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, - int len, int level) +STATIC bool +S_isa_lookup(pTHX_ HV *stash, const char * const name, const HV* const name_stash) { - AV* av; - GV* gv; - GV** gvp; - HV* hv = Nullhv; - SV* subgen = Nullsv; + dVAR; + AV* stash_linear_isa; + SV** svp; const char *hvname; + I32 items; /* 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; - - if (level > 100) - Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", - hvname); - - gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, 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; - } - } - else { - DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n", - hvname) ); - hv_clear(hv); - sv_setiv(subgen, PL_sub_generation); + return TRUE; + + 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))) + return TRUE; } - gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); - - if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { - if (!hv || !subgen) { - gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); - - gv = *gvp; - - if (SvTYPE(gv) != SVt_PVGV) - gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); - - if (!hv) - hv = GvHVn(gv); - if (!subgen) { - subgen = newSViv(PL_sub_generation); - GvSV(gv) = subgen; - } - } - if (hv) { - SV** svp = AvARRAY(av); - /* NOTE: No support for tied ISA */ - I32 items = AvFILLp(av) + 1; - while (items--) { - SV* const sv = *svp++; - HV* const basestash = gv_stashsv(sv, FALSE); - if (!basestash) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %"SVf" for @%s::ISA", - sv, hvname); - continue; - } - if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, - len, level + 1)) { - (void)hv_store(hv,name,len,&PL_sv_yes,0); - return &PL_sv_yes; - } - } - (void)hv_store(hv,name,len,&PL_sv_no,0); - } - } - return &PL_sv_no; + return FALSE; } /* @@ -130,9 +83,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,35 +93,92 @@ 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); + stash = gv_stashsv(sv, 0); } - name_stash = gv_stashpv(name, FALSE); + if (stash) { + HV * const name_stash = gv_stashpv(name, 0); + return isa_lookup(stash, name, name_stash); + } + else + return FALSE; - return (type && strEQ(type,name)) || - (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) - == &PL_sv_yes) - ? TRUE - : 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; + SV *methodname; + + 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_nolen(sv); + } + + if (strEQ(name,classname)) + return TRUE; + + PUSHMARK(SP); + XPUSHs(sv); + XPUSHs(sv_2mortal(newSVpv(name, 0))); + PUTBACK; + + methodname = sv_2mortal(newSVpvs("isa")); + /* ugly hack: use the SvSCREAM flag so S_method_common + * can figure out we're calling DOES() and not isa(), + * and report eventual errors correctly. --rgs */ + SvSCREAM_on(methodname); + call_sv(methodname, G_SCALAR | G_METHOD); + 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); @@ -199,15 +209,30 @@ XS(XS_Regexp_DESTROY); XS(XS_Internals_hash_seed); XS(XS_Internals_rehash_seed); XS(XS_Internals_HvREHASH); -XS(XS_utf8_SWASHGET_heavy); +XS(XS_Internals_inc_sub_generation); +XS(XS_re_is_regexp); +XS(XS_re_regname); +XS(XS_re_regnames); +XS(XS_re_regnames_count); +XS(XS_Tie_Hash_NamedCapture_FETCH); +XS(XS_Tie_Hash_NamedCapture_STORE); +XS(XS_Tie_Hash_NamedCapture_DELETE); +XS(XS_Tie_Hash_NamedCapture_CLEAR); +XS(XS_Tie_Hash_NamedCapture_EXISTS); +XS(XS_Tie_Hash_NamedCapture_FIRSTK); +XS(XS_Tie_Hash_NamedCapture_NEXTK); +XS(XS_Tie_Hash_NamedCapture_SCALAR); +XS(XS_Tie_Hash_NamedCapture_flags); 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 */ @@ -248,13 +273,27 @@ 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, "\\%"); - newXS("utf8::SWASHGET_heavy", XS_utf8_SWASHGET_heavy, 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_count", XS_re_regnames_count, file, ""); + newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file); + newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file); + newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file); + newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file); + newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file); + newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, file); + newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, file); + newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file); + newXS("Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, file); } XS(XS_UNIVERSAL_isa) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 2) Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)"); @@ -277,11 +316,13 @@ XS(XS_UNIVERSAL_isa) XS(XS_UNIVERSAL_can) { + dVAR; dXSARGS; SV *sv; const char *name; SV *rv; HV *pkg = NULL; + PERL_UNUSED_ARG(cv); if (items != 2) Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)"); @@ -303,7 +344,7 @@ XS(XS_UNIVERSAL_can) pkg = SvSTASH(sv); } else { - pkg = gv_stashsv(sv, FALSE); + pkg = gv_stashsv(sv, 0); } if (pkg) { @@ -316,14 +357,36 @@ XS(XS_UNIVERSAL_can) XSRETURN(1); } +XS(XS_UNIVERSAL_DOES) +{ + dVAR; + dXSARGS; + PERL_UNUSED_ARG(cv); + + 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; GV *gv; SV *sv; const char *undef; + PERL_UNUSED_ARG(cv); if (SvROK(ST(0))) { sv = (SV*)SvRV(ST(0)); @@ -332,18 +395,18 @@ XS(XS_UNIVERSAL_VERSION) pkg = SvSTASH(sv); } else { - pkg = gv_stashsv(ST(0), FALSE); + pkg = gv_stashsv(ST(0), 0); } - 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(); sv_setsv(nsv, sv); sv = nsv; if ( !sv_derived_from(sv, "version")) - upg_version(sv); - undef = Nullch; + upg_version(sv, FALSE); + undef = NULL; } else { sv = (SV*)&PL_sv_undef; @@ -368,20 +431,27 @@ XS(XS_UNIVERSAL_VERSION) if ( !sv_derived_from(req, "version")) { /* req may very well be R/O, so create a new object */ - SV * const nsv = sv_newmortal(); - sv_setsv(nsv, req); - req = nsv; - upg_version(req); + req = sv_2mortal( new_version(req) ); + } + + if ( vcmp( req, sv ) > 0 ) { + if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) { + Perl_croak(aTHX_ "%s version %"SVf" required--" + "this is only version %"SVf"", HvNAME_get(pkg), + SVfARG(vnormal(req)), + SVfARG(vnormal(sv))); + } else { + Perl_croak(aTHX_ "%s version %"SVf" required--" + "this is only version %"SVf"", HvNAME_get(pkg), + SVfARG(vstringify(req)), + SVfARG(vstringify(sv))); + } } - 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)); } if ( SvOK(sv) && sv_derived_from(sv, "version") ) { - ST(0) = vnumify(sv); + ST(0) = vstringify(sv); } else { ST(0) = sv; } @@ -391,7 +461,9 @@ XS(XS_UNIVERSAL_VERSION) XS(XS_version_new) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items > 3) Perl_croak(aTHX_ "Usage: version::new(class, version)"); SP -= items; @@ -403,17 +475,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(); @@ -422,7 +487,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; @@ -432,7 +497,9 @@ XS(XS_version_new) XS(XS_version_stringify) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)"); SP -= items; @@ -454,7 +521,9 @@ XS(XS_version_stringify) XS(XS_version_numify) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)"); SP -= items; @@ -476,7 +545,9 @@ XS(XS_version_numify) XS(XS_version_normal) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)"); SP -= items; @@ -498,7 +569,9 @@ XS(XS_version_normal) XS(XS_version_vcmp) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 1) Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)"); SP -= items; @@ -542,13 +615,15 @@ XS(XS_version_vcmp) XS(XS_version_boolean) { - dXSARGS; - if (items < 1) - Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)"); - SP -= items; + dVAR; + dXSARGS; + PERL_UNUSED_ARG(cv); + 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; @@ -559,7 +634,9 @@ XS(XS_version_boolean) 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")) @@ -573,7 +650,9 @@ XS(XS_version_noop) XS(XS_version_is_alpha) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)"); SP -= items; @@ -592,29 +671,19 @@ XS(XS_version_is_alpha) XS(XS_version_qv) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); 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 * const vs = sv_newmortal(); - char *version; - if ( SvNOK(ver) ) /* may get too much accuracy */ - { - char tbuf[64]; - const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); - version = savepvn(tbuf, len); - } - else - { - version = savesvpv(ver); - } - (void)scan_version(version,vs,TRUE); - Safefree(version); - - PUSHs(vs); + SV * const rv = sv_newmortal(); + sv_setsv(rv,ver); /* make a duplicate */ + upg_version(rv, TRUE); + PUSHs(rv); } else { @@ -628,7 +697,9 @@ XS(XS_version_qv) XS(XS_utf8_is_utf8) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); else { @@ -643,7 +714,9 @@ XS(XS_utf8_is_utf8) XS(XS_utf8_valid) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); else { @@ -660,7 +733,9 @@ XS(XS_utf8_valid) 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)); @@ -669,7 +744,9 @@ XS(XS_utf8_encode) XS(XS_utf8_decode) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::decode(sv)"); else { @@ -683,7 +760,9 @@ XS(XS_utf8_decode) XS(XS_utf8_upgrade) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); else { @@ -699,7 +778,9 @@ XS(XS_utf8_upgrade) 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 { @@ -715,8 +796,10 @@ XS(XS_utf8_downgrade) 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)"); @@ -727,8 +810,10 @@ XS(XS_utf8_native_to_unicode) 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)"); @@ -739,8 +824,10 @@ XS(XS_utf8_unicode_to_native) 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)) @@ -764,8 +851,10 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ 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. */ @@ -779,7 +868,9 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ XS(XS_Internals_hv_clear_placehold) { + dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)"); @@ -792,12 +883,15 @@ XS(XS_Internals_hv_clear_placehold) XS(XS_Regexp_DESTROY) { + PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(cv); } 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 @@ -853,7 +947,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))) { @@ -889,9 +983,11 @@ XS(XS_PerlIO_get_layers) else { if (namok && argok) XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", - *namsvp, *argsvp)); + SVfARG(*namsvp), + SVfARG(*argsvp))); else if (namok) - XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp)); + XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, + SVfARG(*namsvp))); else XPUSHs(&PL_sv_undef); nitem++; @@ -899,7 +995,7 @@ XS(XS_PerlIO_get_layers) const IV flags = SvIVX(*flgsvp); if (flags & PERLIO_F_UTF8) { - XPUSHs(newSVpvn("utf8", 4)); + XPUSHs(newSVpvs("utf8")); nitem++; } } @@ -918,6 +1014,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; @@ -928,6 +1025,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; @@ -938,7 +1036,9 @@ XS(XS_Internals_rehash_seed) 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) { @@ -951,414 +1051,386 @@ XS(XS_Internals_HvREHASH) /* Subject to change */ Perl_croak(aTHX_ "Internals::HvREHASH $hashref"); } -XS(XS_utf8_SWASHGET_heavy) +XS(XS_re_is_regexp) { + dVAR; dXSARGS; - if (items != 4) { - Perl_croak(aTHX_ - "Usage: utf8::SWASHGET_heavy($self, $start, $len, DEBUG)"); + PERL_UNUSED_VAR(cv); + + if (items != 1) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv"); + + SP -= items; + + if (SvRXOK(ST(0))) { + XSRETURN_YES; + } else { + XSRETURN_NO; } - { - SV* self = ST(0); - const I32 i_start = (I32)SvIV(ST(1)); - const I32 i_len = (I32)SvIV(ST(2)); - const I32 debug = (I32)SvIV(ST(3)); - U32 start = (U32)i_start; - U32 len = (U32)i_len; - - HV *hv; - SV **listsvp, **typesvp, **bitssvp, **nonesvp, **extssvp, *swatch; - U8 *l, *lend, *x, *xend, *s, *nextline; - STRLEN lcur, xcur, scur; - U8* typestr; - int typeto; - U32 bits, none, end, octets; - - if (SvROK(self) && SvTYPE(SvRV(self))==SVt_PVHV) - hv = (HV*)SvRV(self); - else - Perl_croak(aTHX_ "hv is not a hash reference"); - - if (i_start < 0) - Perl_croak(aTHX_ "SWASHGET negative start"); - if (i_len < 0) - Perl_croak(aTHX_ "SWASHGET negative len"); - - listsvp = hv_fetch(hv, "LIST", 4, FALSE); - typesvp = hv_fetch(hv, "TYPE", 4, FALSE); - bitssvp = hv_fetch(hv, "BITS", 4, FALSE); - nonesvp = hv_fetch(hv, "NONE", 4, FALSE); - extssvp = hv_fetch(hv, "EXTRAS", 6, FALSE); - typestr = SvPV_nolen(*typesvp); - typeto = typestr[0] == 'T' && typestr[1] == 'o'; - bits = (U32)SvUV(*bitssvp); - none = (U32)SvUV(*nonesvp); - end = start + len; - octets = bits >> 3; /* if bits == 1, then octets == 0 */ - - if (bits != 1 && bits != 8 && bits != 16 && bits != 32) { - Perl_croak(aTHX_ "SWASHGET unknown bits %"UVuf, (UV)bits); - } - if (debug) { - char* selfstr = SvPV_nolen(self); - PerlIO_printf(Perl_error_log, "SWASHGET "); - PerlIO_printf(Perl_error_log, "%s %"UVuf" %"UVuf" ", - selfstr, (UV)start, (UV)len); - PerlIO_printf(Perl_error_log, "[%s/%"UVuf"/%"UVuf"]\n", - typestr, (UV)bits, (UV)none); - } +} - /* initialize $swatch */ - swatch = newSVpvn("",0); - scur = octets ? (len * octets) : (len + 7) / 8; - SvGROW(swatch, scur + 1); - s = (U8*)SvPVX(swatch); - if (octets && none) { - const U8* e = s + scur; - while (s < e) { - if (bits == 8) - *s++ = (U8)(none & 0xff); - else if (bits == 16) { - *s++ = (U8)((none >> 8) & 0xff); - *s++ = (U8)( none & 0xff); - } - else if (bits == 32) { - *s++ = (U8)((none >> 24) & 0xff); - *s++ = (U8)((none >> 16) & 0xff); - *s++ = (U8)((none >> 8) & 0xff); - *s++ = (U8)( none & 0xff); - } - } - *s = '\0'; - } - else { - (void)memzero((U8*)s, scur + 1); - } - SvCUR_set(swatch, scur); - s = (U8*)SvPVX(swatch); - - /* read $self->{LIST} */ - l = (U8*)SvPV(*listsvp, lcur); - lend = l + lcur; - while (l < lend) { - U32 min, max, val, key; - STRLEN numlen; - I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX; - - nextline = (U8*)memchr(l, '\n', lend - l); - - numlen = lend - l; - min = (U32)grok_hex(l, &numlen, &flags, NULL); - if (numlen) - l += numlen; - else if (nextline) { - l = nextline + 1; /* 1 is length of "\n" */ - continue; - } - else { - l = lend; /* to the end of LIST, at which no \n */ - break; - } +XS(XS_re_regnames_count) +{ + REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + SV * ret; + dVAR; + dXSARGS; + PERL_UNUSED_ARG(cv); - if (isBLANK(*l)) { - ++l; - flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX; - numlen = lend - l; - max = (U32)grok_hex(l, &numlen, &flags, NULL); - if (numlen) - l += numlen; - else - max = min; - - if (octets) { - if (isBLANK(*l)) { - ++l; - flags = PERL_SCAN_SILENT_ILLDIGIT | - PERL_SCAN_DISALLOW_PREFIX; - numlen = lend - l; - val = (U32)grok_hex(l, &numlen, &flags, NULL); - if (numlen) - l += numlen; - else - val = 0; - } - else { - val = 0; - if (typeto) { - Perl_croak(aTHX_ "%s: illegal mapping '%s'", - typestr, l); - } - } - } - } - else { - max = min; - if (octets) { - val = 0; - if (typeto) { - Perl_croak(aTHX_ "%s: illegal mapping '%s'", - typestr, l); - } - } - } + if (items != 0) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", ""); - if (nextline) - l = nextline + 1; - else - l = lend; - - if (max < start) - continue; - - if (octets) { - if (debug) { - PerlIO_printf(Perl_error_log, - "%"UVuf" %"UVuf" %"UVuf"\n", - (UV)min, (UV)max, (UV)val); - } - if (min < start) { - if (!none || val < none) { - val += start - min; - } - min = start; - } - for (key = min; key <= max; key++) { - U32 offset; - if (key >= end) - goto go_out_list; - if (debug) { - PerlIO_printf(Perl_error_log, - "%"UVuf" => %"UVuf"\n", - (UV)key, (UV)val); - } - - /* offset must be non-negative (start <= min <= key < end) */ - offset = (key - start) * octets; - if (bits == 8) - s[offset] = (U8)(val & 0xff); - else if (bits == 16) { - s[offset ] = (U8)((val >> 8) & 0xff); - s[offset + 1] = (U8)( val & 0xff); - } - else if (bits == 32) { - s[offset ] = (U8)((val >> 24) & 0xff); - s[offset + 1] = (U8)((val >> 16) & 0xff); - s[offset + 2] = (U8)((val >> 8) & 0xff); - s[offset + 3] = (U8)( val & 0xff); - } - - if (!none || val < none) - ++val; - } - } - else { - if (min < start) - min = start; - for (key = min; key <= max; key++) { - U32 offset = key - start; - if (key >= end) - goto go_out_list; - if (debug) { - PerlIO_printf(Perl_error_log, - "%"UVuf" => 1\n", (UV)key); - } - s[offset >> 3] |= 1 << (offset & 7); - } - } - } - go_out_list: - - /* read $self->{EXTRAS} */ - x = (U8*)SvPV(*extssvp, xcur); - xend = x + xcur; - while (x < xend) { - STRLEN namelen; - U8 *namestr; - SV** othersvp; - U32 otherbits; - - U8 opc = *x++; - if (opc == '\n') - continue; - - nextline = (U8*)memchr(x, '\n', xend - x); - - if (opc != '-' && opc != '+' && opc != '!' && opc != '&') { - if (nextline) { - x = nextline + 1; - continue; - } - else { - x = xend; - break; - } - } + SP -= items; - namestr = x; + if (!rx) + XSRETURN_UNDEF; - if (nextline) { - namelen = nextline - namestr; - x = nextline + 1; - } - else { - namelen = xend - namestr; - x = xend; - } + ret = CALLREG_NAMED_BUFF_COUNT(rx); - if (debug) { - U8* tmpstr; - Newx(tmpstr, namelen + 1, U8); - Move(namestr, tmpstr, namelen, U8); - tmpstr[namelen] = '\0'; - PerlIO_printf(Perl_error_log, - "INDIRECT %c %s\n", opc, tmpstr); - Safefree(tmpstr); - } + SPAGAIN; - { - HV* otherhv; - SV **otherbitssvp; - - othersvp = hv_fetch(hv, namestr, namelen, FALSE); - if (*othersvp && SvROK(*othersvp) && - SvTYPE(SvRV(*othersvp))==SVt_PVHV) - otherhv = (HV*)SvRV(*othersvp); - else - Perl_croak(aTHX_ "otherhv is not a hash reference"); - - otherbitssvp = hv_fetch(otherhv, "BITS", 4, FALSE); - otherbits = (U32)SvUV(*otherbitssvp); - if (bits < otherbits) - Perl_croak(aTHX_ "SWASHGET size mismatch"); - } + if (ret) { + XPUSHs(ret); + PUTBACK; + return; + } else { + XSRETURN_UNDEF; + } +} - { - dSP; - ENTER; - SAVETMPS; - PUSHMARK(SP); - EXTEND(SP,3); - PUSHs(*othersvp); - PUSHs(sv_2mortal(newSViv(start))); - PUSHs(sv_2mortal(newSViv(len))); - PUTBACK; - if (call_method("SWASHGET", G_SCALAR)) { - U8 *s, *o; - STRLEN slen, olen; - SV* tmpsv = *PL_stack_sp--; - o = (U8*)SvPV(tmpsv, olen); - - if (!olen) - Perl_croak(aTHX_ "SWASHGET didn't return valid swatch"); - s = SvPV(swatch, slen); - if (bits == 1 && otherbits == 1) { - if (slen != olen) - Perl_croak(aTHX_ "SWASHGET length mismatch"); - - switch (opc) { - case '+': - while (slen--) - *s++ |= *o++; - break; - case '!': - while (slen--) - *s++ |= ~*o++; - break; - case '-': - while (slen--) - *s++ &= ~*o++; - break; - case '&': - while (slen--) - *s++ &= *o++; - break; - default: - break; - } - } - else { - U32 otheroctets = otherbits / 8; - U32 offset = 0; - U8* send = s + slen; - - while (s < send) { - U32 val = 0; - - if (otherbits == 1) { - val = (o[offset >> 3] >> (offset & 7)) & 1; - ++offset; - } - else { - U32 vlen = otheroctets; - val = *o++; - while (--vlen) { - val <<= 8; - val |= *o++; - } - } +XS(XS_re_regname) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + SV * ret; + PERL_UNUSED_ARG(cv); - if (opc == '+' && val) - val = 1; - else if (opc == '!' && !val) - val = 1; - else if (opc == '-' && val) - val = 0; - else if (opc == '&' && !val) - val = 0; - else { - s += octets; - continue; - } + if (items < 1 || items > 2) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]"); - if (bits == 8) - *s++ = (U8)( val & 0xff); - else if (bits == 16) { - *s++ = (U8)((val >> 8) & 0xff); - *s++ = (U8)( val & 0xff); - } - else if (bits == 32) { - *s++ = (U8)((val >> 24) & 0xff); - *s++ = (U8)((val >> 16) & 0xff); - *s++ = (U8)((val >> 8) & 0xff); - *s++ = (U8)( val & 0xff); - } - } - } - } - FREETMPS; - LEAVE; - } - } + SP -= items; - if (debug) { - U8* s = (U8*)SvPVX(swatch); - PerlIO_printf(Perl_error_log, "CELLS "); - if (bits == 1) { - U32 key; - for (key = 0; key < len; key++) { - int val = (s[key >> 3] >> (key & 7)) & 1; - PerlIO_printf(Perl_error_log, val ? "1 " : "0 "); - } - } - else { - U8* send = s + len * octets; - while (s < send) { - U32 vlen = octets; - U32 val = *s++; - while (--vlen) { - val <<= 8; - val |= *s++; - } - PerlIO_printf(Perl_error_log, "%"UVuf" ", (UV)val); - } - } - PerlIO_printf(Perl_error_log, "\n"); - } + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - ST(0) = swatch; - sv_2mortal(ST(0)); + if (!rx) + XSRETURN_UNDEF; + + if (items == 2 && SvTRUE(ST(1))) { + flags = RXapif_ALL; + } else { + flags = RXapif_ONE; } - XSRETURN(1); + ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME)); + + if (ret) { + if (SvROK(ret)) + XPUSHs(ret); + else + XPUSHs(SvREFCNT_inc(ret)); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + + +XS(XS_re_regnames) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + SV *ret; + AV *av; + I32 length; + I32 i; + SV **entry; + PERL_UNUSED_ARG(cv); + + if (items > 1) + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; + + if (items == 1 && SvTRUE(ST(0))) { + flags = RXapif_ALL; + } else { + flags = RXapif_ONE; + } + + SP -= items; + + ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES)); + + SPAGAIN; + + SP -= items; + + if (!ret) + XSRETURN_UNDEF; + + av = (AV*)SvRV(ret); + length = av_len(av); + + for (i = 0; i <= length; i++) { + entry = av_fetch(av, i, FALSE); + + if (!entry) + Perl_croak(aTHX_ "NULL array element in re::regnames()"); + + XPUSHs(*entry); + } + PUTBACK; + return; +} + +XS(XS_Tie_Hash_NamedCapture_FETCH) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + SV * ret; + PERL_UNUSED_ARG(cv); + + if (items != 2) + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $flags)"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; + + SP -= items; + + flags = (U32)INT2PTR(IV,SvIV(SvRV((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)); + PUTBACK; + return; + } + XSRETURN_UNDEF; +} + +XS(XS_Tie_Hash_NamedCapture_STORE) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + PERL_UNUSED_ARG(cv); + + if (items != 3) + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $value, $flags)"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) { + if (!PL_localizing) + Perl_croak(aTHX_ PL_no_modify); + else + XSRETURN_UNDEF; + } + + SP -= items; + + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags); +} + +XS(XS_Tie_Hash_NamedCapture_DELETE) +{ + dVAR; + dXSARGS; + REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + U32 flags; + PERL_UNUSED_ARG(cv); + + if (items != 2) + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::DELETE($key, $flags)"); + + if (!rx) + Perl_croak(aTHX_ PL_no_modify); + + SP -= items; + + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags); +} + +XS(XS_Tie_Hash_NamedCapture_CLEAR) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + PERL_UNUSED_ARG(cv); + + if (items != 1) + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::CLEAR($flags)"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + Perl_croak(aTHX_ PL_no_modify); + + SP -= items; + + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + CALLREG_NAMED_BUFF_CLEAR(rx, flags); +} + +XS(XS_Tie_Hash_NamedCapture_EXISTS) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + SV * ret; + PERL_UNUSED_ARG(cv); + + if (items != 2) + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::EXISTS($key, $flags)"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; + + SP -= items; + + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags); + + SPAGAIN; + + XPUSHs(ret); + PUTBACK; + return; +} + +XS(XS_Tie_Hash_NamedCapture_FIRSTK) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + SV * ret; + PERL_UNUSED_ARG(cv); + + if (items != 1) + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::FIRSTKEY()"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; + + SP -= items; + + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags); + + SPAGAIN; + + if (ret) { + XPUSHs(SvREFCNT_inc(ret)); + PUTBACK; + } else { + XSRETURN_UNDEF; + } + +} + +XS(XS_Tie_Hash_NamedCapture_NEXTK) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + SV * ret; + PERL_UNUSED_ARG(cv); + + if (items != 2) + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::NEXTKEY($lastkey)"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; + + SP -= items; + + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags); + + SPAGAIN; + + if (ret) { + XPUSHs(ret); + } else { + XSRETURN_UNDEF; + } + PUTBACK; +} + +XS(XS_Tie_Hash_NamedCapture_SCALAR) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + SV * ret; + PERL_UNUSED_ARG(cv); + + if (items != 1) + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::SCALAR()"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; + + SP -= items; + + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags); + + SPAGAIN; + + if (ret) { + XPUSHs(ret); + PUTBACK; + return; + } else { + XSRETURN_UNDEF; + } +} + +XS(XS_Tie_Hash_NamedCapture_flags) +{ + dVAR; + dXSARGS; + PERL_UNUSED_ARG(cv); + + if (items != 0) + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::flags()"); + + XPUSHs(sv_2mortal(newSVuv(RXapif_ONE))); + XPUSHs(sv_2mortal(newSVuv(RXapif_ALL))); + PUTBACK; + return; }