File Coverage

blib/lib/Var/Pairs.pm
Criterion Covered Total %
statement 95 141 67.3
branch 27 50 54.0
condition 8 17 47.0
subroutine 19 22 86.3
pod 8 8 100.0
total 157 238 65.9


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