File Coverage

lib/Config/Neat/Util.pm
Criterion Covered Total %
statement 96 115 83.4
branch 37 58 63.7
condition 17 32 53.1
subroutine 21 25 84.0
pod 0 23 0.0
total 171 253 67.5


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Config::Neat::Util - Common utility functions for other Config::Neat modules
4              
5             =head1 COPYRIGHT
6              
7             Copyright (C) 2012-2015 Igor Afanasyev
8              
9             =head1 SEE ALSO
10              
11             L
12              
13             =cut
14              
15             package Config::Neat::Util;
16              
17             our $VERSION = '1.302';
18              
19 4     4   38687 use strict;
  4         10  
  4         106  
20              
21 4     4   1765 use Tie::IxHash;
  4         13940  
  4         4225  
22              
23             our @ISA = qw(Exporter);
24              
25             our @EXPORT_OK = qw(
26             new_ixhash
27             to_ixhash
28             to_ixhash_recursive
29             is_number
30             is_code
31             is_hash
32             is_ixhash
33             is_any_hash
34             is_array
35             is_neat_array
36             is_any_array
37             is_scalar
38             is_simple_array
39             is_homogenous_simple_array
40             hash_has_only_sequential_keys
41             hash_has_sequential_keys
42             get_next_auto_key
43             offset_keys
44             get_keys_in_order
45             reorder_ixhash_numerically
46             reorder_ixhash
47             rename_ixhash_key
48             read_file
49             );
50              
51             sub new_ixhash {
52 634     634 0 1129 my $new = {};
53 634         2191 tie(%$new, 'Tie::IxHash');
54 634         9586 return $new;
55             }
56              
57             sub to_ixhash {
58 0     0 0 0 my $node = shift;
59 0 0 0     0 die "Not a regular hash" unless is_hash($node) && !is_ixhash($node);
60 0         0 my $new = new_ixhash;
61 0         0 map { $new->{$_} = $node->{$_} } keys %$node;
  0         0  
62 0         0 return $new;
63             }
64              
65             sub to_ixhash_recursive {
66 0     0 0 0 my ($node) = @_;
67 0 0 0     0 my $result = is_hash($node) && !is_ixhash($node) ? to_ixhash($node) : $node;
68 0 0       0 if (is_ixhash($result)) {
69             map {
70 0         0 $result->{$_} = to_ixhash_recursive($result->{$_});
  0         0  
71             } keys %$result;
72             }
73 0         0 return $result;
74             }
75              
76             sub is_number {
77 520     520 0 832 my $n = shift;
78 520   66     2785 return defined $n && $n =~ m/^\d+$/;
79             }
80              
81             sub is_code {
82 0     0 0 0 my $node = shift;
83 0         0 return ref($node) eq 'CODE';
84             }
85              
86             sub is_hash {
87 5119     5119 0 8289 my $node = shift;
88 5119         20412 return ref($node) eq 'HASH';
89             }
90              
91             sub is_ixhash {
92 285     285 0 446 my $node = shift;
93 285 50       533 return undef unless is_hash($node);
94 285         854 return ref(tied(%$node)) eq 'Tie::IxHash';
95             }
96              
97             sub is_any_hash {
98 4     4 0 882 my $node = shift;
99 4   33     9 return is_hash($node) || is_ixhash($node);
100             }
101              
102             sub is_array {
103 1406     1406 0 2036 my $node = shift;
104 1406         4432 return ref($node) eq 'ARRAY';
105             }
106              
107             sub is_neat_array {
108 2164     2164 0 18446 my $node = shift;
109 2164         8459 return ref($node) eq 'Config::Neat::Array';
110             }
111              
112             sub is_any_array {
113 643     643 0 6830 my $node = shift;
114 643   66     1114 return is_array($node) || is_neat_array($node);
115             }
116              
117             sub is_scalar {
118 1145     1145 0 3049 my $node = shift;
119 1145 0       3025 return (ref(\$node) eq 'SCALAR') or (ref($node) eq 'SCALAR');
120             }
121              
122             sub is_simple_array {
123 32     32 0 1069 my $node = shift;
124              
125 32 50       131 return 1 if is_scalar($node);
126 32 100 66     80 return undef unless is_array($node) || is_neat_array($node);
127              
128 31         78 foreach my $value (@$node) {
129 50 100       98 return undef unless is_scalar($value);
130             }
131 21         91 return 1;
132             }
133              
134             sub is_homogenous_simple_array {
135 357     357 0 546 my $node = shift;
136              
137 357 50       641 return 1 if is_scalar($node);
138 357 100 100     739 return undef unless is_array($node) || is_neat_array($node);
139              
140 256         439 my $contains_hash = undef;
141 256         363 my $contains_array = undef;
142 256         342 my $contains_scalar = undef;
143              
144 256         440 foreach my $value (@$node) {
145 511 100       840 if (is_hash($value)) {
    100          
146 17         31 $contains_hash |= 1;
147             } elsif (is_any_array($value)) {
148 28         49 $contains_array |= 1;
149             } else {
150 466         819 $contains_scalar |= is_scalar($value);
151             }
152 511 50 66     1365 die "Mixing hashes with simple arrays/scalars within one node is not supported" if $contains_hash && $contains_scalar;
153             }
154 256   66     1332 return $contains_scalar && !$contains_array;
155             }
156              
157             sub hash_has_only_sequential_keys {
158 140     140 0 213 my $node = shift;
159 140         312 return hash_has_sequential_keys($node, 1);
160             }
161              
162             sub hash_has_sequential_keys {
163 295     295 0 533 my ($node, $strict) = @_;
164 295 50       502 die "Not a hash" unless is_hash($node);
165              
166 295         491 my $i = 0;
167             map {
168 295 100       829 if (is_number($_)) {
  398         4230  
169 73 100       219 return undef if $_ != $i;
170 65         132 $i++;
171             } else {
172 325 100       1094 return undef if $strict;
173             }
174             } keys %$node;
175 156         415 return 1;
176             }
177              
178             # supposed to be used against hash that matches the
179             # `hash_has_sequential_keys() == true` criterion
180             sub get_next_auto_key {
181 27     27 0 53 my $node = shift;
182 27 50       108 die "Not a hash" unless is_hash($node);
183              
184             # get max(key)
185 27         54 my $i = -1; # so that next key will start with 0
186             map {
187 27 100 66     98 $i = $_ if is_number($_) && $_ > $i;
  35         394  
188             } keys %$node;
189              
190             # return max + 1
191 27         159 return $i + 1;
192             }
193              
194             sub offset_keys {
195 11     11 0 36 my ($node, $offset) = @_;
196 11 50       68 die "Not a Tie::IxHash" unless is_ixhash($node);
197 11 100       55 return $node if $offset == 0;
198              
199 2         6 my $result = new_ixhash;
200              
201             # remap keys
202             map {
203 2 100       6 if (is_number($_)) {
  5         94  
204 3         10 $result->{$_ + $offset} = $node->{$_};
205             } else {
206 2         6 $result->{$_} = $node->{$_};
207             }
208             } keys %$node;
209              
210 2         46 return $result;
211             }
212              
213             # accepts an array of hasrefs
214             sub get_keys_in_order {
215 128     128 0 257 my $result = new_ixhash;
216              
217             map {
218 128         266 map {
219 256         2367 $result->{$_} = 1;
  203         2994  
220             } keys %$_;
221             } @_;
222              
223 128         2174 return keys %$result;
224             }
225              
226             sub reorder_ixhash_numerically {
227 0     0 0 0 my ($node) = @_;
228 0 0       0 die "Not a Tie::IxHash" unless is_ixhash($node);
229              
230             # sort keys numerically
231 0         0 my @a = sort {$a <=> $b} keys %$node;
  0         0  
232              
233 0         0 return reorder_ixhash($node, \@a);
234             }
235              
236             sub reorder_ixhash {
237 128     128 0 258 my ($node, $keysref) = @_;
238 128 50       251 die "Not a Tie::IxHash" unless is_ixhash($node);
239              
240 128         272 my $result = new_ixhash;
241 128 100       255 map { $result->{$_} = $node->{$_} if exists $node->{$_} } @$keysref;
  184         2001  
242              
243 128         3102 return $result;
244             }
245              
246             sub rename_ixhash_key {
247 18     18 0 51 my ($node, $from, $to) = @_;
248 18 50       43 die "Not a Tie::IxHash" unless is_ixhash($node);
249 18 50       55 die "Can\'t rename key '$from' to '$to', because the target key already exists" if exists $node->{$to};
250              
251 18         113 my $result = new_ixhash;
252             map {
253 18 100       52 my $key = $_ eq $from ? $to : $_;
  25         478  
254 25         80 $result->{$key} = $node->{$_};
255             } keys %$node;
256              
257 18         434 return $result;
258             }
259              
260             sub read_file {
261 97     97 0 226 my ($filename, $binmode) = @_;
262              
263 97 50       3597 open(CFG, $filename) or die "Can't open [$filename]: $!";
264 97   50     737 binmode(CFG, $binmode || ':utf8');
265 97         1531 my $text = join('', );
266 97         753 close(CFG);
267              
268 97         477 return $text;
269             } # end sub
270              
271              
272             1;