Move re::regexp_pattern to universal.c

From: "Jerry D. Hedden" <jdhedden@cpan.org>
Message-ID: <1ff86f510801081201q5c36f055re6165ebfe8876c2e@mail.gmail.com>

p4raw-id: //depot/perl@32911

3 files changed, 16 insertions, 129 deletions

diff --git a/ext/re/re.pm b/ext/re/re.pm
index 0cf5376e86..0c4974645f 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 ccf8ca01aa..484de25cc9 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 c03fce18ab..e618171996 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'=~/(?:(?<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!