From: Yves Orton Date: Wed, 7 Mar 2007 20:44:52 +0000 (+0100) Subject: Re: [PATCH] Tweaks so that miniperl.exe doesnt croak while building perl.exe X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=803059618a6e90fb614193e8cdf81c79f27d8764;p=p5sagit%2Fp5-mst-13.2.git Re: [PATCH] Tweaks so that miniperl.exe doesnt croak while building perl.exe Message-ID: <9b18b3110703071144t787e028s8a79fa1986624b54@mail.gmail.com> p4raw-id: //depot/perl@30517 --- diff --git a/MANIFEST b/MANIFEST index 429f9c1..72e2f73 100644 --- a/MANIFEST +++ b/MANIFEST @@ -977,7 +977,6 @@ ext/POSIX/t/time.t See if POSIX time-related functions work ext/POSIX/t/waitpid.t See if waitpid works ext/POSIX/typemap POSIX extension interface types ext/re/hints/mpeix.pl Hints for re for named architecture -ext/re/lib/re/Tie/Hash/NamedCapture.pm Implements %- and %+ behaviour ext/re/Makefile.PL re extension makefile writer ext/re/re_comp.h re extension wrapper for regcomp.h ext/re/re.pm re extension Perl module @@ -2488,6 +2487,7 @@ lib/Pod/t/user.t See if Pod::LaTeX works lib/Pod/t/utils.t Test for Pod::ParseUtils lib/Pod/Usage.pm Pod-Parser - print usage messages lib/pwd.pl Routines to keep track of PWD environment variable +lib/Tie/Hash/NamedCapture.pm Implements %- and %+ behaviour lib/Search/Dict.pm Perform binary search on dictionaries lib/Search/Dict.t See if Search::Dict works lib/SelectSaver.pm Enforce proper select scoping @@ -3629,6 +3629,7 @@ t/op/regexp_qr.t See if regular expressions work as qr// t/op/regexp.t See if regular expressions work t/op/regexp_trielist.t See if regular expressions work with trie optimisation t/op/regexp_email.t See if regex recursion works by parsing email addresses +t/op/regexp_namedcapture.t Make sure glob assignment doesn't break named capture t/op/regmesg.t See if one can get regular expression errors t/op/repeat.t See if x operator works t/op/re_tests Regular expressions for regexp.t diff --git a/embed.fnc b/embed.fnc index c6a3e08..0ee575f 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1839,6 +1839,7 @@ AMdnoP |int |Perl_signbit |NV f #endif XEMop |void |emulate_cop_io |NN const COP *const c|NN SV *const sv +XEMop |regexp *|get_re_arg|NULLOK SV *sv|U32 flags|NULLOK MAGIC **mgp END_EXTERN_C /* diff --git a/ext/re/re.xs b/ext/re/re.xs index 185fc74..7b3e9fb 100644 --- a/ext/re/re.xs +++ b/ext/re/re.xs @@ -75,21 +75,6 @@ install() void -is_regexp(sv) - SV * sv -PROTOTYPE: $ -PPCODE: -{ - if ( get_re_arg( aTHX_ sv, 0, NULL ) ) - { - XSRETURN_YES; - } else { - XSRETURN_NO; - } - /* NOTREACHED */ -} - -void regexp_pattern(sv) SV * sv PROTOTYPE: $ @@ -204,150 +189,3 @@ PPCODE: XSRETURN_UNDEF; } -void -regname(sv, qr = NULL, all = NULL) - SV * sv - SV * qr - SV * all -PROTOTYPE: ;$$$ -PREINIT: - regexp *re = NULL; - SV *bufs = NULL; -PPCODE: -{ - re = 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; -} - -void -regnames(sv = NULL, all = NULL) - SV *sv - SV *all -PROTOTYPE: ;$$ -PREINIT: - regexp *re = NULL; - IV count = 0; -PPCODE: -{ - re = 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; -} - -void -regnames_iterinit(sv = NULL) - SV * sv -PROTOTYPE: ;$ -PREINIT: - regexp *re = NULL; -PPCODE: -{ - re = 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; - } -} - -void -regnames_iternext(sv = NULL, all = NULL) - SV *sv - SV *all -PROTOTYPE: ;$$ -PREINIT: - regexp *re; -PPCODE: -{ - re = 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; -} - -void -regnames_count(sv = NULL) - SV * sv -PROTOTYPE: ;$ -PREINIT: - regexp *re = NULL; -PPCODE: -{ - re = get_re_arg( aTHX_ sv, 1, NULL ); - if (re && re->paren_names) { - XPUSHs(newSViv(HvTOTALKEYS(re->paren_names))); - } else { - XSRETURN_UNDEF; - } -} diff --git a/ext/re/t/re_funcs.t b/ext/re/t/re_funcs.t index 6ac33d6..6bdafcb 100644 --- a/ext/re/t/re_funcs.t +++ b/ext/re/t/re_funcs.t @@ -72,10 +72,10 @@ if ('1234'=~/(?:(?\d)|(?!))(?\d)(?\d)(?\d)/){ } { use warnings; - require re::Tie::Hash::NamedCapture; + require Tie::Hash::NamedCapture; my $qr = qr/(?foo)/; if ( 'foo' =~ /$qr/ ) { - tie my %hash,"re::Tie::Hash::NamedCapture",re => $qr; + tie my %hash,"Tie::Hash::NamedCapture",re => $qr; if ('bar'=~/bar/) { # last successful match is now different is($hash{foo},'foo'); # prints foo diff --git a/global.sym b/global.sym index 6c8c8a0..7e05c3b 100644 --- a/global.sym +++ b/global.sym @@ -738,4 +738,5 @@ Perl_my_strlcat Perl_my_strlcpy Perl_signbit Perl_emulate_cop_io +Perl_get_re_arg # ex: set ro: diff --git a/gv.c b/gv.c index f0f2145..da1d3a6 100644 --- a/gv.c +++ b/gv.c @@ -1004,7 +1004,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (*name == '!') require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); else if (*name == '-' || *name == '+') - require_tie_mod(gv, name, newSVpvs("re::Tie::Hash::NamedCapture"), "FETCH", 0); + require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0); } } return gv; @@ -1198,6 +1198,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* magicalization must be done before require_tie_mod is called */ if (sv_type == SVt_PVHV) require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); + /* NOTE: Errno.pm does the tieing of %! itself when it is executed. + This is different to the way %+ and %- are handled. */ break; case '-': @@ -1205,7 +1207,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, GvMULTI_on(gv); /* no used once warnings here */ { bool plus = (*name == '+'); - SV *stashname = newSVpvs("re::Tie::Hash::NamedCapture"); + SV *stashname = newSVpvs("Tie::Hash::NamedCapture"); AV* const av = GvAVn(gv); HV *const hv = GvHVn(gv); HV *const hv_tie = newHV(); @@ -1215,7 +1217,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, hv_magic(hv, (GV*)tie, PERL_MAGIC_tied); sv_magic((SV*)av, (plus ? (SV*)av : NULL), PERL_MAGIC_regdata, NULL, 0); sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); - + + /* NOTE: Tie::Hash::NamedCapture does NOT do the tie of %- or %+ itself. + This is different to the way %! is handled. */ if (plus) SvREADONLY_on(GvSVn(gv)); else @@ -1224,13 +1228,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, SvREADONLY_on(hv); SvREADONLY_on(tie); SvREADONLY_on(av); - - if (sv_type == SVt_PVHV) - require_tie_mod(gv, name, stashname, "FETCH", 0); - else - SvREFCNT_dec(stashname); - - break; + + require_tie_mod(gv, name, stashname, "FETCH", 0); + + break; } case '*': case '#': diff --git a/ext/re/lib/re/Tie/Hash/NamedCapture.pm b/lib/Tie/Hash/NamedCapture.pm similarity index 76% rename from ext/re/lib/re/Tie/Hash/NamedCapture.pm rename to lib/Tie/Hash/NamedCapture.pm index 75bf1aa..950adca 100644 --- a/ext/re/lib/re/Tie/Hash/NamedCapture.pm +++ b/lib/Tie/Hash/NamedCapture.pm @@ -1,23 +1,15 @@ -package re::Tie::Hash::NamedCapture; +package Tie::Hash::NamedCapture; use strict; use warnings; -our $VERSION = "0.02"; - -no re 'debug'; -use re qw(is_regexp - regname - regnames - regnames_count - regnames_iterinit - regnames_iternext); +our $VERSION = "0.03"; sub TIEHASH { my $classname = shift; my $hash = {@_}; - if ($hash->{re} && !is_regexp($hash->{re})) { + if ($hash->{re} && !re::is_regexp($hash->{re})) { die "'re' parameter to ",__PACKAGE__,"->TIEHASH must be a qr//" } @@ -25,7 +17,7 @@ sub TIEHASH { } sub FETCH { - return regname($_[1],$_[0]->{re},$_[0]->{all}); + return re::regname($_[1],$_[0]->{re},$_[0]->{all}); } sub STORE { @@ -34,16 +26,16 @@ sub STORE { } sub FIRSTKEY { - regnames_iterinit($_[0]->{re}); + re::regnames_iterinit($_[0]->{re}); return $_[0]->NEXTKEY; } sub NEXTKEY { - return regnames_iternext($_[0]->{re},$_[0]->{all}); + return re::regnames_iternext($_[0]->{re},$_[0]->{all}); } sub EXISTS { - return defined regname( $_[1], $_[0]->{re},$_[0]->{all}); + return defined re::regname( $_[1], $_[0]->{re},$_[0]->{all}); } sub DELETE { @@ -57,7 +49,7 @@ sub CLEAR { } sub SCALAR { - return scalar regnames($_[0]->{re},$_[0]->{all}); + return scalar re::regnames($_[0]->{re},$_[0]->{all}); } 1; @@ -66,14 +58,14 @@ __END__ =head1 NAME -re::Tie::Hash::NamedCapture - Named regexp capture buffers +Tie::Hash::NamedCapture - Named regexp capture buffers =head1 SYNOPSIS - tie my %hash, "re::Tie::Hash::NamedCapture"; + tie my %hash, "Tie::Hash::NamedCapture"; # %hash now behaves like %+ - tie my %hash, "re::Tie::Hash::NamedCapture", re => $qr, all => 1; + tie my %hash, "Tie::Hash::NamedCapture", re => $qr, all => 1; # %hash now access buffers from regexp in $qr like %- =head1 DESCRIPTION @@ -107,7 +99,7 @@ For instance: my $qr = qr/(?bar)/; if ( 'bar' =~ $qr ) { - tie my %hash, "re::Tie::Hash::NamedCapture", re => $qr; + tie my %hash, "Tie::Hash::NamedCapture", re => $qr; print $+{foo}; # prints "bar" print $hash{foo}; # prints "bar" too if ( 'bar' =~ /bar/ ) { diff --git a/pod/perl595delta.pod b/pod/perl595delta.pod index d072d5f..cc7ea80 100644 --- a/pod/perl595delta.pod +++ b/pod/perl595delta.pod @@ -109,7 +109,7 @@ holding values from all capture buffers similarly named, if there should be many of them. C<%+> and C<%-> are implemented as tied hashes through the new module -C. +C. Users exposed to the .NET regex engine will find that the perl implementation differs in that the numerical ordering of the buffers diff --git a/pod/perlvar.pod b/pod/perlvar.pod index f5b098b..f39ac7d 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -352,7 +352,7 @@ The keys of the C<%+> hash list only the names of buffers that have captured (and that are thus associated to defined values). The underlying behaviour of C<%+> is provided by the -L module. +L module. B C<%-> and C<%+> are tied views into a common internal hash associated with the last successful regular expression. Therefore mixing @@ -649,7 +649,7 @@ The keys of the C<%-> hash correspond to all buffer names found in the regular expression. The behaviour of C<%-> is implemented via the -L module. +L module. B C<%-> and C<%+> are tied views into a common internal hash associated with the last successful regular expression. Therefore mixing diff --git a/proto.h b/proto.h index 339ecca..25dc06a 100644 --- a/proto.h +++ b/proto.h @@ -4610,6 +4610,7 @@ PERL_CALLCONV void Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); +PERL_CALLCONV regexp * Perl_get_re_arg(pTHX_ SV *sv, U32 flags, MAGIC **mgp); END_EXTERN_C /* diff --git a/t/op/regexp_namedcapture.t b/t/op/regexp_namedcapture.t new file mode 100644 index 0000000..d2db2d7 --- /dev/null +++ b/t/op/regexp_namedcapture.t @@ -0,0 +1,13 @@ +#!./perl +# +# Tests to make sure the regexp engine doesn't run into limits too soon. +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..1\n"; +*X = *-; +print eval '*X{HASH}{X} || 1' ? "ok\n" :"not ok\n"; diff --git a/universal.c b/universal.c index 4cbda94..69c31f1 100644 --- a/universal.c +++ b/universal.c @@ -220,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); @@ -254,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) @@ -306,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, ";$"); } @@ -1098,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