File Coverage

blib/lib/CTK/ConfGenUtil.pm
Criterion Covered Total %
statement 47 77 61.0
branch 23 54 42.5
condition 20 56 35.7
subroutine 8 13 61.5
pod 9 9 100.0
total 107 209 51.2


line stmt bran cond sub pod time code
1             package CTK::ConfGenUtil;
2 4     4   116559 use strict;
  4         22  
  4         110  
3 4     4   1024 use utf8;
  4         26  
  4         20  
4              
5             =encoding utf-8
6              
7             =head1 NAME
8              
9             CTK::ConfGenUtil - Config::General structure utility functions
10              
11             =head1 VERSION
12              
13             Version 2.69
14              
15             =head1 SYNOPSIS
16              
17             use CTK::ConfGenUtil;
18              
19             #
20             #
21             # Baz qux
22             #
23             #
24             my $foo = node( $config, 'foo' ); # { bar => { baz => 'qux' } }
25             my $bar = node( $config, 'foo', 'bar' ); # { baz => 'qux' }
26             my $bar = node( $config, ['foo', 'bar'] ); # { baz => 'qux' }
27             my $bar = node( $config, 'foo/bar' ); # { baz => 'qux' }
28             my $baz = value( $config, 'foo/bar/baz' ); # qux
29              
30             # Foo bar
31             my $foo = value( $config, 'foo' ); # bar
32              
33             # Foo 123
34             # Foo 456
35             # Foo 789
36             my $foo = array( $config, 'foo' ); # [123,456,789]
37              
38             #
39             # Bar baz
40             #
41             my $foo = hash( $config, 'foo' ); # { bar => 'baz' }
42              
43             #
44             #
45             # Baz blah-blah-blah
46             # Qux 123
47             # Qux 456
48             # Qux 789
49             #
50             #
51             is_scalar( $foo );
52             print "Is scalar : ", is_scalar($config, 'foo/bar/baz') ? 'OK' : 'NO'; # OK
53              
54             is_array( $foo );
55             print "Is array : ", is_array($config, 'foo/bar/qux') ? 'OK' : 'NO'; # OK
56              
57             is_hash( $foo );
58             print "Is hash : ", is_hash($config, 'foo/bar') ? 'OK' : 'NO'; # OK
59              
60             =head1 DESCRIPTION
61              
62             This module based on L
63              
64             =head2 FUNCTIONS
65              
66             Working sample:
67              
68            
69            
70             Baz blah-blah-blah
71             Qux 123
72             Qux 456
73             Qux 789
74            
75            
76              
77             =over 8
78              
79             =item B
80              
81             This method returns the found node of a given key.
82              
83             my $bar = node( $config, 'foo', 'bar' );
84             my $bar = node( $config, ['foo', 'bar'] );
85             my $bar = node( $config, 'foo/bar' );
86             my $bar = node( $config, ['foo/bar'] );
87              
88             my $bar_hash = hash($bar);
89             my $baz = value($bar, 'baz'); # blah-blah-blah
90              
91             =item B
92              
93             This method returns the scalar value (first) of a given key.
94              
95             my $baz = value( $config, 'foo/bar/baz' );
96              
97             =item B
98              
99             This method returns the scalar value (last) of a given key.
100              
101             my $baz = lvalue( $config, 'foo/bar/baz' );
102              
103             =item B
104              
105             This method returns a array reference (if it B one!) from the config which is referenced by
106             "key". Given the sample config above you would get:
107              
108             my $qux = array( $config, 'foo/bar/qux' );
109              
110             =item B
111              
112             This method returns a hash reference (if it B one!) from the config which is referenced by
113             "key". Given the sample config above you would get:
114              
115             my $bar = hash( $config, 'foo/bar' );
116              
117             =item B, B
118              
119             As seen above, you can access parts of your current config using hash, array or scalar
120             functions. This function returns just true if the given key is scalar (regular value)
121              
122             is_scalar( $baz );
123             is_scalar( $config, 'foo/bar/baz' );
124              
125             =item B
126              
127             As seen above, you can access parts of your current config using hash, array or scalar
128             functions. This function returns just true if the given key is array (reference)
129              
130             is_array( $qux );
131             is_array( $config, 'foo/bar/qux' );
132              
133             =item B
134              
135             As seen above, you can access parts of your current config using hash, array or scalar
136             functions. This function returns just true if the given key is hash (reference)
137              
138             is_hash( $bar );
139             is_hash( $config, 'foo/bar' );
140              
141             =back
142              
143             =head1 HISTORY
144              
145             See C file
146              
147             =head1 TO DO
148              
149             See C file
150              
151             =head1 BUGS
152              
153             * none noted
154              
155             =head1 SEE ALSO
156              
157             L
158              
159             =head1 AUTHOR
160              
161             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
162              
163             =head1 COPYRIGHT
164              
165             Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
166              
167             =head1 LICENSE
168              
169             This program is free software; you can redistribute it and/or
170             modify it under the same terms as Perl itself.
171              
172             See C file and L
173              
174             =cut
175              
176 4     4   263 use vars qw/$VERSION/;
  4         7  
  4         203  
