X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=69c31f159029b35649f312fc321917c1c9ac7391;hb=25ff0154ccf606eb5512a8cde622caf50e20fba3;hp=98efe0f8692d6d395f4a83addc00e205c2781a42;hpb=96a5add60f1f39d38341c09c11f0542e68f782b0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/universal.c b/universal.c index 98efe0f..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. @@ -31,8 +31,8 @@ * 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; @@ -45,16 +45,16 @@ 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'", @@ -62,16 +62,19 @@ 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) ); - 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 { @@ -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,24 +109,23 @@ 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", - sv, hvname); + SVfARG(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; } /* @@ -131,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 */ @@ -155,22 +157,92 @@ 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); - return isa_lookup(stash, name, name_stash, strlen(name), 0) == &PL_sv_yes; + HV * const name_stash = gv_stashpv(name, 0); + 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; +} + +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); PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); XS(XS_version_new); XS(XS_version_stringify); @@ -202,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) @@ -211,6 +289,7 @@ Perl_boot_core_UNIVERSAL(pTHX) 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 */ @@ -253,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, ";$"); } @@ -260,6 +345,7 @@ XS(XS_UNIVERSAL_isa) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 2) Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)"); @@ -288,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)"); @@ -309,7 +396,7 @@ XS(XS_UNIVERSAL_can) pkg = SvSTASH(sv); } else { - pkg = gv_stashsv(sv, FALSE); + pkg = gv_stashsv(sv, 0); } if (pkg) { @@ -322,6 +409,26 @@ 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; @@ -331,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)); @@ -339,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; @@ -383,8 +491,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), + SVfARG(vnumify(req)), + SVfARG(vnormal(req)), + SVfARG(vnumify(sv)), + SVfARG(vnormal(sv))); } if ( SvOK(sv) && sv_derived_from(sv, "version") ) { @@ -400,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; @@ -411,17 +523,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(); @@ -430,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; @@ -442,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; @@ -465,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; @@ -488,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; @@ -511,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; @@ -556,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; @@ -574,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")) @@ -589,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; @@ -609,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; @@ -620,7 +733,14 @@ 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)); +#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 @@ -646,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 { @@ -662,6 +783,7 @@ XS(XS_utf8_valid) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); else { @@ -680,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)); @@ -690,6 +813,7 @@ XS(XS_utf8_decode) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::decode(sv)"); else { @@ -705,6 +829,7 @@ XS(XS_utf8_upgrade) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items != 1) Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); else { @@ -722,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 { @@ -740,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)"); @@ -753,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)"); @@ -766,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)) @@ -792,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. */ @@ -807,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)"); @@ -827,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 @@ -918,9 +1050,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++; @@ -971,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) { @@ -995,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