local-lib5/lib/perl5/Config/General/Extended.pm

   1 #
   2 # Config::General::Extended - special Class based on Config::General
   3 #
   4 # Copyright (c) 2000-2008 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 use Config::General 1.18;
  14
  15 use FileHandle;
  16 use Carp;
  17 use Exporter ();
  18 use vars qw(@ISA @EXPORT);
  19
  20 # inherit new() and so on from Config::General
  21 @ISA = qw(Config::General Exporter);
  22
  23 use strict;
  24
  25
  26 $Config::General::Extended::VERSION = "2.03";
  27
  28
  29 sub new {
  30   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   my($this, $key) = @_;
  42
  43   # just create the empty object, just in case
  44   my $empty = $this->SUPER::new( -ExtendedAccess => 1, -ConfigHash => {}, %{$this->{Params}} );
  45
  46   if (exists $this->{config}->{$key}) {
  47     if (!$this->{config}->{$key}) {
  48       # be cool, create an empty object!
  49       return $empty
  50     }
  51     elsif (ref($this->{config}->{$key}) eq "ARRAY") {
  52       my @objlist;
  53       foreach my $element (@{$this->{config}->{$key}}) {
  54         if (ref($element) eq "HASH") {
  55           push @objlist,
  56             $this->SUPER::new( -ExtendedAccess => 1,
  57                                -ConfigHash     => $element,
  58                                %{$this->{Params}} );
  59         }
  60         else {
  61           if ($this->{StrictObjects}) {
  62             croak "element in list \"$key\" does not point to a hash reference!\n";
  63           }
  64           # else: skip this element
  65         }
  66       }
  67       return \@objlist;
  68     }
  69     elsif (ref($this->{config}->{$key}) eq "HASH") {
  70       return $this->SUPER::new( -ExtendedAccess => 1,
  71                                 -ConfigHash => $this->{config}->{$key}, %{$this->{Params}} );
  72     }
  73     else {
  74       # nothing supported
  75       if ($this->{StrictObjects}) {
  76         croak "key \"$key\" does not point to a hash reference!\n";
  77       }
  78       else {
  79         # be cool, create an empty object!
  80         return $empty;
  81       }
  82     }
  83   }
  84   else {
  85     # even return an empty object if $key does not exist
  86     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   my($this, $key, $value) = @_;
  97   if (defined $value) {
  98     $this->{config}->{$key} = $value;
  99   }
 100   else {
 101     if (exists $this->{config}->{$key}) {
 102       return $this->{config}->{$key};
 103     }
 104     else {
 105       if ($this->{StrictObjects}) {
 106         croak "Key \"$key\" does not exist within current object\n";
 107       }
 108       else {
 109         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   my($this, $key) = @_;
 122   if (exists $this->{config}->{$key}) {
 123     return %{$this->{config}->{$key}};
 124   }
 125   else {
 126     if ($this->{StrictObjects}) {
 127       croak "Key \"$key\" does not exist within current object\n";
 128     }
 129     else {
 130       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   my($this, $key) = @_;
 142   if (exists $this->{config}->{$key}) {
 143     return @{$this->{config}->{$key}};
 144   }
 145   if ($this->{StrictObjects}) {
 146       croak "Key \"$key\" does not exist within current object\n";
 147     }
 148   else {
 149     return ();
 150   }
 151 }
 152
 153
 154
 155 sub is_hash {
 156   #
 157   # return true if the given key contains a hashref
 158   #
 159   my($this, $key) = @_;
 160   if (exists $this->{config}->{$key}) {
 161     if (ref($this->{config}->{$key}) eq "HASH") {
 162       return 1;
 163     }
 164     else {
 165       return;
 166     }
 167   }
 168   else {
 169     return;
 170   }
 171 }
 172
 173
 174
 175 sub is_array {
 176   #
 177   # return true if the given key contains an arrayref
 178   #
 179   my($this, $key) = @_;
 180   if (exists $this->{config}->{$key}) {
 181     if (ref($this->{config}->{$key}) eq "ARRAY") {
 182       return 1;
 183     }
 184     else {
 185       return;
 186     }
 187   }
 188   else {
 189     return;
 190   }
 191 }
 192
 193
 194 sub is_scalar {
 195   #
 196   # returns true if the given key contains a scalar(or number)
 197   #
 198   my($this, $key) = @_;
 199   if (exists $this->{config}->{$key} && !ref($this->{config}->{$key})) {
 200     return 1;
 201   }
 202   return;
 203 }
 204
 205
 206
 207 sub exists {
 208   #
 209   # returns true if the key exists
 210   #
 211   my($this, $key) = @_;
 212   if (exists $this->{config}->{$key}) {
 213     return 1;
 214   }
 215   else {
 216     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   my($this, $key) = @_;
 227   if (!$key) {
 228     if (ref($this->{config}) eq "HASH") {
 229       return map { $_ } keys %{$this->{config}};
 230     }
 231     else {
 232       return ();
 233     }
 234   }
 235   elsif (exists $this->{config}->{$key} && ref($this->{config}->{$key}) eq "HASH") {
 236     return map { $_ } keys %{$this->{config}->{$key}};
 237   }
 238   else {
 239     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   my($this, $key) = @_;
 250   if (exists $this->{config}->{$key}) {
 251     return delete $this->{config}->{$key};
 252   }
 253   else {
 254     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   my($this,$file) = @_;
 281   if ($file) {
 282     $this->{configfile} = $file;
 283   }
 284   return $this->{configfile};
 285 }
 286
 287
 288
 289 sub AUTOLOAD {
 290   #
 291   # returns the representing value, if it is a scalar.
 292   #
 293   my($this, $value) = @_;
 294   my $key = $Config::General::Extended::AUTOLOAD;  # get to know how we were called
 295   $key =~ s/.*:://; # remove package name!
 296
 297   if (defined $value) {
 298     # just set $key to $value!
 299     $this->{config}->{$key} = $value;
 300   }
 301   elsif (exists $this->{config}->{$key}) {
 302     if ($this->is_hash($key)) {
 303       croak "Key \"$key\" points to a hash and cannot be automatically accessed\n";
 304     }
 305     elsif ($this->is_array($key)) {
 306       croak "Key \"$key\" points to an array and cannot be automatically accessed\n";
 307     }
 308     else {
 309       return $this->{config}->{$key};
 310     }
 311   }
 312   else {
 313     if ($this->{StrictObjects}) {
 314       croak "Key \"$key\" does not exist within current object\n";
 315     }
 316     else {
 317       # be cool
 318       return undef; # bugfix rt.cpan.org#42331
 319     }
 320   }
 321 }
 322
 323 sub DESTROY {
 324   my $this = shift;
 325   $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-2008 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.03
 597
 598 =cut
 599