File Coverage

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