mirror of
https://codeberg.org/scip/pcp.git
synced 2025-12-16 19:40:57 +01:00
not required anymore
This commit is contained in:
Thomas von Dein
File diff suppressed because it is too large
Load Diff
@@ -1,663 +0,0 @@
|
||||
#
|
||||
# Config::General::Extended - special Class based on Config::General
|
||||
#
|
||||
# Copyright (c) 2000-2014 Thomas Linden <tlinden |AT| cpan.org>.
|
||||
# All Rights Reserved. Std. disclaimer applies.
|
||||
# Artistic License, same as perl itself. Have fun.
|
||||
#
|
||||
|
||||
# namespace
|
||||
package Config::General::Extended;
|
||||
|
||||
# yes we need the hash support of new() in 1.18 or higher!
|
||||
use Config::General 1.18;
|
||||
|
||||
use FileHandle;
|
||||
use Carp;
|
||||
use Exporter ();
|
||||
use vars qw(@ISA @EXPORT);
|
||||
|
||||
# inherit new() and so on from Config::General
|
||||
@ISA = qw(Config::General Exporter);
|
||||
|
||||
use strict;
|
||||
|
||||
|
||||
$Config::General::Extended::VERSION = "2.07";
|
||||
|
||||
|
||||
sub new {
|
||||
croak "Deprecated method Config::General::Extended::new() called.\n"
|
||||
."Use Config::General::new() instead and set the -ExtendedAccess flag.\n";
|
||||
}
|
||||
|
||||
|
||||
sub getbypath {
|
||||
my ($this, $path) = @_;
|
||||
my $xconfig = $this->{config};
|
||||
$path =~ s#^/##;
|
||||
$path =~ s#/$##;
|
||||
my @pathlist = split /\//, $path;
|
||||
my $index;
|
||||
foreach my $element (@pathlist) {
|
||||
if($element =~ /^([^\[]*)\[(\d+)\]$/) {
|
||||
$element = $1;
|
||||
$index = $2;
|
||||
}
|
||||
else {
|
||||
$index = undef;
|
||||
}
|
||||
|
||||
if(ref($xconfig) eq "ARRAY") {
|
||||
return {};
|
||||
}
|
||||
elsif (! exists $xconfig->{$element}) {
|
||||
return {};
|
||||
}
|
||||
|
||||
if(ref($xconfig->{$element}) eq "ARRAY") {
|
||||
if(! defined($index) ) {
|
||||
#croak "$element is an array but you didn't specify an index to access it!\n";
|
||||
$xconfig = $xconfig->{$element};
|
||||
}
|
||||
else {
|
||||
if(exists $xconfig->{$element}->[$index]) {
|
||||
$xconfig = $xconfig->{$element}->[$index];
|
||||
}
|
||||
else {
|
||||
croak "$element doesn't have an element with index $index!\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$xconfig = $xconfig->{$element};
|
||||
}
|
||||
}
|
||||
|
||||
return $xconfig;
|
||||
}
|
||||
|
||||
sub obj {
|
||||
#
|
||||
# returns a config object from a given key
|
||||
# or from the current config hash if the $key does not exist
|
||||
# or an empty object if the content of $key is empty.
|
||||
#
|
||||
my($this, $key) = @_;
|
||||
|
||||
# just create the empty object, just in case
|
||||
my $empty = $this->SUPER::new( -ExtendedAccess => 1, -ConfigHash => {}, %{$this->{Params}} );
|
||||
|
||||
if (exists $this->{config}->{$key}) {
|
||||
if (!$this->{config}->{$key}) {
|
||||
# be cool, create an empty object!
|
||||
return $empty
|
||||
}
|
||||
elsif (ref($this->{config}->{$key}) eq "ARRAY") {
|
||||
my @objlist;
|
||||
foreach my $element (@{$this->{config}->{$key}}) {
|
||||
if (ref($element) eq "HASH") {
|
||||
push @objlist,
|
||||
$this->SUPER::new( -ExtendedAccess => 1,
|
||||
-ConfigHash => $element,
|
||||
%{$this->{Params}} );
|
||||
}
|
||||
else {
|
||||
if ($this->{StrictObjects}) {
|
||||
croak "element in list \"$key\" does not point to a hash reference!\n";
|
||||
}
|
||||
# else: skip this element
|
||||
}
|
||||
}
|
||||
return \@objlist;
|
||||
}
|
||||
elsif (ref($this->{config}->{$key}) eq "HASH") {
|
||||
return $this->SUPER::new( -ExtendedAccess => 1,
|
||||
-ConfigHash => $this->{config}->{$key}, %{$this->{Params}} );
|
||||
}
|
||||
else {
|
||||
# nothing supported
|
||||
if ($this->{StrictObjects}) {
|
||||
croak "key \"$key\" does not point to a hash reference!\n";
|
||||
}
|
||||
else {
|
||||
# be cool, create an empty object!
|
||||
return $empty;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
# even return an empty object if $key does not exist
|
||||
return $empty;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub value {
|
||||
#
|
||||
# returns a value of the config hash from a given key
|
||||
# this can be a hashref or a scalar
|
||||
#
|
||||
my($this, $key, $value) = @_;
|
||||
if (defined $value) {
|
||||
$this->{config}->{$key} = $value;
|
||||
}
|
||||
else {
|
||||
if (exists $this->{config}->{$key}) {
|
||||
return $this->{config}->{$key};
|
||||
}
|
||||
else {
|
||||
if ($this->{StrictObjects}) {
|
||||
croak "Key \"$key\" does not exist within current object\n";
|
||||
}
|
||||
else {
|
||||
return "";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub hash {
|
||||
#
|
||||
# returns a value of the config hash from a given key
|
||||
# as hash
|
||||
#
|
||||
my($this, $key) = @_;
|
||||
if (exists $this->{config}->{$key}) {
|
||||
return %{$this->{config}->{$key}};
|
||||
}
|
||||
else {
|
||||
if ($this->{StrictObjects}) {
|
||||
croak "Key \"$key\" does not exist within current object\n";
|
||||
}
|
||||
else {
|
||||
return ();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub array {
|
||||
#
|
||||
# returns a value of the config hash from a given key
|
||||
# as array
|
||||
#
|
||||
my($this, $key) = @_;
|
||||
if (exists $this->{config}->{$key}) {
|
||||
return @{$this->{config}->{$key}};
|
||||
}
|
||||
if ($this->{StrictObjects}) {
|
||||
croak "Key \"$key\" does not exist within current object\n";
|
||||
}
|
||||
else {
|
||||
return ();
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub is_hash {
|
||||
#
|
||||
# return true if the given key contains a hashref
|
||||
#
|
||||
my($this, $key) = @_;
|
||||
if (exists $this->{config}->{$key}) {
|
||||
if (ref($this->{config}->{$key}) eq "HASH") {
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub is_array {
|
||||
#
|
||||
# return true if the given key contains an arrayref
|
||||
#
|
||||
my($this, $key) = @_;
|
||||
if (exists $this->{config}->{$key}) {
|
||||
if (ref($this->{config}->{$key}) eq "ARRAY") {
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub is_scalar {
|
||||
#
|
||||
# returns true if the given key contains a scalar(or number)
|
||||
#
|
||||
my($this, $key) = @_;
|
||||
if (exists $this->{config}->{$key} && !ref($this->{config}->{$key})) {
|
||||
return 1;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub exists {
|
||||
#
|
||||
# returns true if the key exists
|
||||
#
|
||||
my($this, $key) = @_;
|
||||
if (exists $this->{config}->{$key}) {
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub keys {
|
||||
#
|
||||
# returns all keys under in the hash of the specified key, if
|
||||
# it contains keys (so it must be a hash!)
|
||||
#
|
||||
my($this, $key) = @_;
|
||||
if (!$key) {
|
||||
if (ref($this->{config}) eq "HASH") {
|
||||
return map { $_ } keys %{$this->{config}};
|
||||
}
|
||||
else {
|
||||
return ();
|
||||
}
|
||||
}
|
||||
elsif (exists $this->{config}->{$key} && ref($this->{config}->{$key}) eq "HASH") {
|
||||
return map { $_ } keys %{$this->{config}->{$key}};
|
||||
}
|
||||
else {
|
||||
return ();
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub delete {
|
||||
#
|
||||
# delete the given key from the config, if any
|
||||
# and return what is deleted (just as 'delete $hash{key}' does)
|
||||
#
|
||||
my($this, $key) = @_;
|
||||
if (exists $this->{config}->{$key}) {
|
||||
return delete $this->{config}->{$key};
|
||||
}
|
||||
else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
sub configfile {
|
||||
#
|
||||
# sets or returns the config filename
|
||||
#
|
||||
my($this,$file) = @_;
|
||||
if ($file) {
|
||||
$this->{configfile} = $file;
|
||||
}
|
||||
return $this->{configfile};
|
||||
}
|
||||
|
||||
sub find {
|
||||
my $this = shift;
|
||||
my $key = shift;
|
||||
return undef unless $this->exists($key);
|
||||
if (@_) {
|
||||
return $this->obj($key)->find(@_);
|
||||
}
|
||||
else {
|
||||
return $this->obj($key);
|
||||
}
|
||||
}
|
||||
|
||||
sub AUTOLOAD {
|
||||
#
|
||||
# returns the representing value, if it is a scalar.
|
||||
#
|
||||
my($this, $value) = @_;
|
||||
my $key = $Config::General::Extended::AUTOLOAD; # get to know how we were called
|
||||
$key =~ s/.*:://; # remove package name!
|
||||
|
||||
if (defined $value) {
|
||||
# just set $key to $value!
|
||||
$this->{config}->{$key} = $value;
|
||||
}
|
||||
elsif (exists $this->{config}->{$key}) {
|
||||
if ($this->is_hash($key)) {
|
||||
croak "Key \"$key\" points to a hash and cannot be automatically accessed\n";
|
||||
}
|
||||
elsif ($this->is_array($key)) {
|
||||
croak "Key \"$key\" points to an array and cannot be automatically accessed\n";
|
||||
}
|
||||
else {
|
||||
return $this->{config}->{$key};
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ($this->{StrictObjects}) {
|
||||
croak "Key \"$key\" does not exist within current object\n";
|
||||
}
|
||||
else {
|
||||
# be cool
|
||||
return undef; # bugfix rt.cpan.org#42331
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $this = shift;
|
||||
$this = ();
|
||||
}
|
||||
|
||||
# keep this one
|
||||
1;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Config::General::Extended - Extended access to Config files
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Config::General;
|
||||
|
||||
$conf = Config::General->new(
|
||||
-ConfigFile => 'configfile',
|
||||
-ExtendedAccess => 1
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is an internal module which makes it possible to use object
|
||||
oriented methods to access parts of your config file.
|
||||
|
||||
Normally you don't call it directly.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item configfile('filename')
|
||||
|
||||
Set the filename to be used by B<save> to "filename". It returns the current
|
||||
configured filename if called without arguments.
|
||||
|
||||
|
||||
=item obj('key')
|
||||
|
||||
Returns a new object (of Config::General::Extended Class) from the given key.
|
||||
Short example:
|
||||
Assume you have the following config:
|
||||
|
||||
<individual>
|
||||
<martin>
|
||||
age 23
|
||||
</martin>
|
||||
<joseph>
|
||||
age 56
|
||||
</joseph>
|
||||
</individual>
|
||||
<other>
|
||||
blah blubber
|
||||
blah gobble
|
||||
leer
|
||||
</other>
|
||||
|
||||
and already read it in using B<Config::General::Extended::new()>, then you can get a
|
||||
new object from the "individual" block this way:
|
||||
|
||||
$individual = $conf->obj("individual");
|
||||
|
||||
Now if you call B<getall> on I<$individual> (just for reference) you would get:
|
||||
|
||||
$VAR1 = (
|
||||
martin => { age => 13 }
|
||||
);
|
||||
|
||||
Or, here is another use:
|
||||
|
||||
my $individual = $conf->obj("individual");
|
||||
foreach my $person ($conf->keys("individual")) {
|
||||
$man = $individual->obj($person);
|
||||
print "$person is " . $man->value("age") . " years old\n";
|
||||
}
|
||||
|
||||
See the discussion on B<hash()> and B<value()> below.
|
||||
|
||||
If the key from which you want to create a new object is empty, an empty
|
||||
object will be returned. If you run the following on the above config:
|
||||
|
||||
$obj = $conf->obj("other")->obj("leer");
|
||||
|
||||
Then $obj will be empty, just like if you have had run this:
|
||||
|
||||
$obj = Config::General::Extended->new( () );
|
||||
|
||||
Read operations on this empty object will return nothing or even fail.
|
||||
But you can use an empty object for I<creating> a new config using write
|
||||
operations, i.e.:
|
||||
|
||||
$obj->someoption("value");
|
||||
|
||||
See the discussion on B<AUTOLOAD METHODS> below.
|
||||
|
||||
If the key points to a list of hashes, a list of objects will be
|
||||
returned. Given the following example config:
|
||||
|
||||
<option>
|
||||
name = max
|
||||
</option>
|
||||
<option>
|
||||
name = bea
|
||||
</option>
|
||||
|
||||
you could write code like this to access the list the OOP way:
|
||||
|
||||
my $objlist = $conf->obj("option");
|
||||
foreach my $option (@{$objlist}) {
|
||||
print $option->name;
|
||||
}
|
||||
|
||||
Please note that the list will be returned as a reference to an array.
|
||||
|
||||
Empty elements or non-hash elements of the list, if any, will be skipped.
|
||||
|
||||
=item hash('key')
|
||||
|
||||
This method returns a hash(if it B<is> one!) from the config which is referenced by
|
||||
"key". Given the sample config above you would get:
|
||||
|
||||
my %sub_hash = $conf->hash("individual");
|
||||
print Dumper(\%sub_hash);
|
||||
$VAR1 = {
|
||||
martin => { age => 13 }
|
||||
};
|
||||
|
||||
=item array('key')
|
||||
|
||||
This the equivalent of B<hash()> mentioned above, except that it returns an array.
|
||||
Again, we use the sample config mentioned above:
|
||||
|
||||
$other = $conf->obj("other");
|
||||
my @blahs = $other->array("blah");
|
||||
print Dumper(\@blahs);
|
||||
$VAR1 = [ "blubber", "gobble" ];
|
||||
|
||||
|
||||
=item value('key')
|
||||
|
||||
This method returns the scalar value of a given key. Given the following sample
|
||||
config:
|
||||
|
||||
name = arthur
|
||||
age = 23
|
||||
|
||||
you could do something like that:
|
||||
|
||||
print $conf->value("name") . " is " . $conf->value("age") . " years old\n";
|
||||
|
||||
|
||||
|
||||
You can use this method also to set the value of "key" to something if you give over
|
||||
a hash reference, array reference or a scalar in addition to the key. An example:
|
||||
|
||||
$conf->value("key", \%somehash);
|
||||
# or
|
||||
$conf->value("key", \@somearray);
|
||||
# or
|
||||
$conf->value("key", $somescalar);
|
||||
|
||||
Please note, that this method does not complain about existing values within "key"!
|
||||
|
||||
=item is_hash('key') is_array('key') is_scalar('key')
|
||||
|
||||
As seen above, you can access parts of your current config using hash, array or scalar
|
||||
methods. But you are right if you guess, that this might become problematic, if
|
||||
for example you call B<hash()> on a key which is in real not a hash but a scalar. Under
|
||||
normal circumstances perl would refuse this and die.
|
||||
|
||||
To avoid such behavior you can use one of the methods is_hash() is_array() is_scalar() to
|
||||
check if the value of "key" is really what you expect it to be.
|
||||
|
||||
An example(based on the config example from above):
|
||||
|
||||
if($conf->is_hash("individual") {
|
||||
$individual = $conf->obj("individual");
|
||||
}
|
||||
else {
|
||||
die "You need to configure a "individual" block!\n";
|
||||
}
|
||||
|
||||
|
||||
=item exists('key')
|
||||
|
||||
This method returns just true if the given key exists in the config.
|
||||
|
||||
|
||||
=item keys('key')
|
||||
|
||||
Returns an array of the keys under the specified "key". If you use the example
|
||||
config above you could do that:
|
||||
|
||||
print Dumper($conf->keys("individual");
|
||||
$VAR1 = [ "martin", "joseph" ];
|
||||
|
||||
If no key name was supplied, then the keys of the object itself will be returned.
|
||||
|
||||
You can use this method in B<foreach> loops as seen in an example above(obj() ).
|
||||
|
||||
|
||||
=item delete('key')
|
||||
|
||||
This method removes the given key and all associated data from the internal
|
||||
hash structure. If 'key' contained data, then this data will be returned,
|
||||
otherwise undef will be returned.
|
||||
|
||||
=item find(@list)
|
||||
|
||||
Given a list of nodes, ->find will search for a tree that branches in
|
||||
just this way, returning the Config::General::Extended object it finds
|
||||
at the bottom if it exists. You can also search partway down the tree
|
||||
and ->find should return where you left off.
|
||||
|
||||
For example, given the values B<find (qw (A B C))> and the following
|
||||
tree (</end> tags omitted for brevity):
|
||||
|
||||
<A>
|
||||
<FOO>
|
||||
...
|
||||
<B>
|
||||
<BAZ>
|
||||
...
|
||||
<C>
|
||||
BAR = shoo
|
||||
|
||||
B<find()> will find the object at I<C> with the value BAR = shoo and
|
||||
return it.
|
||||
|
||||
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 AUTOLOAD METHODS
|
||||
|
||||
Another useful feature is implemented in this class using the B<AUTOLOAD> feature
|
||||
of perl. If you know the keynames of a block within your config, you can access to
|
||||
the values of each individual key using the method notation. See the following example
|
||||
and you will get it:
|
||||
|
||||
We assume the following config:
|
||||
|
||||
<person>
|
||||
name = Moser
|
||||
prename = Peter
|
||||
birth = 12.10.1972
|
||||
</person>
|
||||
|
||||
Now we read it in and process it:
|
||||
|
||||
my $conf = Config::General::Extended->new("configfile");
|
||||
my $person = $conf->obj("person");
|
||||
print $person->prename . " " . $person->name . " is " . $person->age . " years old\n";
|
||||
|
||||
This notation supports only scalar values! You need to make sure, that the block
|
||||
<person> does not contain any subblock or multiple identical options(which will become
|
||||
an array after parsing)!
|
||||
|
||||
If you access a non-existent key this way, Config::General will croak an error.
|
||||
You can turn this behavior off by setting B<-StrictObjects> to 0 or "no". In
|
||||
this case undef will be returned.
|
||||
|
||||
Of course you can use this kind of methods for writing data too:
|
||||
|
||||
$person->name("Neustein");
|
||||
|
||||
This changes the value of the "name" key to "Neustein". This feature behaves exactly like
|
||||
B<value()>, which means you can assign hash or array references as well and that existing
|
||||
values under the given key will be overwritten.
|
||||
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2000-2014 Thomas Linden
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
none known yet.
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Thomas Linden <tlinden |AT| cpan.org>
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
2.07
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,355 +0,0 @@
|
||||
#
|
||||
# Config::General::Interpolated - special Class based on Config::General
|
||||
#
|
||||
# Copyright (c) 2001 by Wei-Hon Chen <plasmaball@pchome.com.tw>.
|
||||
# Copyright (c) 2000-2014 by Thomas Linden <tlinden |AT| cpan.org>.
|
||||
# All Rights Reserved. Std. disclaimer applies.
|
||||
# Artistic License, same as perl itself. Have fun.
|
||||
#
|
||||
|
||||
package Config::General::Interpolated;
|
||||
$Config::General::Interpolated::VERSION = "2.15";
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use Config::General;
|
||||
use Exporter ();
|
||||
|
||||
|
||||
# Import stuff from Config::General
|
||||
use vars qw(@ISA @EXPORT);
|
||||
@ISA = qw(Config::General Exporter);
|
||||
|
||||
|
||||
sub new {
|
||||
#
|
||||
# overwrite new() with our own version
|
||||
# and call the parent class new()
|
||||
#
|
||||
|
||||
croak "Deprecated method Config::General::Interpolated::new() called.\n"
|
||||
."Use Config::General::new() instead and set the -InterPolateVars flag.\n";
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub _set_regex {
|
||||
#
|
||||
# set the regex for finding vars
|
||||
#
|
||||
|
||||
# the following regex is provided by Autrijus Tang
|
||||
# <autrijus@autrijus.org>, and I made some modifications.
|
||||
# thanx, autrijus. :)
|
||||
my $regex = qr{
|
||||
(^|\G|[^\\]) # $1: can be the beginning of the line
|
||||
# or the beginning of next match
|
||||
# but can't begin with a '\'
|
||||
\$ # dollar sign
|
||||
(\{)? # $2: optional opening curly
|
||||
([a-zA-Z0-9_\-\.:\+,]+) # $3: capturing variable name (fix of #33447)
|
||||
(?(2) # $4: if there's the opening curly...
|
||||
\} # ... match closing curly
|
||||
)
|
||||
}x;
|
||||
return $regex;
|
||||
}
|
||||
|
||||
|
||||
sub _interpolate {
|
||||
#
|
||||
# interpolate a scalar value and keep the result
|
||||
# on the varstack.
|
||||
#
|
||||
# called directly by Config::General::_parse_value()
|
||||
#
|
||||
my ($this, $config, $key, $value) = @_;
|
||||
my $quote_counter = 100;
|
||||
|
||||
# some dirty trick to circumvent single quoted vars to be interpolated
|
||||
# we remove all quotes and replace them with unique random literals,
|
||||
# which will be replaced after interpolation with the original quotes
|
||||
# fixes bug rt#35766
|
||||
my %quotes;
|
||||
|
||||
if(! $this->{AllowSingleQuoteInterpolation} ) {
|
||||
$value =~ s/(\'[^\']+?\')/
|
||||
my $key = "QUOTE" . ($quote_counter++) . "QUOTE";
|
||||
$quotes{ $key } = $1;
|
||||
$key;
|
||||
/gex;
|
||||
}
|
||||
|
||||
$value =~ s{$this->{regex}}{
|
||||
my $con = $1;
|
||||
my $var = $3;
|
||||
my $var_lc = $this->{LowerCaseNames} ? lc($var) : $var;
|
||||
|
||||
if (exists $config->{__stack}->{$var_lc}) {
|
||||
$con . $config->{__stack}->{$var_lc};
|
||||
}
|
||||
elsif ($this->{InterPolateEnv}) {
|
||||
# may lead to vulnerabilities, by default flag turned off
|
||||
if (defined($ENV{$var})) {
|
||||
$con . $ENV{$var};
|
||||
}
|
||||
else {
|
||||
$con;
|
||||
}
|
||||
}
|
||||
elsif ($this->{StrictVars}) {
|
||||
croak "Use of uninitialized variable (\$$var) while loading config entry: $key = $value\n";
|
||||
}
|
||||
else {
|
||||
# be cool
|
||||
$con;
|
||||
}
|
||||
}egx;
|
||||
|
||||
# re-insert unaltered quotes
|
||||
# fixes bug rt#35766
|
||||
foreach my $quote (keys %quotes) {
|
||||
$value =~ s/$quote/$quotes{$quote}/;
|
||||
}
|
||||
|
||||
return $value;
|
||||
};
|
||||
|
||||
|
||||
sub _interpolate_hash {
|
||||
#
|
||||
# interpolate a complete hash and keep the results
|
||||
# on the varstack.
|
||||
#
|
||||
# called directly by Config::General::new()
|
||||
#
|
||||
my ($this, $config) = @_;
|
||||
|
||||
# bugfix rt.cpan.org#46184, moved code from _interpolate() to here.
|
||||
if ($this->{InterPolateEnv}) {
|
||||
# may lead to vulnerabilities, by default flag turned off
|
||||
for my $key (keys %ENV){
|
||||
$config->{__stack}->{$key}=$ENV{$key};
|
||||
}
|
||||
}
|
||||
|
||||
$config = $this->_var_hash_stacker($config);
|
||||
|
||||
return $config;
|
||||
}
|
||||
|
||||
sub _var_hash_stacker {
|
||||
#
|
||||
# build a varstack of a given hash ref
|
||||
#
|
||||
my ($this, $config) = @_;
|
||||
|
||||
foreach my $key (keys %{$config}) {
|
||||
next if($key eq "__stack");
|
||||
if (ref($config->{$key}) eq "ARRAY" ) {
|
||||
$config->{$key} = $this->_var_array_stacker($config->{$key}, $key);
|
||||
}
|
||||
elsif (ref($config->{$key}) eq "HASH") {
|
||||
my $tmphash = $config->{$key};
|
||||
$tmphash->{__stack} = $config->{__stack};
|
||||
$config->{$key} = $this->_var_hash_stacker($tmphash);
|
||||
}
|
||||
else {
|
||||
# SCALAR
|
||||
$config->{__stack}->{$key} = $config->{$key};
|
||||
}
|
||||
}
|
||||
|
||||
return $config;
|
||||
}
|
||||
|
||||
|
||||
sub _var_array_stacker {
|
||||
#
|
||||
# same as _var_hash_stacker but for arrayrefs
|
||||
#
|
||||
my ($this, $config, $key) = @_;
|
||||
|
||||
my @new;
|
||||
|
||||
foreach my $entry (@{$config}) {
|
||||
if (ref($entry) eq "HASH") {
|
||||
$entry = $this->_var_hash_stacker($entry);
|
||||
}
|
||||
elsif (ref($entry) eq "ARRAY") {
|
||||
# ignore this. Arrays of Arrays cannot be created/supported
|
||||
# with Config::General, because they are not accessible by
|
||||
# any key (anonymous array-ref)
|
||||
next;
|
||||
}
|
||||
else {
|
||||
#### $config->{__stack}->{$key} = $config->{$key};
|
||||
# removed. a array of scalars (eg: option = [1,2,3]) cannot
|
||||
# be used for interpolation (which one shall we use?!), so
|
||||
# we ignore those types of lists.
|
||||
# found by fbicknel, fixes rt.cpan.org#41570
|
||||
}
|
||||
push @new, $entry;
|
||||
}
|
||||
|
||||
return \@new;
|
||||
}
|
||||
|
||||
sub _clean_stack {
|
||||
#
|
||||
# recursively empty the variable stack
|
||||
#
|
||||
my ($this, $config) = @_;
|
||||
#return $config; # DEBUG
|
||||
foreach my $key (keys %{$config}) {
|
||||
if ($key eq "__stack") {
|
||||
delete $config->{__stack};
|
||||
next;
|
||||
}
|
||||
if (ref($config->{$key}) eq "ARRAY" ) {
|
||||
$config->{$key} = $this->_clean_array_stack($config->{$key});
|
||||
}
|
||||
elsif (ref($config->{$key}) eq "HASH") {
|
||||
$config->{$key} = $this->_clean_stack($config->{$key});
|
||||
}
|
||||
}
|
||||
return $config;
|
||||
}
|
||||
|
||||
|
||||
sub _clean_array_stack {
|
||||
#
|
||||
# same as _var_hash_stacker but for arrayrefs
|
||||
#
|
||||
my ($this, $config) = @_;
|
||||
|
||||
my @new;
|
||||
|
||||
foreach my $entry (@{$config}) {
|
||||
if (ref($entry) eq "HASH") {
|
||||
$entry = $this->_clean_stack($entry);
|
||||
}
|
||||
elsif (ref($entry) eq "ARRAY") {
|
||||
# ignore this. Arrays of Arrays cannot be created/supported
|
||||
# with Config::General, because they are not accessible by
|
||||
# any key (anonymous array-ref)
|
||||
next;
|
||||
}
|
||||
push @new, $entry;
|
||||
}
|
||||
|
||||
return \@new;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Config::General::Interpolated - Parse variables within Config files
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Config::General;
|
||||
$conf = Config::General->new(
|
||||
-ConfigFile => 'configfile',
|
||||
-InterPolateVars => 1
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is an internal module which makes it possible to interpolate
|
||||
Perl style variables in your config file (i.e. C<$variable>
|
||||
or C<${variable}>).
|
||||
|
||||
Normally you don't call it directly.
|
||||
|
||||
|
||||
=head1 VARIABLES
|
||||
|
||||
Variables can be defined everywhere in the config and can be used
|
||||
afterwards as the value of an option. Variables cannot be used as
|
||||
keys or as part of keys.
|
||||
|
||||
If you define a variable inside
|
||||
a block or a named block then it is only visible within this block or
|
||||
within blocks which are defined inside this block. Well - let's take a
|
||||
look to an example:
|
||||
|
||||
# sample config which uses variables
|
||||
basedir = /opt/ora
|
||||
user = t_space
|
||||
sys = unix
|
||||
<table intern>
|
||||
instance = INTERN
|
||||
owner = $user # "t_space"
|
||||
logdir = $basedir/log # "/opt/ora/log"
|
||||
sys = macos
|
||||
<procs>
|
||||
misc1 = ${sys}_${instance} # macos_INTERN
|
||||
misc2 = $user # "t_space"
|
||||
</procs>
|
||||
</table>
|
||||
|
||||
This will result in the following structure:
|
||||
|
||||
{
|
||||
'basedir' => '/opt/ora',
|
||||
'user' => 't_space'
|
||||
'sys' => 'unix',
|
||||
'table' => {
|
||||
'intern' => {
|
||||
'sys' => 'macos',
|
||||
'logdir' => '/opt/ora/log',
|
||||
'instance' => 'INTERN',
|
||||
'owner' => 't_space',
|
||||
'procs' => {
|
||||
'misc1' => 'macos_INTERN',
|
||||
'misc2' => 't_space'
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
As you can see, the variable B<sys> has been defined twice. Inside
|
||||
the <procs> block a variable ${sys} has been used, which then were
|
||||
interpolated into the value of B<sys> defined inside the <table>
|
||||
block, not the sys variable one level above. If sys were not defined
|
||||
inside the <table> block then the "global" variable B<sys> would have
|
||||
been used instead with the value of "unix".
|
||||
|
||||
Variables inside double quotes will be interpolated, but variables
|
||||
inside single quotes will B<not> interpolated. This is the same
|
||||
behavior as you know of Perl itself.
|
||||
|
||||
In addition you can surround variable names with curly braces to
|
||||
avoid misinterpretation by the parser.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Config::General>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Thomas Linden <tlinden |AT| cpan.org>
|
||||
Autrijus Tang <autrijus@autrijus.org>
|
||||
Wei-Hon Chen <plasmaball@pchome.com.tw>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2001 by Wei-Hon Chen E<lt>plasmaball@pchome.com.twE<gt>.
|
||||
Copyright 2002-2014 by Thomas Linden <tlinden |AT| cpan.org>.
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
See L<http://www.perl.com/perl/misc/Artistic.html>
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
2.15
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,13 +0,0 @@
|
||||
This is a raw version of Config::General, available via
|
||||
http://search.cpan.org/dist/Config-General/. It's not part of PCP in
|
||||
any way. I just distribute it with PCP so that running the unittests
|
||||
is possible without installing this modulee.
|
||||
|
||||
So, this is not the latest version, it is not supported (as part of
|
||||
PCP), do not open an issue about it on github. Issues for this module
|
||||
go to http://rt.cpan.org/.
|
||||
|
||||
Thanks.
|
||||
|
||||
PS: as I am the author of this perl module, I hereby grant permission
|
||||
to myself to redistribute it with PCP.
|
||||
Reference in New Issue
Block a user