File Coverage

blib/lib/Config/General/Extended.pm
Criterion Covered Total %
statement 52 143 36.3
branch 18 76 23.6
condition 1 6 16.6
subroutine 13 22 59.0
pod 13 14 92.8
total 97 261 37.1


line stmt bran cond sub pod time code
1             #
2             # Config::General::Extended - special Class based on Config::General
3             #
4             # Copyright (c) 2000-2022 Thomas Linden .
5             # All Rights Reserved. Std. disclaimer applies.
6             # Licensed under the Artistic License 2.0.
7             #
8              
9             # namespace
10             package Config::General::Extended;
11              
12             # yes we need the hash support of new() in 1.18 or higher!
13 1     1   6 use Config::General 1.18;
  1         19  
  1         35  
14              
15 1     1   5 use FileHandle;
  1         1  
  1         6  
16 1     1   321 use Carp;
  1         2  
  1         39  
17 1     1   4 use Exporter ();
  1         9  
  1         19  
18 1     1   5 use vars qw(@ISA @EXPORT);
  1         2  
  1         59  
19              
20             # inherit new() and so on from Config::General
21             @ISA = qw(Config::General Exporter);
22              
23 1     1   5 use strict;
  1         2  
  1         1466  
24              
25              
26             $Config::General::Extended::VERSION = "2.07";
27              
28              
29             sub new {
30 0     0 1 0 croak "Deprecated method Config::General::Extended::new() called.\n"
31             ."Use Config::General::new() instead and set the -ExtendedAccess flag.\n";
32             }
33              
34              
35             sub getbypath {
36 0     0 0 0 my ($this, $path) = @_;
37 0         0 my $xconfig = $this->{config};
38 0         0 $path =~ s#^/##;
39 0         0 $path =~ s#/$##;
40 0         0 my @pathlist = split /\//, $path;
41 0         0 my $index;
42 0         0 foreach my $element (@pathlist) {
43 0 0       0 if($element =~ /^([^\[]*)\[(\d+)\]$/) {
44 0         0 $element = $1;
45 0         0 $index = $2;
46             }
47             else {
48 0         0 $index = undef;
49             }
50              
51 0 0       0 if(ref($xconfig) eq "ARRAY") {
    0          
52 0         0 return {};
53             }
54             elsif (! exists $xconfig->{$element}) {
55 0         0 return {};
56             }
57              
58 0 0       0 if(ref($xconfig->{$element}) eq "ARRAY") {
59 0 0       0 if(! defined($index) ) {
60             #croak "$element is an array but you didn't specify an index to access it!\n";
61 0         0 $xconfig = $xconfig->{$element};
62             }
63             else {
64 0 0       0 if(exists $xconfig->{$element}->[$index]) {
65 0         0 $xconfig = $xconfig->{$element}->[$index];
66             }
67             else {
68 0         0 croak "$element doesn't have an element with index $index!\n";
69             }
70             }
71             }
72             else {
73 0         0 $xconfig = $xconfig->{$element};
74             }
75             }
76              
77 0         0 return $xconfig;
78             }
79              
80             sub obj {
81             #
82             # returns a config object from a given key
83             # or from the current config hash if the $key does not exist
84             # or an empty object if the content of $key is empty.
85             #
86 4     4 1 565 my($this, $key) = @_;
87              
88             # just create the empty object, just in case
89 4         8 my $empty = $this->SUPER::new( -ExtendedAccess => 1, -ConfigHash => {}, %{$this->{Params}} );
  4         17  
90              
91 4 50       8 if (exists $this->{config}->{$key}) {
92 4 50       14 if (!$this->{config}->{$key}) {
    50          
    50          
93             # be cool, create an empty object!
94 0         0 return $empty
95             }
96             elsif (ref($this->{config}->{$key}) eq "ARRAY") {
97 0         0 my @objlist;
98 0         0 foreach my $element (@{$this->{config}->{$key}}) {
  0         0  
99 0 0       0 if (ref($element) eq "HASH") {
100             push @objlist,
101             $this->SUPER::new( -ExtendedAccess => 1,
102             -ConfigHash => $element,
103 0         0 %{$this->{Params}} );
  0         0  
104             }
105             else {
106 0 0       0 if ($this->{StrictObjects}) {
107 0         0 croak "element in list \"$key\" does not point to a hash reference!\n";
108             }
109             # else: skip this element
110             }
111             }
112 0         0 return \@objlist;
113             }
114             elsif (ref($this->{config}->{$key}) eq "HASH") {
115             return $this->SUPER::new( -ExtendedAccess => 1,
116 4         8 -ConfigHash => $this->{config}->{$key}, %{$this->{Params}} );
  4         12  
117             }
118             else {
119             # nothing supported
120 0 0       0 if ($this->{StrictObjects}) {
121 0         0 croak "key \"$key\" does not point to a hash reference!\n";
122             }
123             else {
124             # be cool, create an empty object!
125 0         0 return $empty;
126             }
127             }
128             }
129             else {
130             # even return an empty object if $key does not exist
131 0         0 return $empty;
132             }
133             }
134              
135              
136             sub value {
137             #
138             # returns a value of the config hash from a given key
139             # this can be a hashref or a scalar
140             #
141 3     3 1 9 my($this, $key, $value) = @_;
142 3 50       6 if (defined $value) {
143 0         0 $this->{config}->{$key} = $value;
144             }
145             else {
146 3 50       5 if (exists $this->{config}->{$key}) {
147 3         6 return $this->{config}->{$key};
148             }
149             else {
150 0 0       0 if ($this->{StrictObjects}) {
151 0         0 croak "Key \"$key\" does not exist within current object\n";
152             }
153             else {
154 0         0 return "";
155             }
156             }
157             }
158             }
159              
160              
161             sub hash {
162             #
163             # returns a value of the config hash from a given key
164             # as hash
165             #
166 0     0 1 0 my($this, $key) = @_;
167 0 0       0 if (exists $this->{config}->{$key}) {
168 0         0 return %{$this->{config}->{$key}};
  0         0  
169             }
170             else {
171 0 0       0 if ($this->{StrictObjects}) {
172 0         0 croak "Key \"$key\" does not exist within current object\n";
173             }
174             else {
175 0         0 return ();
176             }
177             }
178             }
179              
180              
181             sub array {
182             #
183             # returns a value of the config hash from a given key
184             # as array
185             #
186 0     0 1 0 my($this, $key) = @_;
187 0 0       0 if (exists $this->{config}->{$key}) {
188 0         0 return @{$this->{config}->{$key}};
  0         0  
189             }
190 0 0       0 if ($this->{StrictObjects}) {
191 0         0 croak "Key \"$key\" does not exist within current object\n";
192             }
193             else {
194 0         0 return ();
195             }
196             }
197              
198              
199              
200             sub is_hash {
201             #
202             # return true if the given key contains a hashref
203             #
204 3     3 1 237 my($this, $key) = @_;
205 3 50       6 if (exists $this->{config}->{$key}) {
206 3 100       7 if (ref($this->{config}->{$key}) eq "HASH") {
207 1         2 return 1;
208             }
209             else {
210 2         5 return;
211             }
212             }
213             else {
214 0         0 return;
215             }
216             }
217              
218              
219              
220             sub is_array {
221             #
222             # return true if the given key contains an arrayref
223             #
224 2     2 1 3 my($this, $key) = @_;
225 2 50       4 if (exists $this->{config}->{$key}) {
226 2 50       3 if (ref($this->{config}->{$key}) eq "ARRAY") {
227 0         0 return 1;
228             }
229             else {
230 2         3 return;
231             }
232             }
233             else {
234 0         0 return;
235             }
236             }
237              
238              
239             sub is_scalar {
240             #
241             # returns true if the given key contains a scalar(or number)
242             #
243 0     0 1 0 my($this, $key) = @_;
244 0 0 0     0 if (exists $this->{config}->{$key} && !ref($this->{config}->{$key})) {
245 0         0 return 1;
246             }
247 0         0 return;
248             }
249              
250              
251              
252             sub exists {
253             #
254             # returns true if the key exists
255             #
256 0     0 1 0 my($this, $key) = @_;
257 0 0       0 if (exists $this->{config}->{$key}) {
258 0         0 return 1;
259             }
260             else {
261 0         0 return;
262             }
263             }
264              
265              
266             sub keys {
267             #
268             # returns all keys under in the hash of the specified key, if
269             # it contains keys (so it must be a hash!)
270             #
271 3     3 1 246 my($this, $key) = @_;
272 3 50 33     14 if (!$key) {
    50          
273 0 0       0 if (ref($this->{config}) eq "HASH") {
274 0         0 return map { $_ } keys %{$this->{config}};
  0         0  
  0         0  
275             }
276             else {
277 0         0 return ();
278             }
279             }
280             elsif (exists $this->{config}->{$key} && ref($this->{config}->{$key}) eq "HASH") {
281 3         5 return map { $_ } keys %{$this->{config}->{$key}};
  5         13  
  3         8  
282             }
283             else {
284 0         0 return ();
285             }
286             }
287              
288              
289             sub delete {
290             #
291             # delete the given key from the config, if any
292             # and return what is deleted (just as 'delete $hash{key}' does)
293             #
294 0     0 1 0 my($this, $key) = @_;
295 0 0       0 if (exists $this->{config}->{$key}) {
296 0         0 return delete $this->{config}->{$key};
297             }
298             else {
299 0         0 return undef;
300             }
301             }
302              
303              
304              
305              
306             sub configfile {
307             #
308             # sets or returns the config filename
309             #
310 0     0 1 0 my($this,$file) = @_;
311 0 0       0 if ($file) {
312 0         0 $this->{configfile} = $file;
313             }
314 0         0 return $this->{configfile};
315             }
316              
317             sub find {
318 0     0 1 0 my $this = shift;
319 0         0 my $key = shift;
320 0 0       0 return undef unless $this->exists($key);
321 0 0       0 if (@_) {
322 0         0 return $this->obj($key)->find(@_);
323             }
324             else {
325 0         0 return $this->obj($key);
326             }
327             }
328              
329             sub AUTOLOAD {
330             #
331             # returns the representing value, if it is a scalar.
332             #
333 4     4   27 my($this, $value) = @_;
334 4         6 my $key = $Config::General::Extended::AUTOLOAD; # get to know how we were called
335 4         11 $key =~ s/.*:://; # remove package name!
336              
337 4 100       10 if (defined $value) {
    50          
338             # just set $key to $value!
339 2         3 $this->{config}->{$key} = $value;
340             }
341             elsif (exists $this->{config}->{$key}) {
342 2 50       4 if ($this->is_hash($key)) {
    50          
343 0         0 croak "Key \"$key\" points to a hash and cannot be automatically accessed\n";
344             }
345             elsif ($this->is_array($key)) {
346 0         0 croak "Key \"$key\" points to an array and cannot be automatically accessed\n";
347             }
348             else {
349 2         5 return $this->{config}->{$key};
350             }
351             }
352             else {
353 0 0       0 if ($this->{StrictObjects}) {
354 0         0 croak "Key \"$key\" does not exist within current object\n";
355             }
356             else {
357             # be cool
358 0         0 return undef; # bugfix rt.cpan.org#42331
359             }
360             }
361             }
362              
363             sub DESTROY {
364 11     11   674 my $this = shift;
365 11         202 $this = ();
366             }
367              
368             # keep this one
369             1;
370              
371              
372              
373              
374              
375             =head1 NAME
376              
377             Config::General::Extended - Extended access to Config files
378              
379              
380             =head1 SYNOPSIS
381              
382             use Config::General;
383              
384             $conf = Config::General->new(
385             -ConfigFile => 'configfile',
386             -ExtendedAccess => 1
387             );
388              
389             =head1 DESCRIPTION
390              
391             This is an internal module which makes it possible to use object
392             oriented methods to access parts of your config file.
393              
394             Normally you don't call it directly.
395              
396             =head1 METHODS
397              
398             =over
399              
400             =item configfile('filename')
401              
402             Set the filename to be used by B to "filename". It returns the current
403             configured filename if called without arguments.
404              
405              
406             =item obj('key')
407              
408             Returns a new object (of Config::General::Extended Class) from the given key.
409             Short example:
410             Assume you have the following config:
411              
412            
413            
414             age 23
415            
416            
417             age 56
418            
419            
420            
421             blah blubber
422             blah gobble
423             leer
424            
425              
426             and already read it in using B, then you can get a
427             new object from the "individual" block this way:
428              
429             $individual = $conf->obj("individual");
430              
431             Now if you call B on I<$individual> (just for reference) you would get:
432              
433             $VAR1 = (
434             martin => { age => 13 }
435             );
436              
437             Or, here is another use:
438              
439             my $individual = $conf->obj("individual");
440             foreach my $person ($conf->keys("individual")) {
441             $man = $individual->obj($person);
442             print "$person is " . $man->value("age") . " years old\n";
443             }
444              
445             See the discussion on B and B below.
446              
447             If the key from which you want to create a new object is empty, an empty
448             object will be returned. If you run the following on the above config:
449              
450             $obj = $conf->obj("other")->obj("leer");
451              
452             Then $obj will be empty, just like if you have had run this:
453              
454             $obj = Config::General::Extended->new( () );
455              
456             Read operations on this empty object will return nothing or even fail.
457             But you can use an empty object for I a new config using write
458             operations, i.e.:
459              
460             $obj->someoption("value");
461              
462             See the discussion on B below.
463              
464             If the key points to a list of hashes, a list of objects will be
465             returned. Given the following example config:
466              
467            
468             name = max
469            
470            
471             name = bea
472            
473              
474             you could write code like this to access the list the OOP way:
475              
476             my $objlist = $conf->obj("option");
477             foreach my $option (@{$objlist}) {
478             print $option->name;
479             }
480              
481             Please note that the list will be returned as a reference to an array.
482              
483             Empty elements or non-hash elements of the list, if any, will be skipped.
484              
485             =item hash('key')
486              
487             This method returns a hash(if it B one!) from the config which is referenced by
488             "key". Given the sample config above you would get:
489              
490             my %sub_hash = $conf->hash("individual");
491             print Dumper(\%sub_hash);
492             $VAR1 = {
493             martin => { age => 13 }
494             };
495              
496             =item array('key')
497              
498             This the equivalent of B mentioned above, except that it returns an array.
499             Again, we use the sample config mentioned above:
500              
501             $other = $conf->obj("other");
502             my @blahs = $other->array("blah");
503             print Dumper(\@blahs);
504             $VAR1 = [ "blubber", "gobble" ];
505              
506              
507             =item value('key')
508              
509             This method returns the scalar value of a given key. Given the following sample
510             config:
511              
512             name = arthur
513             age = 23
514              
515             you could do something like that:
516              
517             print $conf->value("name") . " is " . $conf->value("age") . " years old\n";
518              
519              
520              
521             You can use this method also to set the value of "key" to something if you give over
522             a hash reference, array reference or a scalar in addition to the key. An example:
523              
524             $conf->value("key", \%somehash);
525             # or
526             $conf->value("key", \@somearray);
527             # or
528             $conf->value("key", $somescalar);
529              
530             Please note, that this method does not complain about existing values within "key"!
531              
532             =item is_hash('key') is_array('key') is_scalar('key')
533              
534             As seen above, you can access parts of your current config using hash, array or scalar
535             methods. But you are right if you guess, that this might become problematic, if
536             for example you call B on a key which is in real not a hash but a scalar. Under
537             normal circumstances perl would refuse this and die.
538              
539             To avoid such behavior you can use one of the methods is_hash() is_array() is_scalar() to
540             check if the value of "key" is really what you expect it to be.
541              
542             An example(based on the config example from above):
543              
544             if($conf->is_hash("individual") {
545             $individual = $conf->obj("individual");
546             }
547             else {
548             die "You need to configure a "individual" block!\n";
549             }
550              
551              
552             =item exists('key')
553              
554             This method returns just true if the given key exists in the config.
555              
556              
557             =item keys('key')
558              
559             Returns an array of the keys under the specified "key". If you use the example
560             config above you could do that:
561              
562             print Dumper($conf->keys("individual");
563             $VAR1 = [ "martin", "joseph" ];
564              
565             If no key name was supplied, then the keys of the object itself will be returned.
566              
567             You can use this method in B loops as seen in an example above(obj() ).
568              
569              
570             =item delete('key')
571              
572             This method removes the given key and all associated data from the internal
573             hash structure. If 'key' contained data, then this data will be returned,
574             otherwise undef will be returned.
575              
576             =item find(@list)
577              
578             Given a list of nodes, ->find will search for a tree that branches in
579             just this way, returning the Config::General::Extended object it finds
580             at the bottom if it exists. You can also search partway down the tree
581             and ->find should return where you left off.
582              
583             For example, given the values B and the following
584             tree ( tags omitted for brevity):
585              
586            
587            
588             ...
589            
590            
591             ...
592            
593             BAR = shoo
594              
595             B will find the object at I with the value BAR = shoo and
596             return it.
597              
598              
599              
600             =back
601              
602              
603             =head1 AUTOLOAD METHODS
604              
605             Another useful feature is implemented in this class using the B feature
606             of perl. If you know the keynames of a block within your config, you can access to
607             the values of each individual key using the method notation. See the following example
608             and you will get it:
609              
610             We assume the following config:
611              
612            
613             name = Moser
614             prename = Peter
615             birth = 12.10.1972
616            
617              
618             Now we read it in and process it:
619              
620             my $conf = Config::General::Extended->new("configfile");
621             my $person = $conf->obj("person");
622             print $person->prename . " " . $person->name . " is " . $person->age . " years old\n";
623              
624             This notation supports only scalar values! You need to make sure, that the block
625             does not contain any subblock or multiple identical options(which will become
626             an array after parsing)!
627              
628             If you access a non-existent key this way, Config::General will croak an error.
629             You can turn this behavior off by setting B<-StrictObjects> to 0 or "no". In
630             this case undef will be returned.
631              
632             Of course you can use this kind of methods for writing data too:
633              
634             $person->name("Neustein");
635              
636             This changes the value of the "name" key to "Neustein". This feature behaves exactly like
637             B, which means you can assign hash or array references as well and that existing
638             values under the given key will be overwritten.
639              
640              
641             =head1 COPYRIGHT
642              
643             Copyright (c) 2000-2022 Thomas Linden
644              
645             This library is free software; you can redistribute it and/or
646             modify it under the terms of the Artistic License 2.0.
647              
648              
649             =head1 BUGS
650              
651             none known yet.
652              
653              
654             =head1 AUTHOR
655              
656             Thomas Linden
657              
658             =head1 VERSION
659              
660             2.07
661              
662             =cut
663