Re: [PATCH] Change implementation of %+ to use a proper tied hash interface and add...
authorYves Orton <demerphq@gmail.com>
Fri, 29 Dec 2006 21:45:51 +0000 (22:45 +0100)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Thu, 4 Jan 2007 14:30:02 +0000 (14:30 +0000)
Message-ID: <9b18b3110612291245q792fe91cu69422d2b81bb4f0b@mail.gmail.com>

p4raw-id: //depot/perl@29682

21 files changed:
MANIFEST
doop.c
dump.c
embed.fnc
embed.h
ext/re/lib/re/Tie/Hash/NamedCapture.pm [new file with mode: 0644]
ext/re/re.pm
ext/re/re.xs
ext/re/t/re_funcs.t
global.sym
gv.c
hv.c
mg.c
perl.h
pod/perlapi.pod
pod/perlintern.pod
pod/perlvar.pod
proto.h
regcomp.c
sv.c
t/op/pat.t

index 7d36ce5..6d1a0ff 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -980,6 +980,7 @@ ext/re/re_comp.h            re extension wrapper for regcomp.h
 ext/re/re.pm                   re extension Perl module
 ext/re/re_top.h                        re extension symbol hiding header
 ext/re/re.xs                   re extension external subroutines
+ext/re/lib/re/Tie/Hash/NamedCapture.pm Implements %- and %+ behaviour
 ext/re/t/lexical_debug.pl      generate debug output for lexical re 'debug'
 ext/re/t/lexical_debug.t       test that lexical re 'debug' works
 ext/re/t/re_funcs.t            see if exportable funcs from re.pm work
diff --git a/doop.c b/doop.c
index 530fef2..24b75e6 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -1434,8 +1434,7 @@ Perl_do_kv(pTHX)
            RETURN;
        }
 
-       if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied) 
-           && ! SvTIED_mg((SV*)keys, PERL_MAGIC_regdata_names))
+       if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied) )
        {
            i = HvKEYS(keys);
        }
diff --git a/dump.c b/dump.c
index 07fd8b5..6ececc9 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -192,6 +192,10 @@ sequence. Thus the output will either be a single char,
 an octal escape sequence, a special escape like C<\n> or a 3 or 
 more digit hex value. 
 
+If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
+not a '\\'. This is because regexes very often contain backslashed
+sequences, whereas '%' is not a particularly common character in patterns.
+
 Returns a pointer to the escaped text as held by dsv.
 
 =cut
@@ -203,14 +207,16 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
                 const STRLEN count, const STRLEN max, 
                 STRLEN * const escaped, const U32 flags ) 
 {
-    char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
-    char octbuf[PV_ESCAPE_OCTBUFSIZE] = "\\123456789ABCDF";
+    char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
+    char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
+    char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
     STRLEN wrote = 0;    /* chars written so far */
     STRLEN chsize = 0;   /* size of data to be written */
     STRLEN readsize = 1; /* size of data just read */
     bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this unicode */
     const char *pv  = str;
     const char *end = pv + count; /* end of string */
+    octbuf[0] = esc;
 
     if (!flags & PERL_PV_ESCAPE_NOCLEAR) 
            sv_setpvn(dsv, "", 0);
@@ -228,42 +234,49 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
                                       "%"UVxf, u);
             else
                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
-                                      "\\x{%"UVxf"}", u);
+                                      "%cx{%"UVxf"}", esc, u);
         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
             chsize = 1;            
         } else {         
-            if ( (c == dq) || (c == '\\') || !isPRINT(c) ) {
-           chsize = 2;
+            if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
+               chsize = 2;
                 switch (c) {
-               case '\\' : octbuf[1] = '\\'; break;
+                
+               case '\\' : /* fallthrough */
+               case '%'  : if ( c == esc )  {
+                               octbuf[1] = esc;  
+                           } else {
+                               chsize = 1;
+                           }
+                           break;
                case '\v' : octbuf[1] = 'v';  break;
                case '\t' : octbuf[1] = 't';  break;
                case '\r' : octbuf[1] = 'r';  break;
                case '\n' : octbuf[1] = 'n';  break;
                case '\f' : octbuf[1] = 'f';  break;
-                    case '"'  : 
+                case '"'  : 
                         if ( dq == '"' ) 
                                octbuf[1] = '"';
                         else 
                             chsize = 1;
-                               break;
+                        break;
                default:
                         if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
-                                                  "\\%03o", c);
-                           else
+                                                  "%c%03o", esc, c);
+                       else
                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
-                                                  "\\%o", c);
+                                                  "%c%o", esc, c);
                 }
             } else {
-                chsize=1;
+                chsize = 1;
             }
