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

MANIFEST

@@ -990,6 +990,7 @@ ext/re/re_top.h			re extension symbol hiding header
 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/regop.pl		generate debug output for various patterns
 ext/re/t/regop.t		test RE optimizations by scraping debug output
@@ -3753,6 +3754,7 @@ t/op/recurse.t			See if deep recursion works
 t/op/ref.t			See if refs and objects work
 t/op/regexp_email.t		See if regex recursion works by parsing email addresses
 t/op/regexp_namedcapture.t	Make sure glob assignment doesn't break named capture
+t/op/regexp_nc_tie.t	        Test the tied methods of Tie::Hash::NamedCapture
 t/op/regexp_noamp.t		See if regular expressions work with optimizations
 t/op/regexp_notrie.t		See if regular expressions work without trie optimisation
 t/op/regexp_pmod.t		See if regexp /p modifier works as expected

embed.fnc

@@ -694,7 +694,16 @@ Ap	|I32	|regexec_flags	|NN REGEXP * const rx|NN char* stringarg \
 				|NN SV* screamer|NULLOK void* data|U32 flags
 ApR	|regnode*|regnext	|NN regnode* p
 
-EXp	|SV*|reg_named_buff_fetch	|NN REGEXP * const rx|NN SV * const key|const U32 flags
+EXp |SV*|reg_named_buff          |NN REGEXP * const rx|NULLOK SV * const key \
+                                 |NULLOK SV * const value|const U32 flags
+EXp |SV*|reg_named_buff_iter     |NN REGEXP * const rx|NULLOK const SV * const lastkey \
+                                 |const U32 flags
+Ap |SV*|reg_named_buff_fetch    |NN REGEXP * const rx|NN SV * const namesv|const U32 flags
+Ap |bool|reg_named_buff_exists  |NN REGEXP * const rx|NN SV * const key|const U32 flags
+Ap |SV*|reg_named_buff_firstkey |NN REGEXP * const rx|const U32 flags
+Ap |SV*|reg_named_buff_nextkey  |NN REGEXP * const rx|const U32 flags
+Ap |SV*|reg_named_buff_scalar   |NN REGEXP * const rx|const U32 flags
+Ap |SV*|reg_named_buff_all      |NN REGEXP * const rx|const U32 flags
 
 EXp	|void|reg_numbered_buff_fetch|NN REGEXP * const rx|const I32 paren|NULLOK SV * const sv
 EXp	|void|reg_numbered_buff_store|NN REGEXP * const rx|const I32 paren|NULLOK SV const * const value

embed.h

@@ -704,8 +704,15 @@
 #define regexec_flags		Perl_regexec_flags
 #define regnext			Perl_regnext
 #if defined(PERL_CORE) || defined(PERL_EXT)
-#define reg_named_buff_fetch	Perl_reg_named_buff_fetch
+#define reg_named_buff		Perl_reg_named_buff
+#define reg_named_buff_iter	Perl_reg_named_buff_iter
 #endif
+#define reg_named_buff_fetch	Perl_reg_named_buff_fetch
+#define reg_named_buff_exists	Perl_reg_named_buff_exists
+#define reg_named_buff_firstkey	Perl_reg_named_buff_firstkey
+#define reg_named_buff_nextkey	Perl_reg_named_buff_nextkey
+#define reg_named_buff_scalar	Perl_reg_named_buff_scalar
+#define reg_named_buff_all	Perl_reg_named_buff_all
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define reg_numbered_buff_fetch	Perl_reg_numbered_buff_fetch
 #define reg_numbered_buff_store	Perl_reg_numbered_buff_store
@@ -2980,8 +2987,15 @@
 #define regexec_flags(a,b,c,d,e,f,g,h)	Perl_regexec_flags(aTHX_ a,b,c,d,e,f,g,h)
 #define regnext(a)		Perl_regnext(aTHX_ a)
 #if defined(PERL_CORE) || defined(PERL_EXT)
-#define reg_named_buff_fetch(a,b,c)	Perl_reg_named_buff_fetch(aTHX_ a,b,c)
+#define reg_named_buff(a,b,c,d)	Perl_reg_named_buff(aTHX_ a,b,c,d)
+#define reg_named_buff_iter(a,b,c)	Perl_reg_named_buff_iter(aTHX_ a,b,c)
 #endif
