ext/re/t/lexical_debug.pl generate debug output for lexical re 'debug'
ext/re/t/lexical_debug.t test that lexical re 'debug' works
ext/re/t/qr.t test that qr// is a Regexp
-ext/re/t/re_funcs.t see if exportable funcs from re.pm work
+ext/re/t/re_funcs.t See if exportable 're' funcs in re.xs work
ext/re/t/regop.pl generate debug output for various patterns
ext/re/t/regop.t test RE optimizations by scraping debug output
ext/re/t/re.t see if re pragma works
t/op/reg_unsafe.t Check for unsafe match vars
t/op/repeat.t See if x operator works
t/op/reset.t See if reset operator works
+t/op/re.t See if exportable 're' funcs in universal.c work
t/op/re_tests Regular expressions for regexp.t
t/op/reverse.t See if reverse operator works
t/op/runlevel.t See if die() works from perl_call_*()
package Data::Dumper;
-$VERSION = '2.121_15';
+$VERSION = '2.121_16';
#$| = 1;
# regexp_pattern() in list context to get the modifiers separately.
# But since this means loading the full debugging engine in process we wont
# bother unless its necessary for accuracy.
- if ($realpack ne 'Regexp' and $] > 5.009005) {
- defined *re::regexp_pattern{CODE}
- or do { eval 'use re (regexp_pattern); 1' or die $@ };
+ if (($realpack ne 'Regexp') && defined(*re::regexp_pattern{CODE})) {
$pat = re::regexp_pattern($val);
} else {
$pat = "$val";
is($dt, $o, "package name in bless is escaped if needed");
is_deeply(scalar eval($dt), $t, "eval reverts dump");
}
-{
+SKIP: {
+ skip(q/no 're::regexp_pattern'/, 1)
+ if ! defined(*re::regexp_pattern{CODE});
+
my $t = bless( qr//, 'foo');
my $dt = Dumper($t);
my $o = <<'PERL';
use strict;
use warnings;
-our $VERSION = "0.08";
+our $VERSION = "0.09";
our @ISA = qw(Exporter);
-our @EXPORT_OK = qw(is_regexp regexp_pattern regmust
- regname regnames regnames_count);
+my @XS_FUNCTIONS = qw(regmust);
+my %XS_FUNCTIONS = map { $_ => 1 } @XS_FUNCTIONS;
+our @EXPORT_OK = (@XS_FUNCTIONS,
+ qw(is_regexp regexp_pattern
+ regname regnames regnames_count));
our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
# *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
last;
} elsif (exists $bitmask{$s}) {
$bits |= $bitmask{$s};
+ } elsif ($XS_FUNCTIONS{$s}) {
+ _do_install();
+ if (! $installed) {
+ require Carp;
+ Carp::croak("\"re\" function '$s' not available");
+ }
+ require Exporter;
+ re->export_to_level(2, 're', $s);
} elsif ($EXPORT_OK{$s}) {
- _do_install();
require Exporter;
re->export_to_level(2, 're', $s);
} else {
PL_colorset = 0; /* Allow reinspection of ENV. */
/* PL_debug |= DEBUG_r_FLAG; */
XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine))));
-
-
-void
-regexp_pattern(sv)
- SV * sv
-PROTOTYPE: $
-PREINIT:
- REGEXP *re;
-PPCODE:
-{
- /*
- Checks if a reference is a regex or not. If the parameter is
- not a ref, or is not the result of a qr// then returns false
- in scalar context and an empty list in list context.
- Otherwise in list context it returns the pattern and the
- modifiers, in scalar context it returns the pattern just as it
- would if the qr// was stringified normally, regardless as
- to the class of the variable and any strigification overloads
- on the object.
- */
-
- if ((re = SvRX(sv))) /* assign deliberate */
- {
- /* Housten, we have a regex! */
- SV *pattern;
- STRLEN patlen = 0;
- STRLEN left = 0;
- char reflags[6];
-
- if ( GIMME_V == G_ARRAY ) {
- /*
- we are in list context so stringify
- the modifiers that apply. We ignore "negative
- modifiers" in this scenario.
- */
-
- const char *fptr = INT_PAT_MODS;
- char ch;
- U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
- >> RXf_PMf_STD_PMMOD_SHIFT);
-
- while((ch = *fptr++)) {
- if(match_flags & 1) {
- reflags[left++] = ch;
- }
- match_flags >>= 1;
- }
-
- pattern = sv_2mortal(newSVpvn(RX_PRECOMP(re),RX_PRELEN(re)));
- if (RX_UTF8(re))
- SvUTF8_on(pattern);
-
- /* return the pattern and the modifiers */
- XPUSHs(pattern);
- XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
- XSRETURN(2);
- } else {
- /* Scalar, so use the string that Perl would return */
- /* return the pattern in (?msix:..) format */
-#if PERL_VERSION >= 11
- pattern = sv_2mortal(newSVsv((SV*)re));
-#else
- pattern = sv_2mortal(newSVpvn(RX_WRAPPED(re),RX_WRAPLEN(re)));
- if (RX_UTF8(re))
- SvUTF8_on(pattern);
-#endif
- XPUSHs(pattern);
- XSRETURN(1);
- }
- } else {
- /* It ain't a regexp folks */
- if ( GIMME_V == G_ARRAY ) {
- /* return the empty list */
- XSRETURN_UNDEF;
- } else {
- /* Because of the (?:..) wrapping involved in a
- stringified pattern it is impossible to get a
- result for a real regexp that would evaluate to
- false. Therefore we can return PL_sv_no to signify
- that the object is not a regex, this means that one
- can say
-
- if (regex($might_be_a_regex) eq '(?:foo)') { }
-
- and not worry about undefined values.
- */
- XSRETURN_NO;
- }
- }
- /* NOT-REACHED */
-}
-
void
regmust(sv)
use warnings;
use Test::More; # test count at bottom of file
-use re qw(is_regexp regexp_pattern regmust
- regname regnames regnames_count);
-{
- my $qr=qr/foo/pi;
- ok(is_regexp($qr),'is_regexp($qr)');
- ok(!is_regexp(''),'is_regexp("")');
- is((regexp_pattern($qr))[0],'foo','regexp_pattern[0]');
- is((regexp_pattern($qr))[1],'ip','regexp_pattern[1]');
- is(regexp_pattern($qr),'(?pi-xsm:foo)','scalar regexp_pattern');
- ok(!regexp_pattern(''),'!regexp_pattern("")');
-}
+use re qw(regmust);
{
my $qr=qr/here .* there/x;
my ($anchored,$floating)=regmust($qr);
is($anchored,undef,"Regmust anchored - ref");
is($floating,undef,"Regmust anchored - ref");
}
-
-if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){
- my @names = sort +regnames();
- is("@names","A B","regnames");
- @names = sort +regnames(0);
- is("@names","A B","regnames");
- my $names = regnames();
- is($names, "B", "regnames in scalar context");
- @names = sort +regnames(1);
- is("@names","A B C","regnames");
- is(join("", @{regname("A",1)}),"13");
- is(join("", @{regname("B",1)}),"24");
- {
- if ('foobar'=~/(?<foo>foo)(?<bar>bar)/) {
- is(regnames_count(),2);
- } else {
- ok(0); ok(0);
- }
- }
- is(regnames_count(),3);
-}
# New tests above this line, don't forget to update the test count below!
-use Test::More tests => 20;
+use Test::More tests => 6;
# No tests here!
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+use warnings;
+
+use Test::More; # test count at bottom of file
+use re qw(is_regexp regexp_pattern
+ regname regnames regnames_count);
+{
+ my $qr=qr/foo/pi;
+ ok(is_regexp($qr),'is_regexp($qr)');
+ ok(!is_regexp(''),'is_regexp("")');
+ is((regexp_pattern($qr))[0],'foo','regexp_pattern[0]');
+ is((regexp_pattern($qr))[1],'ip','regexp_pattern[1]');
+ is(regexp_pattern($qr),'(?pi-xsm:foo)','scalar regexp_pattern');
+ ok(!regexp_pattern(''),'!regexp_pattern("")');
+}
+
+if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){
+ my @names = sort +regnames();
+ is("@names","A B","regnames");
+ @names = sort +regnames(0);
+ is("@names","A B","regnames");
+ my $names = regnames();
+ is($names, "B", "regnames in scalar context");
+ @names = sort +regnames(1);
+ is("@names","A B C","regnames");
+ is(join("", @{regname("A",1)}),"13");
+ is(join("", @{regname("B",1)}),"24");
+ {
+ if ('foobar'=~/(?<foo>foo)(?<bar>bar)/) {
+ is(regnames_count(),2);
+ } else {
+ ok(0); ok(0);
+ }
+ }
+ is(regnames_count(),3);
+}
+# New tests above this line, don't forget to update the test count below!
+use Test::More tests => 14;
+# No tests here!
XS(XS_re_regname);
XS(XS_re_regnames);
XS(XS_re_regnames_count);
+XS(XS_re_regexp_pattern);
XS(XS_Tie_Hash_NamedCapture_FETCH);
XS(XS_Tie_Hash_NamedCapture_STORE);
XS(XS_Tie_Hash_NamedCapture_DELETE);
newXSproto("re::regname", XS_re_regname, file, ";$$");
newXSproto("re::regnames", XS_re_regnames, file, ";$");
newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
+ newXSproto("re::regexp_pattern", XS_re_regexp_pattern, 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);
return;
}
+XS(XS_re_regexp_pattern)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP *re;
+ PERL_UNUSED_ARG(cv);
+
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: %s(%s)", "re::regexp_pattern", "sv");
+
+ SP -= items;
+
+ /*
+ Checks if a reference is a regex or not. If the parameter is
+ not a ref, or is not the result of a qr// then returns false
+ in scalar context and an empty list in list context.
+ Otherwise in list context it returns the pattern and the
+ modifiers, in scalar context it returns the pattern just as it
+ would if the qr// was stringified normally, regardless as
+ to the class of the variable and any strigification overloads
+ on the object.
+ */
+
+ if ((re = SvRX(ST(0)))) /* assign deliberate */
+ {
+ /* Housten, we have a regex! */
+ SV *pattern;
+ STRLEN left = 0;
+ char reflags[6];
+
+ if ( GIMME_V == G_ARRAY ) {
+ /*
+ we are in list context so stringify
+ the modifiers that apply. We ignore "negative
+ modifiers" in this scenario.
+ */
+
+ const char *fptr = INT_PAT_MODS;
+ char ch;
+ U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
+ >> RXf_PMf_STD_PMMOD_SHIFT);
+
+ while((ch = *fptr++)) {
+ if(match_flags & 1) {
+ reflags[left++] = ch;
+ }
+ match_flags >>= 1;
+ }
+
+ pattern = sv_2mortal(newSVpvn(RX_PRECOMP(re),RX_PRELEN(re)));
+ if (RX_UTF8(re))
+ SvUTF8_on(pattern);
+
+ /* return the pattern and the modifiers */
+ XPUSHs(pattern);
+ XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
+ XSRETURN(2);
+ } else {
+ /* Scalar, so use the string that Perl would return */
+ /* return the pattern in (?msix:..) format */
+#if PERL_VERSION >= 11
+ pattern = sv_2mortal(newSVsv((SV*)re));
+#else
+ pattern = sv_2mortal(newSVpvn(RX_WRAPPED(re),RX_WRAPLEN(re)));
+ if (RX_UTF8(re))
+ SvUTF8_on(pattern);
+#endif
+ XPUSHs(pattern);
+ XSRETURN(1);
+ }
+ } else {
+ /* It ain't a regexp folks */
+ if ( GIMME_V == G_ARRAY ) {
+ /* return the empty list */
+ XSRETURN_UNDEF;
+ } else {
+ /* Because of the (?:..) wrapping involved in a
+ stringified pattern it is impossible to get a
+ result for a real regexp that would evaluate to
+ false. Therefore we can return PL_sv_no to signify
+ that the object is not a regex, this means that one
+ can say
+
+ if (regex($might_be_a_regex) eq '(?:foo)') { }
+
+ and not worry about undefined values.
+ */
+ XSRETURN_NO;
+ }
+ }
+ /* NOT-REACHED */
+}
+
XS(XS_Tie_Hash_NamedCapture_FETCH)
{
dVAR;
projects / p5sagit/p5-mst-13.2.git / commitdiff