-           }
-           if ( max && (wrote + chsize > max) ) {
-               break;
+       }
+       if ( max && (wrote + chsize > max) ) {
+           break;
         } else if (chsize > 1) {
-               sv_catpvn(dsv, octbuf, chsize);
-               wrote += chsize;
+            sv_catpvn(dsv, octbuf, chsize);
+            wrote += chsize;
        } else {
             Perl_sv_catpvf( aTHX_ dsv, "%c", c);
            wrote++;
@@ -308,7 +321,7 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
   const STRLEN max, char const * const start_color, char const * const end_color, 
   const U32 flags ) 
 {
-    U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '\\';
+    U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
     STRLEN escaped;
     
     if ( dq == '"' )
@@ -1129,7 +1142,6 @@ static const struct { const char type; const char *name; } magic_names[] = {
        { PERL_MAGIC_sv,             "sv(\\0)" },
        { PERL_MAGIC_arylen,         "arylen(#)" },
        { PERL_MAGIC_rhash,          "rhash(%)" },
-       { PERL_MAGIC_regdata_names,  "regdata_names(+)" },
        { PERL_MAGIC_pos,            "pos(.)" },
        { PERL_MAGIC_symtab,         "symtab(:)" },
        { PERL_MAGIC_backref,        "backref(<)" },
index e4d2623..963d80f 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -684,7 +684,8 @@ Ap  |I32    |regexec_flags  |NN regexp* prog|NN char* stringarg \
                                |NN char* strend|NN char* strbeg|I32 minend \
                                |NN SV* screamer|NULLOK void* data|U32 flags
 ApR    |regnode*|regnext       |NN regnode* p
-Ep     |SV*|reg_named_buff_sv  |NN SV* namesv
+EXp    |SV*|reg_named_buff_get |NN SV* namesv|NULLOK const REGEXP * const from_re|U32 flags
+EXp    |SV*|reg_numbered_buff_get|I32 paren|NN const REGEXP * const rx|NULLOK SV* usesv|U32 flags
 Ep     |void   |regprop        |NULLOK const regexp *prog|NN SV* sv|NN const regnode* o
 Ap     |void   |repeatcpy      |NN char* to|NN const char* from|I32 len|I32 count
 ApP    |char*  |rninstr        |NN const char* big|NN const char* bigend \
@@ -1100,7 +1101,8 @@ sR        |I32    |do_trans_complex_utf8  |NN SV * const sv
 
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 s      |void   |gv_init_sv     |NN GV *gv|I32 sv_type
-s      |void   |require_errno  |NN GV *gv
+s      |HV*    |require_tie_mod|NN GV *gv|NN const char *varpv|NN SV* namesv \
+                               |NN const char *methpv|const U32 flags
 #endif
 
 : #if defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
diff --git a/embed.h b/embed.h
index 7fde462..b0f0a61 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define regexec_flags          Perl_regexec_flags
 #define regnext                        Perl_regnext
 #if defined(PERL_CORE) || defined(PERL_EXT)
-#define reg_named_buff_sv      Perl_reg_named_buff_sv
+#define reg_named_buff_get     Perl_reg_named_buff_get
+#define reg_numbered_buff_get  Perl_reg_numbered_buff_get
 #define regprop                        Perl_regprop
 #endif
 #define repeatcpy              Perl_repeatcpy
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
 #define gv_init_sv             S_gv_init_sv
-#define require_errno          S_require_errno
+#define require_tie_mod                S_require_tie_mod
 #endif
 #endif
 #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
 #define regexec_flags(a,b,c,d,e,f,g,h) Perl_regexec_flags(aTHX_ a,b,c,d,e,f,g,h)
 #define regnext(a)             Perl_regnext(aTHX_ a)
 #if defined(PERL_CORE) || defined(PERL_EXT)
-#define reg_named_buff_sv(a)   Perl_reg_named_buff_sv(aTHX_ a)
+#define reg_named_buff_get(a,b,c)      Perl_reg_named_buff_get(aTHX_ a,b,c)
+#define reg_numbered_buff_get(a,b,c,d) Perl_reg_numbered_buff_get(aTHX_ a,b,c,d)
 #define regprop(a,b,c)         Perl_regprop(aTHX_ a,b,c)
 #endif
 #define repeatcpy(a,b,c,d)     Perl_repeatcpy(aTHX_ a,b,c,d)
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
 #define gv_init_sv(a,b)                S_gv_init_sv(aTHX_ a,b)
-#define require_errno(a)       S_require_errno(aTHX_ a)
+#define require_tie_mod(a,b,c,d,e)     S_require_tie_mod(aTHX_ a,b,c,d,e)
 #endif
 #endif
 #ifdef PERL_CORE
diff --git a/ext/re/lib/re/Tie/Hash/NamedCapture.pm b/ext/re/lib/re/Tie/Hash/NamedCapture.pm
new file mode 100644 (file)
index 0000000..a76c6ab
--- /dev/null
@@ -0,0 +1,111 @@
+package re::Tie::Hash::NamedCapture;
+use strict;
+use warnings;
+our $VERSION     = "0.01";
+use re qw(is_regexp
+          regname
+          regnames
+          regnames_count
+          regnames_iterinit
+          regnames_iternext);
+
+sub TIEHASH {
+    my $classname = shift;
+    my $hash = {@_};
+
+    if ($hash->{re} && !is_regexp($hash->{re})) {
+        die "'re' parameter to ",__PACKAGE__,"->TIEHASH must be a qr//"
+    }
+
+    return bless $hash, $classname;
+}
+
+sub FETCH {
+    return regname($_[1],$_[0]->{re},$_[0]->{all});
+}
+
+sub STORE {
+    require Carp;
+    Carp::croak("STORE forbidden: Hashes tied to ",__PACKAGE__," are read/only.");
+}
+
+sub FIRSTKEY {
+    regnames_iterinit($_[0]->{re});
+    return $_[0]->NEXTKEY;
+}
+
+sub NEXTKEY {
+    return regnames_iternext($_[0]->{re},$_[0]->{all});
+}
+
+sub EXISTS {
+    return defined regname( $_[1], $_[0]->{re},$_[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 regnames($_[0]->{re},$_[0]->{all});
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+re::Tie::Hash::NamedCapture - Perl module to support named regex capture buffers
+
+=head1 SYNOPSIS
+
+    tie my %hash,"re::Tie::Hash::NamedCapture";
+    # %hash now behaves like %-
+
+    tie my %hash,"re::Tie::Hash::NamedCapture",re => $qr, all=> 1,
+    # %hash now access buffers from regex in $qr like %+
+
+=head1 DESCRIPTION
+
+Implements the behaviour required for C<%+> and C<%-> but can be used
+independently.
+
+When the C<re> parameter is provided, and the value is the result of
+a C<qr//> expression then the hash is bound to that particular regexp
+and will return the results of its last successful match. If the
+parameter is omitted then the hash behaves just as C<$1> does by
+referencing the last successful match.
+
+When the C<all> parameter is provided then the result of a fetch
+is an array ref containing the contents of each buffer whose name
+was the same as the key used for the access. If the buffer wasn't
+involved in the match then an undef will be stored. When the all
+parameter is omitted or not a true value then the return will be
+a the content of the left most defined buffer with the given name.
+If there is no buffer with the desired name defined then C<undef>
+is returned.
+
+
+For instance:
+
+    my $qr = qr/(?<foo>bar)/;
+    if ( 'bar' =~ /$qr/ ) {
+        tie my %hash,"re::Tie::Hash::NamedCapture",re => $qr, all => 1;
+        if ('bar'=~/bar/) {
+            # last successful match is now different
+            print $hash{foo}; # prints foo
+        }
+    }
+
+=head1 SEE ALSO
+
+L<re>, L<perlmodlib/Pragmatic Modules>.
+
+=cut
index ce01214..4a64af3 100644 (file)
@@ -4,9 +4,11 @@ package re;
 use strict;
 use warnings;
 
-our $VERSION     = "0.07";
+our $VERSION     = "0.08";
 our @ISA         = qw(Exporter);
-our @EXPORT_OK   = qw(is_regexp regexp_pattern regmust);
+our @EXPORT_OK   = qw(is_regexp regexp_pattern regmust 
+                      regname regnames 
+                      regnames_count regnames_iterinit regnames_iternext);
 our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
 
 # *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
@@ -464,6 +466,46 @@ floating string. This will be what the optimiser of the Perl that you
 are using thinks is the longest. If you believe that the result is wrong
 please report it via the L<perlbug> utility.
 
+=item regname($name,$qr,$all)
+
+Returns the contents of a named buffer. If $qr is missing, or is not the
+result of a qr// then returns the result of the last successful match. If
+$all is true then returns an array ref containing one entry per buffer,
+otherwise returns the first defined buffer.
+
+=item regnames($qr,$all)
+
+Returns a list of all of the named buffers defined in a pattern. If 
+$all is true then it returns all names defined, if not returns only 
+names which were involved in the last successful match. If $qr is omitted
+or is not the result of a qr// then returns the details for the last
+successful match.
+
+=item regnames_iterinit($qr)
+
+Initializes the internal hash iterator associated to a regexps named capture
+buffers. If $qr is omitted resets the iterator associated with the regexp used 
+in the last successful match.
+
+=item regnames_iternext($qr,$all)
+
+Gets the next key from the hash associated with a regexp. If $qr
+is omitted resets the iterator associated with the regexp used in the 
+last successful match. If $all is true returns the keys of all of the 
+distinct named buffers in the pattern, if not returns only those names
+used in the last successful match.
+
+=item regnames_count($qr)
+
+Returns the number of distinct names defined in the regexp $qr. If
+$qr is omitted or not a regexp returns the count of names in the 
+last successful match. 
+
+B<Note:> that this result is always the actual  number of distinct 
+named buffers defined, it may not actually match that which is 
+returned by C<regnames()> and related routines when those routines 
+have not been called with the $all parameter set..
+
 =back
 
 =head1 SEE ALSO
index d1d2702..aa601cf 100644 (file)
@@ -41,6 +41,25 @@ const struct regexp_engine my_reg_engine = {
 #endif
 };
 
+regexp *
+get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) {
+    MAGIC *mg;
+    if (sv) {
+        if (SvMAGICAL(sv))
+            mg_get(sv);
+        if (SvROK(sv) &&
+            (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
+            SvTYPE(sv) == SVt_PVMG &&
+            (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
+        {        
+            if (mgp) *mgp = mg;
+            return (regexp *)mg->mg_obj;       
+        }
+    }    
+    if (mgp) *mgp = NULL;
+    return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL);
+}
+
 MODULE = re    PACKAGE = re
 
 void
@@ -55,16 +74,9 @@ void
 is_regexp(sv)
     SV * sv
 PROTOTYPE: $
-PREINIT:
-    MAGIC *mg;
 PPCODE:
 {
-    if (SvMAGICAL(sv))  
-        mg_get(sv);
-    if (SvROK(sv) && 
-        (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
-        SvTYPE(sv) == SVt_PVMG && 
-        (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
+    if ( get_re_arg( aTHX_ sv, 0, NULL ) ) 
     {
         XSRETURN_YES;
     } else {
@@ -79,6 +91,7 @@ regexp_pattern(sv)
 PROTOTYPE: $
 PREINIT:
     MAGIC *mg;
+    regexp *re;
 PPCODE:
 {
     /*
@@ -92,17 +105,10 @@ PPCODE:
        on the object. 
     */
 
-    if (SvMAGICAL(sv))  
-        mg_get(sv);
-    if (SvROK(sv) && 
-        (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
-        SvTYPE(sv) == SVt_PVMG && 
-        (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
+    if ( re = get_re_arg( aTHX_ sv, 0, &mg) ) /* assign deliberate */
     {
-    
         /* Housten, we have a regex! */
         SV *pattern;
-        regexp *re = (regexp *)mg->mg_obj;
         STRLEN patlen = 0;
         STRLEN left = 0;
         char reflags[6];
@@ -173,19 +179,13 @@ regmust(sv)
     SV * sv
 PROTOTYPE: $
 PREINIT:
-    MAGIC *mg;
+    regexp *re;
 PPCODE:
 {
-    if (SvMAGICAL(sv))
-        mg_get(sv);
-    if (SvROK(sv) &&
-        (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
-        SvTYPE(sv) == SVt_PVMG &&
-        (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
+    if ( re = get_re_arg( aTHX_ sv, 0, 0) ) /* assign deliberate */
     {
         SV *an = &PL_sv_no;
         SV *fl = &PL_sv_no;
-        regexp *re = (regexp *)mg->mg_obj;
         if (re->anchored_substr) {
             an = newSVsv(re->anchored_substr);
         } else if (re->anchored_utf8) {
@@ -202,3 +202,151 @@ PPCODE:
     }
     XSRETURN_UNDEF;
 }
+
+void
+regname(sv, qr = NULL, all = NULL)
+    SV * sv
+    SV * qr
+    SV * all
+PROTOTYPE: ;$$$
+PREINIT:
+    regexp *re = NULL;
+    SV *bufs = NULL;
+PPCODE:
+{
+    re = get_re_arg( aTHX_ qr, 1, NULL);
+    if (SvPOK(sv) && re && re->paren_names) {
+        bufs = Perl_reg_named_buff_get(aTHX_ sv, re ,all && SvTRUE(all));
+        if (bufs) {
+            if (all && SvTRUE(all))
+                XPUSHs(newRV(bufs));
+            else
+                XPUSHs(SvREFCNT_inc(bufs));
+            XSRETURN(1);
+        }
+    }
+    XSRETURN_UNDEF;
+}        
+    
+void
+regnames(sv = NULL, all = NULL)
+    SV *sv
+    SV *all
+PROTOTYPE: ;$$
+PREINIT:
+    regexp *re = NULL;
+    IV count = 0;
+PPCODE:
+{
+    re = get_re_arg( aTHX_  sv, 1, NULL );
+    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->startp[nums[i]] != -1 &&
+                        re->endp[nums[i]] != -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 {
+                break;
+            }
+        }
+    }
+    if ( GIMME_V == G_ARRAY ) 
+        XSRETURN(count);
+    else 
+        XSRETURN_UNDEF;
+}    
+
+void
+regnames_iterinit(sv = NULL)
+    SV * sv
+PROTOTYPE: ;$
+PREINIT:
+    regexp *re = NULL;
+PPCODE:
+{
+    re = get_re_arg( aTHX_  sv, 1, NULL );
+    if (re && re->paren_names) {
+        (void)hv_iterinit(re->paren_names);
+        XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
+    } else {
+        XSRETURN_UNDEF;
+    }  
+}
+
+void
+regnames_iternext(sv = NULL, all = NULL)
+    SV *sv
+    SV *all
+PROTOTYPE: ;$$
+PREINIT:
+    regexp *re;
+PPCODE:
+{
+    re = get_re_arg( aTHX_  sv, 1, NULL ); 
+    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->startp[nums[i]] != -1 &&
+                        re->endp[nums[i]] != -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;
+            }
+        }
+    }
+    XSRETURN_UNDEF;
+}    
+
+void
+regnames_count(sv = NULL)
+    SV * sv
+PROTOTYPE: ;$
+PREINIT:
+    regexp *re = NULL;
+PPCODE:
+{
+    re = get_re_arg( aTHX_  sv, 1, NULL );
+    if (re && re->paren_names) {
+        XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
+    } else {
+        XSRETURN_UNDEF;
+    }  
+}
index f84e2b0..736829c 100644 (file)
@@ -13,7 +13,9 @@ BEGIN {
 use strict;
 
 use Test::More; # test count at bottom of file
-use re qw(is_regexp regexp_pattern regmust);
+use re qw(is_regexp regexp_pattern regmust 
+          regname regnames regnames_count 
+          regnames_iterinit regnames_iternext);
 my $qr=qr/foo/i;
 
 ok(is_regexp($qr),'is_regexp($qr)');
@@ -37,6 +39,48 @@ ok(!regexp_pattern(''),'!regexp_pattern("")');
     is($floating,undef,"Regmust anchored - ref");
 }
 
+
+if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){
+    my $qr = qr/(?<foo>foo)(?<bar>bar)/;    
+    my @names = sort +regnames($qr);
+    is("@names","","regnames");
+    @names = sort +regnames($qr,1);
+    is("@names","bar foo","regnames - all");
+    @names = sort +regnames();
+    is("@names","A B","regnames");
+    @names = sort +regnames(undef,1);
+    is("@names","A B C","regnames");
+    is(join("", @{regname("A",undef,1)}),"13");
+    is(join("", @{regname("B",undef,1)}),"24");    
+    {
+        if ('foobar'=~/$qr/) {
+            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);
+        }
+    }
+    is(regnames_count(),3);
+    is(regnames_count($qr),2);
+}    
+{
+    use warnings;
+    require re::Tie::Hash::NamedCapture;
+    my $qr = qr/(?<foo>foo)/;
+    if ( 'foo' =~ /$qr/ ) {
+        tie my %hash,"re::Tie::Hash::NamedCapture",re => $qr;
+        if ('bar'=~/bar/) {
+            # last successful match is now different
+            is($hash{foo},'foo'); # prints foo
+        }
+    }
+}    
 # New tests above this line, don't forget to update the test count below!
-use Test::More tests => 12;
+use Test::More tests => 23;
 # No tests here!
index d221857..3bc3928 100644 (file)
@@ -396,6 +396,8 @@ Perl_re_intuit_start
 Perl_re_intuit_string
 Perl_regexec_flags
 Perl_regnext
+Perl_reg_named_buff_get
+Perl_reg_numbered_buff_get
 Perl_repeatcpy
 Perl_rninstr
 Perl_rsignal
diff --git a/gv.c b/gv.c
index 4878d80..b6fa4d0 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -664,28 +664,44 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     return gv;
 }
 
-/* The "gv" parameter should be the glob known to Perl code as *!
- * The scalar must already have been magicalized.
+
+/* require_tie_mod() internal routine for requiring a module
+ * that implements the logic of automatical ties like %! and %-
+ *
+ * The "gv" parameter should be the glob.
+ * "varpv" holds the name of the var, used for error messages
+ * "namesv" holds the module name
+ * "methpv" holds the method name to test for to check that things
+ *   are working reasonably close to as expected
+ * "flags" if flag & 1 then save the scalar before loading.
+ * For the protection of $! to work (it is set by this routine)
+ * the sv slot must already be magicalized.
  */
-STATIC void
-S_require_errno(pTHX_ GV *gv)
+STATIC HV*
+S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
 {
     dVAR;
-    HV* stash = gv_stashpvs("Errno", FALSE);
-
-    if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
+    HV* stash = gv_stashsv(namesv, FALSE);
+    
+    if (!stash || !(gv_fetchmethod(stash, methpv))) {
+        SV *module = newSVsv(namesv);
        dSP;
        PUTBACK;
        ENTER;
-       save_scalar(gv); /* keep the value of $! */
-        Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
-                         newSVpvs("Errno"), NULL);
+       if ( flags & 1 )
+           save_scalar(gv); 
+        Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
        LEAVE;
        SPAGAIN;
-       stash = gv_stashpvs("Errno", FALSE);
-       if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
-           Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
+       stash = gv_stashsv(namesv, FALSE);
+       if (!stash)
+           Perl_croak( aTHX_ "panic: Can't use %%%s because %"SVf" is not available", 
+               varpv, module);
+       else if (!gv_fetchmethod(stash, methpv))    
+           Perl_croak( aTHX_ "panic: Can't use %%%s because %"SVf" does not support method %s", 
+               varpv, module, methpv);
     }
+    return stash;
 }
 
 /*
@@ -976,8 +992,14 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
        if (add) {
            GvMULTI_on(gv);
            gv_init_sv(gv, sv_type);
-           if (*name=='!' && sv_type == SVt_PVHV && len==1)
-               require_errno(gv);
+           if (sv_type == SVt_PVHV && len == 1 ) {
+               if (*name == '!')
+                   require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+               else
+               if (*name == '-' || *name == '+') 
+                    require_tie_mod(gv, name, newSVpvs("re::Tie::Hash::NamedCapture"), "FETCH", 0);
+               
+            }              
        }
        return gv;
     } else if (no_init) {
@@ -1156,25 +1178,45 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            goto magicalize;
 
        case '!':
-
-           /* If %! has been used, automatically load Errno.pm.
-              The require will itself set errno, so in order to
-              preserve its value we have to set up the magic
-              now (rather than going to magicalize)
-           */
+       GvMULTI_on(gv);    
+           /* If %! has been used, automatically load Errno.pm. */
 
            sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 
+            /* magicalization must be done before require_tie_mod is called */
            if (sv_type == SVt_PVHV)
-               require_errno(gv);
+               require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
 
            break;
        case '-':
-       {
-           AV* const av = GvAVn(gv);
-            sv_magic((SV*)av, NULL, PERL_MAGIC_regdata, NULL, 0);
-           SvREADONLY_on(av);
-           goto magicalize;
+       case '+':
+       GvMULTI_on(gv); /* no used once warnings here */
+        {
+            bool plus = (*name == '+');
+            SV *stashname = newSVpvs("re::Tie::Hash::NamedCapture");
+            AV* const av = GvAVn(gv);
+           HV *const hv = GvHVn(gv);
+           HV *const hv_tie = newHV();
+            SV *tie = newRV_noinc((SV*)hv_tie);
+
+            sv_bless(tie, gv_stashsv(stashname,1));
+            hv_magic(hv, (GV*)tie, PERL_MAGIC_tied);    
+            sv_magic((SV*)av, (plus ? (SV*)av : NULL), PERL_MAGIC_regdata, NULL, 0);
+            sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
+
+            if (plus)
+                SvREADONLY_on(GvSVn(gv));
+            else
+                Perl_hv_store(aTHX_ hv_tie, STR_WITH_LEN("all"), newSViv(1), 0);
+            
+            SvREADONLY_on(hv);
+            SvREADONLY_on(tie);
+            SvREADONLY_on(av);
+                
+            if (sv_type == SVt_PVHV) 
+                require_tie_mod(gv, name, stashname, "FETCH", 0);
+
+           break;
        }
        case '*':
        case '#':
@@ -1192,18 +1234,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                hv_magic(hv, NULL, PERL_MAGIC_hints);
            }
            goto magicalize;
-
-       case '+':
-       GvMULTI_on(gv);
-       {
-           AV* const av = GvAVn(gv);
-           HV* const hv = GvHVn(gv);
-            sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0);
-           SvREADONLY_on(av);
-           hv_magic(hv, NULL, PERL_MAGIC_regdata_names);
-           SvREADONLY_on(hv);
-           /* FALL THROUGH */
-       }
        case '\023':    /* $^S */
        case '1':
        case '2':
diff --git a/hv.c b/hv.c
index aa60e53..3852754 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -450,10 +450,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
     xhv = (XPVHV*)SvANY(hv);
     if (SvMAGICAL(hv)) {
        if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
-           MAGIC *regdata = NULL;
-           if (( regdata = mg_find((SV*)hv, PERL_MAGIC_regdata_names)) ||
-               mg_find((SV*)hv, PERL_MAGIC_tied) ||
-               SvGMAGICAL((SV*)hv))
+           if ( mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv))
            {
                /* XXX should be able to skimp on the HE/HEK here when
                   HV_FETCH_JUST_SV is true.  */
@@ -465,14 +462,8 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
                } else {
                    keysv = newSVsv(keysv);
                }
-               if (regdata) {
-                   sv = Perl_reg_named_buff_sv(aTHX_ keysv);
-                   if (!sv)
-                       sv = sv_newmortal();
-               } else {
-                   sv = sv_newmortal();
-                   mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
-               }
+                sv = sv_newmortal();
+                mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
 
                /* grab a fake HE/HEK pair from the pool or make a new one */
                entry = PL_hv_fetch_ent_mh;
@@ -1931,17 +1922,7 @@ Perl_hv_iterinit(pTHX_ HV *hv)
     } else {
        hv_auxinit(hv);
     }
-    if ( SvRMAGICAL(hv) ) {
-        MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_regdata_names);
-        if ( mg ) {
-             if (PL_curpm) {
-                const REGEXP * const rx = PM_GETRE(PL_curpm);
-                if (rx && rx->paren_names) {
-                    (void)hv_iterinit(rx->paren_names);
-                } 
-            } 
-        }
-    }
+
     /* used to be xhv->xhv_fill before 5.004_65 */
     return HvTOTALKEYS(hv);
 }
@@ -2109,83 +2090,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
 
     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
-       if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_regdata_names) ) ) {
-            SV * key;
-            SV *val = NULL;
-            REGEXP * rx;
-            if (!PL_curpm)
-                return NULL;
-            rx = PM_GETRE(PL_curpm);
-            if (rx && rx->paren_names) {
-                hv = rx->paren_names;
-            } else {
-                return NULL;
-            }
-
-            key = sv_newmortal();
-            if (entry) {
-                sv_setsv(key, HeSVKEY_force(entry));
-                SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
-            }
-            else {
-                char *k;
-                HEK *hek;
-
-                /* one HE per MAGICAL hash */
-                iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
-                Zero(entry, 1, HE);
-                Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
-                hek = (HEK*)k;
-                HeKEY_hek(entry) = hek;
-                HeKLEN(entry) = HEf_SVKEY;
-            }
-            {
-                while (!val) {
-                    HE *temphe = hv_iternext_flags(hv,flags);
-                    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->startp[nums[i]] != -1 &&
-                                rx->endp[nums[i]] != -1)
-                            {
-                                parno = nums[i];
-                                break;
-                            }
-                        }
-                        if (parno) {
-                            GV *gv_paren;
-                            STRLEN len;
-                            SV *sv = sv_newmortal();
-                            const char* pvkey = HePV(temphe, len);
-
-                            Perl_sv_setpvf(aTHX_ sv, "%"IVdf,(IV)parno);
-                            gv_paren = Perl_gv_fetchsv(aTHX_ sv, GV_ADD, SVt_PVGV);
-                            Perl_sv_setpvn(aTHX_ key, pvkey, len);
-                            val = GvSVn(gv_paren);
-                        }
-                    } else {
-                        break;
-                    }
-                }
-            }
-            if (val && SvOK(key)) {
-                /* force key to stay around until next time */
-                HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
-                HeVAL(entry) = SvREFCNT_inc_simple_NN(val);
-                return entry;               /* beware, hent_val is not set */
-            }
-            if (HeVAL(entry))
-                SvREFCNT_dec(HeVAL(entry));
-            Safefree(HeKEY_hek(entry));
-            del_HE(entry);
-            iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
-            return NULL;
-        }
-       else if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) {
+       if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) {
             SV * const key = sv_newmortal();
             if (entry) {
                 sv_setsv(key, HeSVKEY_force(entry));
diff --git a/mg.c b/mg.c
index c5566dc..c055b9a 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -672,7 +672,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     dVAR;
     register I32 paren;
     register char *s = NULL;
-    register I32 i;
     register REGEXP *rx;
     const char * const remaining = mg->mg_ptr + 1;
     const char nextchar = *remaining;
@@ -851,90 +850,46 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9': case '&':
        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
-           I32 s1, t1;
-
            /*
             * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
             * XXX Does the new way break anything?
             */
            paren = atoi(mg->mg_ptr); /* $& is in [0] */
-         getparen:
-           if (paren <= (I32)rx->nparens &&
-               (s1 = rx->startp[paren]) != -1 &&
-               (t1 = rx->endp[paren]) != -1)
-           {
-               i = t1 - s1;
-               s = rx->subbeg + s1;
-               assert(rx->subbeg);
-               assert(rx->sublen >= s1);
-
-             getrx:
-               if (i >= 0) {
-                   const int oldtainted = PL_tainted;
-                   TAINT_NOT;
-                   sv_setpvn(sv, s, i);
-                   PL_tainted = oldtainted;
-                   if ( (rx->extflags & RXf_CANY_SEEN)
-                       ? (RX_MATCH_UTF8(rx)
-                                   && (!i || is_utf8_string((U8*)s, i)))
-                       : (RX_MATCH_UTF8(rx)) )
-                   {
-                       SvUTF8_on(sv);
-                   }
-                   else
-                       SvUTF8_off(sv);
-                   if (PL_tainting) {
-                       if (RX_MATCH_TAINTED(rx)) {
-                           MAGIC* const mg = SvMAGIC(sv);
-                           MAGIC* mgt;
-                           PL_tainted = 1;
-                           SvMAGIC_set(sv, mg->mg_moremagic);
-                           SvTAINT(sv);
-                           if ((mgt = SvMAGIC(sv))) {
-                               mg->mg_moremagic = mgt;
-                               SvMAGIC_set(sv, mg);
-                           }
-                       } else
-                           SvTAINTED_off(sv);
-                   }
-                   break;
-               }
-           }
+           reg_numbered_buff_get( paren, rx, sv, 0);
+           break;
        }
        sv_setsv(sv,&PL_sv_undef);
        break;
     case '+':
        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
-           paren = rx->lastparen;
-           if (paren)
-               goto getparen;
+           if (rx->lastparen) {
+               reg_numbered_buff_get( rx->lastparen, rx, sv, 0);
+               break;
+           }
        }
        sv_setsv(sv,&PL_sv_undef);
        break;
     case '\016':               /* ^N */
        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
