1 diff --git a/embed.fnc b/embed.fnc
2 index fec5643..643c652 100644
5 @@ -694,7 +694,15 @@ Ap |I32 |regexec_flags |NN REGEXP * const rx|NN char* stringarg \
6 |NN SV* screamer|NULLOK void* data|U32 flags
7 ApR |regnode*|regnext |NN regnode* p
9 -EXp |SV*|reg_named_buff_fetch |NN REGEXP * const rx|NN SV * const key|const U32 flags
10 +EXp |SV*|reg_named_buff_fetch |NN REGEXP * const rx|NN SV * const namesv|const U32 flags
11 +EXp |void|reg_named_buff_store |NN REGEXP * const rx|NN SV * const key \
12 + |NN SV * const value|const U32 flags
13 +EXp |void|reg_named_buff_delete |NN REGEXP * const rx|NN SV * const key|const U32 flags
14 +EXp |void|reg_named_buff_clear |NN REGEXP * const rx|const U32 flags
15 +EXp |bool|reg_named_buff_exists |NN REGEXP * const rx|NN SV * const key|const U32 flags
16 +EXp |SV*|reg_named_buff_firstkey |NN REGEXP * const rx|const U32 flags
17 +EXp |SV*|reg_named_buff_nextkey |NN REGEXP * const rx|NN SV * const lastkey|const U32 flags
18 +EXp |SV*|reg_named_buff_scalar |NN REGEXP * const rx|const U32 flags
20 EXp |void|reg_numbered_buff_fetch|NN REGEXP * const rx|const I32 paren|NULLOK SV * const sv
21 EXp |void|reg_numbered_buff_store|NN REGEXP * const rx|const I32 paren|NULLOK SV const * const value
22 diff --git a/embed.h b/embed.h
23 index 8e0ecba..aa0aa72 100644
27 #define regnext Perl_regnext
28 #if defined(PERL_CORE) || defined(PERL_EXT)
29 #define reg_named_buff_fetch Perl_reg_named_buff_fetch
30 +#define reg_named_buff_store Perl_reg_named_buff_store
31 +#define reg_named_buff_delete Perl_reg_named_buff_delete
32 +#define reg_named_buff_clear Perl_reg_named_buff_clear
33 +#define reg_named_buff_exists Perl_reg_named_buff_exists
34 +#define reg_named_buff_firstkey Perl_reg_named_buff_firstkey
35 +#define reg_named_buff_nextkey Perl_reg_named_buff_nextkey
36 +#define reg_named_buff_scalar Perl_reg_named_buff_scalar
38 #if defined(PERL_CORE) || defined(PERL_EXT)
39 #define reg_numbered_buff_fetch Perl_reg_numbered_buff_fetch
40 @@ -2981,6 +2988,13 @@
41 #define regnext(a) Perl_regnext(aTHX_ a)
42 #if defined(PERL_CORE) || defined(PERL_EXT)
43 #define reg_named_buff_fetch(a,b,c) Perl_reg_named_buff_fetch(aTHX_ a,b,c)
44 +#define reg_named_buff_store(a,b,c,d) Perl_reg_named_buff_store(aTHX_ a,b,c,d)
45 +#define reg_named_buff_delete(a,b,c) Perl_reg_named_buff_delete(aTHX_ a,b,c)
46 +#define reg_named_buff_clear(a,b) Perl_reg_named_buff_clear(aTHX_ a,b)
47 +#define reg_named_buff_exists(a,b,c) Perl_reg_named_buff_exists(aTHX_ a,b,c)
48 +#define reg_named_buff_firstkey(a,b) Perl_reg_named_buff_firstkey(aTHX_ a,b)
49 +#define reg_named_buff_nextkey(a,b,c) Perl_reg_named_buff_nextkey(aTHX_ a,b,c)
50 +#define reg_named_buff_scalar(a,b) Perl_reg_named_buff_scalar(aTHX_ a,b)
52 #if defined(PERL_CORE) || defined(PERL_EXT)
53 #define reg_numbered_buff_fetch(a,b,c) Perl_reg_numbered_buff_fetch(aTHX_ a,b,c)
54 diff --git a/ext/re/re.xs b/ext/re/re.xs
55 index 1344065..fe59940 100644
58 @@ -30,8 +30,22 @@ extern void my_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
59 extern I32 my_reg_numbered_buff_length(pTHX_ REGEXP * const rx,
60 const SV * const sv, const I32 paren);
62 -extern SV* my_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const key,
64 +extern SV* my_reg_named_buff_fetch(pTHX_ REGEXP * const, SV * const,
66 +extern void my_reg_named_buff_store(pTHX_ REGEXP * const rx,
67 + SV * const key, SV * const value,
69 +extern void my_reg_named_buff_delete(pTHX_ REGEXP * const rx,
70 + SV * const key, const U32 flags);
71 +extern void my_reg_named_buff_clear(pTHX_ REGEXP * const rx, const U32 flags);
72 +extern bool my_reg_named_buff_exists(pTHX_ REGEXP * const rx,
73 + SV * const key, const U32 flags);
74 +extern SV* my_reg_named_buff_firstkey(pTHX_ REGEXP * const rx,
76 +extern SV* my_reg_named_buff_nextkey(pTHX_ REGEXP * const rx,
77 + SV * const lastkey, const U32 flags);
78 +extern SV* my_reg_named_buff_scalar(pTHX_ REGEXP * const rx,
81 extern SV* my_reg_qr_package(pTHX_ REGEXP * const rx);
82 #if defined(USE_ITHREADS)
83 @@ -52,6 +66,13 @@ const struct regexp_engine my_reg_engine = {
84 my_reg_numbered_buff_store,
85 my_reg_numbered_buff_length,
86 my_reg_named_buff_fetch,
87 + my_reg_named_buff_store,
88 + my_reg_named_buff_delete,
89 + my_reg_named_buff_clear,
90 + my_reg_named_buff_exists,
91 + my_reg_named_buff_firstkey,
92 + my_reg_named_buff_nextkey,
93 + my_reg_named_buff_scalar,
95 #if defined(USE_ITHREADS)
97 diff --git a/ext/re/re_top.h b/ext/re/re_top.h
98 index 5570ed7..23ee654 100644
100 +++ b/ext/re/re_top.h
102 #define Perl_reg_numbered_buff_store my_reg_numbered_buff_store
103 #define Perl_reg_numbered_buff_length my_reg_numbered_buff_length
104 #define Perl_reg_named_buff_fetch my_reg_named_buff_fetch
105 +#define Perl_reg_named_buff_store my_reg_named_buff_store
106 +#define Perl_reg_named_buff_delete my_reg_named_buff_delete
107 +#define Perl_reg_named_buff_clear my_reg_named_buff_clear
108 +#define Perl_reg_named_buff_exists my_reg_named_buff_exists
109 +#define Perl_reg_named_buff_firstkey my_reg_named_buff_firstkey
110 +#define Perl_reg_named_buff_nextkey my_reg_named_buff_nextkey
111 +#define Perl_reg_named_buff_scalar my_reg_named_buff_scalar
112 #define Perl_reg_qr_package my_reg_qr_package
114 #define PERL_NO_GET_CONTEXT
115 diff --git a/ext/re/t/re_funcs.t b/ext/re/t/re_funcs.t
116 index 0d9092a..fa3e11b 100644
117 --- a/ext/re/t/re_funcs.t
118 +++ b/ext/re/t/re_funcs.t
119 @@ -40,23 +40,17 @@ use re qw(is_regexp regexp_pattern regmust
120 is($floating,undef,"Regmust anchored - ref");
124 if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){
125 my @names = sort +regnames();
126 is("@names","A B","regnames");
127 + my @names = sort +regnames(0);
128 + is("@names","A B","regnames");
129 @names = sort +regnames(1);
130 is("@names","A B C","regnames");
131 is(join("", @{regname("A",1)}),"13");
132 is(join("", @{regname("B",1)}),"24");
134 if ('foobar'=~/(?<foo>foo)(?<bar>bar)/) {
135 - regnames_iterinit();
137 - while (defined(my $key=regnames_iternext)) {
141 - is("@res","bar foo");
142 is(regnames_count(),2);
145 diff --git a/global.sym b/global.sym
146 index c5181b4..0714bff 100644
149 @@ -406,6 +406,13 @@ Perl_re_intuit_string
152 Perl_reg_named_buff_fetch
153 +Perl_reg_named_buff_store
154 +Perl_reg_named_buff_delete
155 +Perl_reg_named_buff_clear
156 +Perl_reg_named_buff_exists
157 +Perl_reg_named_buff_firstkey
158 +Perl_reg_named_buff_nextkey
159 +Perl_reg_named_buff_scalar
160 Perl_reg_numbered_buff_fetch
161 Perl_reg_numbered_buff_store
162 Perl_reg_numbered_buff_length
163 diff --git a/gv.c b/gv.c
164 index 17f754f..8f98f00 100644
167 @@ -1014,7 +1014,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
169 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
170 else if (*name == '-' || *name == '+')
171 - require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
172 + require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
176 @@ -1224,7 +1224,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
179 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
180 - require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
181 + require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
185 diff --git a/lib/Tie/Hash/NamedCapture.pm b/lib/Tie/Hash/NamedCapture.pm
186 index 73bc20b..66cf1b5 100644
187 --- a/lib/Tie/Hash/NamedCapture.pm
188 +++ b/lib/Tie/Hash/NamedCapture.pm
190 package Tie::Hash::NamedCapture;
194 +our $VERSION = "0.06";
196 -our $VERSION = "0.05";
197 +# The real meat implemented in XS in universal.c in the core, but this
198 +# method was left behind because gv.c expects a Purl-Perl method in
199 +# this package when it loads the tie magic for %+ and %-
202 - my $classname = shift;
205 - my $self = bless { all => $opts{all} }, $classname;
210 - return re::regname($_[1],$_[0]->{all});
215 - Carp::croak("STORE forbidden: hashes tied to ",__PACKAGE__," are read-only.");
219 - re::regnames_iterinit();
220 - return $_[0]->NEXTKEY;
222 +# These should match the #defines in regexp.h
223 +sub RXf_HASH_ONE () { 0x00000001 } # %+
224 +sub RXf_HASH_ALL () { 0x00000002 } # %-
227 - return re::regnames_iternext($_[0]->{all});
231 - return defined re::regname( $_[1], $_[0]->{all});
236 - Carp::croak("DELETE forbidden: hashes tied to ",__PACKAGE__," are read-only");
241 - Carp::croak("CLEAR forbidden: hashes tied to ",__PACKAGE__," are read-only");
245 - return scalar re::regnames($_[0]->{all});
247 + my ($pkg, %arg) = @_;
248 + my $flag = $arg{all} ? RXf_HASH_ALL : RXf_HASH_ONE;
249 + bless \$flag => $pkg;
253 @@ -91,6 +58,7 @@ buffers that have captured (and that are thus associated to defined values).
257 -L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">, L<perlvar/"%-">.
258 +L<perlreapi>, L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">,
262 diff --git a/mg.c b/mg.c
263 index 77ae021..bc08d4a 100644
266 @@ -603,15 +603,15 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
271 + paren = RXrf_PREMATCH;
276 + paren = RXrf_POSTMATCH;
281 + paren = RXrf_MATCH;
283 case '1': case '2': case '3': case '4':
284 case '5': case '6': case '7': case '8': case '9':
285 @@ -2235,15 +2235,15 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
287 case '`': /* ${^PREMATCH} caught below */
290 + paren = RXrf_PREMATCH;
292 case '\'': /* ${^POSTMATCH} caught below */
295 + paren = RXrf_POSTMATCH;
300 + paren = RXrf_MATCH;
302 case '1': case '2': case '3': case '4':
303 case '5': case '6': case '7': case '8': case '9':
304 diff --git a/perl.h b/perl.h
305 index 8cd8753..0a4aebf 100644
309 #define CALLREG_NAMEDBUF_FETCH(rx,name,flags) \
310 CALL_FPTR((rx)->engine->named_buff_FETCH)(aTHX_ (rx),(name),(flags))
312 +#define CALLREG_NAMEDBUF_STORE(rx,key,value,flags) \
313 + CALL_FPTR((rx)->engine->named_buff_STORE)(aTHX_ (rx),(key),(value),(flags))
315 +#define CALLREG_NAMEDBUF_DELETE(rx,key,flags) \
316 + CALL_FPTR((rx)->engine->named_buff_DELETE)(aTHX_ (rx),(key),(flags))
318 +#define CALLREG_NAMEDBUF_CLEAR(rx,flags) \
319 + CALL_FPTR((rx)->engine->named_buff_CLEAR)(aTHX_ (rx),(flags))
321 +#define CALLREG_NAMEDBUF_EXISTS(rx,key,flags) \
322 + CALL_FPTR((rx)->engine->named_buff_EXISTS)(aTHX_ (rx),(key),(flags))
324 +#define CALLREG_NAMEDBUF_FIRSTKEY(rx,flags) \
325 + CALL_FPTR((rx)->engine->named_buff_FIRSTKEY)(aTHX_ (rx),(flags))
327 +#define CALLREG_NAMEDBUF_NEXTKEY(rx,lastkey,flags) \
328 + CALL_FPTR((rx)->engine->named_buff_NEXTKEY)(aTHX_ (rx),(lastkey),(flags))
330 +#define CALLREG_NAMEDBUF_SCALAR(rx,flags) \
331 + CALL_FPTR((rx)->engine->named_buff_SCALAR)(aTHX_ (rx),(flags))
333 #define CALLREG_PACKAGE(rx) \
334 CALL_FPTR((rx)->engine->qr_package)(aTHX_ (rx))
336 diff --git a/pod/perlreapi.pod b/pod/perlreapi.pod
337 index 1a170ff..08ae8cd 100644
338 --- a/pod/perlreapi.pod
339 +++ b/pod/perlreapi.pod
340 @@ -26,6 +26,18 @@ structure of the following format:
342 SV* (*named_buff_FETCH) (pTHX_ REGEXP * const rx, SV * const sv,
344 + void (*named_buff_STORE) (pTHX_ REGEXP * const rx, SV * const key,
345 + SV * const value, const U32 flags);
346 + void (*named_buff_DELETE) (pTHX_ REGEXP * const rx,
347 + SV * const key, const U32 flags);
348 + void (*named_buff_CLEAR) (pTHX_ REGEXP * const rx, const U32 flags);
349 + bool (*named_buff_EXISTS) (pTHX_ REGEXP * const rx,
350 + SV * const key, const U32 flags);
351 + SV* (*named_buff_FIRSTKEY) (pTHX_ REGEXP * const rx, const U32 flags);
352 + SV* (*named_buff_NEXTKEY) (pTHX_ REGEXP * const rx,
353 + SV * const lastkey, const U32 flags);
354 + SV* (*named_buff_SCALAR) (pTHX_ REGEXP * const rx,
356 SV* (*qr_package)(pTHX_ REGEXP * const rx);
358 void* (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
359 @@ -186,38 +198,45 @@ can release any resources pointed to by the C<pprivate> member of the
360 regexp structure. This is only responsible for freeing private data;
361 perl will handle releasing anything else contained in the regexp structure.
363 -=head2 numbered_buff_FETCH
364 +=head2 Numbered capture callbacks
366 - void numbered_buff_FETCH(pTHX_ REGEXP * const rx, const I32 paren,
369 -Called to get the value of C<$`>, C<$'>, C<$&> (and their named
370 -equivalents, see L<perlvar>) and the numbered capture buffers (C<$1>,
372 +Called to get/set the value of C<$`>, C<$'>, C<$&> and their named
373 +equivalents, ${^PREMATCH}, ${^POSTMATCH} and $^{MATCH}, as well as the
374 +numbered capture buffers (C<$1>, C<$2>, ...).
376 The C<paren> paramater will be C<-2> for C<$`>, C<-1> for C<$'>, C<0>
377 for C<$&>, C<1> for C<$1> and so forth.
379 -C<sv> should be set to the scalar to return, the scalar is passed as
380 -an argument rather than being returned from the function because when
381 -it's called perl already has a scalar to store the value, creating
382 -another one would be redundant. The scalar can be set with
383 -C<sv_setsv>, C<sv_setpvn> and friends, see L<perlapi>.
384 +The names have been chosen by analogy with L<Tie::Scalar> methods
385 +names with an additional B<LENGTH> callback for efficiency. However
386 +named capture variables are currently not tied internally but
387 +implemented via magic.
389 +=head3 numbered_buff_FETCH
391 + void numbered_buff_FETCH(pTHX_ REGEXP * const rx, const I32 paren,
394 +Fetch a specified numbered capture. C<sv> should be set to the scalar
395 +to return, the scalar is passed as an argument rather than being
396 +returned from the function because when it's called perl already has a
397 +scalar to store the value, creating another one would be
398 +redundant. The scalar can be set with C<sv_setsv>, C<sv_setpvn> and
399 +friends, see L<perlapi>.
401 This callback is where perl untaints its own capture variables under
402 taint mode (see L<perlsec>). See the C<Perl_reg_numbered_buff_get>
403 function in F<regcomp.c> for how to untaint capture variables if
404 that's something you'd like your engine to do as well.
406 -=head2 numbered_buff_STORE
407 +=head3 numbered_buff_STORE
409 void (*numbered_buff_STORE) (pTHX_ REGEXP * const rx, const I32 paren,
410 SV const * const value);
412 -Called to set the value of a numbered capture variable. C<paren> is
413 -the paren number (see the L<mapping|/numbered_buff_FETCH> above) and
414 -C<value> is the scalar that is to be used as the new value. It's up to
415 -the engine to make sure this is used as the new value (or reject it).
416 +Set the value of a numbered capture variable. C<value> is the scalar
417 +that is to be used as the new value. It's up to the engine to make
418 +sure this is used as the new value (or reject it).
422 @@ -262,19 +281,19 @@ behave in the same situation:
424 Because C<$sv> is C<undef> when the C<y///> operator is applied to it
425 the transliteration won't actually execute and the program won't
426 -C<die>. This is different to how 5.8 behaved since the capture
427 -variables were READONLY variables then, now they'll just die on
428 -assignment in the default engine.
429 +C<die>. This is different to how 5.8 and earlier versions behaved
430 +since the capture variables were READONLY variables then, now they'll
431 +just die when assigned to in the default engine.
433 -=head2 numbered_buff_LENGTH
434 +=head3 numbered_buff_LENGTH
436 I32 numbered_buff_LENGTH (pTHX_ REGEXP * const rx, const SV * const sv,
439 Get the C<length> of a capture variable. There's a special callback
440 for this so that perl doesn't have to do a FETCH and run C<length> on
441 -the result, since the length is (in perl's case) known from a memory
442 -offset this is much more efficient:
443 +the result, since the length is (in perl's case) known from an offset
444 +stored in C<<rx->offs> this is much more efficient:
446 I32 s1 = rx->offs[paren].start;
447 I32 s2 = rx->offs[paren].end;
448 @@ -284,14 +303,79 @@ This is a little bit more complex in the case of UTF-8, see what
449 C<Perl_reg_numbered_buff_length> does with
450 L<is_utf8_string_loclen|perlapi/is_utf8_string_loclen>.
452 -=head2 named_buff_FETCH
453 +=head2 Named capture callbacks
455 +Called to get/set the value of C<%+> and C<%->. If C<%+> is being
456 +operated on C<flags & RXf_HASH_ONE> will be true and C<flags &
457 +RXf_HASH_ALL> will be true for C<%->. There's also an additional flag
458 +for the L<SCALAR|/named_buff_SCALAR> callback, see below.
460 +This is implemented with a real tied interface via
461 +L<Tie::Hash::NamedCapture>, its methods call back into these
462 +functions, the usage of L<Tie::Hash::NamedCapture> for this purpose
463 +might change in future releases. For instance this might be
464 +implemented by magic instead (would need an extension to mgvtbl).
466 +Since these functions are just C level wrappers for the interface
467 +described in L<Tie::Hash> their arguments and return values are as
468 +described there, only with C prototypes.
470 +=head3 named_buff_FETCH
472 SV* named_buff_FETCH(pTHX_ REGEXP * const rx, SV * const key,
475 -Called to get the value of key in the C<%+> and C<%-> hashes, C<key>
476 -is the hash key being requested and if C<flags & 1> is true C<%-> is
477 -being requested (and C<%+> if it's not).
480 +=head3 named_buff_STORE
482 + void named_buff_STORE (pTHX_ REGEXP * const rx, SV * const key,
483 + SV * const value, const U32 flags);
487 +=head3 named_buff_DELETE
489 + void named_buff_DELETE (pTHX_ REGEXP * const rx,
490 + SV * const key, const U32 flags);
494 +=head3 named_buff_CLEAR
496 + void named_buff_CLEAR (pTHX_ REGEXP * const rx, const U32 flags);
500 +=head3 named_buff_EXISTS
502 + bool named_buff_EXISTS (pTHX_ REGEXP * const rx,
503 + SV * const key, const U32 flags);
505 +Check whether an entry C<exists>.
507 +=head3 named_buff_FIRSTKEY
509 + SV* (*named_buff_FIRSTKEY) (pTHX_ REGEXP * const rx, const U32 flags);
511 +Begin iterating the hash.
513 +=head3 named_buff_NEXTKEY
515 + SV* named_buff_NEXTKEY (pTHX_ REGEXP * const rx,
516 + SV * const lastkey, const U32 flags);
518 +Get the next entry in the hash.
520 +=head3 named_buff_SCALAR
522 + SV* named_buff_SCALAR (pTHX_ REGEXP * const rx, const U32 flags);
524 +Return what the hash evaluates to in C<scalar> context.
526 +This will also be called by L<re::regnames_count|re> to get the total
527 +number of named capture buffers defined for the pattern, in this case
528 +C<flags & RXf_HASH_COUNT> will be true.
532 @@ -333,7 +417,7 @@ following snippet:
533 SvTYPE(sv) == SVt_PVMG &&
534 (mg = mg_find(sv, PERL_MAGIC_qr))) /* assignment deliberate */
536 - re = (REGEXP *)mg->mg_obj;
537 + re = (REGEXP *)mg->mg_obj;
540 Or use the (CURRENTLY UNDOCUMENETED!) C<Perl_get_re_arg> function:
541 @@ -448,8 +532,9 @@ TODO, see L<http://www.mail-archive.com/perl5-changes@perl.org/msg17328.html>
545 -This will be used by perl to see what flags the regexp was compiled with, this
546 -will normally be set to the value of the flags parameter on L</comp>.
547 +This will be used by perl to see what flags the regexp was compiled
548 +with, this will normally be set to the value of the flags parameter by
549 +the L<comp|/comp> callback.
551 =head2 C<minlen> C<minlenret>
553 @@ -479,7 +564,9 @@ Left offset from pos() to start match at.
558 +Substring data about strings that must appear in the final match. This
559 +is currently only used internally by perl's engine for but might be
560 +used in the future for all engines for optimisations like C<minlen>.
562 =head2 C<nparens>, C<lasparen>, and C<lastcloseparen>
564 @@ -490,7 +577,7 @@ the last close paren to be entered.
567 The engine's private copy of the flags the pattern was compiled with. Usually
568 -this is the same as C<extflags> unless the engine chose to modify one of them
569 +this is the same as C<extflags> unless the engine chose to modify one of them.
573 @@ -520,8 +607,18 @@ C<$paren >= 1>.
575 =head2 C<precomp> C<prelen>
577 -Used for debugging purposes. C<precomp> holds a copy of the pattern
578 -that was compiled and C<prelen> its length.
579 +Used for optimisations. C<precomp> holds a copy of the pattern that
580 +was compiled and C<prelen> its length. When a new pattern is to be
581 +compiled (such as inside a loop) the internal C<regcomp> operator
582 +checks whether the last compiled C<REGEXP>'s C<precomp> and C<prelen>
583 +are equivalent to the new one, and if so uses the old pattern instead
584 +of compiling a new one.
586 +The relevant snippet from C<Perl_pp_regcomp>:
588 + if (!re || !re->precomp || re->prelen != (I32)len ||
589 + memNE(re->precomp, t, len))
590 + /* Compile a new pattern */
592 =head2 C<paren_names>
594 @@ -563,11 +660,11 @@ inline modifiers it's best to have C<qr//> stringify to the supplied pattern,
595 note that this will create invalid patterns in cases such as:
597 my $x = qr/a|b/; # "a|b"
598 - my $y = qr/c/; # "c"
599 + my $y = qr/c/i; # "c"
600 my $z = qr/$x$y/; # "a|bc"
602 -There's no solution for such problems other than making the custom engine
603 -understand some for of inline modifiers.
604 +There's no solution for this problem other than making the custom
605 +engine understand a construct like C<(?:)>.
607 The C<Perl_reg_stringify> in F<regcomp.c> does the stringification work.
609 diff --git a/proto.h b/proto.h
610 index dee615f..02b24d5 100644
613 @@ -1893,10 +1893,36 @@ PERL_CALLCONV regnode* Perl_regnext(pTHX_ regnode* p)
614 __attribute__nonnull__(pTHX_1);
617 -PERL_CALLCONV SV* Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const key, const U32 flags)
618 +PERL_CALLCONV SV* Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags)
619 __attribute__nonnull__(pTHX_1)
620 __attribute__nonnull__(pTHX_2);
622 +PERL_CALLCONV void Perl_reg_named_buff_store(pTHX_ REGEXP * const rx, SV * const key, SV * const value, const U32 flags)
623 + __attribute__nonnull__(pTHX_1)
624 + __attribute__nonnull__(pTHX_2)
625 + __attribute__nonnull__(pTHX_3);
627 +PERL_CALLCONV void Perl_reg_named_buff_delete(pTHX_ REGEXP * const rx, SV * const key, const U32 flags)
628 + __attribute__nonnull__(pTHX_1)
629 + __attribute__nonnull__(pTHX_2);
631 +PERL_CALLCONV void Perl_reg_named_buff_clear(pTHX_ REGEXP * const rx, const U32 flags)
632 + __attribute__nonnull__(pTHX_1);
634 +PERL_CALLCONV bool Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key, const U32 flags)
635 + __attribute__nonnull__(pTHX_1)
636 + __attribute__nonnull__(pTHX_2);
638 +PERL_CALLCONV SV* Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags)
639 + __attribute__nonnull__(pTHX_1);
641 +PERL_CALLCONV SV* Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, SV * const lastkey, const U32 flags)
642 + __attribute__nonnull__(pTHX_1)
643 + __attribute__nonnull__(pTHX_2);
645 +PERL_CALLCONV SV* Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags)
646 + __attribute__nonnull__(pTHX_1);
649 PERL_CALLCONV void Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv)
650 __attribute__nonnull__(pTHX_1);
651 diff --git a/regcomp.c b/regcomp.c
652 index baa5d99..c144d76 100644
655 @@ -228,7 +228,7 @@ typedef struct RExC_state_t {
659 - Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
660 +v Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
661 strings (because they follow a .* construct). study_chunk will identify
662 both FOO and BAR as being the longest fixed and floating strings respectively.
664 @@ -4800,7 +4800,7 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32
669 + if (flags & RXf_HASH_ALL)
672 if (rx && rx->paren_names) {
673 @@ -4810,9 +4810,9 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32
674 SV* sv_dat=HeVAL(he_str);
675 I32 *nums=(I32*)SvPVX(sv_dat);
676 for ( i=0; i<SvIVX(sv_dat); i++ ) {
677 - if ((I32)(rx->nparens) >= nums[i]
678 - && rx->offs[nums[i]].start != -1
679 - && rx->offs[nums[i]].end != -1)
680 + if ((I32)(rx->nparens) >= nums[i]
681 + && rx->offs[nums[i]].start != -1
682 + && rx->offs[nums[i]].end != -1)
685 CALLREG_NUMBUF_FETCH(rx,nums[i],ret);
686 @@ -4827,13 +4827,116 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32
690 - return (SV*)retarray;
691 + return newRV((SV*)retarray);
698 +Perl_reg_named_buff_store(pTHX_ REGEXP * const rx, SV * const key,
699 + SV * const value, const U32 flags)
701 + PERL_UNUSED_ARG(rx);
702 + PERL_UNUSED_ARG(key);
703 + PERL_UNUSED_ARG(value);
704 + PERL_UNUSED_ARG(flags);
706 + Perl_croak(aTHX_ PL_no_modify);
710 +Perl_reg_named_buff_delete(pTHX_ REGEXP * const rx, SV * const key, const U32 flags)
712 + PERL_UNUSED_ARG(rx);
713 + PERL_UNUSED_ARG(key);
714 + PERL_UNUSED_ARG(flags);
716 + Perl_croak(aTHX_ PL_no_modify);
720 +Perl_reg_named_buff_clear(pTHX_ REGEXP * const rx, const U32 flags)
722 + PERL_UNUSED_ARG(rx);
723 + PERL_UNUSED_ARG(flags);
725 + Perl_croak(aTHX_ PL_no_modify);
729 +Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key,
732 + PERL_UNUSED_ARG(flags);
734 + if (rx && rx->paren_names) {
735 + return hv_exists_ent(rx->paren_names, key, 0);
742 +Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags)
744 + PERL_UNUSED_ARG(flags);
746 + (void)hv_iterinit(rx->paren_names);
748 + return CALLREG_NAMEDBUF_NEXTKEY(rx, NULL, flags);
752 +Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, SV * const lastkey,
755 + PERL_UNUSED_ARG(lastkey);
756 + bool all = flags & RXf_HASH_ALL;
758 + if (rx && rx->paren_names) {
759 + HV *hv= rx->paren_names;
761 + HE *temphe = hv_iternext_flags(hv,0);
765 + SV* sv_dat = HeVAL(temphe);
766 + I32 *nums = (I32*)SvPVX(sv_dat);
767 + for ( i = 0; i < SvIVX(sv_dat); i++ ) {
768 + if ((I32)(rx->lastcloseparen) >= nums[i] &&
769 + rx->offs[nums[i]].start != -1 &&
770 + rx->offs[nums[i]].end != -1)
776 + if (parno || all) {
778 + char *pv = HePV(temphe, len);
779 + return newSVpvn(pv,len);
791 +Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags)
793 + PERL_UNUSED_ARG(flags);
795 + if (rx && rx->paren_names)
796 + return newSViv(HvTOTALKEYS(rx->paren_names));
797 + return &PL_sv_undef;
801 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv)
804 @@ -4845,13 +4948,13 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * cons
808 - if (paren == -2 && rx->offs[0].start != -1) {
809 + if (paren == RXrf_PREMATCH && rx->offs[0].start != -1) {
811 i = rx->offs[0].start;
815 - if (paren == -1 && rx->offs[0].end != -1) {
816 + if (paren == RXrf_POSTMATCH && rx->offs[0].end != -1) {
818 s = rx->subbeg + rx->offs[0].end;
819 i = rx->sublen - rx->offs[0].end;
820 @@ -4929,7 +5032,8 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv,
822 /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
825 + /* $` / ${^PREMATCH} */
826 + case RXrf_PREMATCH:
827 if (rx->offs[0].start != -1) {
828 i = rx->offs[0].start;
830 @@ -4939,7 +5043,8 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv,
835 + /* $' / ${^POSTMATCH} */
836 + case RXrf_POSTMATCH:
837 if (rx->offs[0].end != -1) {
838 i = rx->sublen - rx->offs[0].end;
840 @@ -4949,7 +5054,8 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv,
844 - default: /* $&, $1, $2, ... */
845 + /* $& / ${^MATCH}, $1, $2, ... */
847 if (paren <= (I32)rx->nparens &&
848 (s1 = rx->offs[paren].start) != -1 &&
849 (t1 = rx->offs[paren].end) != -1)
850 diff --git a/regcomp.h b/regcomp.h
851 index 33c3eef..5be7f32 100644
854 @@ -473,6 +473,13 @@ EXTCONST regexp_engine PL_core_reg_engine = {
855 Perl_reg_numbered_buff_store,
856 Perl_reg_numbered_buff_length,
857 Perl_reg_named_buff_fetch,
858 + Perl_reg_named_buff_store,
859 + Perl_reg_named_buff_delete,
860 + Perl_reg_named_buff_clear,
861 + Perl_reg_named_buff_exists,
862 + Perl_reg_named_buff_firstkey,
863 + Perl_reg_named_buff_nextkey,
864 + Perl_reg_named_buff_scalar,
866 #if defined(USE_ITHREADS)
867 Perl_regdupe_internal
868 diff --git a/regexp.h b/regexp.h
869 index 1f72112..31d264d 100644
872 @@ -136,14 +136,40 @@ typedef struct regexp_engine {
873 SV const * const value);
874 I32 (*numbered_buff_LENGTH) (pTHX_ REGEXP * const rx, const SV * const sv,
876 - SV* (*named_buff_FETCH) (pTHX_ REGEXP * const rx, SV * const key,
877 + SV* (*named_buff_FETCH) (pTHX_ REGEXP * const rx, SV * const sv,
879 + void (*named_buff_STORE) (pTHX_ REGEXP * const rx, SV * const key,
880 + SV * const value, const U32 flags);
881 + void (*named_buff_DELETE) (pTHX_ REGEXP * const rx,
882 + SV * const key, const U32 flags);
883 + void (*named_buff_CLEAR) (pTHX_ REGEXP * const rx, const U32 flags);
884 + bool (*named_buff_EXISTS) (pTHX_ REGEXP * const rx,
885 + SV * const key, const U32 flags);
886 + SV* (*named_buff_FIRSTKEY) (pTHX_ REGEXP * const rx, const U32 flags);
887 + SV* (*named_buff_NEXTKEY) (pTHX_ REGEXP * const rx,
888 + SV * const lastkey, const U32 flags);
889 + SV* (*named_buff_SCALAR) (pTHX_ REGEXP * const rx,
891 SV* (*qr_package)(pTHX_ REGEXP * const rx);
893 void* (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
898 + These are passed to the numbered capture variable callbacks as the
899 + paren name. >= 1 is reserved for actual numbered captures, i.e. $1,
903 +#define RXrf_PREMATCH -2 /* $` / ${^PREMATCH} */
904 +#define RXrf_POSTMATCH -1 /* $' / ${^POSTMATCH} */
905 +#define RXrf_MATCH 0 /* $& / ${^MATCH} */
907 +#define RXf_HASH_ONE 0x00000001 /* %+ */
908 +#define RXf_HASH_ALL 0x00000002 /* %- */
909 +#define RXf_HASH_COUNT 0x00000004 /* scalar %+ / scalar %- */
911 /* Flags stored in regexp->extflags
912 * These are used by code external to the regexp engine
914 diff --git a/t/TEST b/t/TEST
917 diff --git a/t/op/readdir.t b/t/op/readdir.t
918 index c4d5ed2..971a02a 100644
921 @@ -24,7 +24,7 @@ closedir(OP);
922 ## This range will have to adjust as the number of tests expands,
923 ## as it's counting the number of .t files in src/t
925 -my ($min, $max) = (140, 160);
926 +my ($min, $max) = (150, 170);
927 if (@D > $min && @D < $max) { print "ok 2\n"; }
929 printf "not ok 2 # counting op/*.t, expect $min < %d < $max files\n",
930 diff --git a/t/op/regexp_namedcapture_tie.t b/t/op/regexp_namedcapture_tie.t
932 index 0000000..f72970e
934 +++ b/t/op/regexp_namedcapture_tie.t
939 + chdir 't' if -d 't';
941 + require './test.pl';
944 +# Do a basic test on all the tied methods of Tie::Hash::NamedCapture
957 +is($+{a}, "h", "FETCH");
958 +is($+{b}, "l", "FETCH");
959 +is($-{a}[0], "h", "FETCH");
960 +is($-{a}[1], "a", "FETCH");
963 +eval { $+{a} = "yon" };
964 +ok(index($@, "read-only") != -1, "STORE");
967 +eval { delete $+{a} };
968 +ok(index($@, "read-only") != -1, "DELETE");
972 +ok(index($@, "read-only") != -1, "CLEAR");
975 +ok(exists $+{e}, "EXISTS");
976 +ok(!exists $+{d}, "EXISTS");
979 +is(join('|', sort keys %+), "a|b|e", "FIRSTKEY/NEXTKEY");
982 +is(scalar(%+), 3, "SCALAR");
983 +is(scalar(%-), 3, "SCALAR");
984 diff --git a/universal.c b/universal.c
985 index 396dd3d..f506441 100644
990 /* This file contains the code that implements the functions in Perl's
991 * UNIVERSAL package, such as UNIVERSAL->can().
993 + * It is also used to store XS functions that need to be present in
994 + * miniperl for a lack of a better place to put them. It might be
995 + * clever to move them to seperate XS files which would then be pulled
996 + * in by some to-be-written build process.
1000 @@ -226,11 +231,17 @@ XS(XS_Internals_rehash_seed);
1001 XS(XS_Internals_HvREHASH);
1002 XS(XS_Internals_inc_sub_generation);
1003 XS(XS_re_is_regexp);
1005 -XS(XS_re_regnames);
1006 -XS(XS_re_regnames_iterinit);
1007 -XS(XS_re_regnames_iternext);
1009 +XS(XS_re_regnames);
1010 XS(XS_re_regnames_count);
1011 +XS(XS_Tie_Hash_NamedCapture_FETCH);
1012 +XS(XS_Tie_Hash_NamedCapture_STORE);
1013 +XS(XS_Tie_Hash_NamedCapture_DELETE);
1014 +XS(XS_Tie_Hash_NamedCapture_CLEAR);
1015 +XS(XS_Tie_Hash_NamedCapture_EXISTS);
1016 +XS(XS_Tie_Hash_NamedCapture_FIRSTKEY);
1017 +XS(XS_Tie_Hash_NamedCapture_NEXTKEY);
1018 +XS(XS_Tie_Hash_NamedCapture_SCALAR);
1021 Perl_boot_core_UNIVERSAL(pTHX)
1022 @@ -284,9 +295,15 @@ Perl_boot_core_UNIVERSAL(pTHX)
1023 newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
1024 newXSproto("re::regname", XS_re_regname, file, ";$$");
1025 newXSproto("re::regnames", XS_re_regnames, file, ";$");
1026 - newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, "");
1027 - newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$");
1028 newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
1029 + newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
1030 + newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
1031 + newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
1032 + newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file);
1033 + newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file);
1034 + newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTKEY, file);
1035 + newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTKEY, file);
1036 + newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file);
1040 @@ -1072,206 +1089,341 @@ XS(XS_re_is_regexp)
1049 +XS(XS_re_regnames_count)
1052 + REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1058 + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
1059 + PERL_UNUSED_VAR(cv); /* -W */
1060 + PERL_UNUSED_VAR(ax); /* -Wall */
1066 + ret = CALLREG_NAMEDBUF_SCALAR(rx, RXf_HASH_COUNT);
1083 if (items < 1 || items > 2)
1084 - Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
1085 + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
1086 PERL_UNUSED_VAR(cv); /* -W */
1087 PERL_UNUSED_VAR(ax); /* -Wall */
1092 - regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1094 + REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1104 - if (SvPOK(sv) && re && re->paren_names) {
1105 - bufs = CALLREG_NAMEDBUF_FETCH(re,sv,all && SvTRUE(all));
1107 - if (all && SvTRUE(all))
1108 - XPUSHs(newRV(bufs));
1110 - XPUSHs(SvREFCNT_inc(bufs));
1121 + if (items == 2 && SvTRUE(ST(1))) {
1122 + flags = RXf_HASH_ALL;
1124 + flags = RXf_HASH_ONE;
1126 + ret = CALLREG_NAMEDBUF_FETCH(rx, ST(0), flags);
1132 + XPUSHs(SvREFCNT_inc(ret));
1144 if (items < 0 || items > 1)
1145 - Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
1146 + Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
1147 PERL_UNUSED_VAR(cv); /* -W */
1148 PERL_UNUSED_VAR(ax); /* -Wall */
1152 - regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1154 + REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1164 - if (re && re->paren_names) {
1165 - HV *hv= re->paren_names;
1166 - (void)hv_iterinit(hv);
1168 - HE *temphe = hv_iternext_flags(hv,0);
1172 - SV* sv_dat = HeVAL(temphe);
1173 - I32 *nums = (I32*)SvPVX(sv_dat);
1174 - for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1175 - if ((I32)(re->lastcloseparen) >= nums[i] &&
1176 - re->offs[nums[i]].start != -1 &&
1177 - re->offs[nums[i]].end != -1)
1183 - if (parno || (all && SvTRUE(all))) {
1185 - char *pv = HePV(temphe, len);
1186 - if ( GIMME_V == G_ARRAY )
1187 - XPUSHs(newSVpvn(pv,len));
1194 + if (items == 1 && SvTRUE(ST(0))) {
1200 + if (rx && rx->paren_names) {
1201 + HV *hv= rx->paren_names;
1202 + (void)hv_iterinit(hv);
1204 + HE *temphe = hv_iternext_flags(hv,0);
1208 + SV* sv_dat = HeVAL(temphe);
1209 + I32 *nums = (I32*)SvPVX(sv_dat);
1210 + for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1211 + if ((I32)(rx->lastcloseparen) >= nums[i] &&
1212 + rx->offs[nums[i]].start != -1 &&
1213 + rx->offs[nums[i]].end != -1)
1219 + if (parno || flags) {
1221 + char *pv = HePV(temphe, len);
1222 + if ( GIMME_V == G_ARRAY )
1223 + XPUSHs(newSVpvn(pv,len));
1229 - if ( GIMME_V == G_ARRAY )
1239 + if ( GIMME_V == G_ARRAY )
1246 -XS(XS_re_regnames_iterinit)
1247 +XS(XS_Tie_Hash_NamedCapture_FETCH)
1253 - Perl_croak(aTHX_ "Usage: re::regnames_iterinit()");
1254 - PERL_UNUSED_VAR(cv); /* -W */
1255 - PERL_UNUSED_VAR(ax); /* -Wall */
1256 + REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1261 + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $flags)");
1268 - regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1269 - if (re && re->paren_names) {
1270 - (void)hv_iterinit(re->paren_names);
1271 - XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1274 + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1275 + ret = CALLREG_NAMEDBUF_FETCH(rx, ST(1), flags);
1283 + XPUSHs(SvREFCNT_inc(ret));
1290 +XS(XS_Tie_Hash_NamedCapture_STORE)
1294 + REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1298 + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $value, $flags)");
1301 + if (!PL_localizing)
1302 + Perl_croak(aTHX_ PL_no_modify);
1312 + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1313 + CALLREG_NAMEDBUF_STORE(rx,ST(1), ST(2), flags);
1316 +XS(XS_Tie_Hash_NamedCapture_DELETE)
1320 + REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1323 -XS(XS_re_regnames_iternext)
1325 + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::DELETE($key, $flags)");
1328 + Perl_croak(aTHX_ PL_no_modify);
1332 + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1333 + CALLREG_NAMEDBUF_DELETE(rx, ST(1), flags);
1336 +XS(XS_Tie_Hash_NamedCapture_CLEAR)
1341 - if (items < 0 || items > 1)
1342 - Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "[all]");
1343 - PERL_UNUSED_VAR(cv); /* -W */
1344 - PERL_UNUSED_VAR(ax); /* -Wall */
1345 + REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1349 + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::CLEAR($flags)");
1352 + Perl_croak(aTHX_ PL_no_modify);
1357 - regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1364 - if (re && re->paren_names) {
1365 - HV *hv= re->paren_names;
1367 - HE *temphe = hv_iternext_flags(hv,0);
1371 - SV* sv_dat = HeVAL(temphe);
1372 - I32 *nums = (I32*)SvPVX(sv_dat);
1373 - for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1374 - if ((I32)(re->lastcloseparen) >= nums[i] &&
1375 - re->offs[nums[i]].start != -1 &&
1376 - re->offs[nums[i]].end != -1)
1382 - if (parno || (all && SvTRUE(all))) {
1384 - char *pv = HePV(temphe, len);
1385 - XPUSHs(newSVpvn(pv,len));
1393 + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1394 + CALLREG_NAMEDBUF_CLEAR(rx, flags);
1397 +XS(XS_Tie_Hash_NamedCapture_EXISTS)
1401 + REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1406 + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::EXISTS($key, $flags)");
1415 + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1416 + exists = CALLREG_NAMEDBUF_EXISTS(rx, ST(1), flags);
1427 +XS(XS_Tie_Hash_NamedCapture_FIRSTKEY)
1431 + REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1435 -XS(XS_re_regnames_count)
1437 + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::FIRSTKEY()");
1444 + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1445 + ret = CALLREG_NAMEDBUF_FIRSTKEY(rx, flags);
1450 + XPUSHs(SvREFCNT_inc(ret));
1458 +XS(XS_Tie_Hash_NamedCapture_NEXTKEY)
1460 - regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1464 + REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1469 + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::NEXTKEY($lastkey)");
1475 - Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
1476 - PERL_UNUSED_VAR(cv); /* -W */
1477 - PERL_UNUSED_VAR(ax); /* -Wall */
1480 - if (re && re->paren_names) {
1481 - XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1483 + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1484 + ret = CALLREG_NAMEDBUF_NEXTKEY(rx, ST(1), flags);
1497 +XS(XS_Tie_Hash_NamedCapture_SCALAR)
1501 + REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1506 + Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::SCALAR()");
1513 + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1514 + ret = CALLREG_NAMEDBUF_SCALAR(rx, flags);