From: Jerry D. Hedden Date: Tue, 8 Jan 2008 15:01:02 +0000 (-0500) Subject: Move re::regexp_pattern to universal.c X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=192c1e277b50bfcbfdd3717ce2ae7c1a42fa9601;p=p5sagit%2Fp5-mst-13.2.git Move re::regexp_pattern to universal.c From: "Jerry D. Hedden" Message-ID: <1ff86f510801081201q5c36f055re6165ebfe8876c2e@mail.gmail.com> p4raw-id: //depot/perl@32911 --- diff --git a/MANIFEST b/MANIFEST index 4e9c6ea..d09923c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -999,7 +999,7 @@ ext/re/re.xs re extension external subroutines 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 @@ -3900,6 +3900,7 @@ t/op/reg_pmod.t See if regexp /p modifier works as expected 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_*() diff --git a/ext/Data/Dumper/Dumper.pm b/ext/Data/Dumper/Dumper.pm index 462884f..d1a3a0f 100644 --- a/ext/Data/Dumper/Dumper.pm +++ b/ext/Data/Dumper/Dumper.pm @@ -9,7 +9,7 @@ package Data::Dumper; -$VERSION = '2.121_15'; +$VERSION = '2.121_16'; #$| = 1; @@ -367,9 +367,7 @@ sub _dump { # 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"; diff --git a/ext/Data/Dumper/t/bless.t b/ext/Data/Dumper/t/bless.t index 5dc3e86..1716d14 100644 --- a/ext/Data/Dumper/t/bless.t +++ b/ext/Data/Dumper/t/bless.t @@ -37,7 +37,10 @@ PERL 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'; diff --git a/ext/re/re.pm b/ext/re/re.pm index 0cf5376..0c49746 100644 --- a/ext/re/re.pm +++ b/ext/re/re.pm @@ -4,10 +4,13 @@ package re; 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 *** @@ -142,8 +145,15 @@ sub bits { 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 { diff --git a/ext/re/re.xs b/ext/re/re.xs index ccf8ca0..484de25 100644 --- a/ext/re/re.xs +++ b/ext/re/re.xs @@ -69,98 +69,6 @@ install() 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) diff --git a/ext/re/t/re_funcs.t b/ext/re/t/re_funcs.t index c03fce1..e618171 100644 --- a/ext/re/t/re_funcs.t +++ b/ext/re/t/re_funcs.t @@ -14,17 +14,7 @@ use strict; 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); @@ -39,27 +29,6 @@ use re qw(is_regexp regexp_pattern regmust is($anchored,undef,"Regmust anchored - ref"); is($floating,undef,"Regmust anchored - ref"); } - -if ('1234'=~/(?:(?\d)|(?!))(?\d)(?\d)(?\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)(?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! diff --git a/t/op/re.t b/t/op/re.t new file mode 100644 index 0000000..d098bdc --- /dev/null +++ b/t/op/re.t @@ -0,0 +1,46 @@ +#!./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'=~/(?:(?\d)|(?!))(?\d)(?\d)(?\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)(?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! diff --git a/universal.c b/universal.c index a6b3f6e..c835286 100644 --- a/universal.c +++ b/universal.c @@ -214,6 +214,7 @@ XS(XS_re_is_regexp); 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); @@ -277,6 +278,7 @@ Perl_boot_core_UNIVERSAL(pTHX) 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); @@ -1187,6 +1189,99 @@ XS(XS_re_regnames) 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;