Commit | Line | Data |
44a2ac75 |
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 |