-           paren = rx->lastcloseparen;
-           if (paren)
-               goto getparen;
+           if (rx->lastcloseparen) {
+               reg_numbered_buff_get( rx->lastcloseparen, rx, sv, 0);
+               break;
+           }
+
        }
        sv_setsv(sv,&PL_sv_undef);
        break;
     case '`':
        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
-           if ((s = rx->subbeg) && rx->startp[0] != -1) {
-               i = rx->startp[0];
-               goto getrx;
-           }
+         reg_numbered_buff_get( -2, rx, sv, 0);
+         break;
        }
        sv_setsv(sv,&PL_sv_undef);
        break;
     case '\'':
        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
-           if (rx->subbeg && rx->endp[0] != -1) {
-               s = rx->subbeg + rx->endp[0];
-               i = rx->sublen - rx->endp[0];
-               goto getrx;
-           }
+         reg_numbered_buff_get( -1, rx, sv, 0);
+         break;
        }
        sv_setsv(sv,&PL_sv_undef);
        break;
diff --git a/perl.h b/perl.h
index 9d1c1b1..45d8db2 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3654,8 +3654,6 @@ Gid_t getegid (void);
 #define PERL_MAGIC_overload_elem  'a' /* %OVERLOAD hash element */
 #define PERL_MAGIC_overload_table 'c' /* Holds overload table (AMT) on stash */
 #define PERL_MAGIC_bm            'B' /* Boyer-Moore (fast string search) */