+#define reg_named_buff_fetch(a,b,c)	Perl_reg_named_buff_fetch(aTHX_ a,b,c)
+#define reg_named_buff_exists(a,b,c)	Perl_reg_named_buff_exists(aTHX_ a,b,c)
+#define reg_named_buff_firstkey(a,b)	Perl_reg_named_buff_firstkey(aTHX_ a,b)
+#define reg_named_buff_nextkey(a,b)	Perl_reg_named_buff_nextkey(aTHX_ a,b)
+#define reg_named_buff_scalar(a,b)	Perl_reg_named_buff_scalar(aTHX_ a,b)
+#define reg_named_buff_all(a,b)	Perl_reg_named_buff_all(aTHX_ a,b)
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define reg_numbered_buff_fetch(a,b,c)	Perl_reg_numbered_buff_fetch(aTHX_ a,b,c)
 #define reg_numbered_buff_store(a,b,c)	Perl_reg_numbered_buff_store(aTHX_ a,b,c)

ext/B/t/concise-xs.t

@@ -117,9 +117,9 @@ use Getopt::Std;
 use Carp;
 use Test::More tests => ( # per-pkg tests (function ct + require_ok)
 			  40 + 16	# Data::Dumper, Digest::MD5
-			  + 517 + 262	# B::Deparse, B
+			  + 517 + 276	# B::Deparse, B
 			  + 595 + 190	# POSIX, IO::Socket
-			  - 6);		# fudge
+			  - 20);		# fudge
 
 require_ok("B::Concise");
 

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

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 

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

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" );

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!

global.sym

@@ -405,7 +405,14 @@ Perl_re_intuit_start
 Perl_re_intuit_string
 Perl_regexec_flags
 Perl_regnext
+Perl_reg_named_buff
+Perl_reg_named_buff_iter
 Perl_reg_named_buff_fetch
+Perl_reg_named_buff_exists
+Perl_reg_named_buff_firstkey
+Perl_reg_named_buff_nextkey
+Perl_reg_named_buff_scalar
+Perl_reg_named_buff_all
 Perl_reg_numbered_buff_fetch
 Perl_reg_numbered_buff_store
 Perl_reg_numbered_buff_length

gv.c

@@ -1014,7 +1014,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	        if (*name == '!')
 		    require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
 		else if (*name == '-' || *name == '+')
-		    require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
+		    require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
 	    }
 	}
 	return gv;
@@ -1224,7 +1224,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
             SvREADONLY_on(av);
 
             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
-                require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
+                require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
 
             break;
 	}

lib/Tie/Hash/NamedCapture.pm

@@ -1,52 +1,17 @@
 package Tie::Hash::NamedCapture;
 
-use strict;
-use warnings;
+our $VERSION = "0.06";
 
-our $VERSION = "0.05";
+# The real meat implemented in XS in universal.c in the core, but this
+# method was left behind because gv.c expects a Purl-Perl method in
+# this package when it loads the tie magic for %+ and %-
 
-sub TIEHASH {
-    my $classname = shift;
-    my %opts = @_;
-
-    my $self = bless { all => $opts{all} }, $classname;
-    return $self;
-}
-
-sub FETCH {
-    return re::regname($_[1],$_[0]->{all});
-}
-
-sub STORE {
-    require Carp;
-    Carp::croak("STORE forbidden: hashes tied to ",__PACKAGE__," are read-only.");
-}
-
-sub FIRSTKEY {
-    re::regnames_iterinit();
-    return $_[0]->NEXTKEY;
-}
+my ($one, $all) = Tie::Hash::NamedCapture::flags();
 
