named-capture.patch

   1 diff --git a/embed.fnc b/embed.fnc
   2 index fec5643..643c652 100644
   3 --- a/embed.fnc
   4 +++ b/embed.fnc
   5 @@ -694,7 +694,15 @@ Ap |I32    |regexec_flags  |NN REGEXP * const rx|NN char* stringarg \
   6                                 |NN SV* screamer|NULLOK void* data|U32 flags
   7  ApR    |regnode*|regnext       |NN regnode* p
   8
   9 -EXp    |SV*|reg_named_buff_fetch       |NN REGEXP * const rx|NN SV * const key|const U32 flags
  10 +EXp |SV*|reg_named_buff_fetch    |NN REGEXP * const rx|NN SV * const namesv|const U32 flags
  11 +EXp |void|reg_named_buff_store   |NN REGEXP * const rx|NN SV * const key \
  12 +                                 |NN SV * const value|const U32 flags
  13 +EXp |void|reg_named_buff_delete  |NN REGEXP * const rx|NN SV * const key|const U32 flags
  14 +EXp |void|reg_named_buff_clear   |NN REGEXP * const rx|const U32 flags
  15 +EXp |bool|reg_named_buff_exists  |NN REGEXP * const rx|NN SV * const key|const U32 flags
  16 +EXp |SV*|reg_named_buff_firstkey |NN REGEXP * const rx|const U32 flags
  17 +EXp |SV*|reg_named_buff_nextkey  |NN REGEXP * const rx|NN SV * const lastkey|const U32 flags
  18 +EXp |SV*|reg_named_buff_scalar   |NN REGEXP * const rx|const U32 flags
  19
  20  EXp    |void|reg_numbered_buff_fetch|NN REGEXP * const rx|const I32 paren|NULLOK SV * const sv
  21  EXp    |void|reg_numbered_buff_store|NN REGEXP * const rx|const I32 paren|NULLOK SV const * const value
  22 diff --git a/embed.h b/embed.h
  23 index 8e0ecba..aa0aa72 100644
  24 --- a/embed.h
  25 +++ b/embed.h
  26 @@ -705,6 +705,13 @@
  27  #define regnext                        Perl_regnext
  28  #if defined(PERL_CORE) || defined(PERL_EXT)
  29  #define reg_named_buff_fetch   Perl_reg_named_buff_fetch
  30 +#define reg_named_buff_store   Perl_reg_named_buff_store
  31 +#define reg_named_buff_delete  Perl_reg_named_buff_delete
  32 +#define reg_named_buff_clear   Perl_reg_named_buff_clear
  33 +#define reg_named_buff_exists  Perl_reg_named_buff_exists
  34 +#define reg_named_buff_firstkey        Perl_reg_named_buff_firstkey
  35 +#define reg_named_buff_nextkey Perl_reg_named_buff_nextkey
  36 +#define reg_named_buff_scalar  Perl_reg_named_buff_scalar
  37  #endif
  38  #if defined(PERL_CORE) || defined(PERL_EXT)
  39  #define reg_numbered_buff_fetch        Perl_reg_numbered_buff_fetch
  40 @@ -2981,6 +2988,13 @@
  41  #define regnext(a)             Perl_regnext(aTHX_ a)
  42  #if defined(PERL_CORE) || defined(PERL_EXT)
  43  #define reg_named_buff_fetch(a,b,c)    Perl_reg_named_buff_fetch(aTHX_ a,b,c)
  44 +#define reg_named_buff_store(a,b,c,d)  Perl_reg_named_buff_store(aTHX_ a,b,c,d)
  45 +#define reg_named_buff_delete(a,b,c)   Perl_reg_named_buff_delete(aTHX_ a,b,c)
  46 +#define reg_named_buff_clear(a,b)      Perl_reg_named_buff_clear(aTHX_ a,b)
  47 +#define reg_named_buff_exists(a,b,c)   Perl_reg_named_buff_exists(aTHX_ a,b,c)
  48 +#define reg_named_buff_firstkey(a,b)   Perl_reg_named_buff_firstkey(aTHX_ a,b)
  49 +#define reg_named_buff_nextkey(a,b,c)  Perl_reg_named_buff_nextkey(aTHX_ a,b,c)
  50 +#define reg_named_buff_scalar(a,b)     Perl_reg_named_buff_scalar(aTHX_ a,b)
  51  #endif
  52  #if defined(PERL_CORE) || defined(PERL_EXT)
  53  #define reg_numbered_buff_fetch(a,b,c) Perl_reg_numbered_buff_fetch(aTHX_ a,b,c)
  54 diff --git a/ext/re/re.xs b/ext/re/re.xs
  55 index 1344065..fe59940 100644
  56 --- a/ext/re/re.xs
  57 +++ b/ext/re/re.xs
  58 @@ -30,8 +30,22 @@ extern void  my_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
  59  extern I32     my_reg_numbered_buff_length(pTHX_ REGEXP * const rx,
  60                                             const SV * const sv, const I32 paren);
  61
  62 -extern SV*     my_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const key,
  63 -                                       const U32 flags);
  64 +extern SV*     my_reg_named_buff_fetch(pTHX_ REGEXP * const, SV * const,
  65 +                                                                       const U32);
  66 +extern void    my_reg_named_buff_store(pTHX_ REGEXP * const rx,
  67 +                                                                       SV * const key, SV * const value,
  68 +                                                                       const U32 flags);
  69 +extern void    my_reg_named_buff_delete(pTHX_ REGEXP * const rx,
  70 +                                                                        SV * const key, const U32 flags);
  71 +extern void    my_reg_named_buff_clear(pTHX_ REGEXP * const rx, const U32 flags);
  72 +extern bool    my_reg_named_buff_exists(pTHX_ REGEXP * const rx,
  73 +                                                                        SV * const key, const U32 flags);
  74 +extern SV*     my_reg_named_buff_firstkey(pTHX_ REGEXP * const rx,
  75 +                                                                          const U32 flags);
  76 +extern SV*     my_reg_named_buff_nextkey(pTHX_ REGEXP * const rx,
  77 +                                                                         SV * const lastkey, const U32 flags);
  78 +extern SV*     my_reg_named_buff_scalar(pTHX_ REGEXP * const rx,
  79 +                                                                        const U32 flags);
  80
  81  extern SV*      my_reg_qr_package(pTHX_ REGEXP * const rx);
  82  #if defined(USE_ITHREADS)
  83 @@ -52,6 +66,13 @@ const struct regexp_engine my_reg_engine = {
  84          my_reg_numbered_buff_store,
  85          my_reg_numbered_buff_length,
  86          my_reg_named_buff_fetch,
  87 +        my_reg_named_buff_store,
  88 +        my_reg_named_buff_delete,
  89 +        my_reg_named_buff_clear,
  90 +        my_reg_named_buff_exists,
  91 +        my_reg_named_buff_firstkey,
  92 +        my_reg_named_buff_nextkey,
  93 +        my_reg_named_buff_scalar,
  94          my_reg_qr_package,
  95  #if defined(USE_ITHREADS)
  96          my_regdupe
  97 diff --git a/ext/re/re_top.h b/ext/re/re_top.h
  98 index 5570ed7..23ee654 100644
  99 --- a/ext/re/re_top.h
 100 +++ b/ext/re/re_top.h
 101 @@ -20,6 +20,13 @@
 102  #define Perl_reg_numbered_buff_store  my_reg_numbered_buff_store
 103  #define Perl_reg_numbered_buff_length  my_reg_numbered_buff_length
 104  #define Perl_reg_named_buff_fetch  my_reg_named_buff_fetch
 105 +#define Perl_reg_named_buff_store  my_reg_named_buff_store
 106 +#define Perl_reg_named_buff_delete  my_reg_named_buff_delete
 107 +#define Perl_reg_named_buff_clear  my_reg_named_buff_clear
 108 +#define Perl_reg_named_buff_exists  my_reg_named_buff_exists
 109 +#define Perl_reg_named_buff_firstkey  my_reg_named_buff_firstkey
 110 +#define Perl_reg_named_buff_nextkey  my_reg_named_buff_nextkey
 111 +#define Perl_reg_named_buff_scalar  my_reg_named_buff_scalar
 112  #define Perl_reg_qr_package        my_reg_qr_package
 113
 114  #define PERL_NO_GET_CONTEXT
 115 diff --git a/ext/re/t/re_funcs.t b/ext/re/t/re_funcs.t
 116 index 0d9092a..fa3e11b 100644
 117 --- a/ext/re/t/re_funcs.t
 118 +++ b/ext/re/t/re_funcs.t
 119 @@ -40,23 +40,17 @@ use re qw(is_regexp regexp_pattern regmust
 120      is($floating,undef,"Regmust anchored - ref");
 121  }
 122
 123 -
 124  if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){
 125      my @names = sort +regnames();
 126      is("@names","A B","regnames");
 127 +    my @names = sort +regnames(0);
 128 +    is("@names","A B","regnames");
 129      @names = sort +regnames(1);
 130      is("@names","A B C","regnames");
 131      is(join("", @{regname("A",1)}),"13");
 132      is(join("", @{regname("B",1)}),"24");
 133      {
 134          if ('foobar'=~/(?<foo>foo)(?<bar>bar)/) {
 135 -            regnames_iterinit();
 136 -            my @res;
 137 -            while (defined(my $key=regnames_iternext)) {
 138 -                push @res,$key;
 139 -            }
 140 -            @res=sort @res;
 141 -            is("@res","bar foo");
 142              is(regnames_count(),2);
 143          } else {
 144              ok(0); ok(0);
 145 diff --git a/global.sym b/global.sym
 146 index c5181b4..0714bff 100644
 147 --- a/global.sym
 148 +++ b/global.sym
 149 @@ -406,6 +406,13 @@ Perl_re_intuit_string
 150  Perl_regexec_flags
 151  Perl_regnext
 152  Perl_reg_named_buff_fetch
 153 +Perl_reg_named_buff_store
 154 +Perl_reg_named_buff_delete
 155 +Perl_reg_named_buff_clear
 156 +Perl_reg_named_buff_exists
 157 +Perl_reg_named_buff_firstkey
 158 +Perl_reg_named_buff_nextkey
 159 +Perl_reg_named_buff_scalar
 160  Perl_reg_numbered_buff_fetch
 161  Perl_reg_numbered_buff_store
 162  Perl_reg_numbered_buff_length
 163 diff --git a/gv.c b/gv.c
 164 index 17f754f..8f98f00 100644
 165 --- a/gv.c
 166 +++ b/gv.c
 167 @@ -1014,7 +1014,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 168                 if (*name == '!')
 169                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
 170                 else if (*name == '-' || *name == '+')
 171 -                   require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
 172 +                   require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
 173             }
 174         }
 175         return gv;
 176 @@ -1224,7 +1224,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 177              SvREADONLY_on(av);
 178
 179              if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
 180 -                require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
 181 +                require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
 182
 183              break;
 184         }
 185 diff --git a/lib/Tie/Hash/NamedCapture.pm b/lib/Tie/Hash/NamedCapture.pm
 186 index 73bc20b..66cf1b5 100644
 187 --- a/lib/Tie/Hash/NamedCapture.pm
 188 +++ b/lib/Tie/Hash/NamedCapture.pm
 189 @@ -1,52 +1,19 @@
 190  package Tie::Hash::NamedCapture;
 191
 192 -use strict;
 193 -use warnings;
 194 +our $VERSION = "0.06";
 195
 196 -our $VERSION = "0.05";
 197 +# The real meat implemented in XS in universal.c in the core, but this
 198 +# method was left behind because gv.c expects a Purl-Perl method in
 199 +# this package when it loads the tie magic for %+ and %-
 200
 201 -sub TIEHASH {
 202 -    my $classname = shift;
 203 -    my %opts = @_;
 204 -
 205 -    my $self = bless { all => $opts{all} }, $classname;
 206 -    return $self;
 207 -}
 208 -
 209 -sub FETCH {
 210 -    return re::regname($_[1],$_[0]->{all});
 211 -}
 212 -
 213 -sub STORE {
 214 -    require Carp;
 215 -    Carp::croak("STORE forbidden: hashes tied to ",__PACKAGE__," are read-only.");
 216 -}
 217 -
 218 -sub FIRSTKEY {
 219 -    re::regnames_iterinit();
 220 -    return $_[0]->NEXTKEY;
 221 -}
 222 +# These should match the #defines in regexp.h
 223 +sub RXf_HASH_ONE () { 0x00000001 } # %+
 224 +sub RXf_HASH_ALL () { 0x00000002 } # %-
 225
 226 -sub NEXTKEY {
 227 -    return re::regnames_iternext($_[0]->{all});
 228 -}
 229 -
 230 -sub EXISTS {
 231 -    return defined re::regname( $_[1], $_[0]->{all});
 232 -}
 233 -
 234 -sub DELETE {
 235 -    require Carp;
 236 -    Carp::croak("DELETE forbidden: hashes tied to ",__PACKAGE__," are read-only");
 237 -}
 238 -
 239 -sub CLEAR {
 240 -    require Carp;
 241 -    Carp::croak("CLEAR forbidden: hashes tied to ",__PACKAGE__," are read-only");
 242 -}
 243 -
 244 -sub SCALAR {
 245 -    return scalar re::regnames($_[0]->{all});
 246 +sub TIEHASH {
 247 +    my ($pkg, %arg) = @_;
 248 +    my $flag = $arg{all} ? RXf_HASH_ALL : RXf_HASH_ONE;
 249 +    bless \$flag => $pkg;
 250  }
 251
 252  tie %+, __PACKAGE__;
 253 @@ -91,6 +58,7 @@ buffers that have captured (and that are thus associated to defined values).
 254
 255  =head1 SEE ALSO
 256
 257 -L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">, L<perlvar/"%-">.
 258 +L<perlreapi>, L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">,
 259 +L<perlvar/"%-">.
 260
 261  =cut
 262 diff --git a/mg.c b/mg.c
 263 index 77ae021..bc08d4a 100644
 264 --- a/mg.c
 265 +++ b/mg.c
 266 @@ -603,15 +603,15 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 267      }
 268      case '`':
 269        do_prematch:
 270 -      paren = -2;
 271 +      paren = RXrf_PREMATCH;
 272        goto maybegetparen;
 273      case '\'':
 274        do_postmatch:
 275 -      paren = -1;
 276 +      paren = RXrf_POSTMATCH;
 277        goto maybegetparen;
 278      case '&':
 279        do_match:
 280 -      paren = 0;
 281 +      paren = RXrf_MATCH;
 282        goto maybegetparen;
 283      case '1': case '2': case '3': case '4':
 284      case '5': case '6': case '7': case '8': case '9':
 285 @@ -2235,15 +2235,15 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 286            goto do_match;
 287      case '`': /* ${^PREMATCH} caught below */
 288        do_prematch:
 289 -      paren = -2;
 290 +      paren = RXrf_PREMATCH;
 291        goto setparen;
 292      case '\'': /* ${^POSTMATCH} caught below */
 293        do_postmatch:
 294 -      paren = -1;
 295 +      paren = RXrf_POSTMATCH;
 296        goto setparen;
 297      case '&':
 298        do_match:
 299 -      paren = 0;
 300 +      paren = RXrf_MATCH;
 301        goto setparen;
 302      case '1': case '2': case '3': case '4':
 303      case '5': case '6': case '7': case '8': case '9':
 304 diff --git a/perl.h b/perl.h
 305 index 8cd8753..0a4aebf 100644
 306 --- a/perl.h
 307 +++ b/perl.h
 308 @@ -231,6 +231,27 @@
 309  #define CALLREG_NAMEDBUF_FETCH(rx,name,flags) \
 310      CALL_FPTR((rx)->engine->named_buff_FETCH)(aTHX_ (rx),(name),(flags))
 311
 312 +#define CALLREG_NAMEDBUF_STORE(rx,key,value,flags) \
 313 +    CALL_FPTR((rx)->engine->named_buff_STORE)(aTHX_ (rx),(key),(value),(flags))
 314 +
 315 +#define CALLREG_NAMEDBUF_DELETE(rx,key,flags) \
 316 +    CALL_FPTR((rx)->engine->named_buff_DELETE)(aTHX_ (rx),(key),(flags))
 317 +
 318 +#define CALLREG_NAMEDBUF_CLEAR(rx,flags) \
 319 +    CALL_FPTR((rx)->engine->named_buff_CLEAR)(aTHX_ (rx),(flags))
 320 +
 321 +#define CALLREG_NAMEDBUF_EXISTS(rx,key,flags) \
 322 +    CALL_FPTR((rx)->engine->named_buff_EXISTS)(aTHX_ (rx),(key),(flags))
 323 +
 324 +#define CALLREG_NAMEDBUF_FIRSTKEY(rx,flags) \
 325 +    CALL_FPTR((rx)->engine->named_buff_FIRSTKEY)(aTHX_ (rx),(flags))
 326 +
 327 +#define CALLREG_NAMEDBUF_NEXTKEY(rx,lastkey,flags) \
 328 +    CALL_FPTR((rx)->engine->named_buff_NEXTKEY)(aTHX_ (rx),(lastkey),(flags))
 329 +
 330 +#define CALLREG_NAMEDBUF_SCALAR(rx,flags) \
 331 +    CALL_FPTR((rx)->engine->named_buff_SCALAR)(aTHX_ (rx),(flags))
 332 +
 333  #define CALLREG_PACKAGE(rx) \
 334      CALL_FPTR((rx)->engine->qr_package)(aTHX_ (rx))
 335
 336 diff --git a/pod/perlreapi.pod b/pod/perlreapi.pod
 337 index 1a170ff..08ae8cd 100644
 338 --- a/pod/perlreapi.pod
 339 +++ b/pod/perlreapi.pod
 340 @@ -26,6 +26,18 @@ structure of the following format:
 341                                          const I32 paren);
 342          SV*     (*named_buff_FETCH) (pTHX_ REGEXP * const rx, SV * const sv,
 343                                       const U32 flags);
 344 +        void    (*named_buff_STORE) (pTHX_ REGEXP * const rx, SV * const key,
 345 +                                     SV * const value, const U32 flags);
 346 +        void    (*named_buff_DELETE) (pTHX_ REGEXP * const rx,
 347 +                                      SV * const key, const U32 flags);
 348 +        void    (*named_buff_CLEAR) (pTHX_ REGEXP * const rx, const U32 flags);
 349 +        bool    (*named_buff_EXISTS) (pTHX_ REGEXP * const rx,
 350 +                                      SV * const key, const U32 flags);
 351 +        SV*     (*named_buff_FIRSTKEY) (pTHX_ REGEXP * const rx, const U32 flags);
 352 +        SV*     (*named_buff_NEXTKEY) (pTHX_ REGEXP * const rx,
 353 +                                       SV * const lastkey, const U32 flags);
 354 +        SV*     (*named_buff_SCALAR) (pTHX_ REGEXP * const rx,
 355 +                                      const U32 flags);
 356          SV*     (*qr_package)(pTHX_ REGEXP * const rx);
 357      #ifdef USE_ITHREADS
 358          void*   (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
 359 @@ -186,38 +198,45 @@ can release any resources pointed to by the C<pprivate> member of the
 360  regexp structure. This is only responsible for freeing private data;
 361  perl will handle releasing anything else contained in the regexp structure.
 362
 363 -=head2 numbered_buff_FETCH
 364 +=head2 Numbered capture callbacks
 365
 366 -    void numbered_buff_FETCH(pTHX_ REGEXP * const rx, const I32 paren,
 367 -                             SV * const sv);
 368 -
 369 -Called to get the value of C<$`>, C<$'>, C<$&> (and their named
 370 -equivalents, see L<perlvar>) and the numbered capture buffers (C<$1>,
 371 -C<$2>, ...).
 372 +Called to get/set the value of C<$`>, C<$'>, C<$&> and their named
 373 +equivalents, ${^PREMATCH}, ${^POSTMATCH} and $^{MATCH}, as well as the
 374 +numbered capture buffers (C<$1>, C<$2>, ...).
 375
 376  The C<paren> paramater will be C<-2> for C<$`>, C<-1> for C<$'>, C<0>
 377  for C<$&>, C<1> for C<$1> and so forth.
 378
 379 -C<sv> should be set to the scalar to return, the scalar is passed as
 380 -an argument rather than being returned from the function because when
 381 -it's called perl already has a scalar to store the value, creating
 382 -another one would be redundant. The scalar can be set with
 383 -C<sv_setsv>, C<sv_setpvn> and friends, see L<perlapi>.
 384 +The names have been chosen by analogy with L<Tie::Scalar> methods
 385 +names with an additional B<LENGTH> callback for efficiency. However
 386 +named capture variables are currently not tied internally but
 387 +implemented via magic.
 388 +
 389 +=head3 numbered_buff_FETCH
 390 +
 391 +    void numbered_buff_FETCH(pTHX_ REGEXP * const rx, const I32 paren,
 392 +                             SV * const sv);
 393 +
 394 +Fetch a specified numbered capture. C<sv> should be set to the scalar
 395 +to return, the scalar is passed as an argument rather than being
 396 +returned from the function because when it's called perl already has a
 397 +scalar to store the value, creating another one would be
 398 +redundant. The scalar can be set with C<sv_setsv>, C<sv_setpvn> and
 399 +friends, see L<perlapi>.
 400
 401  This callback is where perl untaints its own capture variables under
 402  taint mode (see L<perlsec>). See the C<Perl_reg_numbered_buff_get>
 403  function in F<regcomp.c> for how to untaint capture variables if
 404  that's something you'd like your engine to do as well.
 405
 406 -=head2 numbered_buff_STORE
 407 +=head3 numbered_buff_STORE
 408
 409      void    (*numbered_buff_STORE) (pTHX_ REGEXP * const rx, const I32 paren,
 410                                      SV const * const value);
 411
 412 -Called to set the value of a numbered capture variable. C<paren> is
 413 -the paren number (see the L<mapping|/numbered_buff_FETCH> above) and
 414 -C<value> is the scalar that is to be used as the new value. It's up to
 415 -the engine to make sure this is used as the new value (or reject it).
 416 +Set the value of a numbered capture variable. C<value> is the scalar
 417 +that is to be used as the new value. It's up to the engine to make
 418 +sure this is used as the new value (or reject it).
 419
 420  Example:
 421
 422 @@ -262,19 +281,19 @@ behave in the same situation:
 423
 424  Because C<$sv> is C<undef> when the C<y///> operator is applied to it
 425  the transliteration won't actually execute and the program won't
 426 -C<die>. This is different to how 5.8 behaved since the capture
 427 -variables were READONLY variables then, now they'll just die on
 428 -assignment in the default engine.
 429 +C<die>. This is different to how 5.8 and earlier versions behaved
 430 +since the capture variables were READONLY variables then, now they'll
 431 +just die when assigned to in the default engine.
 432
 433 -=head2 numbered_buff_LENGTH
 434 +=head3 numbered_buff_LENGTH
 435
 436      I32 numbered_buff_LENGTH (pTHX_ REGEXP * const rx, const SV * const sv,
 437                                const I32 paren);
 438
 439  Get the C<length> of a capture variable. There's a special callback
 440  for this so that perl doesn't have to do a FETCH and run C<length> on
 441 -the result, since the length is (in perl's case) known from a memory
 442 -offset this is much more efficient:
 443 +the result, since the length is (in perl's case) known from an offset
 444 +stored in C<<rx->offs> this is much more efficient:
 445
 446      I32 s1  = rx->offs[paren].start;
 447      I32 s2  = rx->offs[paren].end;
 448 @@ -284,14 +303,79 @@ This is a little bit more complex in the case of UTF-8, see what
 449  C<Perl_reg_numbered_buff_length> does with
 450  L<is_utf8_string_loclen|perlapi/is_utf8_string_loclen>.
 451
 452 -=head2 named_buff_FETCH
 453 +=head2 Named capture callbacks
 454 +
 455 +Called to get/set the value of C<%+> and C<%->. If C<%+> is being
 456 +operated on C<flags & RXf_HASH_ONE> will be true and C<flags &
 457 +RXf_HASH_ALL> will be true for C<%->. There's also an additional flag
 458 +for the L<SCALAR|/named_buff_SCALAR> callback, see below.
 459 +
 460 +This is implemented with a real tied interface via
 461 +L<Tie::Hash::NamedCapture>, its methods call back into these
 462 +functions, the usage of L<Tie::Hash::NamedCapture> for this purpose
 463 +might change in future releases. For instance this might be
 464 +implemented by magic instead (would need an extension to mgvtbl).
 465 +
 466 +Since these functions are just C level wrappers for the interface
 467 +described in L<Tie::Hash> their arguments and return values are as
 468 +described there, only with C prototypes.
 469 +
 470 +=head3 named_buff_FETCH
 471
 472      SV* named_buff_FETCH(pTHX_ REGEXP * const rx, SV * const key,
 473                            const U32 flags);
 474
 475 -Called to get the value of key in the C<%+> and C<%-> hashes, C<key>
 476 -is the hash key being requested and if C<flags & 1> is true C<%-> is
 477 -being requested (and C<%+> if it's not).
 478 +Get an entry.
 479 +
 480 +=head3 named_buff_STORE
 481 +
 482 +    void named_buff_STORE (pTHX_ REGEXP * const rx, SV * const key,
 483 +                           SV * const value, const U32 flags);
 484 +
 485 +Store a value.
 486 +
 487 +=head3 named_buff_DELETE
 488 +
 489 +    void named_buff_DELETE (pTHX_ REGEXP * const rx,
 490 +                            SV * const key, const U32 flags);
 491 +
 492 +Delete an entry.
 493 +
 494 +=head3 named_buff_CLEAR
 495 +
 496 +    void named_buff_CLEAR (pTHX_ REGEXP * const rx, const U32 flags);
 497 +
 498 +Clear the hash.
 499 +
 500 +=head3 named_buff_EXISTS
 501 +
 502 +    bool named_buff_EXISTS (pTHX_ REGEXP * const rx,
 503 +                            SV * const key, const U32 flags);
 504 +
 505 +Check whether an entry C<exists>.
 506 +
 507 +=head3 named_buff_FIRSTKEY
 508 +
 509 +    SV*     (*named_buff_FIRSTKEY) (pTHX_ REGEXP * const rx, const U32 flags);
 510 +
 511 +Begin iterating the hash.
 512 +
 513 +=head3 named_buff_NEXTKEY
 514 +
 515 +    SV* named_buff_NEXTKEY (pTHX_ REGEXP * const rx,
 516 +                            SV * const lastkey, const U32 flags);
 517 +
 518 +Get the next entry in the hash.
 519 +
 520 +=head3 named_buff_SCALAR
 521 +
 522 +    SV* named_buff_SCALAR (pTHX_ REGEXP * const rx, const U32 flags);
 523 +
 524 +Return what the hash evaluates to in C<scalar> context.
 525 +
 526 +This will also be called by L<re::regnames_count|re> to get the total
 527 +number of named capture buffers defined for the pattern, in this case
 528 +C<flags & RXf_HASH_COUNT> will be true.
 529
 530  =head2 qr_package
 531
 532 @@ -333,7 +417,7 @@ following snippet:
 533              SvTYPE(sv) == SVt_PVMG &&
 534              (mg = mg_find(sv, PERL_MAGIC_qr))) /* assignment deliberate */
 535          {
 536 -            re = (REGEXP *)mg->mg_obj;
 537 +            re = (REGEXP *)mg->mg_obj;
 538          }
 539
 540  Or use the (CURRENTLY UNDOCUMENETED!) C<Perl_get_re_arg> function:
 541 @@ -448,8 +532,9 @@ TODO, see L<http://www.mail-archive.com/perl5-changes@perl.org/msg17328.html>
 542
 543  =head2 C<extflags>
 544
 545 -This will be used by perl to see what flags the regexp was compiled with, this
 546 -will normally be set to the value of the flags parameter on L</comp>.
 547 +This will be used by perl to see what flags the regexp was compiled
 548 +with, this will normally be set to the value of the flags parameter by
 549 +the L<comp|/comp> callback.
 550
 551  =head2 C<minlen> C<minlenret>
 552
 553 @@ -479,7 +564,9 @@ Left offset from pos() to start match at.
 554
 555  =head2 C<substrs>
 556
 557 -TODO: document
 558 +Substring data about strings that must appear in the final match. This
 559 +is currently only used internally by perl's engine for but might be
 560 +used in the future for all engines for optimisations like C<minlen>.
 561
 562  =head2 C<nparens>, C<lasparen>, and C<lastcloseparen>
 563
 564 @@ -490,7 +577,7 @@ the last close paren to be entered.
 565  =head2 C<intflags>
 566
 567  The engine's private copy of the flags the pattern was compiled with. Usually
 568 -this is the same as C<extflags> unless the engine chose to modify one of them
 569 +this is the same as C<extflags> unless the engine chose to modify one of them.
 570
 571  =head2 C<pprivate>
 572
 573 @@ -520,8 +607,18 @@ C<$paren >= 1>.
 574
 575  =head2 C<precomp> C<prelen>
 576
 577 -Used for debugging purposes. C<precomp> holds a copy of the pattern
 578 -that was compiled and C<prelen> its length.
 579 +Used for optimisations. C<precomp> holds a copy of the pattern that
 580 +was compiled and C<prelen> its length. When a new pattern is to be
 581 +compiled (such as inside a loop) the internal C<regcomp> operator
 582 +checks whether the last compiled C<REGEXP>'s C<precomp> and C<prelen>
 583 +are equivalent to the new one, and if so uses the old pattern instead
 584 +of compiling a new one.
 585 +
 586 +The relevant snippet from C<Perl_pp_regcomp>:
 587 +
 588 +       if (!re || !re->precomp || re->prelen != (I32)len ||
 589 +           memNE(re->precomp, t, len))
 590 +        /* Compile a new pattern */
 591
 592  =head2 C<paren_names>
 593
 594 @@ -563,11 +660,11 @@ inline modifiers it's best to have C<qr//> stringify to the supplied pattern,
 595  note that this will create invalid patterns in cases such as:
 596
 597      my $x = qr/a|b/;  # "a|b"
 598 -    my $y = qr/c/;    # "c"
 599 +    my $y = qr/c/i;   # "c"
 600      my $z = qr/$x$y/; # "a|bc"
 601
 602 -There's no solution for such problems other than making the custom engine
 603 -understand some for of inline modifiers.
 604 +There's no solution for this problem other than making the custom
 605 +engine understand a construct like C<(?:)>.
 606
 607  The C<Perl_reg_stringify> in F<regcomp.c> does the stringification work.
 608
 609 diff --git a/proto.h b/proto.h
 610 index dee615f..02b24d5 100644
 611 --- a/proto.h
 612 +++ b/proto.h
 613 @@ -1893,10 +1893,36 @@ PERL_CALLCONV regnode*  Perl_regnext(pTHX_ regnode* p)
 614                         __attribute__nonnull__(pTHX_1);
 615
 616
 617 -PERL_CALLCONV SV*      Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const key, const U32 flags)
 618 +PERL_CALLCONV SV*      Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags)
 619                         __attribute__nonnull__(pTHX_1)
 620                         __attribute__nonnull__(pTHX_2);
 621
 622 +PERL_CALLCONV void     Perl_reg_named_buff_store(pTHX_ REGEXP * const rx, SV * const key, SV * const value, const U32 flags)
 623 +                       __attribute__nonnull__(pTHX_1)
 624 +                       __attribute__nonnull__(pTHX_2)
 625 +                       __attribute__nonnull__(pTHX_3);
 626 +
 627 +PERL_CALLCONV void     Perl_reg_named_buff_delete(pTHX_ REGEXP * const rx, SV * const key, const U32 flags)
 628 +                       __attribute__nonnull__(pTHX_1)
 629 +                       __attribute__nonnull__(pTHX_2);
 630 +
 631 +PERL_CALLCONV void     Perl_reg_named_buff_clear(pTHX_ REGEXP * const rx, const U32 flags)
 632 +                       __attribute__nonnull__(pTHX_1);
 633 +
 634 +PERL_CALLCONV bool     Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key, const U32 flags)
 635 +                       __attribute__nonnull__(pTHX_1)
 636 +                       __attribute__nonnull__(pTHX_2);
 637 +
 638 +PERL_CALLCONV SV*      Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags)
 639 +                       __attribute__nonnull__(pTHX_1);
 640 +
 641 +PERL_CALLCONV SV*      Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, SV * const lastkey, const U32 flags)
 642 +                       __attribute__nonnull__(pTHX_1)
 643 +                       __attribute__nonnull__(pTHX_2);
 644 +
 645 +PERL_CALLCONV SV*      Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags)
 646 +                       __attribute__nonnull__(pTHX_1);
 647 +
 648
 649  PERL_CALLCONV void     Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv)
 650                         __attribute__nonnull__(pTHX_1);
 651 diff --git a/regcomp.c b/regcomp.c
 652 index baa5d99..c144d76 100644
 653 --- a/regcomp.c
 654 +++ b/regcomp.c
 655 @@ -228,7 +228,7 @@ typedef struct RExC_state_t {
 656
 657      /FOO[xX]A.*B[xX]BAR/
 658
 659 -  Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
 660 +v  Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
 661    strings (because they follow a .* construct). study_chunk will identify
 662    both FOO and BAR as being the longest fixed and floating strings respectively.
 663
 664 @@ -4800,7 +4800,7 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32
 665  {
 666      AV *retarray = NULL;
 667      SV *ret;
 668 -    if (flags & 1)
 669 +    if (flags & RXf_HASH_ALL)
 670          retarray=newAV();
 671
 672      if (rx && rx->paren_names) {
 673 @@ -4810,9 +4810,9 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32
 674              SV* sv_dat=HeVAL(he_str);
 675              I32 *nums=(I32*)SvPVX(sv_dat);
 676              for ( i=0; i<SvIVX(sv_dat); i++ ) {
 677 -               if ((I32)(rx->nparens) >= nums[i]
 678 -                       && rx->offs[nums[i]].start != -1
 679 -                       && rx->offs[nums[i]].end != -1)
 680 +                if ((I32)(rx->nparens) >= nums[i]
 681 +                    && rx->offs[nums[i]].start != -1
 682 +                    && rx->offs[nums[i]].end != -1)
 683                  {
 684                      ret = newSVpvs("");
 685                      CALLREG_NUMBUF_FETCH(rx,nums[i],ret);
 686 @@ -4827,13 +4827,116 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32
 687                  }
 688              }
 689              if (retarray)
 690 -                return (SV*)retarray;
 691 +                return newRV((SV*)retarray);
 692          }
 693      }
 694      return NULL;
 695  }
 696
 697  void
 698 +Perl_reg_named_buff_store(pTHX_ REGEXP * const rx, SV * const key,
 699 +                          SV * const value, const U32 flags)
 700 +{
 701 +    PERL_UNUSED_ARG(rx);
 702 +    PERL_UNUSED_ARG(key);
 703 +    PERL_UNUSED_ARG(value);
 704 +    PERL_UNUSED_ARG(flags);
 705 +
 706 +    Perl_croak(aTHX_ PL_no_modify);
 707 +}
 708 +
 709 +void
 710 +Perl_reg_named_buff_delete(pTHX_ REGEXP * const rx, SV * const key, const U32 flags)
 711 +{
 712 +    PERL_UNUSED_ARG(rx);
 713 +    PERL_UNUSED_ARG(key);
 714 +    PERL_UNUSED_ARG(flags);
 715 +
 716 +    Perl_croak(aTHX_ PL_no_modify);
 717 +}
 718 +
 719 +void
 720 +Perl_reg_named_buff_clear(pTHX_ REGEXP * const rx, const U32 flags)
 721 +{
 722 +    PERL_UNUSED_ARG(rx);
 723 +    PERL_UNUSED_ARG(flags);
 724 +
 725 +    Perl_croak(aTHX_ PL_no_modify);
 726 +}
 727 +
 728 +bool
 729 +Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key,
 730 +                           const U32 flags)
 731 +{
 732 +    PERL_UNUSED_ARG(flags);
 733 +
 734 +    if (rx && rx->paren_names) {
 735 +        return hv_exists_ent(rx->paren_names, key, 0);
 736 +    } else {
 737 +        return FALSE;
 738 +    }
 739 +}
 740 +
 741 +SV*
 742 +Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags)
 743 +{
 744 +    PERL_UNUSED_ARG(flags);
 745 +
 746 +    (void)hv_iterinit(rx->paren_names);
 747 +
 748 +    return CALLREG_NAMEDBUF_NEXTKEY(rx, NULL, flags);
 749 +}
 750 +
 751 +SV*
 752 +Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, SV * const lastkey,
 753 +                            const U32 flags)
 754 +{
 755 +    PERL_UNUSED_ARG(lastkey);
 756 +    bool all = flags & RXf_HASH_ALL;
 757 +
 758 +    if (rx && rx->paren_names) {
 759 +        HV *hv= rx->paren_names;
 760 +        while (1) {
 761 +            HE *temphe = hv_iternext_flags(hv,0);
 762 +            if (temphe) {
 763 +                IV i;
 764 +                IV parno = 0;
 765 +                SV* sv_dat = HeVAL(temphe);
 766 +                I32 *nums = (I32*)SvPVX(sv_dat);
 767 +                for ( i = 0; i < SvIVX(sv_dat); i++ ) {
 768 +                    if ((I32)(rx->lastcloseparen) >= nums[i] &&
 769 +                        rx->offs[nums[i]].start != -1 &&
 770 +                        rx->offs[nums[i]].end != -1)
 771 +                    {
 772 +                        parno = nums[i];
 773 +                        break;
 774 +                    }
 775 +                }
 776 +                if (parno || all) {
 777 +                    STRLEN len;
 778 +                    char *pv = HePV(temphe, len);
 779 +                    return newSVpvn(pv,len);
 780 +                }
 781 +            } else {
 782 +                break;
 783 +            }
 784 +        }
 785 +    }
 786 +
 787 +    return NULL;
 788 +}
 789 +
 790 +SV*
 791 +Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags)
 792 +{
 793 +    PERL_UNUSED_ARG(flags);
 794 +
 795 +    if (rx && rx->paren_names)
 796 +        return newSViv(HvTOTALKEYS(rx->paren_names));
 797 +       return &PL_sv_undef;
 798 +}
 799 +
 800 +void
 801  Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv)
 802  {
 803      char *s = NULL;
 804 @@ -4845,13 +4948,13 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * cons
 805          return;
 806      }
 807      else
 808 -    if (paren == -2 && rx->offs[0].start != -1) {
 809 +    if (paren == RXrf_PREMATCH && rx->offs[0].start != -1) {
 810          /* $` */
 811         i = rx->offs[0].start;
 812         s = rx->subbeg;
 813      }
 814      else
 815 -    if (paren == -1 && rx->offs[0].end != -1) {
 816 +    if (paren == RXrf_POSTMATCH && rx->offs[0].end != -1) {
 817          /* $' */
 818         s = rx->subbeg + rx->offs[0].end;
 819         i = rx->sublen - rx->offs[0].end;
 820 @@ -4929,7 +5032,8 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv,
 821
 822      /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
 823         switch (paren) {
 824 -      case -2: /* $` */
 825 +      /* $` / ${^PREMATCH} */
 826 +      case RXrf_PREMATCH:
 827          if (rx->offs[0].start != -1) {
 828                         i = rx->offs[0].start;
 829                         if (i > 0) {
 830 @@ -4939,7 +5043,8 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv,
 831                         }
 832             }
 833          return 0;
 834 -      case -1: /* $' */
 835 +      /* $' / ${^POSTMATCH} */
 836 +      case RXrf_POSTMATCH:
 837             if (rx->offs[0].end != -1) {
 838                         i = rx->sublen - rx->offs[0].end;
 839                         if (i > 0) {
 840 @@ -4949,7 +5054,8 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv,
 841                         }
 842             }
 843          return 0;
 844 -      default: /* $&, $1, $2, ... */
 845 +      /* $& / ${^MATCH}, $1, $2, ... */
 846 +      default:
 847             if (paren <= (I32)rx->nparens &&
 848              (s1 = rx->offs[paren].start) != -1 &&
 849              (t1 = rx->offs[paren].end) != -1)
 850 diff --git a/regcomp.h b/regcomp.h
 851 index 33c3eef..5be7f32 100644
 852 --- a/regcomp.h
 853 +++ b/regcomp.h
 854 @@ -473,6 +473,13 @@ EXTCONST regexp_engine PL_core_reg_engine = {
 855          Perl_reg_numbered_buff_store,
 856          Perl_reg_numbered_buff_length,
 857          Perl_reg_named_buff_fetch,
 858 +        Perl_reg_named_buff_store,
 859 +        Perl_reg_named_buff_delete,
 860 +        Perl_reg_named_buff_clear,
 861 +        Perl_reg_named_buff_exists,
 862 +        Perl_reg_named_buff_firstkey,
 863 +        Perl_reg_named_buff_nextkey,
 864 +        Perl_reg_named_buff_scalar,
 865          Perl_reg_qr_package,
 866  #if defined(USE_ITHREADS)
 867          Perl_regdupe_internal
 868 diff --git a/regexp.h b/regexp.h
 869 index 1f72112..31d264d 100644
 870 --- a/regexp.h
 871 +++ b/regexp.h
 872 @@ -136,14 +136,40 @@ typedef struct regexp_engine {
 873                                     SV const * const value);
 874      I32     (*numbered_buff_LENGTH) (pTHX_ REGEXP * const rx, const SV * const sv,
 875                                      const I32 paren);
 876 -    SV*     (*named_buff_FETCH) (pTHX_ REGEXP * const rx, SV * const key,
 877 +    SV*     (*named_buff_FETCH) (pTHX_ REGEXP * const rx, SV * const sv,
 878                                   const U32 flags);
 879 +    void    (*named_buff_STORE) (pTHX_ REGEXP * const rx, SV * const key,
 880 +                                 SV * const value, const U32 flags);
 881 +    void    (*named_buff_DELETE) (pTHX_ REGEXP * const rx,
 882 +                                  SV * const key, const U32 flags);
 883 +    void    (*named_buff_CLEAR) (pTHX_ REGEXP * const rx, const U32 flags);
 884 +    bool    (*named_buff_EXISTS) (pTHX_ REGEXP * const rx,
 885 +                                  SV * const key, const U32 flags);
 886 +    SV*     (*named_buff_FIRSTKEY) (pTHX_ REGEXP * const rx, const U32 flags);
 887 +    SV*     (*named_buff_NEXTKEY) (pTHX_ REGEXP * const rx,
 888 +                                   SV * const lastkey, const U32 flags);
 889 +    SV*     (*named_buff_SCALAR) (pTHX_ REGEXP * const rx,
 890 +                                  const U32 flags);
 891      SV*     (*qr_package)(pTHX_ REGEXP * const rx);
 892  #ifdef USE_ITHREADS
 893      void*   (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
 894  #endif
 895  } regexp_engine;
 896
 897 +/*
 898 +  These are passed to the numbered capture variable callbacks as the
 899 +  paren name. >= 1 is reserved for actual numbered captures, i.e. $1,
 900 +  $2 etc.
 901 +*/
 902 +
 903 +#define RXrf_PREMATCH  -2 /* $` / ${^PREMATCH}  */
 904 +#define RXrf_POSTMATCH -1 /* $' / ${^POSTMATCH} */
 905 +#define RXrf_MATCH      0 /* $& / ${^MATCH}     */
 906 +
 907 +#define RXf_HASH_ONE      0x00000001 /* %+ */
 908 +#define RXf_HASH_ALL      0x00000002 /* %- */
 909 +#define RXf_HASH_COUNT    0x00000004 /* scalar %+ / scalar %- */
 910 +
 911  /* Flags stored in regexp->extflags
 912   * These are used by code external to the regexp engine
 913   *
 914 diff --git a/t/TEST b/t/TEST
 915 old mode 100644
 916 new mode 100755
 917 diff --git a/t/op/readdir.t b/t/op/readdir.t
 918 index c4d5ed2..971a02a 100644
 919 --- a/t/op/readdir.t
 920 +++ b/t/op/readdir.t
 921 @@ -24,7 +24,7 @@ closedir(OP);
 922  ## This range will have to adjust as the number of tests expands,
 923  ## as it's counting the number of .t files in src/t
 924  ##
 925 -my ($min, $max) = (140, 160);
 926 +my ($min, $max) = (150, 170);
 927  if (@D > $min && @D < $max) { print "ok 2\n"; }
 928  else {
 929      printf "not ok 2 # counting op/*.t, expect $min < %d < $max files\n",
 930 diff --git a/t/op/regexp_namedcapture_tie.t b/t/op/regexp_namedcapture_tie.t
 931 new file mode 100644
 932 index 0000000..f72970e
 933 --- /dev/null
 934 +++ b/t/op/regexp_namedcapture_tie.t
 935 @@ -0,0 +1,48 @@
 936 +#!./perl
 937 +
 938 +BEGIN {
 939 +    chdir 't' if -d 't';
 940 +    @INC = '../lib';
 941 +    require './test.pl';
 942 +}
 943 +
 944 +# Do a basic test on all the tied methods of Tie::Hash::NamedCapture
 945 +
 946 +print "1..12\n";
 947 +
 948 +"hlagh" =~ /
 949 +    (?<a>.)
 950 +    (?<b>.)
 951 +    (?<a>.)
 952 +    .*
 953 +    (?<e>$)
 954 +/x;
 955 +
 956 +# FETCH
 957 +is($+{a}, "h", "FETCH");
 958 +is($+{b}, "l", "FETCH");
 959 +is($-{a}[0], "h", "FETCH");
 960 +is($-{a}[1], "a", "FETCH");
 961 +
 962 +# STORE
 963 +eval { $+{a} = "yon" };
 964 +ok(index($@, "read-only") != -1, "STORE");
 965 +
 966 +# DELETE
 967 +eval { delete $+{a} };
 968 +ok(index($@, "read-only") != -1, "DELETE");
 969 +
 970 +# CLEAR
 971 +eval { %+ = () };
 972 +ok(index($@, "read-only") != -1, "CLEAR");
 973 +
 974 +# EXISTS
 975 +ok(exists $+{e}, "EXISTS");
 976 +ok(!exists $+{d}, "EXISTS");
 977 +
 978 +# FIRSTKEY/NEXTKEY
 979 +is(join('|', sort keys %+), "a|b|e", "FIRSTKEY/NEXTKEY");
 980 +
 981 +# SCALAR
 982 +is(scalar(%+), 3, "SCALAR");
 983 +is(scalar(%-), 3, "SCALAR");
 984 diff --git a/universal.c b/universal.c
 985 index 396dd3d..f506441 100644
 986 --- a/universal.c
 987 +++ b/universal.c
 988 @@ -16,6 +16,11 @@
 989
 990  /* This file contains the code that implements the functions in Perl's
 991   * UNIVERSAL package, such as UNIVERSAL->can().
 992 + *
 993 + * It is also used to store XS functions that need to be present in
 994 + * miniperl for a lack of a better place to put them. It might be
 995 + * clever to move them to seperate XS files which would then be pulled
 996 + * in by some to-be-written build process.
 997   */
 998
 999  #include "EXTERN.h"
1000 @@ -226,11 +231,17 @@ XS(XS_Internals_rehash_seed);
1001  XS(XS_Internals_HvREHASH);
1002  XS(XS_Internals_inc_sub_generation);
1003  XS(XS_re_is_regexp);
1004 -XS(XS_re_regname);
1005 -XS(XS_re_regnames);
1006 -XS(XS_re_regnames_iterinit);
1007 -XS(XS_re_regnames_iternext);
1008 +XS(XS_re_regname);
1009 +XS(XS_re_regnames);
1010  XS(XS_re_regnames_count);
1011 +XS(XS_Tie_Hash_NamedCapture_FETCH);
1012 +XS(XS_Tie_Hash_NamedCapture_STORE);
1013 +XS(XS_Tie_Hash_NamedCapture_DELETE);
1014 +XS(XS_Tie_Hash_NamedCapture_CLEAR);
1015 +XS(XS_Tie_Hash_NamedCapture_EXISTS);
1016 +XS(XS_Tie_Hash_NamedCapture_FIRSTKEY);
1017 +XS(XS_Tie_Hash_NamedCapture_NEXTKEY);
1018 +XS(XS_Tie_Hash_NamedCapture_SCALAR);
1019
1020  void
1021  Perl_boot_core_UNIVERSAL(pTHX)
1022 @@ -284,9 +295,15 @@ Perl_boot_core_UNIVERSAL(pTHX)
1023      newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
1024      newXSproto("re::regname", XS_re_regname, file, ";$$");
1025      newXSproto("re::regnames", XS_re_regnames, file, ";$");
1026 -    newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, "");
1027 -    newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$");
1028      newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
1029 +    newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
1030 +    newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
1031 +    newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
1032 +    newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file);
1033 +    newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file);
1034 +    newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTKEY, file);
1035 +    newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTKEY, file);
1036 +    newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file);
1037  }
1038
1039
1040 @@ -1072,206 +1089,341 @@ XS(XS_re_is_regexp)
1041          /* NOTREACHED */
1042         PUTBACK;
1043         return;
1044 +
1045      }
1046  }
1047
1048 -XS(XS_re_regname)
1049 +XS(XS_re_regnames_count)
1050  {
1051 -
1052 +    REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1053 +    SV *ret;
1054      dVAR;
1055      dXSARGS;
1056 +
1057 +    if (items != 0)
1058 +       Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
1059 +    PERL_UNUSED_VAR(cv); /* -W */
1060 +    PERL_UNUSED_VAR(ax); /* -Wall */
1061 +    SP -= items;
1062 +
1063 +    if (!rx)
1064 +        XSRETURN_UNDEF;
1065 +
1066 +    ret = CALLREG_NAMEDBUF_SCALAR(rx, RXf_HASH_COUNT);
1067 +
1068 +    SPAGAIN;
1069 +
1070 +    if (ret) {
1071 +        XPUSHs(ret);
1072 +        PUTBACK;
1073 +        return;
1074 +    } else {
1075 +        XSRETURN_UNDEF;
1076 +    }
1077 +}
1078 +
1079 +XS(XS_re_regname)
1080 +{
1081 +    dVAR;
1082 +    dXSARGS;
1083      if (items < 1 || items > 2)
1084 -       Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
1085 +        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
1086      PERL_UNUSED_VAR(cv); /* -W */
1087      PERL_UNUSED_VAR(ax); /* -Wall */
1088      SP -= items;
1089 -    {
1090 -       SV *    sv = ST(0);
1091 -       SV *    all;
1092 -        regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1093 -        SV *bufs = NULL;
1094 +    REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1095 +    U32 flags;
1096 +    SV * ret;
1097
1098 -       if (items < 2)
1099 -           all = NULL;
1100 -       else {
1101 -           all = ST(1);
1102 -       }
1103 -        {
1104 -            if (SvPOK(sv) && re && re->paren_names) {
1105 -                bufs = CALLREG_NAMEDBUF_FETCH(re,sv,all && SvTRUE(all));
1106 -                if (bufs) {
1107 -                    if (all && SvTRUE(all))
1108 -                        XPUSHs(newRV(bufs));
1109 -                    else
1110 -                        XPUSHs(SvREFCNT_inc(bufs));
1111 -                    XSRETURN(1);
1112 -                }
1113 -            }
1114 -            XSRETURN_UNDEF;
1115 -        }
1116 -       PUTBACK;
1117 -       return;
1118 +    if (!rx)
1119 +        XSRETURN_UNDEF;
1120 +
1121 +    if (items == 2 && SvTRUE(ST(1))) {
1122 +        flags = RXf_HASH_ALL;
1123 +    } else {
1124 +        flags = RXf_HASH_ONE;
1125 +    }
1126 +    ret = CALLREG_NAMEDBUF_FETCH(rx, ST(0), flags);
1127 +
1128 +    if (ret) {
1129 +        if (SvROK(ret))
1130 +            XPUSHs(ret);
1131 +        else
1132 +            XPUSHs(SvREFCNT_inc(ret));
1133 +        XSRETURN(1);
1134      }
1135 +    XSRETURN_UNDEF;
1136  }
1137
1138 +
1139  XS(XS_re_regnames)
1140  {
1141 -    dVAR;
1142 +    dVAR;
1143      dXSARGS;
1144      if (items < 0 || items > 1)
1145 -       Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
1146 +        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
1147      PERL_UNUSED_VAR(cv); /* -W */
1148      PERL_UNUSED_VAR(ax); /* -Wall */
1149      SP -= items;
1150 -    {
1151 -       SV *    all;
1152 -        regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1153 -        IV count = 0;
1154 +    REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1155 +    U32 flags;
1156 +    IV count = 0;
1157
1158 -       if (items < 1)
1159 -           all = NULL;
1160 -       else {
1161 -           all = ST(0);
1162 -       }
1163 -        {
1164 -            if (re && re->paren_names) {
1165 -                HV *hv= re->paren_names;
1166 -                (void)hv_iterinit(hv);
1167 -                while (1) {
1168 -                    HE *temphe = hv_iternext_flags(hv,0);
1169 -                    if (temphe) {
1170 -                        IV i;
1171 -                        IV parno = 0;
1172 -                        SV* sv_dat = HeVAL(temphe);
1173 -                        I32 *nums = (I32*)SvPVX(sv_dat);
1174 -                        for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1175 -                            if ((I32)(re->lastcloseparen) >= nums[i] &&
1176 -                                re->offs[nums[i]].start != -1 &&
1177 -                                re->offs[nums[i]].end != -1)
1178 -                            {
1179 -                                parno = nums[i];
1180 -                                break;
1181 -                            }
1182 -                        }
1183 -                        if (parno || (all && SvTRUE(all))) {
1184 -                            STRLEN len;
1185 -                            char *pv = HePV(temphe, len);
1186 -                            if ( GIMME_V == G_ARRAY )
1187 -                                XPUSHs(newSVpvn(pv,len));
1188 -                            count++;
1189 -                        }
1190 -                    } else {
1191 +    if (!rx)
1192 +        XSRETURN_UNDEF;
1193 +
1194 +    if (items == 1 && SvTRUE(ST(0))) {
1195 +        flags = 1;
1196 +    } else {
1197 +        flags = 0;
1198 +    }
1199 +
1200 +    if (rx && rx->paren_names) {
1201 +        HV *hv= rx->paren_names;
1202 +        (void)hv_iterinit(hv);
1203 +        while (1) {
1204 +            HE *temphe = hv_iternext_flags(hv,0);
1205 +            if (temphe) {
1206 +                IV i;
1207 +                IV parno = 0;
1208 +                SV* sv_dat = HeVAL(temphe);
1209 +                I32 *nums = (I32*)SvPVX(sv_dat);
1210 +                for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1211 +                    if ((I32)(rx->lastcloseparen) >= nums[i] &&
1212 +                        rx->offs[nums[i]].start != -1 &&
1213 +                        rx->offs[nums[i]].end != -1)
1214 +                    {
1215 +                        parno = nums[i];
1216                          break;
1217                      }
1218                  }
1219 +                if (parno || flags) {
1220 +                    STRLEN len;
1221 +                    char *pv = HePV(temphe, len);
1222 +                    if ( GIMME_V == G_ARRAY )
1223 +                        XPUSHs(newSVpvn(pv,len));
1224 +                    count++;
1225 +                }
1226 +            } else {
1227 +                break;
1228              }
1229 -            if ( GIMME_V == G_ARRAY )
1230 -                XSRETURN(count);
1231 -            else
1232 -                XSRETURN_UNDEF;
1233 -        }
1234 -       PUTBACK;
1235 -       return;
1236 +        }
1237      }
1238 +
1239 +    if ( GIMME_V == G_ARRAY )
1240 +        XSRETURN(count);
1241 +    else
1242 +        XSRETURN_UNDEF;
1243  }
1244
1245 -
1246 -XS(XS_re_regnames_iterinit)
1247 +XS(XS_Tie_Hash_NamedCapture_FETCH)
1248  {
1249 -    dVAR;
1250 +    dVAR;
1251      dXSARGS;
1252 -    if (items != 0)
1253 -       Perl_croak(aTHX_ "Usage: re::regnames_iterinit()");
1254 -    PERL_UNUSED_VAR(cv); /* -W */
1255 -    PERL_UNUSED_VAR(ax); /* -Wall */
1256 +    REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1257 +    U32 flags;
1258 +    SV * ret;
1259 +
1260 +    if (items != 2)
1261 +        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $flags)");
1262 +
1263 +    if (!rx)
1264 +        XSRETURN_UNDEF;
1265 +
1266      SP -= items;
1267 -    {
1268 -        regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1269 -        if (re && re->paren_names) {
1270 -            (void)hv_iterinit(re->paren_names);
1271 -            XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1272 -        } else {
1273 +
1274 +    flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1275 +    ret = CALLREG_NAMEDBUF_FETCH(rx, ST(1), flags);
1276 +
1277 +    SPAGAIN;
1278 +
1279 +    if (ret) {
1280 +        if (SvROK(ret))
1281 +            XPUSHs(ret);
1282 +        else
1283 +            XPUSHs(SvREFCNT_inc(ret));
1284 +        PUTBACK;
1285 +        return;
1286 +    }
1287 +    XSRETURN_UNDEF;
1288 +}
1289 +
1290 +XS(XS_Tie_Hash_NamedCapture_STORE)
1291 +{
1292 +    dVAR;
1293 +    dXSARGS;
1294 +    REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1295 +    U32 flags;
1296 +
1297 +    if (items != 3)
1298 +        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $value, $flags)");
1299 +
1300 +    if (!rx) {
1301 +        if (!PL_localizing)
1302 +            Perl_croak(aTHX_ PL_no_modify);
1303 +        else
1304              XSRETURN_UNDEF;
1305 -        }
1306 -       PUTBACK;
1307 -       return;
1308      }
1309 +
1310 +    SP -= items;
1311 +
1312 +    flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1313 +    CALLREG_NAMEDBUF_STORE(rx,ST(1), ST(2), flags);
1314  }
1315
1316 +XS(XS_Tie_Hash_NamedCapture_DELETE)
1317 +{
1318 +    dVAR;
1319 +    dXSARGS;
1320 +    REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1321 +    U32 flags;
1322
1323 -XS(XS_re_regnames_iternext)
1324 +    if (items != 2)
1325 +        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::DELETE($key, $flags)");
1326 +
1327 +    if (!rx)
1328 +        Perl_croak(aTHX_ PL_no_modify);
1329 +
1330 +    SP -= items;
1331 +
1332 +    flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1333 +    CALLREG_NAMEDBUF_DELETE(rx, ST(1), flags);
1334 +}
1335 +
1336 +XS(XS_Tie_Hash_NamedCapture_CLEAR)
1337  {
1338 -    dVAR;
1339 +    dVAR;
1340      dXSARGS;
1341 -    if (items < 0 || items > 1)
1342 -       Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "[all]");
1343 -    PERL_UNUSED_VAR(cv); /* -W */
1344 -    PERL_UNUSED_VAR(ax); /* -Wall */
1345 +    REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1346 +    U32 flags;
1347 +
1348 +    if (items != 1)
1349 +        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::CLEAR($flags)");
1350 +
1351 +    if (!rx)
1352 +        Perl_croak(aTHX_ PL_no_modify);
1353 +
1354      SP -= items;
1355 -    {
1356 -       SV *    all;
1357 -        regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1358
1359 -       if (items < 1)
1360 -           all = NULL;
1361 -       else {
1362 -           all = ST(0);
1363 -       }
1364 -        if (re && re->paren_names) {
1365 -            HV *hv= re->paren_names;
1366 -            while (1) {
1367 -                HE *temphe = hv_iternext_flags(hv,0);
1368 -                if (temphe) {
1369 -                    IV i;
1370 -                    IV parno = 0;
1371 -                    SV* sv_dat = HeVAL(temphe);
1372 -                    I32 *nums = (I32*)SvPVX(sv_dat);
1373 -                    for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1374 -                        if ((I32)(re->lastcloseparen) >= nums[i] &&
1375 -                            re->offs[nums[i]].start != -1 &&
1376 -                            re->offs[nums[i]].end != -1)
1377 -                        {
1378 -                            parno = nums[i];
1379 -                            break;
1380 -                        }
1381 -                    }
1382 -                    if (parno || (all && SvTRUE(all))) {
1383 -                        STRLEN len;
1384 -                        char *pv = HePV(temphe, len);
1385 -                        XPUSHs(newSVpvn(pv,len));
1386 -                        XSRETURN(1);
1387 -                    }
1388 -                } else {
1389 -                    break;
1390 -                }
1391 -            }
1392 -        }
1393 +    flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1394 +    CALLREG_NAMEDBUF_CLEAR(rx, flags);
1395 +}
1396 +
1397 +XS(XS_Tie_Hash_NamedCapture_EXISTS)
1398 +{
1399 +    dVAR;
1400 +    dXSARGS;
1401 +    REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1402 +    U32 flags;
1403 +    bool exists;
1404 +
1405 +    if (items != 2)
1406 +        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::EXISTS($key, $flags)");
1407 +
1408 +    if (!rx)
1409          XSRETURN_UNDEF;
1410 -       PUTBACK;
1411 -       return;
1412 +
1413 +    SP -= items;
1414 +
1415 +    flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1416 +    exists = CALLREG_NAMEDBUF_EXISTS(rx, ST(1), flags);
1417 +
1418 +    SPAGAIN;
1419 +
1420 +    if (exists) {
1421 +        XSRETURN_YES;
1422 +    } else {
1423 +        XSRETURN_NO;
1424      }
1425  }
1426
1427 +XS(XS_Tie_Hash_NamedCapture_FIRSTKEY)
1428 +{
1429 +    dVAR;
1430 +    dXSARGS;
1431 +    REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1432 +    U32 flags;
1433 +    SV * ret;
1434
1435 -XS(XS_re_regnames_count)
1436 +    if (items != 1)
1437 +        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::FIRSTKEY()");
1438 +
1439 +    if (!rx)
1440 +        XSRETURN_UNDEF;
1441 +
1442 +    SP -= items;
1443 +
1444 +    flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1445 +    ret = CALLREG_NAMEDBUF_FIRSTKEY(rx, flags);
1446 +
1447 +    SPAGAIN;
1448 +
1449 +    if (ret) {
1450 +        XPUSHs(SvREFCNT_inc(ret));
1451 +        PUTBACK;
1452 +    } else {
1453 +        XSRETURN_UNDEF;
1454 +    }
1455 +
1456 +}
1457 +
1458 +XS(XS_Tie_Hash_NamedCapture_NEXTKEY)
1459  {
1460 -    regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1461 -    dVAR;
1462 +    dVAR;
1463      dXSARGS;
1464 +    REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1465 +    U32 flags;
1466 +    SV * ret;
1467 +
1468 +    if (items != 2)
1469 +        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::NEXTKEY($lastkey)");
1470 +
1471 +    if (!rx)
1472 +        XSRETURN_UNDEF;
1473
1474 -    if (items != 0)
1475 -       Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
1476 -    PERL_UNUSED_VAR(cv); /* -W */
1477 -    PERL_UNUSED_VAR(ax); /* -Wall */
1478      SP -= items;
1479 -
1480 -    if (re && re->paren_names) {
1481 -        XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1482 +
1483 +    flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1484 +    ret = CALLREG_NAMEDBUF_NEXTKEY(rx, ST(1), flags);
1485 +
1486 +    SPAGAIN;
1487 +
1488 +    if (ret) {
1489 +        XPUSHs(ret);
1490      } else {
1491          XSRETURN_UNDEF;
1492      }
1493      PUTBACK;
1494 -    return;
1495 +}
1496 +
1497 +XS(XS_Tie_Hash_NamedCapture_SCALAR)
1498 +{
1499 +    dVAR;
1500 +    dXSARGS;
1501 +    REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1502 +    U32 flags;
1503 +    SV * ret;
1504 +
1505 +    if (items != 1)
1506 +        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::SCALAR()");
1507 +
1508 +    if (!rx)
1509 +        XSRETURN_UNDEF;
1510 +
1511 +    SP -= items;
1512 +
1513 +    flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1514 +    ret = CALLREG_NAMEDBUF_SCALAR(rx, flags);
1515 +
1516 +    SPAGAIN;
1517 +
1518 +    if (ret) {
1519 +        XPUSHs(ret);
1520 +        PUTBACK;
1521 +        return;
1522 +    } else {
1523 +        XSRETURN_UNDEF;
1524 +    }
1525  }
1526
1527