-#define PERL_MAGIC_regdata_names  '+' /* Regex named capture buffer hash 
-                                       (%+ support) */
 #define PERL_MAGIC_regdata       'D' /* Regex match position data
                                        (@+ and @- vars) */
 #define PERL_MAGIC_regdatum      'd' /* Regex match position data element */
@@ -5711,10 +5709,11 @@ extern void moncontrol(int);
 #define PERL_PV_ESCAPE_ALL         0x1000
 #define PERL_PV_ESCAPE_NOBACKSLASH  0x2000
 #define PERL_PV_ESCAPE_NOCLEAR      0x4000
+#define PERL_PV_ESCAPE_RE           0x8000
 
 /* used by pv_display in dump.c*/
 #define PERL_PV_PRETTY_DUMP  PERL_PV_PRETTY_ELIPSES|PERL_PV_PRETTY_QUOTE
-#define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELIPSES|PERL_PV_PRETTY_LTGT
+#define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE
 
 /*
 
index 992afe8..9acb5f9 100644 (file)
@@ -824,6 +824,10 @@ sequence. Thus the output will either be a single char,
 an octal escape sequence, a special escape like C<\n> or a 3 or 
 more digit hex value. 
 
+If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
+not a '\\'. This is because regexes very often contain backslashed
+sequences, whereas '%' is not a particularly common character in patterns.
+
 Returns a pointer to the escaped text as held by dsv.
 
 NOTE: the perl_ form of this function is deprecated.
index 5ee68ad..83bdda3 100644 (file)
@@ -622,7 +622,7 @@ The SVs in the names AV have their PV being the name of the variable.
 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
 which the name is valid.  For typed lexicals name SV is SVt_PVMG and SvSTASH
 points at the type.  For C<our> lexicals, the type is also SVt_PVMG, with the
-OURSTASH slot pointing at the stash of the associated global (so that
+SvOURSTASH slot pointing at the stash of the associated global (so that
 duplicate C<our> declarations in the same package can be detected).  SvUVX is
 sometimes hijacked to store the generation number during compilation.
 
@@ -714,7 +714,7 @@ offset.
 If C<typestash> is valid, the name is for a typed lexical; set the
 name's stash to that value.
 If C<ourstash> is valid, it's an our lexical, set the name's
-OURSTASH to that value
+SvOURSTASH to that value
 
 If fake, it means we're cloning an existing entry
 
index 8a486b2..a211c37 100644 (file)
@@ -324,6 +324,15 @@ C<$+{foo}> is equivalent to C<$1> after the following match:
 
   'foo'=~/(?<foo>foo)/;
 
+The underlying behaviour of %+ is provided by the L<re::Tie::Hash::NamedCapture>
+module.
+
+B<Note:> As C<%-> and C<%+> are tied views into a common internal hash
+associated with the last successful regular expression. Therefore mixing
+iterative access to them via C<each> may have unpredictable results.
+Likewise, if the last successful match changes then the results may be
+surprising.
+
 =item HANDLE->input_line_number(EXPR)
 
 =item $INPUT_LINE_NUMBER
@@ -579,6 +588,40 @@ After a match against some variable $var:
 
 =back
 
+=item %-
+X<%->
+
+Similar to %+, this variable allows access to the named capture
+buffers that were defined in the last successful match. It returns
+a reference to an array containing one value per buffer of a given
+name in the pattern.
+
+    if ('1234'=~/(?<A>1)(?<B>2)(?<A>3)(?<B>4)/) {
+        foreach my $name (sort keys(%-)) {
+            my $ary = $-{$name};
+            foreach my $idx (0..$#$ary) {
+                print "\$-{$name}[$idx] : ",
+                      (defined($ary->[$idx]) ? "'$ary->[$idx]'" : "undef"),
+                      "\n";
+            }
+        }
+    }
+
+would print out:
+
+    $-{A}[0] : '1'
+    $-{A}[1] : '3'
+    $-{B}[0] : '2'
+    $-{B}[1] : '4'
+
+The behaviour of %- is implemented via the L<re::Tie::Hash::NamedCapture> module.
+
+Note that C<%-> and C<%+> are tied views into a common internal hash
+associated with the last successful regular expression. Therefore mixing
+iterative access to them via C<each> may have unpredictable results.
+Likewise, if the last successful match changes then the results may be
+surprising.
+
 =item HANDLE->format_name(EXPR)
 
 =item $FORMAT_NAME
diff --git a/proto.h b/proto.h
index 3ce04ca..c82f94b 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1873,9 +1873,12 @@ PERL_CALLCONV regnode*   Perl_regnext(pTHX_ regnode* p)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1);
 
-PERL_CALLCONV SV*      Perl_reg_named_buff_sv(pTHX_ SV* namesv)
+PERL_CALLCONV SV*      Perl_reg_named_buff_get(pTHX_ SV* namesv, const REGEXP * const from_re, U32 flags)
                        __attribute__nonnull__(pTHX_1);
 
+PERL_CALLCONV SV*      Perl_reg_numbered_buff_get(pTHX_ I32 paren, const REGEXP * const rx, SV* usesv, U32 flags)
+                       __attribute__nonnull__(pTHX_2);
+
 PERL_CALLCONV void     Perl_regprop(pTHX_ const regexp *prog, SV* sv, const regnode* o)
                        __attribute__nonnull__(pTHX_2)
                        __attribute__nonnull__(pTHX_3);
@@ -2953,8 +2956,11 @@ STATIC I32       S_do_trans_complex_utf8(pTHX_ SV * const sv)
 STATIC void    S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
                        __attribute__nonnull__(pTHX_1);
 
-STATIC void    S_require_errno(pTHX_ GV *gv)
-                       __attribute__nonnull__(pTHX_1);
+STATIC HV*     S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv, const U32 flags)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2)
+                       __attribute__nonnull__(pTHX_3)
+                       __attribute__nonnull__(pTHX_4);
 
 #endif
 
index a5eee5b..9f44c82 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -4624,11 +4624,15 @@ reStudy:
 
 #ifndef PERL_IN_XSUB_RE
 SV*
-Perl_reg_named_buff_sv(pTHX_ SV* namesv)
+Perl_reg_named_buff_get(pTHX_ SV* namesv, const REGEXP * const from_re, U32 flags)
 {
-    I32 parno = 0; /* no match */
-    if (PL_curpm) {
-        const REGEXP * const rx = PM_GETRE(PL_curpm);
+    AV *retarray = NULL;
+    SV *ret;
+    if (flags & 1) 
+        retarray=newAV();
+    
+    if (from_re || PL_curpm) {
+        const REGEXP * const rx = from_re ? from_re : PM_GETRE(PL_curpm);
         if (rx && rx->paren_names) {            
             HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 );
             if (he_str) {
@@ -4639,22 +4643,97 @@ Perl_reg_named_buff_sv(pTHX_ SV* namesv)
                     if ((I32)(rx->lastparen) >= nums[i] &&
                         rx->endp[nums[i]] != -1) 
                     {
-                        parno = nums[i];
-                        break;
+                        ret = reg_numbered_buff_get(nums[i],rx,NULL,0);
+                        if (!retarray) 
+                            return ret;
+                    } else {
+                        ret = newSVsv(&PL_sv_undef);
+                    }
+                    if (retarray) {
+                        SvREFCNT_inc(ret); 
+                        av_push(retarray, ret);
                     }
                 }
+                if (retarray)
+                    return (SV*)retarray;
             }
         }
     }
