File Coverage

blib/lib/Var/Pairs.pm
Criterion Covered Total %
statement 105 170 61.7
branch 41 88 46.5
condition 10 31 32.2
subroutine 23 31 74.1
pod 9 9 100.0
total 188 329 57.1


line stmt bran cond sub pod time code
1             package Var::Pairs;
2 21     21   1637931 use 5.014;
  21         275  
3              
4             our $VERSION = '0.004001';
5              
6 21     21   164 use warnings;
  21         45  
  21         1175  
7 21     21   10076 no if $] >= 5.018, warnings => "experimental::smartmatch";
  21         219  
  21         136  
8 21     21   1531 use Carp;
  21         44  
  21         1483  
9 21     21   9468 use Devel::Callsite;
  21         15488  
  21         1257  
10 21     21   10563 use Scope::Upper qw< reap UP >;
  21         21732  
  21         1502  
11 21     21   9111 use PadWalker qw< var_name >;
  21         11860  
  21         3517  
12              
13             # Check for autoboxing, and set up pairs() method if applicable..
14             my $autoboxing;
15             BEGIN {
16 21 50   21   80 if (eval{ require autobox }) {
  21         6271  
17 0         0 $autoboxing = 1;
18 0         0 push @Var::Pairs::ISA, 'autobox';
19              
20 0         0 *Var::Pairs::autobox::pairs = \&Var::Pairs::pairs;
21 0         0 *Var::Pairs::autobox::kvs = \&Var::Pairs::kvs;
22 0         0 *Var::Pairs::autobox::each_pair = \&Var::Pairs::each_pair;
23 0         0 *Var::Pairs::autobox::each_kv = \&Var::Pairs::each_kv;
24 0         0 *Var::Pairs::autobox::each_value = \&Var::Pairs::each_value;
25 0         0 *Var::Pairs::autobox::invert = \&Var::Pairs::invert;
26 0         0 *Var::Pairs::autobox::invert_pairs = \&Var::Pairs::invert_pairs;
27             }
28             }
29              
30             # API...
31             my %EXPORTABLE;
32             @EXPORTABLE{qw< pairs kvs each_pair each_kv each_value to_kv to_pair invert invert_pairs >} = ();
33              
34             sub import {
35 21     21   213 my ($class, @exports) = @_;
36              
37             # Check for export requests...
38 21 50       98 if (!@exports) {
39 21         103 @exports = keys %EXPORTABLE;
40             }
41             else {
42 0         0 my @bad = grep { !exists $EXPORTABLE{$_} } @exports;
  0         0  
43 0 0       0 carp 'Unknown subroutine' . (@bad==1 ? q{} : q{s}) . " requested: @bad"
    0          
44             if @bad;
45             }
46              
47             # Export API...
48 21     21   186 no strict 'refs';
  21         52  
  21         1291  
49 21         307 my $caller = caller;
50 21         62 for my $subname (@exports) {
51 21     21   150 no strict 'refs';
  21         60  
  21         43780  
52 189         265 *{$caller.'::'.$subname} = \&{$subname};
  189         1258  
  189         365  
53             }
54              
55             # Enable autoboxing of ->pairs() in caller's lexical scope, if possible...
56 21 50       30049 if ($autoboxing) {
57 0         0 $class->SUPER::import(
58             HASH => 'Var::Pairs::autobox',
59             ARRAY => 'Var::Pairs::autobox',
60             );
61             }
62             }
63              
64             # Track iterators for each call...
65             state %iterator_for;
66              
67             # Convert one or more vars into a ('varname', $varname,...) list...
68              
69             sub to_kv (\[$@%];\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]) {
70              
71             # Take each var ref and convert to 'name' => 'ref_or_val' pairs...
72 5     5 1 92 return map { my $name = var_name(1, $_); $name =~ s/^.//;
  7         20  
  7         20  
73 7 100       52 $name => (ref($_) =~ /SCALAR|REF/ ? $$_ : $_)
74             } @_;
75             }
76              
77             # Convert one or more vars into 'varname' => $varname pairs...
78              
79             sub to_pair (\[$@%];\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]) {
80              
81 9     9 1 149 return map { my $name = var_name(1, $_); $name =~ s/^.//;
  11         83  
  11         67  
82 11 100       105 Var::Pairs::Pair->new($name => (ref($_) =~ /SCALAR|REF/ ? $$_ : $_), 'none')
83             } @_;
84             }
85              
86              
87             # Generate pairs for iterating hashes and arrays...
88             sub pairs (+) {
89 46 100   46 1 20379 if (!defined wantarray) {
    100          
90 1         110 croak("Useless use of pairs() in void context");
91             }
92             elsif (!wantarray) {
93 1         127 croak("Invalid call to pairs() in scalar context.\nDid you mean each_pair()?\nError")
94             }
95              
96 44         68 my $container_ref = shift;
97 44   100     131 my $container_type = ref $container_ref || 'scalar value';
98              
99             # Verify the single argument...
100 44 100       167 if ($container_type !~ m{^ARRAY$|^HASH$}) {
101 2         325 croak "Argument to pairs() must be array or hash (not \L$container_type\E)";
102             }
103              
104             # Uniquely identify this call, according to its lexical context...
105 42         186 my $ID = callsite() . context() . $container_ref;
106              
107             # Short-circuit if this is a repeated call...
108 42 0 33     102 if (!wantarray && $iterator_for{$ID}) {
109 0         0 return _get_each_pair($ID);
110             }
111              
112             # Generate the list of pairs, according to the container type...
113 42         74 my $container_is_array = $container_type eq 'ARRAY';
114 227 100       528 my @pairs = map { Var::Pairs::Pair->new($_, $container_ref, $container_is_array ? 'array' : 'hash') }
115 42 100       87 $container_is_array ? 0..$#{$container_ref} : keys %{$container_ref};
  29         78  
  13         48  
116              
117             # Return them all in list context...
118 42         155 return @pairs;
119              
120             # In scalar context, return the first pair, remembering the rest...
121 0         0 $iterator_for{$ID} = \@pairs;
122 0         0 return shift @pairs;
123             }
124              
125             sub each_pair (+) {
126 134     134 1 998 my ($container_ref) = @_;
127              
128             # Uniquely identify this call, according to its lexical context...
129 134 50 33     760 my $ID = callsite() . context() . (ref($_[0]) && var_name(1,$_[0]) ? $container_ref : q{});
130              
131             # Install a destructor for it at the send of the caller's block...
132 21 100   21   1388 reap { delete $iterator_for{$ID} if exists $iterator_for{$ID} } UP UP
133 134 100       383 if !$iterator_for{$ID};
134              
135             # Build an iterator...
136             $iterator_for{$ID} //= ref($container_ref) eq 'CODE'
137             ? sub {
138 0     0   0 state $n=0;
139 0 0       0 my ($next) = $container_ref->() or return;
140 0         0 return ($n++, $next);
141             }
142 134 50 66     258 : [ &pairs ];
143              
144             # Iterate...
145 134         190 return _get_each_pair($ID);
146             }
147              
148             # Generate key, value,... lists for iterating hashes and arrays...
149             sub kvs (+) {
150 16 50   16 1 131 if (!defined wantarray) {
    50          
151 0         0 croak("Useless use of kvs() in void context");
152             }
153             elsif (!wantarray) {
154 0         0 croak("Invalid call to kvs() in scalar context.\nDid you mean each_kv()?\nError")
155             }
156              
157 16         29 my $container_ref = shift;
158 16   50     48 my $container_type = ref $container_ref || 'scalar value';
159              
160             # Verify the single argument...
161 16 50       72 if ($container_type !~ m{^ARRAY$|^HASH$}) {
162 0         0 croak "Argument to pairs() must be array or hash (not \L$container_type\E)";
163             }
164              
165             # Uniquely identify this call, according to its lexical context...
166 16         74 my $ID = callsite() . context() . $container_ref;
167              
168             # Return the key/value list, according to the container type...
169 16 100       44 if ($container_type eq 'ARRAY') {
170 14         26 return map { ($_, $container_ref->[$_]) } 0..$#{$container_ref};
  84         229  
  14         36  
171             }
172             else {
173 2         3 return %{$container_ref};
  2         12  
174             }
175             }
176              
177             sub each_kv (+) {
178 91     91 1 22425 my ($container_ref) = @_;
179              
180             # Uniquely identify this call, according to its lexical context and iteration target...
181 91 50 33     761 my $ID = callsite() . context() . (ref($_[0]) && var_name(1,$_[0]) ? $container_ref : q{});
182              
183             # Install a destructor for it at the send of the caller's block...
184 15 100   15   1911 reap { delete $iterator_for{$ID} if exists $iterator_for{$ID} } UP UP
185 91 100       354 if !$iterator_for{$ID};
186              
187             $iterator_for{$ID} //= ref($container_ref) eq 'CODE'
188             ? sub {
189 0     0   0 state $n=0;
190 0 0       0 my ($next) = $container_ref->() or return;
191 0         0 return ($n++, $next);
192             }
193 91 50 66     251 : [ &kvs ];
194              
195             # Iterate...
196 91         178 return _get_each_kv($ID);
197             }
198              
199             # Iterate just the values of a container...
200             sub each_value (+) {
201 0     0 1 0 my ($container_ref) = @_;
202              
203             # Uniquely identify this call, according to its lexical context and iteration target...
204 0 0 0     0 my $ID = callsite() . context() . (ref($_[0]) && var_name(1,$_[0]) ? $container_ref : q{});
205              
206             # Install a destructor for it at the send of the caller's block...
207 0 0   0   0 reap { delete $iterator_for{$ID} if exists $iterator_for{$ID} } UP UP
208 0 0       0 if !$iterator_for{$ID};
209              
210             $iterator_for{$ID} //= ref($container_ref) eq 'CODE'
211             ? sub {
212 0     0   0 state $n=0;
213 0 0       0 my ($next) = $container_ref->() or return;
214 0         0 return ($n++, $next);
215             }
216 0 0 0     0 : [ &kvs ];
217              
218             # Iterate...
219 0 0       0 my @next = _get_each_kv($ID) or return;
220 0         0 return $next[1];
221             }
222              
223             # Invert the key=>values of a hash or array...
224              
225             sub invert (+) {
226 0     0 1 0 goto &_invert;
227             }
228              
229             sub invert_pairs (+) {
230 0     0 1 0 push @_, 1;
231 0         0 goto &_invert;
232             }
233              
234              
235             # Utilities...
236              
237             # Perform var inversions...
238              
239             sub _invert {
240 0     0   0 my ($var_ref, $return_as_pairs) = @_;
241 0         0 my %inversion;
242              
243 0 0       0 if (!defined wantarray) {
    0          
244 0         0 croak 'Useless use of invert() in void context';
245             }
246             elsif (!wantarray) {
247 0         0 croak 'Invalid call to invert() in scalar context';
248             }
249              
250 0   0     0 given (ref($var_ref) || 'SCALAR') {
251 0         0 when ('HASH') {
252 0         0 for my $key (keys %{$var_ref}) {
  0         0  
253 0         0 my $values = $var_ref->{$key};
254 0 0       0 for my $value ( ref $values eq 'ARRAY' ? @$values : $values ) {
255 0   0     0 $inversion{$value} //= [];
256 0         0 push @{$inversion{$value}}, $key;
  0         0  
257             }
258             }
259             }
260 0         0 when ('ARRAY') {
261 0         0 for my $key (0..$#{$var_ref}) {
  0         0  
262 0         0 my $values = $var_ref->[$key];
263 0 0       0 for my $value ( ref $values eq 'ARRAY' ? @$values : $values ) {
264 0   0     0 $inversion{$value} //= [];
265 0         0 push @{$inversion{$value}}, $key;
  0         0  
266             }
267             }
268             }
269 0         0 default {
270 0         0 croak "Argument to invert() must be hash or array (not \L$_\E)";
271             }
272             }
273              
274 0 0       0 return $return_as_pairs ? pairs %inversion : %inversion;
275             }
276              
277             # Iterate, cleaning up if appropriate...
278             sub _get_each_pair {
279 134     134   156 my $ID = shift;
280              
281             # Iterate the requested iterator...
282 134         163 my $iterator = $iterator_for{$ID};
283 134         131 my $each_pair;
284 134 50       205 if (ref($iterator) eq 'CODE') {
285 0         0 my @kv = $iterator->();
286 0 0       0 $each_pair = Var::Pairs::Pair->new(@kv, 'none') if @kv;
287             }
288             else {
289 134         131 $each_pair = shift @{$iterator};
  134         173  
290             }
291              
292             # If nothing was left to iterate, clean up the empty iterator...
293 134 100       211 if (!defined $each_pair) {
294 18         40 delete $iterator_for{$ID};
295             }
296              
297 134         258 return $each_pair;
298             }
299              
300             sub _get_each_kv {
301 91     91   148 my $ID = shift;
302              
303             # Iterate the requested iterator...
304 91         146 my $iterator = $iterator_for{$ID};
305             my @each_kv = ref($iterator) eq 'CODE'
306             ? $iterator->()
307 91 50       191 : splice @{$iterator}, 0, 2;
  91         220  
308              
309             # If nothing was left to iterate, clean up the empty iterator...
310 91 100       206 if (!@each_kv) {
311 11         30 delete $iterator_for{$ID};
312             }
313              
314             # Return key or key/value, as appropriate (a la each())...
315 91 50       343 return wantarray ? @each_kv : $each_kv[0];
316             }
317              
318 21     21   184 use if $] < 5.022, 'Var::Pairs::Pair_DataAlias';
  21         67  
  21         203  
319 21     21   1221 use if $] >= 5.022, 'Var::Pairs::Pair_BuiltIn';
  21         53  
  21         96  
320              
321             1; # Magic true value required at end of module
322             __END__