| 1 | package re::Tie::Hash::NamedCapture; |
| 2 | use strict; |
| 3 | use warnings; |
| 4 | our $VERSION = "0.01"; |
| 5 | use re qw(is_regexp |
| 6 | regname |
| 7 | regnames |
| 8 | regnames_count |
| 9 | regnames_iterinit |
| 10 | regnames_iternext); |
| 11 | |
| 12 | sub TIEHASH { |
| 13 | my $classname = shift; |
| 14 | my $hash = {@_}; |
| 15 | |
| 16 | if ($hash->{re} && !is_regexp($hash->{re})) { |
| 17 | die "'re' parameter to ",__PACKAGE__,"->TIEHASH must be a qr//" |
| 18 | } |
| 19 | |
| 20 | return bless $hash, $classname; |
| 21 | } |
| 22 | |
| 23 | sub FETCH { |
| 24 | return regname($_[1],$_[0]->{re},$_[0]->{all}); |
| 25 | } |
| 26 | |
| 27 | sub STORE { |
| 28 | require Carp; |
| 29 | Carp::croak("STORE forbidden: Hashes tied to ",__PACKAGE__," are read/only."); |
| 30 | } |
| 31 | |
| 32 | sub FIRSTKEY { |
| 33 | regnames_iterinit($_[0]->{re}); |
| 34 | return $_[0]->NEXTKEY; |
| 35 | } |
| 36 | |
| 37 | sub NEXTKEY { |
| 38 | return regnames_iternext($_[0]->{re},$_[0]->{all}); |
| 39 | } |
| 40 | |
| 41 | sub EXISTS { |
| 42 | return defined regname( $_[1], $_[0]->{re},$_[0]->{all}); |
| 43 | } |
| 44 | |
| 45 | sub DELETE { |
| 46 | require Carp; |
| 47 | Carp::croak("DELETE forbidden: Hashes tied to ",__PACKAGE__," are read/only"); |
| 48 | } |
| 49 | |
| 50 | sub CLEAR { |
| 51 | require Carp; |
| 52 | Carp::croak("CLEAR forbidden: Hashes tied to ",__PACKAGE__," are read/only"); |
| 53 | } |
| 54 | |
| 55 | sub SCALAR { |
| 56 | return scalar regnames($_[0]->{re},$_[0]->{all}); |
| 57 | } |
| 58 | |
| 59 | 1; |
| 60 | |
| 61 | __END__ |
| 62 | |
| 63 | =head1 NAME |
| 64 | |
| 65 | re::Tie::Hash::NamedCapture - Perl module to support named regex capture buffers |
| 66 | |
| 67 | =head1 SYNOPSIS |
| 68 | |
| 69 | tie my %hash,"re::Tie::Hash::NamedCapture"; |
| 70 | # %hash now behaves like %- |
| 71 | |
| 72 | tie my %hash,"re::Tie::Hash::NamedCapture",re => $qr, all=> 1, |
| 73 | # %hash now access buffers from regex in $qr like %+ |
| 74 | |
| 75 | =head1 DESCRIPTION |
| 76 | |
| 77 | Implements the behaviour required for C<%+> and C<%-> but can be used |
| 78 | independently. |
| 79 | |
| 80 | When the C<re> parameter is provided, and the value is the result of |
| 81 | a C<qr//> expression then the hash is bound to that particular regexp |
| 82 | and will return the results of its last successful match. If the |
| 83 | parameter is omitted then the hash behaves just as C<$1> does by |
| 84 | referencing the last successful match. |
| 85 | |
| 86 | When the C<all> parameter is provided then the result of a fetch |
| 87 | is an array ref containing the contents of each buffer whose name |
| 88 | was the same as the key used for the access. If the buffer wasn't |
| 89 | involved in the match then an undef will be stored. When the all |
| 90 | parameter is omitted or not a true value then the return will be |
| 91 | a the content of the left most defined buffer with the given name. |
| 92 | If there is no buffer with the desired name defined then C<undef> |
| 93 | is returned. |
| 94 | |
| 95 | |
| 96 | For instance: |
| 97 | |
| 98 | my $qr = qr/(?<foo>bar)/; |
| 99 | if ( 'bar' =~ /$qr/ ) { |
| 100 | tie my %hash,"re::Tie::Hash::NamedCapture",re => $qr, all => 1; |
| 101 | if ('bar'=~/bar/) { |
| 102 | # last successful match is now different |
| 103 | print $hash{foo}; # prints foo |
| 104 | } |
| 105 | } |
| 106 | |
| 107 | =head1 SEE ALSO |
| 108 | |
| 109 | L<re>, L<perlmodlib/Pragmatic Modules>. |
| 110 | |
| 111 | =cut |