-    if ( !parno ) {
-        return 0;
+    return NULL;
+}
+
+SV*
+Perl_reg_numbered_buff_get(pTHX_ I32 paren, const REGEXP * const rx, SV* usesv, U32 flags)
+{
+    char *s = NULL;
+    I32 i;
+    I32 s1, t1;
+    SV *sv = usesv ? usesv : newSVpvs("");
+        
+    if (paren == -2 && (s = rx->subbeg) && rx->startp[0] != -1) {
+        /* $` */
+       i = rx->startp[0];
+    }
+    else 
+    if (paren == -1 && rx->subbeg && rx->endp[0] != -1) {
+        /* $' */
+       s = rx->subbeg + rx->endp[0];
+       i = rx->sublen - rx->endp[0];
+    } 
+    else
+    if ( 0 <= paren && paren <= (I32)rx->nparens &&
+        (s1 = rx->startp[paren]) != -1 &&
+        (t1 = rx->endp[paren]) != -1)
+    {
+        /* $& $1 ... */
+        i = t1 - s1;
+        s = rx->subbeg + s1;
+    }
+      
+    if (s) {        
+        assert(rx->subbeg);
+        assert(rx->sublen >= (s - rx->subbeg) + i );
+            
+        if (i >= 0) {
+            const int oldtainted = PL_tainted;
+            TAINT_NOT;
+            sv_setpvn(sv, s, i);
+            PL_tainted = oldtainted;
+            if ( (rx->extflags & RXf_CANY_SEEN)
+                ? (RX_MATCH_UTF8(rx)
+                            && (!i || is_utf8_string((U8*)s, i)))
+                : (RX_MATCH_UTF8(rx)) )
+            {
+                SvUTF8_on(sv);
+            }
+            else
+                SvUTF8_off(sv);
+            if (PL_tainting) {
+                if (RX_MATCH_TAINTED(rx)) {
+                    if (SvTYPE(sv) >= SVt_PVMG) {
+                        MAGIC* const mg = SvMAGIC(sv);
+                        MAGIC* mgt;
+                        PL_tainted = 1;
+                        SvMAGIC_set(sv, mg->mg_moremagic);
+                        SvTAINT(sv);
+                        if ((mgt = SvMAGIC(sv))) {
+                            mg->mg_moremagic = mgt;
+                            SvMAGIC_set(sv, mg);
+                        }
+                    } else {
+                        PL_tainted = 1;
+                        SvTAINT(sv);
+                    }
+                } else 
+                    SvTAINTED_off(sv);
+            }
+        } else {
+            sv_setsv(sv,&PL_sv_undef);
+        }
     } else {
-        GV *gv_paren;
-        SV *sv= sv_newmortal();
-        Perl_sv_setpvf(aTHX_ sv, "%"IVdf,(IV)parno);
-        gv_paren= Perl_gv_fetchsv(aTHX_ sv, GV_ADD, SVt_PVGV);
-        return GvSVn(gv_paren);
+        sv_setsv(sv,&PL_sv_undef);
     }
+    return sv;
 }
 #endif
 
