Re: [PATCH] Callbacks for named captures (%+ and %-)

From: "Ævar Arnfjörð Bjarmason" <avarab@gmail.com>
Message-ID: <51dd1af80706031324y5618d519p460da27a2e7fe712@mail.gmail.com>

p4raw-id: //depot/perl@31341

5 files changed, 30 insertions, 29 deletions

diff --git a/ext/re/re.pm b/ext/re/re.pm
index e06602da33..61e373ef18 100644
--- a/ext/re/re.pm
+++ b/ext/re/re.pm
@@ -7,8 +7,7 @@ use warnings;
 our $VERSION     = "0.08";
 our @ISA         = qw(Exporter);
 our @EXPORT_OK   = qw(is_regexp regexp_pattern regmust 
-                      regname regnames 
-                      regnames_count regnames_iterinit regnames_iternext);
+                      regname regnames regnames_count);
 our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
 
 # *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
@@ -485,18 +484,6 @@ Returns a list of all of the named buffers defined in the last successful
 match. If $all is true, then it returns all names defined, if not it returns
 only names which were involved in the match.
 
-=item regnames_iterinit()
-
-Initializes the internal hash iterator associated to the last successful
-matches named capture buffers.
-
-=item regnames_iternext($all)
-
-Gets the next key from the named capture buffer hash associated with the
-last successful match. If $all is true returns the keys of all of the
-distinct named buffers in the pattern, if not returns only those names
-used in the last successful match.
-
 =item regnames_count()
 
 Returns the number of distinct names defined in the pattern used
diff --git a/ext/re/re.xs b/ext/re/re.xs
index 13440659d0..2e93400ffe 100644
--- a/ext/re/re.xs
+++ b/ext/re/re.xs
@@ -30,8 +30,10 @@ extern void	my_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
 extern I32	my_reg_numbered_buff_length(pTHX_ REGEXP * const rx,
 					    const SV * const sv, const I32 paren);
 
-extern SV*	my_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const key,
-					const U32 flags);
+extern SV*	my_reg_named_buff(pTHX_ REGEXP * const, SV * const, SV * const,
+                              const U32);
+extern SV*	my_reg_named_buff_iter(pTHX_ REGEXP * const rx,
+                                   const SV * const lastkey, const U32 flags);
 
 extern SV*      my_reg_qr_package(pTHX_ REGEXP * const rx);
 #if defined(USE_ITHREADS)
@@ -51,7 +53,8 @@ const struct regexp_engine my_reg_engine = {
         my_reg_numbered_buff_fetch,
         my_reg_numbered_buff_store,
         my_reg_numbered_buff_length,
-        my_reg_named_buff_fetch,
+        my_reg_named_buff,
+        my_reg_named_buff_iter,
         my_reg_qr_package,
 #if defined(USE_ITHREADS)
         my_regdupe 
diff --git a/ext/re/re_top.h b/ext/re/re_top.h
index 5570ed7d8f..23782677f1 100644
--- a/ext/re/re_top.h
+++ b/ext/re/re_top.h
@@ -19,7 +19,8 @@
 #define Perl_reg_numbered_buff_fetch  my_reg_numbered_buff_fetch
 #define Perl_reg_numbered_buff_store  my_reg_numbered_buff_store
 #define Perl_reg_numbered_buff_length  my_reg_numbered_buff_length
-#define Perl_reg_named_buff_fetch  my_reg_named_buff_fetch
+#define Perl_reg_named_buff      my_reg_named_buff
+#define Perl_reg_named_buff_iter my_reg_named_buff_iter
 #define Perl_reg_qr_package        my_reg_qr_package
 
 #define PERL_NO_GET_CONTEXT
diff --git a/ext/re/t/qr.t b/ext/re/t/qr.t
new file mode 100644
index 0000000000..9a59a046bd
--- /dev/null
+++ b/ext/re/t/qr.t
@@ -0,0 +1,15 @@
+#!./perl
+
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+	require Config;
+	if (($Config::Config{'extensions'} !~ /\bre\b/) ){
+        	print "1..0 # Skip -- Perl configured without re module\n";
+		exit 0;
+	}
+}
+
+use Test::More tests => 1;
+use re 'Debug';
+isa_ok( qr//, "Regexp" );
diff --git a/ext/re/t/re_funcs.t b/ext/re/t/re_funcs.t
index 0d9092aa64..97f795eac9 100644
--- a/ext/re/t/re_funcs.t
+++ b/ext/re/t/re_funcs.t
@@ -14,8 +14,7 @@ use strict;
 
 use Test::More; # test count at bottom of file
 use re qw(is_regexp regexp_pattern regmust 
-          regname regnames regnames_count 
-          regnames_iterinit regnames_iternext);
+          regname regnames regnames_count);
 {
     my $qr=qr/foo/pi;
     ok(is_regexp($qr),'is_regexp($qr)');
@@ -40,23 +39,19 @@ use re qw(is_regexp regexp_pattern regmust
     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");
+    my @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)/) {
-            regnames_iterinit();
-            my @res;
-            while (defined(my $key=regnames_iternext)) {
-                push @res,$key;
-            }
-            @res=sort @res;
-            is("@res","bar foo");
             is(regnames_count(),2);
         } else {
             ok(0); ok(0);
@@ -65,5 +60,5 @@ if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){
     is(regnames_count(),3);
 }    
 # New tests above this line, don't forget to update the test count below!
-use Test::More tests => 19;
+use Test::More tests => 20;
 # No tests here!