Move re::regexp_pattern to universal.c
authorJerry D. Hedden <jdhedden@cpan.org>
Tue, 8 Jan 2008 15:01:02 +0000 (10:01 -0500)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Wed, 9 Jan 2008 10:54:27 +0000 (10:54 +0000)
From: "Jerry D. Hedden" <jdhedden@cpan.org>
Message-ID: <1ff86f510801081201q5c36f055re6165ebfe8876c2e@mail.gmail.com>

p4raw-id: //depot/perl@32911

MANIFEST
ext/Data/Dumper/Dumper.pm
ext/Data/Dumper/t/bless.t
ext/re/re.pm
ext/re/re.xs
ext/re/t/re_funcs.t
t/op/re.t [new file with mode: 0644]
universal.c

index 4e9c6ea..d09923c 100644 (file)
--- 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_*()
index 462884f..d1a3a0f 100644 (file)
@@ -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";
index 5dc3e86..1716d14 100644 (file)
@@ -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';
index 0cf5376..0c49746 100644 (file)
@@ -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 {
index ccf8ca0..484de25 100644 (file)
@@ -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)
index c03fce1..e618171 100644 (file)
@@ -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'=~/(?:(?<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!
diff --git a/t/op/re.t b/t/op/re.t
new file mode 100644 (file)
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'=~/(?:(?<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!
index a6b3f6e..c835286 100644 (file)
@@ -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;