From: Ævar Arnfjörð Bjarmason Date: Wed, 30 May 2007 01:52:00 +0000 (+0000) Subject: Importing re-engine-Plugin-0.04_01.tar.gz X-Git-Tag: v0.04_01^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Fre-engine-Plugin.git;a=commitdiff_plain;h=dd88e700bfcc92fc03db9d994ec747ca1c14ade7 Importing re-engine-Plugin-0.04_01.tar.gz --- diff --git a/ChangeLog b/ChangeLog index 50a3310..13757f9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,22 @@ +2007-05-29 Ævar Arnfjörð Bjarmason (0.04_01) + + * Plugin.xs: Implementation of named buffer callbacks, there is + some debate about whether this patch should go into + blead so I'm making a dev release + * named_capture.patch: The patch to blead that makes this tick + * Plugin.xs: Dumped CODE: in favor of PPCODE:, the former is teh sux + * Plugin.xs: Minor cleanups here and there + * Plugin.pod: New todo and a developer release notice + * Plugin.h: Named buffer callbacks + * Plugin.pm: Named buffer callbacks + * t/methods/stash.t: Test return value of $rx->stash({}); + * t/methods/str/modify.t: New test for modification of ->str when + a reference is used + * t/methods/str/types.t: This was testing pattern types, fixed + + * t/Example.[t|pm]: Moved to t/usage + * t/named_buff: Tests for named buffer callbacks + 2007-05-17 Ævar Arnfjörð Bjarmason (0.03) * Plugin.xs: The exec callback would call_sv on a NULL value diff --git a/MANIFEST b/MANIFEST index 97d9d7e..eb36f03 100644 --- a/MANIFEST +++ b/MANIFEST @@ -14,6 +14,7 @@ inc/Module/Install/WriteAll.pm Makefile.PL MANIFEST This list of files META.yml +named-capture.patch Plugin.h Plugin.pm Plugin.pod @@ -21,8 +22,6 @@ Plugin.xs t/00-compile.t t/eval-comp.t t/eval-exec.t -t/Example.pm -t/Example.t t/import.t t/methods.t t/methods/free.t @@ -33,11 +32,24 @@ t/methods/mod.t t/methods/pattern/modify.t t/methods/pattern/types.t t/methods/stash.t +t/methods/str/modify.t t/methods/str/types.t t/methods/str/undef.t +t/named_buff/CLEAR.t +t/named_buff/DELETE.t +t/named_buff/EXISTS.t +t/named_buff/FETCH.t +t/named_buff/FIRSTKEY.t +t/named_buff/NEXTKEY.t +t/named_buff/SCALAR.t +t/named_buff/STORE.t t/num_buff/FETCH.t t/num_buff/LENGTH.t t/num_buff/STORE.t t/taint/rx.t t/taint/util.t +t/usage/basic.pm +t/usage/basic.t +t/usage/import.pm +t/usage/import.t typemap diff --git a/Plugin.h b/Plugin.h index 2124ad8..668aec9 100644 --- a/Plugin.h +++ b/Plugin.h @@ -30,6 +30,20 @@ EXTERN_C I32 Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const, const SV * const, const I32); EXTERN_C SV * Plugin_named_buff_FETCH(pTHX_ REGEXP * const, SV * const, const U32); +EXTERN_C void Plugin_named_buff_STORE(pTHX_ REGEXP * const rx, + SV * const key, SV * const value, + const U32 flags); +EXTERN_C void Plugin_named_buff_DELETE(pTHX_ REGEXP * const rx, + SV * const key, const U32 flags); +EXTERN_C void Plugin_named_buff_CLEAR (pTHX_ REGEXP * const rx, const U32 flags); +EXTERN_C bool Plugin_named_buff_EXISTS (pTHX_ REGEXP * const rx, + SV * const key, const U32 flags); +EXTERN_C SV * Plugin_named_buff_FIRSTKEY (pTHX_ REGEXP * const rx, + const U32 flags); +EXTERN_C SV * Plugin_named_buff_NEXTKEY (pTHX_ REGEXP * const rx, + SV * const lastkey, const U32 flags); +EXTERN_C SV * Plugin_named_buff_SCALAR (pTHX_ REGEXP * const rx, + const U32 flags); EXTERN_C SV * Plugin_package(pTHX_ REGEXP * const); #ifdef USE_ITHREADS EXTERN_C void * Plugin_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *); @@ -51,6 +65,13 @@ const regexp_engine engine_plugin = { Plugin_numbered_buff_STORE, Plugin_numbered_buff_LENGTH, Plugin_named_buff_FETCH, + Plugin_named_buff_STORE, + Plugin_named_buff_DELETE, + Plugin_named_buff_CLEAR, + Plugin_named_buff_EXISTS, + Plugin_named_buff_FIRSTKEY, + Plugin_named_buff_NEXTKEY, + Plugin_named_buff_SCALAR, Plugin_package, #if defined(USE_ITHREADS) Plugin_dupe, @@ -75,10 +96,18 @@ typedef struct replug { * Callbacks */ - SV * cb_free; - /* ->num_captures */ SV * cb_num_capture_buff_FETCH; SV * cb_num_capture_buff_STORE; SV * cb_num_capture_buff_LENGTH; + + /* ->named_captures */ + SV * cb_named_capture_buff_FETCH; + SV * cb_named_capture_buff_STORE; + SV * cb_named_capture_buff_DELETE; + SV * cb_named_capture_buff_CLEAR; + SV * cb_named_capture_buff_EXISTS; + SV * cb_named_capture_buff_FIRSTKEY; + SV * cb_named_capture_buff_NEXTKEY; + SV * cb_named_capture_buff_SCALAR; } *re__engine__Plugin; diff --git a/Plugin.pm b/Plugin.pm index 220dfdf..80fa389 100644 --- a/Plugin.pm +++ b/Plugin.pm @@ -5,7 +5,7 @@ use base 'Regexp'; use strict; use XSLoader (); -our $VERSION = '0.03'; +our $VERSION = '0.04_01'; XSLoader::load __PACKAGE__, $VERSION; @@ -26,7 +26,7 @@ sub import my ($pkg, %sub) = @_; # Valid callbacks - my @callback = qw(comp exec intuit checkstr free dupe); + my @callback = qw(comp exec); #intuit checkstr free dupe); for (@callback) { next unless exists $sub{$_}; @@ -83,4 +83,15 @@ sub num_captures } } +sub named_captures +{ + my ($re, %callback) = @_; + + for my $key (keys %callback) { + $key =~ y/a-z/A-Z/; # ASCII uc + my $name = '_named_capture_buff_' . $key; + $re->$name( $callback{$key} ); + } +} + 1; diff --git a/Plugin.pod b/Plugin.pod index 3ae9882..1438f64 100644 --- a/Plugin.pod +++ b/Plugin.pod @@ -2,6 +2,11 @@ re::engine::Plugin - API to write custom regex engines +=head1 NOTICE + +This is a B that requires a patch to blead to work, +the patch can be found in F in this distribution. + =head1 DESCRIPTION As of perl 5.9.5 it's possible to lexically replace perl's built-in @@ -224,12 +229,10 @@ name an example). =head2 named_captures -B: implement +B: document -perl internals still needs to be changed to support this but when it's -done it'll allow the binding of C<%+> and C<%-> and support the -L methods FETCH, STORE, DELETE, CLEAR, EXISTS, FIRSTKEY, -NEXTKEY and SCALAR. +This is implemented but not documented, see F for usage +examples. =head1 Tainting @@ -300,6 +303,11 @@ I =item * +Export constants defined as macros in core relevant to our interests, +e.g. PMf_ stuff and things needed by extflags. + +=item * + Engines implemented with this module don't support C and C, the appropriate parts of the C struct need to be wrapped and documented. diff --git a/Plugin.xs b/Plugin.xs index aa95e8b..6d003d9 100644 --- a/Plugin.xs +++ b/Plugin.xs @@ -67,7 +67,7 @@ Plugin_comp(pTHX_ const SV * const pattern, const U32 flags) rx->extflags = flags; /* Flags for perl to use */ rx->engine = RE_ENGINE_PLUGIN; /* Compile to use this engine */ - /* Store a precompiled regexp for pp_regcomp to use */ + /* Precompiled regexp for pp_regcomp to use */ rx->prelen = plen; rx->precomp = savepvn(exp, rx->prelen); @@ -216,7 +216,6 @@ Plugin_dupe(pTHX_ const REGEXP * rx, CLONE_PARAMS *param) return rx->pprivate; } - void Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv) @@ -292,9 +291,7 @@ Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const rx, const SV * const sv, dSP; I32 items; SV * callback; - re__engine__Plugin self; - - SELF_FROM_PPRIVATE(self,rx->pprivate); + GET_SELF_FROM_PPRIVATE(rx->pprivate); callback = self->cb_num_capture_buff_LENGTH; @@ -328,11 +325,262 @@ Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const rx, const SV * const sv, SV* Plugin_named_buff_FETCH(pTHX_ REGEXP * const rx, SV * const key, U32 flags) { - PERL_UNUSED_ARG(rx); - PERL_UNUSED_ARG(key); - PERL_UNUSED_ARG(flags); + dSP; + SV * callback; + GET_SELF_FROM_PPRIVATE(rx->pprivate); - return NULL; + callback = self->cb_named_capture_buff_FETCH; + + if (callback) { + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(rx->pprivate); + XPUSHs(SvREFCNT_inc(key)); + XPUSHs(sv_2mortal(newSViv(flags & 1 ? 1 : 0))); + PUTBACK; + + call_sv(callback, G_SCALAR); + + SPAGAIN; + + SV* ret = POPs; + SvREFCNT_inc(ret); + + PUTBACK; + FREETMPS; + LEAVE; + + return ret; + } else { + return NULL; + } +} + +void +Plugin_named_buff_STORE(pTHX_ REGEXP * const rx, SV * const key, + SV * const value, const U32 flags) +{ + dSP; + SV * callback; + GET_SELF_FROM_PPRIVATE(rx->pprivate); + + callback = self->cb_named_capture_buff_STORE; + + if (callback) { + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(rx->pprivate); + XPUSHs(SvREFCNT_inc(key)); + XPUSHs(SvREFCNT_inc(value)); + XPUSHs(sv_2mortal(newSViv(flags))); + PUTBACK; + + call_sv(callback, G_DISCARD); + + PUTBACK; + FREETMPS; + LEAVE; + } +} + +void +Plugin_named_buff_DELETE(pTHX_ REGEXP * const rx, SV * const key, const U32 flags) +{ + dSP; + SV * callback; + GET_SELF_FROM_PPRIVATE(rx->pprivate); + + callback = self->cb_named_capture_buff_DELETE; + + if (callback) { + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(rx->pprivate); + XPUSHs(SvREFCNT_inc(key)); + XPUSHs(sv_2mortal(newSViv(flags))); + PUTBACK; + + call_sv(callback, G_DISCARD); + + PUTBACK; + FREETMPS; + LEAVE; + } +} + +void +Plugin_named_buff_CLEAR(pTHX_ REGEXP * const rx, const U32 flags) +{ + dSP; + SV * callback; + GET_SELF_FROM_PPRIVATE(rx->pprivate); + + callback = self->cb_named_capture_buff_CLEAR; + + if (callback) { + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(rx->pprivate); + XPUSHs(sv_2mortal(newSViv(flags))); + PUTBACK; + + call_sv(callback, G_DISCARD); + + PUTBACK; + FREETMPS; + LEAVE; + } +} + +bool +Plugin_named_buff_EXISTS(pTHX_ REGEXP * const rx, SV * const key, + const U32 flags) +{ + dSP; + SV * callback; + bool truthiness = FALSE; + GET_SELF_FROM_PPRIVATE(rx->pprivate); + + callback = self->cb_named_capture_buff_EXISTS; + + if (callback) { + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(rx->pprivate); + XPUSHs(SvREFCNT_inc(key)); + XPUSHs(sv_2mortal(newSViv(flags))); + PUTBACK; + + call_sv(callback, G_SCALAR); + + SPAGAIN; + + SV * ret = POPs; + truthiness = SvTRUE(ret); + + PUTBACK; + FREETMPS; + LEAVE; + } + + return truthiness; +} + +SV* +Plugin_named_buff_FIRSTKEY(pTHX_ REGEXP * const rx, const U32 flags) +{ + dSP; + SV * callback; + GET_SELF_FROM_PPRIVATE(rx->pprivate); + + callback = self->cb_named_capture_buff_FIRSTKEY; + + if (callback) { + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(rx->pprivate); + XPUSHs(sv_2mortal(newSViv(flags))); + PUTBACK; + + call_sv(callback, G_SCALAR); + + SPAGAIN; + + SV * ret = POPs; + SvREFCNT_inc(ret); + + PUTBACK; + FREETMPS; + LEAVE; + + return ret; + } else { + return NULL; + } +} + +SV* +Plugin_named_buff_NEXTKEY(pTHX_ REGEXP * const rx, SV * const lastkey, + const U32 flags) +{ + dSP; + SV * callback; + GET_SELF_FROM_PPRIVATE(rx->pprivate); + + callback = self->cb_named_capture_buff_NEXTKEY; + + if (callback) { + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(rx->pprivate); + XPUSHs(SvREFCNT_inc(lastkey)); + XPUSHs(sv_2mortal(newSViv(flags))); + PUTBACK; + + call_sv(callback, G_SCALAR); + + SPAGAIN; + + SV * ret = POPs; + SvREFCNT_inc(ret); + + PUTBACK; + FREETMPS; + LEAVE; + + return ret; + } else { + return NULL; + } +} + +SV* +Plugin_named_buff_SCALAR(pTHX_ REGEXP * const rx, const U32 flags) +{ + dSP; + SV * callback; + GET_SELF_FROM_PPRIVATE(rx->pprivate); + + callback = self->cb_named_capture_buff_SCALAR; + + if (callback) { + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(rx->pprivate); + XPUSHs(sv_2mortal(newSViv(flags))); + PUTBACK; + + call_sv(callback, G_SCALAR); + + SPAGAIN; + + SV * ret = POPs; + SvREFCNT_inc(ret); + + PUTBACK; + FREETMPS; + LEAVE; + + return ret; + } else { + return NULL; + } } SV* @@ -343,25 +591,19 @@ Plugin_package(pTHX_ REGEXP * const rx) } MODULE = re::engine::Plugin PACKAGE = re::engine::Plugin -PROTOTYPES: ENABLE +PROTOTYPES: DISABLE -SV * +void pattern(re::engine::Plugin self, ...) -CODE: - SvREFCNT_inc(self->pattern); - RETVAL = self->pattern; -OUTPUT: - RETVAL +PPCODE: + XPUSHs(self->pattern); -SV * +void str(re::engine::Plugin self, ...) -CODE: - SvREFCNT_inc(self->str); - RETVAL = self->str; -OUTPUT: - RETVAL +PPCODE: + XPUSHs(self->str); -char* +void mod(re::engine::Plugin self, ...) PPCODE: /* /i */ @@ -394,50 +636,58 @@ PPCODE: XPUSHs(&PL_sv_yes); } -SV * +void stash(re::engine::Plugin self, ...) -PREINIT: - SV * stash; -CODE: +PPCODE: if (items > 1) { - self->stash = sv_mortalcopy(ST(1)); + self->stash = ST(1); SvREFCNT_inc(self->stash); + XSRETURN_EMPTY; + } else { + XPUSHs(self->stash); } - SvREFCNT_inc(self->stash); - RETVAL = self->stash; -OUTPUT: - RETVAL -SV * +void minlen(re::engine::Plugin self, ...) -CODE: +PPCODE: if (items > 1) { self->rx->minlen = (I32)SvIV(ST(1)); + XSRETURN_EMPTY; + } else { + if (self->rx->minlen) { + XPUSHs(sv_2mortal(newSViv(self->rx->minlen))); + } else { + XPUSHs(sv_2mortal(&PL_sv_undef)); + } } - RETVAL = self->rx->minlen ? newSViv(self->rx->minlen) : &PL_sv_undef; -OUTPUT: - RETVAL - -SV * +void gofs(re::engine::Plugin self, ...) -CODE: +PPCODE: if (items > 1) { self->rx->gofs = (U32)SvIV(ST(1)); + XSRETURN_EMPTY; + } else { + if (self->rx->gofs) { + XPUSHs(sv_2mortal(newSVuv(self->rx->gofs))); + } else { + XPUSHs(sv_2mortal(&PL_sv_undef)); + } } - RETVAL = self->rx->gofs ? newSVuv(self->rx->gofs) : &PL_sv_undef; -OUTPUT: - RETVAL -SV * +void nparens(re::engine::Plugin self, ...) -CODE: +PPCODE: if (items > 1) { self->rx->nparens = (U32)SvIV(ST(1)); + XSRETURN_EMPTY; + } else { + if (self->rx->nparens) { + XPUSHs(sv_2mortal(newSVuv(self->rx->nparens))); + } else { + XPUSHs(sv_2mortal(&PL_sv_undef)); + } } - RETVAL = self->rx->nparens ? newSVuv(self->rx->nparens) : &PL_sv_undef; -OUTPUT: - RETVAL void _num_capture_buff_FETCH(re::engine::Plugin self, ...) @@ -463,6 +713,70 @@ PPCODE: SvREFCNT_inc(self->cb_num_capture_buff_LENGTH); } +void +_named_capture_buff_FETCH(re::engine::Plugin self, ...) +PPCODE: + if (items > 1) { + self->cb_named_capture_buff_FETCH = ST(1); + SvREFCNT_inc(self->cb_named_capture_buff_FETCH); + } + +void +_named_capture_buff_STORE(re::engine::Plugin self, ...) +PPCODE: + if (items > 1) { + self->cb_named_capture_buff_STORE = ST(1); + SvREFCNT_inc(self->cb_named_capture_buff_STORE); + } + +void +_named_capture_buff_DELETE(re::engine::Plugin self, ...) +PPCODE: + if (items > 1) { + self->cb_named_capture_buff_DELETE = ST(1); + SvREFCNT_inc(self->cb_named_capture_buff_DELETE); + } + +void +_named_capture_buff_CLEAR(re::engine::Plugin self, ...) +PPCODE: + if (items > 1) { + self->cb_named_capture_buff_CLEAR = ST(1); + SvREFCNT_inc(self->cb_named_capture_buff_CLEAR); + } + +void +_named_capture_buff_EXISTS(re::engine::Plugin self, ...) +PPCODE: + if (items > 1) { + self->cb_named_capture_buff_EXISTS = ST(1); + SvREFCNT_inc(self->cb_named_capture_buff_EXISTS); + } + +void +_named_capture_buff_FIRSTKEY(re::engine::Plugin self, ...) +PPCODE: + if (items > 1) { + self->cb_named_capture_buff_FIRSTKEY = ST(1); + SvREFCNT_inc(self->cb_named_capture_buff_FIRSTKEY); + } + +void +_named_capture_buff_NEXTKEY(re::engine::Plugin self, ...) +PPCODE: + if (items > 1) { + self->cb_named_capture_buff_NEXTKEY = ST(1); + SvREFCNT_inc(self->cb_named_capture_buff_NEXTKEY); + } + +void +_named_capture_buff_SCALAR(re::engine::Plugin self, ...) +PPCODE: + if (items > 1) { + self->cb_named_capture_buff_SCALAR = ST(1); + SvREFCNT_inc(self->cb_named_capture_buff_SCALAR); + } + void ENGINE() PPCODE: diff --git a/named-capture.patch b/named-capture.patch new file mode 100644 index 0000000..2cbcb8c --- /dev/null +++ b/named-capture.patch @@ -0,0 +1,1527 @@ +diff --git a/embed.fnc b/embed.fnc +index fec5643..643c652 100644 +--- a/embed.fnc ++++ b/embed.fnc +@@ -694,7 +694,15 @@ 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_fetch |NN REGEXP * const rx|NN SV * const namesv|const U32 flags ++EXp |void|reg_named_buff_store |NN REGEXP * const rx|NN SV * const key \ ++ |NN SV * const value|const U32 flags ++EXp |void|reg_named_buff_delete |NN REGEXP * const rx|NN SV * const key|const U32 flags ++EXp |void|reg_named_buff_clear |NN REGEXP * const rx|const U32 flags ++EXp |bool|reg_named_buff_exists |NN REGEXP * const rx|NN SV * const key|const U32 flags ++EXp |SV*|reg_named_buff_firstkey |NN REGEXP * const rx|const U32 flags ++EXp |SV*|reg_named_buff_nextkey |NN REGEXP * const rx|NN SV * const lastkey|const U32 flags ++EXp |SV*|reg_named_buff_scalar |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 +diff --git a/embed.h b/embed.h +index 8e0ecba..aa0aa72 100644 +--- a/embed.h ++++ b/embed.h +@@ -705,6 +705,13 @@ + #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_store Perl_reg_named_buff_store ++#define reg_named_buff_delete Perl_reg_named_buff_delete ++#define reg_named_buff_clear Perl_reg_named_buff_clear ++#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 + #endif + #if defined(PERL_CORE) || defined(PERL_EXT) + #define reg_numbered_buff_fetch Perl_reg_numbered_buff_fetch +@@ -2981,6 +2988,13 @@ + #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_store(a,b,c,d) Perl_reg_named_buff_store(aTHX_ a,b,c,d) ++#define reg_named_buff_delete(a,b,c) Perl_reg_named_buff_delete(aTHX_ a,b,c) ++#define reg_named_buff_clear(a,b) Perl_reg_named_buff_clear(aTHX_ a,b) ++#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,c) Perl_reg_named_buff_nextkey(aTHX_ a,b,c) ++#define reg_named_buff_scalar(a,b) Perl_reg_named_buff_scalar(aTHX_ a,b) + #endif + #if defined(PERL_CORE) || defined(PERL_EXT) + #define reg_numbered_buff_fetch(a,b,c) Perl_reg_numbered_buff_fetch(aTHX_ a,b,c) +diff --git a/ext/re/re.xs b/ext/re/re.xs +index 1344065..fe59940 100644 +--- a/ext/re/re.xs ++++ b/ext/re/re.xs +@@ -30,8 +30,22 @@ 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_fetch(pTHX_ REGEXP * const, SV * const, ++ const U32); ++extern void my_reg_named_buff_store(pTHX_ REGEXP * const rx, ++ SV * const key, SV * const value, ++ const U32 flags); ++extern void my_reg_named_buff_delete(pTHX_ REGEXP * const rx, ++ SV * const key, const U32 flags); ++extern void my_reg_named_buff_clear(pTHX_ REGEXP * const rx, const U32 flags); ++extern bool my_reg_named_buff_exists(pTHX_ REGEXP * const rx, ++ SV * const key, const U32 flags); ++extern SV* my_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, ++ const U32 flags); ++extern SV* my_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, ++ SV * const lastkey, const U32 flags); ++extern SV* my_reg_named_buff_scalar(pTHX_ REGEXP * const rx, ++ const U32 flags); + + extern SV* my_reg_qr_package(pTHX_ REGEXP * const rx); + #if defined(USE_ITHREADS) +@@ -52,6 +66,13 @@ const struct regexp_engine my_reg_engine = { + my_reg_numbered_buff_store, + my_reg_numbered_buff_length, + my_reg_named_buff_fetch, ++ my_reg_named_buff_store, ++ my_reg_named_buff_delete, ++ my_reg_named_buff_clear, ++ my_reg_named_buff_exists, ++ my_reg_named_buff_firstkey, ++ my_reg_named_buff_nextkey, ++ my_reg_named_buff_scalar, + 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 5570ed7..23ee654 100644 +--- a/ext/re/re_top.h ++++ b/ext/re/re_top.h +@@ -20,6 +20,13 @@ + #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_store my_reg_named_buff_store ++#define Perl_reg_named_buff_delete my_reg_named_buff_delete ++#define Perl_reg_named_buff_clear my_reg_named_buff_clear ++#define Perl_reg_named_buff_exists my_reg_named_buff_exists ++#define Perl_reg_named_buff_firstkey my_reg_named_buff_firstkey ++#define Perl_reg_named_buff_nextkey my_reg_named_buff_nextkey ++#define Perl_reg_named_buff_scalar my_reg_named_buff_scalar + #define Perl_reg_qr_package my_reg_qr_package + + #define PERL_NO_GET_CONTEXT +diff --git a/ext/re/t/re_funcs.t b/ext/re/t/re_funcs.t +index 0d9092a..fa3e11b 100644 +--- a/ext/re/t/re_funcs.t ++++ b/ext/re/t/re_funcs.t +@@ -40,23 +40,17 @@ use re qw(is_regexp regexp_pattern regmust + is($floating,undef,"Regmust anchored - ref"); + } + +- + if ('1234'=~/(?:(?\d)|(?!))(?\d)(?\d)(?\d)/){ + my @names = sort +regnames(); + is("@names","A B","regnames"); ++ my @names = sort +regnames(0); ++ is("@names","A B","regnames"); + @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)(?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); +diff --git a/global.sym b/global.sym +index c5181b4..0714bff 100644 +--- a/global.sym ++++ b/global.sym +@@ -406,6 +406,13 @@ Perl_re_intuit_string + Perl_regexec_flags + Perl_regnext + Perl_reg_named_buff_fetch ++Perl_reg_named_buff_store ++Perl_reg_named_buff_delete ++Perl_reg_named_buff_clear ++Perl_reg_named_buff_exists ++Perl_reg_named_buff_firstkey ++Perl_reg_named_buff_nextkey ++Perl_reg_named_buff_scalar + Perl_reg_numbered_buff_fetch + Perl_reg_numbered_buff_store + Perl_reg_numbered_buff_length +diff --git a/gv.c b/gv.c +index 17f754f..8f98f00 100644 +--- a/gv.c ++++ b/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; + } +diff --git a/lib/Tie/Hash/NamedCapture.pm b/lib/Tie/Hash/NamedCapture.pm +index 73bc20b..66cf1b5 100644 +--- a/lib/Tie/Hash/NamedCapture.pm ++++ b/lib/Tie/Hash/NamedCapture.pm +@@ -1,52 +1,19 @@ + 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; +-} ++# These should match the #defines in regexp.h ++sub RXf_HASH_ONE () { 0x00000001 } # %+ ++sub RXf_HASH_ALL () { 0x00000002 } # %- + +-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} ? RXf_HASH_ALL : RXf_HASH_ONE; ++ bless \$flag => $pkg; + } + + tie %+, __PACKAGE__; +@@ -91,6 +58,7 @@ buffers that have captured (and that are thus associated to defined values). + + =head1 SEE ALSO + +-L, L, L, L. ++L, L, L, L, ++L. + + =cut +diff --git a/mg.c b/mg.c +index 77ae021..bc08d4a 100644 +--- a/mg.c ++++ b/mg.c +@@ -603,15 +603,15 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) + } + case '`': + do_prematch: +- paren = -2; ++ paren = RXrf_PREMATCH; + goto maybegetparen; + case '\'': + do_postmatch: +- paren = -1; ++ paren = RXrf_POSTMATCH; + goto maybegetparen; + case '&': + do_match: +- paren = 0; ++ paren = RXrf_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 = RXrf_PREMATCH; + goto setparen; + case '\'': /* ${^POSTMATCH} caught below */ + do_postmatch: +- paren = -1; ++ paren = RXrf_POSTMATCH; + goto setparen; + case '&': + do_match: +- paren = 0; ++ paren = RXrf_MATCH; + goto setparen; + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': +diff --git a/perl.h b/perl.h +index 8cd8753..0a4aebf 100644 +--- a/perl.h ++++ b/perl.h +@@ -231,6 +231,27 @@ + #define CALLREG_NAMEDBUF_FETCH(rx,name,flags) \ + CALL_FPTR((rx)->engine->named_buff_FETCH)(aTHX_ (rx),(name),(flags)) + ++#define CALLREG_NAMEDBUF_STORE(rx,key,value,flags) \ ++ CALL_FPTR((rx)->engine->named_buff_STORE)(aTHX_ (rx),(key),(value),(flags)) ++ ++#define CALLREG_NAMEDBUF_DELETE(rx,key,flags) \ ++ CALL_FPTR((rx)->engine->named_buff_DELETE)(aTHX_ (rx),(key),(flags)) ++ ++#define CALLREG_NAMEDBUF_CLEAR(rx,flags) \ ++ CALL_FPTR((rx)->engine->named_buff_CLEAR)(aTHX_ (rx),(flags)) ++ ++#define CALLREG_NAMEDBUF_EXISTS(rx,key,flags) \ ++ CALL_FPTR((rx)->engine->named_buff_EXISTS)(aTHX_ (rx),(key),(flags)) ++ ++#define CALLREG_NAMEDBUF_FIRSTKEY(rx,flags) \ ++ CALL_FPTR((rx)->engine->named_buff_FIRSTKEY)(aTHX_ (rx),(flags)) ++ ++#define CALLREG_NAMEDBUF_NEXTKEY(rx,lastkey,flags) \ ++ CALL_FPTR((rx)->engine->named_buff_NEXTKEY)(aTHX_ (rx),(lastkey),(flags)) ++ ++#define CALLREG_NAMEDBUF_SCALAR(rx,flags) \ ++ CALL_FPTR((rx)->engine->named_buff_SCALAR)(aTHX_ (rx),(flags)) ++ + #define CALLREG_PACKAGE(rx) \ + CALL_FPTR((rx)->engine->qr_package)(aTHX_ (rx)) + +diff --git a/pod/perlreapi.pod b/pod/perlreapi.pod +index 1a170ff..08ae8cd 100644 +--- a/pod/perlreapi.pod ++++ b/pod/perlreapi.pod +@@ -26,6 +26,18 @@ structure of the following format: + const I32 paren); + SV* (*named_buff_FETCH) (pTHX_ REGEXP * const rx, SV * const sv, + const U32 flags); ++ void (*named_buff_STORE) (pTHX_ REGEXP * const rx, SV * const key, ++ SV * const value, const U32 flags); ++ void (*named_buff_DELETE) (pTHX_ REGEXP * const rx, ++ SV * const key, const U32 flags); ++ void (*named_buff_CLEAR) (pTHX_ REGEXP * const rx, const U32 flags); ++ bool (*named_buff_EXISTS) (pTHX_ REGEXP * const rx, ++ SV * const key, const U32 flags); ++ SV* (*named_buff_FIRSTKEY) (pTHX_ REGEXP * const rx, const U32 flags); ++ SV* (*named_buff_NEXTKEY) (pTHX_ REGEXP * const rx, ++ SV * const lastkey, const U32 flags); ++ SV* (*named_buff_SCALAR) (pTHX_ REGEXP * const rx, ++ const U32 flags); + SV* (*qr_package)(pTHX_ REGEXP * const rx); + #ifdef USE_ITHREADS + void* (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param); +@@ -186,38 +198,45 @@ can release any resources pointed to by the C member of the + regexp structure. This is only responsible for freeing private data; + perl will handle releasing anything else contained in the regexp structure. + +-=head2 numbered_buff_FETCH ++=head2 Numbered capture callbacks + +- void numbered_buff_FETCH(pTHX_ REGEXP * const rx, const I32 paren, +- SV * const sv); +- +-Called to get the value of C<$`>, C<$'>, C<$&> (and their named +-equivalents, see L) and the numbered capture buffers (C<$1>, +-C<$2>, ...). ++Called to get/set the value of C<$`>, C<$'>, C<$&> and their named ++equivalents, ${^PREMATCH}, ${^POSTMATCH} and $^{MATCH}, as well as the ++numbered capture buffers (C<$1>, C<$2>, ...). + + The C paramater will be C<-2> for C<$`>, C<-1> for C<$'>, C<0> + for C<$&>, C<1> for C<$1> and so forth. + +-C should be set to the scalar to return, the scalar is passed as +-an argument rather than being returned from the function because when +-it's called perl already has a scalar to store the value, creating +-another one would be redundant. The scalar can be set with +-C, C and friends, see L. ++The names have been chosen by analogy with L methods ++names with an additional B callback for efficiency. However ++named capture variables are currently not tied internally but ++implemented via magic. ++ ++=head3 numbered_buff_FETCH ++ ++ void numbered_buff_FETCH(pTHX_ REGEXP * const rx, const I32 paren, ++ SV * const sv); ++ ++Fetch a specified numbered capture. C should be set to the scalar ++to return, the scalar is passed as an argument rather than being ++returned from the function because when it's called perl already has a ++scalar to store the value, creating another one would be ++redundant. The scalar can be set with C, C and ++friends, see L. + + This callback is where perl untaints its own capture variables under + taint mode (see L). See the C + function in F for how to untaint capture variables if + that's something you'd like your engine to do as well. + +-=head2 numbered_buff_STORE ++=head3 numbered_buff_STORE + + void (*numbered_buff_STORE) (pTHX_ REGEXP * const rx, const I32 paren, + SV const * const value); + +-Called to set the value of a numbered capture variable. C is +-the paren number (see the L above) and +-C is the scalar that is to be used as the new value. It's up to +-the engine to make sure this is used as the new value (or reject it). ++Set the value of a numbered capture variable. C is the scalar ++that is to be used as the new value. It's up to the engine to make ++sure this is used as the new value (or reject it). + + Example: + +@@ -262,19 +281,19 @@ behave in the same situation: + + Because C<$sv> is C when the C operator is applied to it + the transliteration won't actually execute and the program won't +-C. This is different to how 5.8 behaved since the capture +-variables were READONLY variables then, now they'll just die on +-assignment in the default engine. ++C. This is different to how 5.8 and earlier versions behaved ++since the capture variables were READONLY variables then, now they'll ++just die when assigned to in the default engine. + +-=head2 numbered_buff_LENGTH ++=head3 numbered_buff_LENGTH + + I32 numbered_buff_LENGTH (pTHX_ REGEXP * const rx, const SV * const sv, + const I32 paren); + + Get the C of a capture variable. There's a special callback + for this so that perl doesn't have to do a FETCH and run C on +-the result, since the length is (in perl's case) known from a memory +-offset this is much more efficient: ++the result, since the length is (in perl's case) known from an offset ++stored in C<offs> this is much more efficient: + + I32 s1 = rx->offs[paren].start; + I32 s2 = rx->offs[paren].end; +@@ -284,14 +303,79 @@ This is a little bit more complex in the case of UTF-8, see what + C does with + L. + +-=head2 named_buff_FETCH ++=head2 Named capture callbacks ++ ++Called to get/set the value of C<%+> and C<%->. If C<%+> is being ++operated on C will be true and C will be true for C<%->. There's also an additional flag ++for the L callback, see below. ++ ++This is implemented with a real tied interface via ++L, its methods call back into these ++functions, the usage of L for this purpose ++might change in future releases. For instance this might be ++implemented by magic instead (would need an extension to mgvtbl). ++ ++Since these functions are just C level wrappers for the interface ++described in L their arguments and return values are as ++described there, only with C prototypes. ++ ++=head3 named_buff_FETCH + + SV* named_buff_FETCH(pTHX_ REGEXP * const rx, SV * const key, + const U32 flags); + +-Called to get the value of key in the C<%+> and C<%-> hashes, C +-is the hash key being requested and if C is true C<%-> is +-being requested (and C<%+> if it's not). ++Get an entry. ++ ++=head3 named_buff_STORE ++ ++ void named_buff_STORE (pTHX_ REGEXP * const rx, SV * const key, ++ SV * const value, const U32 flags); ++ ++Store a value. ++ ++=head3 named_buff_DELETE ++ ++ void named_buff_DELETE (pTHX_ REGEXP * const rx, ++ SV * const key, const U32 flags); ++ ++Delete an entry. ++ ++=head3 named_buff_CLEAR ++ ++ void named_buff_CLEAR (pTHX_ REGEXP * const rx, const U32 flags); ++ ++Clear the hash. ++ ++=head3 named_buff_EXISTS ++ ++ bool named_buff_EXISTS (pTHX_ REGEXP * const rx, ++ SV * const key, const U32 flags); ++ ++Check whether an entry C. ++ ++=head3 named_buff_FIRSTKEY ++ ++ SV* (*named_buff_FIRSTKEY) (pTHX_ REGEXP * const rx, const U32 flags); ++ ++Begin iterating the hash. ++ ++=head3 named_buff_NEXTKEY ++ ++ SV* named_buff_NEXTKEY (pTHX_ REGEXP * const rx, ++ SV * const lastkey, const U32 flags); ++ ++Get the next entry in the hash. ++ ++=head3 named_buff_SCALAR ++ ++ SV* named_buff_SCALAR (pTHX_ REGEXP * const rx, const U32 flags); ++ ++Return what the hash evaluates to in C context. ++ ++This will also be called by L to get the total ++number of named capture buffers defined for the pattern, in this case ++C will be true. + + =head2 qr_package + +@@ -333,7 +417,7 @@ following snippet: + SvTYPE(sv) == SVt_PVMG && + (mg = mg_find(sv, PERL_MAGIC_qr))) /* assignment deliberate */ + { +- re = (REGEXP *)mg->mg_obj; ++ re = (REGEXP *)mg->mg_obj; + } + + Or use the (CURRENTLY UNDOCUMENETED!) C function: +@@ -448,8 +532,9 @@ TODO, see L + + =head2 C + +-This will be used by perl to see what flags the regexp was compiled with, this +-will normally be set to the value of the flags parameter on L. ++This will be used by perl to see what flags the regexp was compiled ++with, this will normally be set to the value of the flags parameter by ++the L callback. + + =head2 C C + +@@ -479,7 +564,9 @@ Left offset from pos() to start match at. + + =head2 C + +-TODO: document ++Substring data about strings that must appear in the final match. This ++is currently only used internally by perl's engine for but might be ++used in the future for all engines for optimisations like C. + + =head2 C, C, and C + +@@ -490,7 +577,7 @@ the last close paren to be entered. + =head2 C + + The engine's private copy of the flags the pattern was compiled with. Usually +-this is the same as C unless the engine chose to modify one of them ++this is the same as C unless the engine chose to modify one of them. + + =head2 C + +@@ -520,8 +607,18 @@ C<$paren >= 1>. + + =head2 C C + +-Used for debugging purposes. C holds a copy of the pattern +-that was compiled and C its length. ++Used for optimisations. C holds a copy of the pattern that ++was compiled and C its length. When a new pattern is to be ++compiled (such as inside a loop) the internal C operator ++checks whether the last compiled C's C and C ++are equivalent to the new one, and if so uses the old pattern instead ++of compiling a new one. ++ ++The relevant snippet from C: ++ ++ if (!re || !re->precomp || re->prelen != (I32)len || ++ memNE(re->precomp, t, len)) ++ /* Compile a new pattern */ + + =head2 C + +@@ -563,11 +660,11 @@ inline modifiers it's best to have C stringify to the supplied pattern, + note that this will create invalid patterns in cases such as: + + my $x = qr/a|b/; # "a|b" +- my $y = qr/c/; # "c" ++ my $y = qr/c/i; # "c" + my $z = qr/$x$y/; # "a|bc" + +-There's no solution for such problems other than making the custom engine +-understand some for of inline modifiers. ++There's no solution for this problem other than making the custom ++engine understand a construct like C<(?:)>. + + The C in F does the stringification work. + +diff --git a/proto.h b/proto.h +index dee615f..02b24d5 100644 +--- a/proto.h ++++ b/proto.h +@@ -1893,10 +1893,36 @@ PERL_CALLCONV regnode* Perl_regnext(pTHX_ regnode* p) + __attribute__nonnull__(pTHX_1); + + +-PERL_CALLCONV SV* Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const key, const U32 flags) ++PERL_CALLCONV SV* Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); + ++PERL_CALLCONV void Perl_reg_named_buff_store(pTHX_ REGEXP * const rx, SV * const key, SV * const value, const U32 flags) ++ __attribute__nonnull__(pTHX_1) ++ __attribute__nonnull__(pTHX_2) ++ __attribute__nonnull__(pTHX_3); ++ ++PERL_CALLCONV void Perl_reg_named_buff_delete(pTHX_ REGEXP * const rx, SV * const key, const U32 flags) ++ __attribute__nonnull__(pTHX_1) ++ __attribute__nonnull__(pTHX_2); ++ ++PERL_CALLCONV void Perl_reg_named_buff_clear(pTHX_ REGEXP * const rx, const U32 flags) ++ __attribute__nonnull__(pTHX_1); ++ ++PERL_CALLCONV bool Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key, const U32 flags) ++ __attribute__nonnull__(pTHX_1) ++ __attribute__nonnull__(pTHX_2); ++ ++PERL_CALLCONV SV* Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags) ++ __attribute__nonnull__(pTHX_1); ++ ++PERL_CALLCONV SV* Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, SV * const lastkey, const U32 flags) ++ __attribute__nonnull__(pTHX_1) ++ __attribute__nonnull__(pTHX_2); ++ ++PERL_CALLCONV SV* Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags) ++ __attribute__nonnull__(pTHX_1); ++ + + PERL_CALLCONV void Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv) + __attribute__nonnull__(pTHX_1); +diff --git a/regcomp.c b/regcomp.c +index baa5d99..c144d76 100644 +--- a/regcomp.c ++++ b/regcomp.c +@@ -228,7 +228,7 @@ typedef struct RExC_state_t { + + /FOO[xX]A.*B[xX]BAR/ + +- Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating ++v Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating + strings (because they follow a .* construct). study_chunk will identify + both FOO and BAR as being the longest fixed and floating strings respectively. + +@@ -4800,7 +4800,7 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 + { + AV *retarray = NULL; + SV *ret; +- if (flags & 1) ++ if (flags & RXf_HASH_ALL) + retarray=newAV(); + + if (rx && rx->paren_names) { +@@ -4810,9 +4810,9 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 + SV* sv_dat=HeVAL(he_str); + I32 *nums=(I32*)SvPVX(sv_dat); + for ( i=0; inparens) >= nums[i] +- && rx->offs[nums[i]].start != -1 +- && rx->offs[nums[i]].end != -1) ++ if ((I32)(rx->nparens) >= nums[i] ++ && rx->offs[nums[i]].start != -1 ++ && rx->offs[nums[i]].end != -1) + { + ret = newSVpvs(""); + CALLREG_NUMBUF_FETCH(rx,nums[i],ret); +@@ -4827,13 +4827,116 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 + } + } + if (retarray) +- return (SV*)retarray; ++ return newRV((SV*)retarray); + } + } + return NULL; + } + + void ++Perl_reg_named_buff_store(pTHX_ REGEXP * const rx, SV * const key, ++ SV * const value, const U32 flags) ++{ ++ PERL_UNUSED_ARG(rx); ++ PERL_UNUSED_ARG(key); ++ PERL_UNUSED_ARG(value); ++ PERL_UNUSED_ARG(flags); ++ ++ Perl_croak(aTHX_ PL_no_modify); ++} ++ ++void ++Perl_reg_named_buff_delete(pTHX_ REGEXP * const rx, SV * const key, const U32 flags) ++{ ++ PERL_UNUSED_ARG(rx); ++ PERL_UNUSED_ARG(key); ++ PERL_UNUSED_ARG(flags); ++ ++ Perl_croak(aTHX_ PL_no_modify); ++} ++ ++void ++Perl_reg_named_buff_clear(pTHX_ REGEXP * const rx, const U32 flags) ++{ ++ PERL_UNUSED_ARG(rx); ++ PERL_UNUSED_ARG(flags); ++ ++ Perl_croak(aTHX_ PL_no_modify); ++} ++ ++bool ++Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key, ++ const U32 flags) ++{ ++ PERL_UNUSED_ARG(flags); ++ ++ if (rx && rx->paren_names) { ++ return hv_exists_ent(rx->paren_names, key, 0); ++ } else { ++ return FALSE; ++ } ++} ++ ++SV* ++Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags) ++{ ++ PERL_UNUSED_ARG(flags); ++ ++ (void)hv_iterinit(rx->paren_names); ++ ++ return CALLREG_NAMEDBUF_NEXTKEY(rx, NULL, flags); ++} ++ ++SV* ++Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, SV * const lastkey, ++ const U32 flags) ++{ ++ PERL_UNUSED_ARG(lastkey); ++ bool all = flags & RXf_HASH_ALL; ++ ++ if (rx && rx->paren_names) { ++ HV *hv= rx->paren_names; ++ while (1) { ++ HE *temphe = hv_iternext_flags(hv,0); ++ if (temphe) { ++ IV i; ++ IV parno = 0; ++ SV* sv_dat = HeVAL(temphe); ++ I32 *nums = (I32*)SvPVX(sv_dat); ++ for ( i = 0; i < SvIVX(sv_dat); i++ ) { ++ if ((I32)(rx->lastcloseparen) >= nums[i] && ++ rx->offs[nums[i]].start != -1 && ++ rx->offs[nums[i]].end != -1) ++ { ++ parno = nums[i]; ++ break; ++ } ++ } ++ if (parno || all) { ++ STRLEN len; ++ char *pv = HePV(temphe, len); ++ return newSVpvn(pv,len); ++ } ++ } else { ++ break; ++ } ++ } ++ } ++ ++ return NULL; ++} ++ ++SV* ++Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags) ++{ ++ PERL_UNUSED_ARG(flags); ++ ++ if (rx && rx->paren_names) ++ return newSViv(HvTOTALKEYS(rx->paren_names)); ++ return &PL_sv_undef; ++} ++ ++void + Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv) + { + char *s = NULL; +@@ -4845,13 +4948,13 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * cons + return; + } + else +- if (paren == -2 && rx->offs[0].start != -1) { ++ if (paren == RXrf_PREMATCH && rx->offs[0].start != -1) { + /* $` */ + i = rx->offs[0].start; + s = rx->subbeg; + } + else +- if (paren == -1 && rx->offs[0].end != -1) { ++ if (paren == RXrf_POSTMATCH && rx->offs[0].end != -1) { + /* $' */ + s = rx->subbeg + rx->offs[0].end; + i = rx->sublen - rx->offs[0].end; +@@ -4929,7 +5032,8 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv, + + /* Some of this code was originally in C in F */ + switch (paren) { +- case -2: /* $` */ ++ /* $` / ${^PREMATCH} */ ++ case RXrf_PREMATCH: + if (rx->offs[0].start != -1) { + i = rx->offs[0].start; + if (i > 0) { +@@ -4939,7 +5043,8 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv, + } + } + return 0; +- case -1: /* $' */ ++ /* $' / ${^POSTMATCH} */ ++ case RXrf_POSTMATCH: + if (rx->offs[0].end != -1) { + i = rx->sublen - rx->offs[0].end; + if (i > 0) { +@@ -4949,7 +5054,8 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv, + } + } + return 0; +- default: /* $&, $1, $2, ... */ ++ /* $& / ${^MATCH}, $1, $2, ... */ ++ default: + if (paren <= (I32)rx->nparens && + (s1 = rx->offs[paren].start) != -1 && + (t1 = rx->offs[paren].end) != -1) +diff --git a/regcomp.h b/regcomp.h +index 33c3eef..5be7f32 100644 +--- a/regcomp.h ++++ b/regcomp.h +@@ -473,6 +473,13 @@ EXTCONST regexp_engine PL_core_reg_engine = { + Perl_reg_numbered_buff_store, + Perl_reg_numbered_buff_length, + Perl_reg_named_buff_fetch, ++ Perl_reg_named_buff_store, ++ Perl_reg_named_buff_delete, ++ Perl_reg_named_buff_clear, ++ Perl_reg_named_buff_exists, ++ Perl_reg_named_buff_firstkey, ++ Perl_reg_named_buff_nextkey, ++ Perl_reg_named_buff_scalar, + Perl_reg_qr_package, + #if defined(USE_ITHREADS) + Perl_regdupe_internal +diff --git a/regexp.h b/regexp.h +index 1f72112..31d264d 100644 +--- a/regexp.h ++++ b/regexp.h +@@ -136,14 +136,40 @@ typedef struct regexp_engine { + SV const * const value); + I32 (*numbered_buff_LENGTH) (pTHX_ REGEXP * const rx, const SV * const sv, + const I32 paren); +- SV* (*named_buff_FETCH) (pTHX_ REGEXP * const rx, SV * const key, ++ SV* (*named_buff_FETCH) (pTHX_ REGEXP * const rx, SV * const sv, + const U32 flags); ++ void (*named_buff_STORE) (pTHX_ REGEXP * const rx, SV * const key, ++ SV * const value, const U32 flags); ++ void (*named_buff_DELETE) (pTHX_ REGEXP * const rx, ++ SV * const key, const U32 flags); ++ void (*named_buff_CLEAR) (pTHX_ REGEXP * const rx, const U32 flags); ++ bool (*named_buff_EXISTS) (pTHX_ REGEXP * const rx, ++ SV * const key, const U32 flags); ++ SV* (*named_buff_FIRSTKEY) (pTHX_ REGEXP * const rx, const U32 flags); ++ SV* (*named_buff_NEXTKEY) (pTHX_ REGEXP * const rx, ++ SV * const lastkey, const U32 flags); ++ SV* (*named_buff_SCALAR) (pTHX_ REGEXP * const rx, ++ const U32 flags); + SV* (*qr_package)(pTHX_ REGEXP * const rx); + #ifdef USE_ITHREADS + void* (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param); + #endif + } regexp_engine; + ++/* ++ These are passed to the numbered capture variable callbacks as the ++ paren name. >= 1 is reserved for actual numbered captures, i.e. $1, ++ $2 etc. ++*/ ++ ++#define RXrf_PREMATCH -2 /* $` / ${^PREMATCH} */ ++#define RXrf_POSTMATCH -1 /* $' / ${^POSTMATCH} */ ++#define RXrf_MATCH 0 /* $& / ${^MATCH} */ ++ ++#define RXf_HASH_ONE 0x00000001 /* %+ */ ++#define RXf_HASH_ALL 0x00000002 /* %- */ ++#define RXf_HASH_COUNT 0x00000004 /* scalar %+ / scalar %- */ ++ + /* Flags stored in regexp->extflags + * These are used by code external to the regexp engine + * +diff --git a/t/TEST b/t/TEST +old mode 100644 +new mode 100755 +diff --git a/t/op/readdir.t b/t/op/readdir.t +index c4d5ed2..971a02a 100644 +--- a/t/op/readdir.t ++++ b/t/op/readdir.t +@@ -24,7 +24,7 @@ closedir(OP); + ## This range will have to adjust as the number of tests expands, + ## as it's counting the number of .t files in src/t + ## +-my ($min, $max) = (140, 160); ++my ($min, $max) = (150, 170); + if (@D > $min && @D < $max) { print "ok 2\n"; } + else { + printf "not ok 2 # counting op/*.t, expect $min < %d < $max files\n", +diff --git a/t/op/regexp_namedcapture_tie.t b/t/op/regexp_namedcapture_tie.t +new file mode 100644 +index 0000000..f72970e +--- /dev/null ++++ b/t/op/regexp_namedcapture_tie.t +@@ -0,0 +1,48 @@ ++#!./perl ++ ++BEGIN { ++ chdir 't' if -d 't'; ++ @INC = '../lib'; ++ require './test.pl'; ++} ++ ++# Do a basic test on all the tied methods of Tie::Hash::NamedCapture ++ ++print "1..12\n"; ++ ++"hlagh" =~ / ++ (?.) ++ (?.) ++ (?.) ++ .* ++ (?$) ++/x; ++ ++# FETCH ++is($+{a}, "h", "FETCH"); ++is($+{b}, "l", "FETCH"); ++is($-{a}[0], "h", "FETCH"); ++is($-{a}[1], "a", "FETCH"); ++ ++# STORE ++eval { $+{a} = "yon" }; ++ok(index($@, "read-only") != -1, "STORE"); ++ ++# DELETE ++eval { delete $+{a} }; ++ok(index($@, "read-only") != -1, "DELETE"); ++ ++# CLEAR ++eval { %+ = () }; ++ok(index($@, "read-only") != -1, "CLEAR"); ++ ++# EXISTS ++ok(exists $+{e}, "EXISTS"); ++ok(!exists $+{d}, "EXISTS"); ++ ++# FIRSTKEY/NEXTKEY ++is(join('|', sort keys %+), "a|b|e", "FIRSTKEY/NEXTKEY"); ++ ++# SCALAR ++is(scalar(%+), 3, "SCALAR"); ++is(scalar(%-), 3, "SCALAR"); +diff --git a/universal.c b/universal.c +index 396dd3d..f506441 100644 +--- a/universal.c ++++ b/universal.c +@@ -16,6 +16,11 @@ + + /* This file contains the code that implements the functions in Perl's + * UNIVERSAL package, such as UNIVERSAL->can(). ++ * ++ * It is also used to store XS functions that need to be present in ++ * miniperl for a lack of a better place to put them. It might be ++ * clever to move them to seperate XS files which would then be pulled ++ * in by some to-be-written build process. + */ + + #include "EXTERN.h" +@@ -226,11 +231,17 @@ XS(XS_Internals_rehash_seed); + XS(XS_Internals_HvREHASH); + XS(XS_Internals_inc_sub_generation); + XS(XS_re_is_regexp); +-XS(XS_re_regname); +-XS(XS_re_regnames); +-XS(XS_re_regnames_iterinit); +-XS(XS_re_regnames_iternext); ++XS(XS_re_regname); ++XS(XS_re_regnames); + XS(XS_re_regnames_count); ++XS(XS_Tie_Hash_NamedCapture_FETCH); ++XS(XS_Tie_Hash_NamedCapture_STORE); ++XS(XS_Tie_Hash_NamedCapture_DELETE); ++XS(XS_Tie_Hash_NamedCapture_CLEAR); ++XS(XS_Tie_Hash_NamedCapture_EXISTS); ++XS(XS_Tie_Hash_NamedCapture_FIRSTKEY); ++XS(XS_Tie_Hash_NamedCapture_NEXTKEY); ++XS(XS_Tie_Hash_NamedCapture_SCALAR); + + void + Perl_boot_core_UNIVERSAL(pTHX) +@@ -284,9 +295,15 @@ Perl_boot_core_UNIVERSAL(pTHX) + newXSproto("re::is_regexp", XS_re_is_regexp, file, "$"); + newXSproto("re::regname", XS_re_regname, file, ";$$"); + newXSproto("re::regnames", XS_re_regnames, file, ";$"); +- newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, ""); +- newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$"); + newXSproto("re::regnames_count", XS_re_regnames_count, 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); ++ newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file); ++ newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file); ++ newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTKEY, file); ++ newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTKEY, file); ++ newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file); + } + + +@@ -1072,206 +1089,341 @@ XS(XS_re_is_regexp) + /* NOTREACHED */ + PUTBACK; + return; ++ + } + } + +-XS(XS_re_regname) ++XS(XS_re_regnames_count) + { +- ++ REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; ++ SV *ret; + dVAR; + dXSARGS; ++ ++ if (items != 0) ++ Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", ""); ++ PERL_UNUSED_VAR(cv); /* -W */ ++ PERL_UNUSED_VAR(ax); /* -Wall */ ++ SP -= items; ++ ++ if (!rx) ++ XSRETURN_UNDEF; ++ ++ ret = CALLREG_NAMEDBUF_SCALAR(rx, RXf_HASH_COUNT); ++ ++ SPAGAIN; ++ ++ if (ret) { ++ XPUSHs(ret); ++ PUTBACK; ++ return; ++ } else { ++ XSRETURN_UNDEF; ++ } ++} ++ ++XS(XS_re_regname) ++{ ++ dVAR; ++ dXSARGS; + if (items < 1 || items > 2) +- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]"); ++ Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; +- { +- SV * sv = ST(0); +- SV * all; +- regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL; +- SV *bufs = NULL; ++ REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; ++ U32 flags; ++ SV * ret; + +- if (items < 2) +- all = NULL; +- else { +- all = ST(1); +- } +- { +- if (SvPOK(sv) && re && re->paren_names) { +- bufs = CALLREG_NAMEDBUF_FETCH(re,sv,all && SvTRUE(all)); +- if (bufs) { +- if (all && SvTRUE(all)) +- XPUSHs(newRV(bufs)); +- else +- XPUSHs(SvREFCNT_inc(bufs)); +- XSRETURN(1); +- } +- } +- XSRETURN_UNDEF; +- } +- PUTBACK; +- return; ++ if (!rx) ++ XSRETURN_UNDEF; ++ ++ if (items == 2 && SvTRUE(ST(1))) { ++ flags = RXf_HASH_ALL; ++ } else { ++ flags = RXf_HASH_ONE; ++ } ++ ret = CALLREG_NAMEDBUF_FETCH(rx, ST(0), flags); ++ ++ if (ret) { ++ if (SvROK(ret)) ++ XPUSHs(ret); ++ else ++ XPUSHs(SvREFCNT_inc(ret)); ++ XSRETURN(1); + } ++ XSRETURN_UNDEF; + } + ++ + XS(XS_re_regnames) + { +- dVAR; ++ dVAR; + dXSARGS; + if (items < 0 || items > 1) +- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]"); ++ Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]"); + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; +- { +- SV * all; +- regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL; +- IV count = 0; ++ REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; ++ U32 flags; ++ IV count = 0; + +- if (items < 1) +- all = NULL; +- else { +- all = ST(0); +- } +- { +- if (re && re->paren_names) { +- HV *hv= re->paren_names; +- (void)hv_iterinit(hv); +- while (1) { +- HE *temphe = hv_iternext_flags(hv,0); +- if (temphe) { +- IV i; +- IV parno = 0; +- SV* sv_dat = HeVAL(temphe); +- I32 *nums = (I32*)SvPVX(sv_dat); +- for ( i = 0; i < SvIVX(sv_dat); i++ ) { +- if ((I32)(re->lastcloseparen) >= nums[i] && +- re->offs[nums[i]].start != -1 && +- re->offs[nums[i]].end != -1) +- { +- parno = nums[i]; +- break; +- } +- } +- if (parno || (all && SvTRUE(all))) { +- STRLEN len; +- char *pv = HePV(temphe, len); +- if ( GIMME_V == G_ARRAY ) +- XPUSHs(newSVpvn(pv,len)); +- count++; +- } +- } else { ++ if (!rx) ++ XSRETURN_UNDEF; ++ ++ if (items == 1 && SvTRUE(ST(0))) { ++ flags = 1; ++ } else { ++ flags = 0; ++ } ++ ++ if (rx && rx->paren_names) { ++ HV *hv= rx->paren_names; ++ (void)hv_iterinit(hv); ++ while (1) { ++ HE *temphe = hv_iternext_flags(hv,0); ++ if (temphe) { ++ IV i; ++ IV parno = 0; ++ SV* sv_dat = HeVAL(temphe); ++ I32 *nums = (I32*)SvPVX(sv_dat); ++ for ( i = 0; i < SvIVX(sv_dat); i++ ) { ++ if ((I32)(rx->lastcloseparen) >= nums[i] && ++ rx->offs[nums[i]].start != -1 && ++ rx->offs[nums[i]].end != -1) ++ { ++ parno = nums[i]; + break; + } + } ++ if (parno || flags) { ++ STRLEN len; ++ char *pv = HePV(temphe, len); ++ if ( GIMME_V == G_ARRAY ) ++ XPUSHs(newSVpvn(pv,len)); ++ count++; ++ } ++ } else { ++ break; + } +- if ( GIMME_V == G_ARRAY ) +- XSRETURN(count); +- else +- XSRETURN_UNDEF; +- } +- PUTBACK; +- return; ++ } + } ++ ++ if ( GIMME_V == G_ARRAY ) ++ XSRETURN(count); ++ else ++ XSRETURN_UNDEF; + } + +- +-XS(XS_re_regnames_iterinit) ++XS(XS_Tie_Hash_NamedCapture_FETCH) + { +- dVAR; ++ dVAR; + dXSARGS; +- if (items != 0) +- Perl_croak(aTHX_ "Usage: re::regnames_iterinit()"); +- PERL_UNUSED_VAR(cv); /* -W */ +- PERL_UNUSED_VAR(ax); /* -Wall */ ++ REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; ++ U32 flags; ++ SV * ret; ++ ++ if (items != 2) ++ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $flags)"); ++ ++ if (!rx) ++ XSRETURN_UNDEF; ++ + SP -= items; +- { +- regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL; +- if (re && re->paren_names) { +- (void)hv_iterinit(re->paren_names); +- XPUSHs(newSViv(HvTOTALKEYS(re->paren_names))); +- } else { ++ ++ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); ++ ret = CALLREG_NAMEDBUF_FETCH(rx, ST(1), flags); ++ ++ SPAGAIN; ++ ++ if (ret) { ++ if (SvROK(ret)) ++ XPUSHs(ret); ++ else ++ XPUSHs(SvREFCNT_inc(ret)); ++ PUTBACK; ++ return; ++ } ++ XSRETURN_UNDEF; ++} ++ ++XS(XS_Tie_Hash_NamedCapture_STORE) ++{ ++ dVAR; ++ dXSARGS; ++ REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; ++ U32 flags; ++ ++ if (items != 3) ++ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $value, $flags)"); ++ ++ if (!rx) { ++ if (!PL_localizing) ++ Perl_croak(aTHX_ PL_no_modify); ++ else + XSRETURN_UNDEF; +- } +- PUTBACK; +- return; + } ++ ++ SP -= items; ++ ++ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); ++ CALLREG_NAMEDBUF_STORE(rx,ST(1), ST(2), flags); + } + ++XS(XS_Tie_Hash_NamedCapture_DELETE) ++{ ++ dVAR; ++ dXSARGS; ++ REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; ++ U32 flags; + +-XS(XS_re_regnames_iternext) ++ if (items != 2) ++ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::DELETE($key, $flags)"); ++ ++ if (!rx) ++ Perl_croak(aTHX_ PL_no_modify); ++ ++ SP -= items; ++ ++ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); ++ CALLREG_NAMEDBUF_DELETE(rx, ST(1), flags); ++} ++ ++XS(XS_Tie_Hash_NamedCapture_CLEAR) + { +- dVAR; ++ dVAR; + dXSARGS; +- if (items < 0 || items > 1) +- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "[all]"); +- PERL_UNUSED_VAR(cv); /* -W */ +- PERL_UNUSED_VAR(ax); /* -Wall */ ++ REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; ++ U32 flags; ++ ++ if (items != 1) ++ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::CLEAR($flags)"); ++ ++ if (!rx) ++ Perl_croak(aTHX_ PL_no_modify); ++ + SP -= items; +- { +- SV * all; +- regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + +- if (items < 1) +- all = NULL; +- else { +- all = ST(0); +- } +- if (re && re->paren_names) { +- HV *hv= re->paren_names; +- while (1) { +- HE *temphe = hv_iternext_flags(hv,0); +- if (temphe) { +- IV i; +- IV parno = 0; +- SV* sv_dat = HeVAL(temphe); +- I32 *nums = (I32*)SvPVX(sv_dat); +- for ( i = 0; i < SvIVX(sv_dat); i++ ) { +- if ((I32)(re->lastcloseparen) >= nums[i] && +- re->offs[nums[i]].start != -1 && +- re->offs[nums[i]].end != -1) +- { +- parno = nums[i]; +- break; +- } +- } +- if (parno || (all && SvTRUE(all))) { +- STRLEN len; +- char *pv = HePV(temphe, len); +- XPUSHs(newSVpvn(pv,len)); +- XSRETURN(1); +- } +- } else { +- break; +- } +- } +- } ++ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); ++ CALLREG_NAMEDBUF_CLEAR(rx, flags); ++} ++ ++XS(XS_Tie_Hash_NamedCapture_EXISTS) ++{ ++ dVAR; ++ dXSARGS; ++ REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; ++ U32 flags; ++ bool exists; ++ ++ if (items != 2) ++ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::EXISTS($key, $flags)"); ++ ++ if (!rx) + XSRETURN_UNDEF; +- PUTBACK; +- return; ++ ++ SP -= items; ++ ++ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); ++ exists = CALLREG_NAMEDBUF_EXISTS(rx, ST(1), flags); ++ ++ SPAGAIN; ++ ++ if (exists) { ++ XSRETURN_YES; ++ } else { ++ XSRETURN_NO; + } + } + ++XS(XS_Tie_Hash_NamedCapture_FIRSTKEY) ++{ ++ dVAR; ++ dXSARGS; ++ REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; ++ U32 flags; ++ SV * ret; + +-XS(XS_re_regnames_count) ++ if (items != 1) ++ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::FIRSTKEY()"); ++ ++ if (!rx) ++ XSRETURN_UNDEF; ++ ++ SP -= items; ++ ++ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); ++ ret = CALLREG_NAMEDBUF_FIRSTKEY(rx, flags); ++ ++ SPAGAIN; ++ ++ if (ret) { ++ XPUSHs(SvREFCNT_inc(ret)); ++ PUTBACK; ++ } else { ++ XSRETURN_UNDEF; ++ } ++ ++} ++ ++XS(XS_Tie_Hash_NamedCapture_NEXTKEY) + { +- regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL; +- dVAR; ++ dVAR; + dXSARGS; ++ REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; ++ U32 flags; ++ SV * ret; ++ ++ if (items != 2) ++ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::NEXTKEY($lastkey)"); ++ ++ if (!rx) ++ XSRETURN_UNDEF; + +- if (items != 0) +- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", ""); +- PERL_UNUSED_VAR(cv); /* -W */ +- PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; +- +- if (re && re->paren_names) { +- XPUSHs(newSViv(HvTOTALKEYS(re->paren_names))); ++ ++ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); ++ ret = CALLREG_NAMEDBUF_NEXTKEY(rx, ST(1), flags); ++ ++ SPAGAIN; ++ ++ if (ret) { ++ XPUSHs(ret); + } else { + XSRETURN_UNDEF; + } + PUTBACK; +- return; ++} ++ ++XS(XS_Tie_Hash_NamedCapture_SCALAR) ++{ ++ dVAR; ++ dXSARGS; ++ REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; ++ U32 flags; ++ SV * ret; ++ ++ if (items != 1) ++ Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::SCALAR()"); ++ ++ if (!rx) ++ XSRETURN_UNDEF; ++ ++ SP -= items; ++ ++ flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); ++ ret = CALLREG_NAMEDBUF_SCALAR(rx, flags); ++ ++ SPAGAIN; ++ ++ if (ret) { ++ XPUSHs(ret); ++ PUTBACK; ++ return; ++ } else { ++ XSRETURN_UNDEF; ++ } + } + + diff --git a/t/methods/stash.t b/t/methods/stash.t index b719753..34895e2 100644 --- a/t/methods/stash.t +++ b/t/methods/stash.t @@ -5,7 +5,7 @@ Test the C method =cut use strict; -use Test::More tests => 4; +use Test::More tests => 5; use re::engine::Plugin ( comp => sub { @@ -19,6 +19,9 @@ use re::engine::Plugin ( my ($re, $str) = @_; my $stash = $re->stash; + my $ret = $re->stash( $stash ); + ok(!$ret, "stash returns no value on assignment"); + my %h = qw( 0 a 1 o 2 e 3 u ); for (keys %h) { is($h{$_}, $stash->[$_]); diff --git a/t/methods/str/modify.t b/t/methods/str/modify.t new file mode 100644 index 0000000..a30d76a --- /dev/null +++ b/t/methods/str/modify.t @@ -0,0 +1,17 @@ +use strict; +use Test::More tests => 1; +use re::engine::Plugin ( + exec => sub { + my ($re, $str) = @_; + + $$str = "eek"; + + return 1; + }, +); + +my $sv = "ook"; +if (\$sv =~ /pattern/) { + is($sv, "eek"); +} + diff --git a/t/methods/str/types.t b/t/methods/str/types.t index f79ba36..ed45fb1 100644 --- a/t/methods/str/types.t +++ b/t/methods/str/types.t @@ -4,18 +4,18 @@ use re::engine::Plugin ( exec => sub { my ($re, $str) = @_; - is_deeply($str, $re->str); + isa_ok($str, $re->pattern); return 1; }, ); my $sv; -"SCALAR" =~ \$sv; -"REF" =~ \\$sv; -"ARRAY" =~ []; -"HASH" =~ {}; -"GLOB" =~ \*STDIN; -"CODE" =~ sub {}; -"main" =~ bless {} => "main"; +\$sv =~ "SCALAR"; +\\$sv =~ "REF"; +[] =~ "ARRAY"; +{} =~ "HASH"; +\*STDIN =~ "GLOB"; +sub {} =~ "CODE"; +bless({} => "main") =~ "main" diff --git a/t/named_buff/CLEAR.t b/t/named_buff/CLEAR.t new file mode 100644 index 0000000..fcd97a7 --- /dev/null +++ b/t/named_buff/CLEAR.t @@ -0,0 +1,38 @@ +use strict; +use Test::More tests => 6; + +use re::engine::Plugin ( + exec => sub { + my $re = shift; + + $re->stash( [ + { flags => 0 }, + { flags => 0 }, + { flags => 0 }, + { flags => 1 }, + { flags => 1 }, + { flags => 1 }, + ] ); + + $re->named_captures( + CLEAR => sub { + my ($re, $flags) = @_; + my $hv = shift @{ $re->stash }; + + is($flags, $hv->{flags}, "flags == $flags"); + }, + ); + + 1; + }, +); + +"a" =~ /a/; +%+ = (); +%+ = (a => 1); +undef %+; +%- = (); +%- = (b => 1); +undef %-; + + diff --git a/t/named_buff/DELETE.t b/t/named_buff/DELETE.t new file mode 100644 index 0000000..5eee569 --- /dev/null +++ b/t/named_buff/DELETE.t @@ -0,0 +1,37 @@ +use strict; +use Test::More tests => 4; + +use re::engine::Plugin ( + exec => sub { + my $re = shift; + + $re->stash( [ + { + key => 'one', + flags => 0, + }, + { + key => 'two', + flags => 1, + }, + ] ); + + $re->named_captures( + DELETE => sub { + my ($re, $key, $flags) = @_; + my $hv = shift @{ $re->stash }; + + is($key, $hv->{key}, "key eq $key"); + is($flags, $hv->{flags}, "flags == $flags"); + }, + ); + + 1; + }, +); + +"a" =~ /a/; +delete $+{one}; +delete $-{two}; + + diff --git a/t/named_buff/EXISTS.t b/t/named_buff/EXISTS.t new file mode 100644 index 0000000..7b5a7dc --- /dev/null +++ b/t/named_buff/EXISTS.t @@ -0,0 +1,31 @@ +use strict; +use Test::More tests => 6; + +use re::engine::Plugin ( + exec => sub { + my $re = shift; + + $re->stash( [ + { key => "boob", flags => 0, ret => 1 }, + { key => "ies", flags => 1, ret => 0 }, + ] ); + + $re->named_captures( + EXISTS => sub { + my ($re, $key, $flags) = @_; + my $hv = shift @{ $re->stash }; + + is($key, $hv->{key}, "key == $key"); + is($flags, $hv->{flags}, "flags == $flags"); + return $hv->{ret}; + }, + ); + + 1; + }, +); + +"a" =~ /a/; +ok(exists $+{boob}); +ok(!exists $-{ies});; + diff --git a/t/named_buff/FETCH.t b/t/named_buff/FETCH.t new file mode 100644 index 0000000..b8e88a9 --- /dev/null +++ b/t/named_buff/FETCH.t @@ -0,0 +1,51 @@ +use strict; +use Test::More tests => 16; + +use re::engine::Plugin ( + exec => sub { + my $re = shift; + + $re->stash( [ + { + key => "a", + flags => 0, + ret => "b", + }, + { + key => "c", + flags => 0, + ret => "d", + }, + { + key => "e", + flags => 1, + ret => "f", + }, + { + key => "g", + flags => 1, + ret => \%ENV, + }, + ] ); + + $re->named_captures( + FETCH => sub { + my ($re, $key, $flags) = @_; + my $hv = shift @{ $re->stash }; + + is($key, $hv->{key}, "key == $key"); + is($flags, $hv->{flags}, "flags == $flags"); + is($hv->{ret}, $hv->{ret}, "ret = $hv->{ret}"); + return $hv->{ret}; + }, + ); + + 1; + }, +); + +"a" =~ /a/; +cmp_ok($+{a}, 'eq', "b"); +cmp_ok($+{c}, 'eq', "d"); +cmp_ok($-{e}, 'eq', "f"); +cmp_ok($-{g}, '==', \%ENV); diff --git a/t/named_buff/FIRSTKEY.t b/t/named_buff/FIRSTKEY.t new file mode 100644 index 0000000..b02ca02 --- /dev/null +++ b/t/named_buff/FIRSTKEY.t @@ -0,0 +1,53 @@ +use strict; +use Test::More tests => 10; + +use re::engine::Plugin ( + exec => sub { + my $re = shift; + + my $stash = 0; + my @stash = ( + { + key => "a", + flags => 0, + ret => "b", + }, + { + key => "c", + flags => 1, + ret => "d", + }, + ); + + $re->named_captures( + FIRSTKEY => sub { + my ($re, $flags) = @_; + my $hv = $stash[$stash]; + + return $hv->{key}; + }, + FETCH => sub { + my ($re, $key, $flags) = @_; + my $hv = $stash[$stash++]; + + is($key, $hv->{key}, "key == $key"); + is($flags, $hv->{flags}, "flags == $flags"); + is($hv->{ret}, $hv->{ret}, "ret = $hv->{ret}"); + return $hv->{ret}; + }, + ); + + 1; + }, +); + +"a" =~ /a/; +my ($k, $v); + +($k, $v) = each %+; +is($k, "a"); +is($v, "b"); + +($k, $v) = each %-; +is($k, "c"); +is($v, "d"); diff --git a/t/named_buff/NEXTKEY.t b/t/named_buff/NEXTKEY.t new file mode 100644 index 0000000..74a8d29 --- /dev/null +++ b/t/named_buff/NEXTKEY.t @@ -0,0 +1,29 @@ +use strict; +use Test::More tests => 6; + +use re::engine::Plugin ( + exec => sub { + my $re = shift; + + my @keys = ("a" .. "f"); + + $re->named_captures( + FIRSTKEY => sub { shift @keys }, + NEXTKEY => sub { + my ($re, $lastkey, $flag) = @_; + my $key = shift @keys; + + is(chr(ord($key)-1), $lastkey, "$lastkey value makes sense") + if defined $key; + + return $key; + }, + ); + + 1; + }, +); + +"a" =~ /a/; +my $key = join "|", keys %+; +is($key, "a|b|c|d|e|f", "key row correct"); diff --git a/t/named_buff/SCALAR.t b/t/named_buff/SCALAR.t new file mode 100644 index 0000000..cb5e3f3 --- /dev/null +++ b/t/named_buff/SCALAR.t @@ -0,0 +1,31 @@ +use strict; +use Test::More tests => 6; + +use re::engine::Plugin ( + exec => sub { + my ($re) = @_; + + my @stash = ( + { flags => 0, ret => "ook" }, + { flags => 1, ret => "eek" }, + ); + + $re->named_captures( + SCALAR => sub { + my ($re, $flags) = @_; + my $hv = shift @stash; + + is($flags, $hv->{flags}, "flags == $flags"); + ok($hv->{ret}, "ret == $hv->{ret}"); + + return $hv->{ret}; + }, + ); + + 1; + }, +); + +"a" =~ /a/; +is(scalar %+, "ook"); +is(scalar %-, "eek"); diff --git a/t/named_buff/STORE.t b/t/named_buff/STORE.t new file mode 100644 index 0000000..2ed6b4f --- /dev/null +++ b/t/named_buff/STORE.t @@ -0,0 +1,52 @@ +use strict; +use Test::More tests => 12; + +use re::engine::Plugin ( + exec => sub { + my $re = shift; + + $re->stash( [ + { + key => 'one', + value => 'a', + flags => 0, + }, + { + key => 'two', + value => 'b', + flags => 0, + }, + { + key => 'three', + value => 'c', + flags => 1, + }, + { + key => 'four', + value => 'd', + flags => 1, + }, + ] ); + + $re->named_captures( + STORE => sub { + my ($re, $key, $value, $flags) = @_; + my $hv = shift @{ $re->stash }; + + is($key, $hv->{key}, "key eq $key"); + is($value, $hv->{value}, "value eq $value"); + is($flags, $hv->{flags}, "flags == $flags"); + }, + ); + + 1; + }, +); + +"a" =~ /a/; +$+{one} = "a"; +$+{two} = "b"; +$-{three} = "c"; +$-{four} = "d"; + + diff --git a/t/usage/basic.pm b/t/usage/basic.pm new file mode 100644 index 0000000..80add8b --- /dev/null +++ b/t/usage/basic.pm @@ -0,0 +1,31 @@ +package basic; +use strict; + +# Note the (), doesn't call ->import +use re::engine::Plugin (); + +sub import { + # Populates %^H with re::engine::Plugin hooks + re::engine::Plugin->import( + exec => \&exec, + ); +} + +*unimport = \&re::engine::Plugin::unimport; + +sub exec +{ + my ($re, $str) = @_; + + $re->num_captures( + FETCH => sub { + my ($re, $paren) = @_; + + $str . "_" . $paren; + } + ); + + 1; +} + +1; diff --git a/t/usage/basic.t b/t/usage/basic.t new file mode 100644 index 0000000..d7f2c57 --- /dev/null +++ b/t/usage/basic.t @@ -0,0 +1,9 @@ +use strict; +use lib 't/usage'; +use Test::More tests => 1; + +use basic; + +"str" =~ /pattern/; + +is($1, "str_1"); diff --git a/t/usage/import.pm b/t/usage/import.pm new file mode 100644 index 0000000..0c364ec --- /dev/null +++ b/t/usage/import.pm @@ -0,0 +1,22 @@ +package import; +use strict; + +sub exec; +use re::engine::Plugin ':import'; + +sub exec +{ + my ($re, $str) = @_; + + $re->num_captures( + FETCH => sub { + my ($re, $paren) = @_; + + $str . "_" . $paren; + } + ); + + 1; +} + +1; diff --git a/t/usage/import.t b/t/usage/import.t new file mode 100644 index 0000000..40aad43 --- /dev/null +++ b/t/usage/import.t @@ -0,0 +1,40 @@ +use strict; +use lib 't/usage'; +use Test::More skip_all => "Needs lameness in user code"; + +# my $caller = caller; +# +# This won't work unless the subs are predeclared before the C statement +# # Handle import tags +# if (@_ == 1) { +# if ($_[0] ne ":import") { +# require Carp; +# Carp::croak("Unknown tag '$_[0]'"); +# } +# +# # We have :import, generate import and unimport methods in the +# # calling package +# my %pkg; +# for (qw(comp exec)) { +# no strict 'refs'; +# $pkg{$_} = *{"$caller\::$_"}{CODE} if *{"$caller\::$_"}{CODE}; +# } +# +# use Data::Dumper; +# warn Dumper \%pkg; +# +# no strict 'refs'; +# *{"$caller\::import"} = sub { +# __PACKAGE__->import(%pkg); +# }; +# *{"$caller\::unimport"} = \&unimport; +# +# return; +# } +# + +use import; + +"ook" =~ /pattern/; + +is($1, "ook_1");