177             $VERSION = '2.69';
178              
179 4     4   20 use base qw/Exporter/;
  4         7  
  4         3566  
180              
181             # Default export (all):
182             our @EXPORT = qw/ node value lvalue array hash is_value is_scalar is_array is_hash /;
183             # Required only:
184             our @EXPORT_OK = qw/ node value lvalue array hash is_value is_scalar is_array is_hash /;
185              
186             sub node {
187             #
188             # getnode( $config, [qw/foo bar baz/] )
189             # getnode( $config, qw/foo bar baz/ )
190             # getnode( $config, 'foo' )
191             # getnode( $config, 'foo', 'bar/baz' )
192             #
193 1   50 1 1 12 my $cc = shift || {};
194 1   50     5 my $ar = shift || [];
195 1         2 my %rcc = ();
196 1 50       9 %rcc = %$cc if ref($cc) eq 'HASH';
197 1         3 my @arcc = ();
198 1 50       12 @arcc = @$cc if ref($cc) eq 'ARRAY';
199 1         2 my @rar = ();
200 1 50       4 if (ref($ar) eq 'ARRAY') {
201 0         0 push @rar, split(/\//, $_) for (grep {$_} (@$ar));
  0         0  
202             } else {
203 1         2 push @rar, split(/\//, $_) for (grep {$_} ($ar,@_));
  1         7  
204             }
205              
206 1         2 my $tnode = \%rcc;
207 1         2 my $laststat = 0;
208              
209 1         2 foreach my $k (@rar) {
210             #debug $k;
211 3 50 33     22 if ($tnode && (ref($tnode) eq 'HASH') && defined($tnode->{$k})) {
      33        
212 3         12 $tnode = $tnode->{$k};
213 3         11 $laststat = 1;
214             } else {
215             #debug Dumper($tnode);
216 0         0 $laststat = 0;
217 0         0 next;
218             }
219             }
220 1 0 33     4 if (!$laststat && @arcc && defined($arcc[0])) {
      33        
221 0   0     0 my $kk = pop(@rar) || '';
222 0 0       0 if ($kk) {
223 0         0 foreach my $an (@arcc) {
224 0 0 0     0 if ($an && (ref($an) eq 'HASH') && defined($an->{$kk})) {
      0        
225 0         0 $tnode = $an->{$kk};
226 0         0 $laststat = 1;
227 0         0 last;
228             }
229             }
230             }
231             }
232              
233 1 50       6 return $laststat ? $tnode : undef;
234             }
235             sub value {
236 8     8 1 157 my $node = shift;
237 8 100       21 $node = node($node, @_) if defined($_[0]);
238 8 100 100     47 if ($node && ref($node) eq 'ARRAY') {
    100 100        
239 3 100       17 return exists($node->[0]) ? $node->[0] : undef;
240             } elsif (defined($node) && !ref($node)) {
241 3         15 return $node
242             } else {
243             return undef
244 2         10 }
245             }
246             sub lvalue {
247 7     7 1 13 my $node = shift;
248 7 50       17 $node = node($node, @_) if defined($_[0]);
249 7 100 100     49 if ($node && ref($node) eq 'ARRAY') {
    100 66        
250 1 50       6 return exists($node->[0]) ? $node->[-1] : undef;
251             } elsif (defined($node) && !ref($node)) {
252 2         11 return $node
253             } else {
254             return undef
255 4         33 }
256             }
257             sub array {
258 3     3 1 7 my $node = shift;
259 3 50       8 $node = node($node, @_) if defined $_[0];
260 3 50 33     15 if ($node && ref($node) eq 'ARRAY') {
    100 66        
261 0         0 return $node;
262             } elsif (defined($node) && !ref($node)) {
263 2         8 return [$node];
264             } else {
265 1         4 return [];
266             }
267             }
268             sub hash {
269 0   0 0 1   my $node = shift || {};
270 0 0         $node = node($node, @_) if defined $_[0];
271 0 0 0       if ($node && ref($node) eq 'HASH') {
272 0           return $node;
273             } else {
274 0           return {};
275             }
276             }
277             sub is_hash {
278 0     0 1   my $node = shift;
279 0 0         $node = node($node, @_) if defined($_[0]);
280 0 0 0       return 1 if $node && ref($node) eq 'HASH';
281 0           return;
282             }
283             sub is_array {
284 0     0 1   my $node = shift;
285 0 0         $node = node($node,@_) if defined($_[0]);
286 0 0 0       return 1 if $node && ref($node) eq 'ARRAY';
287 0           return;
288             }
289             sub is_value {
290 0     0 1   my $node = shift;
291 0 0         $node = node($node, @_) if defined($_[0]);
292 0 0 0       return 1 if defined($node) && !ref($node);
293 0           return;
294             }
295 0     0 1   sub is_scalar { goto &is_value }
296              
297             1;
298              
299             __END__