-sub NEXTKEY {
-    return re::regnames_iternext($_[0]->{all});
-}
-
-sub EXISTS {
-    return defined re::regname( $_[1], $_[0]->{all});
-}
-
-sub DELETE {
-    require Carp;
-    Carp::croak("DELETE forbidden: hashes tied to ",__PACKAGE__," are read-only");
-}
-
-sub CLEAR {
-    require Carp;
-    Carp::croak("CLEAR forbidden: hashes tied to ",__PACKAGE__," are read-only");
-}
-
-sub SCALAR {
-    return scalar re::regnames($_[0]->{all});
+sub TIEHASH {
+    my ($pkg, %arg) = @_;
+    my $flag = $arg{all} ? $all : $one;
+    bless \$flag => $pkg;
 }
 
 tie %+, __PACKAGE__;
@@ -91,6 +56,7 @@ buffers that have captured (and that are thus associated to defined values).
 
 =head1 SEE ALSO
 
-L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">, L<perlvar/"%-">.
+L<perlreapi>, L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">,
+L<perlvar/"%-">.
 
 =cut

mg.c

@@ -603,15 +603,15 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
     }
     case '`':
       do_prematch:
-      paren = -2;
+      paren = RXf_PREMATCH;
       goto maybegetparen;
     case '\'':
       do_postmatch:
-      paren = -1;
+      paren = RXf_POSTMATCH;
       goto maybegetparen;
     case '&':
       do_match:
-      paren = 0;
+      paren = RXf_MATCH;
       goto maybegetparen;
     case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9':
@@ -2235,15 +2235,15 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
           goto do_match;
     case '`': /* ${^PREMATCH} caught below */
       do_prematch:
-      paren = -2;
+      paren = RXf_PREMATCH;
       goto setparen;
     case '\'': /* ${^POSTMATCH} caught below */
       do_postmatch:
-      paren = -1;
+      paren = RXf_POSTMATCH;
       goto setparen;
     case '&':
       do_match:
-      paren = 0;
+      paren = RXf_MATCH;
       goto setparen;
     case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9':

perl.h

@@ -228,8 +228,35 @@
 #define CALLREG_NUMBUF_LENGTH(rx,sv,paren)                              \
     CALL_FPTR((rx)->engine->numbered_buff_LENGTH)(aTHX_ (rx),(sv),(paren))
 
-#define CALLREG_NAMEDBUF_FETCH(rx,name,flags) \
-    CALL_FPTR((rx)->engine->named_buff_FETCH)(aTHX_ (rx),(name),(flags))
+#define CALLREG_NAMED_BUFF_FETCH(rx, key, flags) \
+    CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), (key), NULL, ((flags) | RXf_HASH_FETCH))
+
+#define CALLREG_NAMED_BUFF_STORE(rx, key, value, flags) \
+    CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), (key), (value), ((flags) | RXf_HASH_STORE))
+
+#define CALLREG_NAMED_BUFF_DELETE(rx, key, flags) \
+    CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx),(key), NULL, ((flags) | RXf_HASH_DELETE))
+
+#define CALLREG_NAMED_BUFF_CLEAR(rx, flags) \
+    CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), NULL, NULL, ((flags) | RXf_HASH_CLEAR))
+
+#define CALLREG_NAMED_BUFF_EXISTS(rx, key, flags) \
+    CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), (key), NULL, ((flags) | RXf_HASH_EXISTS))
+
+#define CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags) \
+    CALL_FPTR((rx)->engine->named_buff_iter)(aTHX_ (rx), NULL, ((flags) | RXf_HASH_FIRSTKEY))
+
+#define CALLREG_NAMED_BUFF_NEXTKEY(rx, lastkey, flags) \
+    CALL_FPTR((rx)->engine->named_buff_iter)(aTHX_ (rx), (lastkey), ((flags) | RXf_HASH_NEXTKEY))
+
+#define CALLREG_NAMED_BUFF_SCALAR(rx, flags) \
+    CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), NULL, NULL, ((flags) | RXf_HASH_SCALAR))
+
+#define CALLREG_NAMED_BUFF_COUNT(rx) \
+    CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), NULL, NULL, RXf_HASH_REGNAMES_COUNT)
+
+#define CALLREG_NAMED_BUFF_ALL(rx, flags) \
+    CALL_FPTR((rx)->engine->named_buff)(aTHX_ (rx), NULL, NULL, flags)
 
 #define CALLREG_PACKAGE(rx) \
     CALL_FPTR((rx)->engine->qr_package)(aTHX_ (rx))