diff --git a/sv.c b/sv.c
index fc9914f..9f2460d 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4515,9 +4515,6 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     case PERL_MAGIC_regdata:
        vtable = &PL_vtbl_regdata;
        break;
-    case PERL_MAGIC_regdata_names:
-       vtable = &PL_vtbl_regdata_names;
-       break;
     case PERL_MAGIC_regdatum:
        vtable = &PL_vtbl_regdatum;
        break;
index 84dc2e8..24aa38a 100755 (executable)
@@ -3745,7 +3745,24 @@ sub iseq($$;$) {
     ';
     ok(!$@,'lvalue $+{...} should not throw an exception');
 }
-
+{
+    my $s='foo bar baz';
+    my @res;
+    if ('1234'=~/(?<A>1)(?<B>2)(?<A>3)(?<B>4)/) {
+        foreach my $name (sort keys(%-)) {
+            my $ary = $-{$name};
+            foreach my $idx (0..$#$ary) {
+                push @res,"$name:$idx:$ary->[$idx]";
+            }
+        }
+    }
+    my @expect=qw(A:0:1 A:1:3 B:0:2 B:1:4);
+    iseq("@res","@expect","Check %-");
+    eval'
+        print for $-{this_key_doesnt_exist};
+    ';
+    ok(!$@,'lvalue $-{...} should not throw an exception');
+}
 # stress test CURLYX/WHILEM.
 #
 # This test includes varying levels of nesting, and according to
@@ -4240,7 +4257,7 @@ ok($@=~/\QSequence \k... not terminated in regex;\E/);
 iseq(0+$::test,$::TestCount,"Got the right number of tests!");
 # Don't forget to update this!
 BEGIN {
-    $::TestCount = 1606;
+    $::TestCount = 1608;
     print "1..$::TestCount\n";
 }