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
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
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
#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
/*
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: $
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;
- }
-}
}
{
use warnings;
- require re::Tie::Hash::NamedCapture;
+ require Tie::Hash::NamedCapture;
my $qr = qr/(?<foo>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
Perl_my_strlcpy
Perl_signbit
Perl_emulate_cop_io
+Perl_get_re_arg
# ex: set ro:
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;
/* 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 '-':
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();
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
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 '#':
-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//"
}
}
sub FETCH {
- return regname($_[1],$_[0]->{re},$_[0]->{all});
+ return re::regname($_[1],$_[0]->{re},$_[0]->{all});
}
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 {
}
sub SCALAR {
- return scalar regnames($_[0]->{re},$_[0]->{all});
+ return scalar re::regnames($_[0]->{re},$_[0]->{all});
}
1;
=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
my $qr = qr/(?<foo>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/ ) {
be many of them.
C<%+> and C<%-> are implemented as tied hashes through the new module
-C<re::Tie::Hash::NamedCapture>.
+C<Tie::Hash::NamedCapture>.
Users exposed to the .NET regex engine will find that the perl
implementation differs in that the numerical ordering of the buffers
captured (and that are thus associated to defined values).
The underlying behaviour of C<%+> is provided by the
-L<re::Tie::Hash::NamedCapture> module.
+L<Tie::Hash::NamedCapture> module.
B<Note:> C<%-> and C<%+> are tied views into a common internal hash
associated with the last successful regular expression. Therefore mixing
the regular expression.
The behaviour of C<%-> is implemented via the
-L<re::Tie::Hash::NamedCapture> module.
+L<Tie::Hash::NamedCapture> module.
B<Note:> C<%-> and C<%+> are tied views into a common internal hash
associated with the last successful regular expression. Therefore mixing
__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
/*
--- /dev/null
+#!./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";
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);
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)
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, ";$");
}
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
projects / p5sagit/p5-mst-13.2.git / commitdiff