scip/Config-General
1
0
Fork 0
mirror of https://codeberg.org/scip/Config-General.git synced 2025-12-17 20:51:00 +01:00
Code Issues Packages Projects Releases Wiki Activity

2.20

Browse Source 
- fixed bug reported by Stefano di Sandro <stedis@ulis.it>: in
 	   OOP mode (extended access) the obj() method returned the whole
	   config object if the given key does not exist. Now it returns
	   a new empty object.

	 - added patch by David Dick <david_dick@iprimus.com.au> which
	   sets $/ if it is unset.

	 - added patch by David Dick <david_dick@iprimus.com.au> which
	   calls the binmode() function in case the modules is being
	   used under win32 systems. Read perldoc -f binmode for more
	   informations on this issue.

	 - added feature suggested by Chase Phillips <cmp@uiuc.edu>:
	   the new() method has a new parameter -Tie which takes the
	   name of a Tie class that each new hash should be based off
	   of. This makes it possible to create a config hash with
	   ordered contents across nested structures.


git-svn-id: http://dev.catalyst.perl.org/repos/Config-General/trunk@46 be1acefe-a474-0410-9a34-9b3221f2030f
This commit is contained in:
Thomas von Dein
2009-10-10 16:28:06 +00:00
parent 66621adfb8
commit 8167848582
4 changed files with 114 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files

20
Changelog
View File

@@ -1,3 +1,23 @@
2.20
- fixed bug reported by Stefano di Sandro <stedis@ulis.it>: in
OOP mode (extended access) the obj() method returned the whole
config object if the given key does not exist. Now it returns
a new empty object.
- added patch by David Dick <david_dick@iprimus.com.au> which
sets $/ if it is unset.
- added patch by David Dick <david_dick@iprimus.com.au> which
calls the bindmode() function in case the modules is being
used under win32 systems. Read perldoc -f binmode for more
informations on this issue.
- added feature suggested by Chase Phillips <cmp@uiuc.edu>:
the new() method has a new parameter -Tie which takes the
name of a Tie class that each new hash should be based off
of. This makes it possible to create a config hash with
ordered contents across nested structures.
2.19 2.19
- forgot to import 'catfile' from File::Spec. Bug reported by - forgot to import 'catfile' from File::Spec. Bug reported by
various people. various people.

107
General.pm
View File

@@ -18,7 +18,7 @@ use strict;
use Carp; use Carp;
use Exporter; use Exporter;
$Config::General::VERSION = "2.19"; $Config::General::VERSION = "2.20";
use vars qw(@ISA @EXPORT); use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter); @ISA = qw(Exporter);
@@ -72,7 +72,9 @@ sub new {
StrictVars => 1, # be strict on undefined variables in Interpolate mode StrictVars => 1, # be strict on undefined variables in Interpolate mode
parsed => 0, Tie => "", # could be set to a perl module for tie'ing new hashes
parsed => 0, # internal state stuff for variable interpolation
upperkey => "", upperkey => "",
lastkey => "", lastkey => "",
prevkey => " ", prevkey => " ",
@@ -107,6 +109,14 @@ sub new {
} }
delete $conf{-String}; delete $conf{-String};
} }
if (exists $conf{-Tie}) {
if ($conf{-Tie}) {
$self->{Tie} = delete $conf{-Tie};
$self->{DefaultConfig} = $self->_hashref();
}
}
if (exists $conf{-FlagBits}) { if (exists $conf{-FlagBits}) {
if ($conf{-FlagBits} && ref($conf{-FlagBits}) eq "HASH") { if ($conf{-FlagBits} && ref($conf{-FlagBits}) eq "HASH") {
$self->{FlagBits} = 1; $self->{FlagBits} = 1;
@@ -121,11 +131,10 @@ sub new {
} }
elsif ($conf{-DefaultConfig} && ref($conf{-DefaultConfig}) eq "") { elsif ($conf{-DefaultConfig} && ref($conf{-DefaultConfig}) eq "") {
$self->_read($conf{-DefaultConfig}, "SCALAR"); $self->_read($conf{-DefaultConfig}, "SCALAR");
$self->{DefaultConfig} = $self->_parse({}, $self->{content}); $self->{DefaultConfig} = $self->_parse($self->_hashref(), $self->{content});
$self->{content} = (); $self->{content} = ();
} }
delete $conf{-DefaultConfig}; delete $conf{-DefaultConfig};
delete $conf{-BaseHash}; # ignore BaseHash if a default one was given
} }
# handle options which may either be true or false # handle options which may either be true or false
@@ -161,7 +170,7 @@ sub new {
} }
else { else {
# this happens if $#param == -1,1 thus no param was given to new! # this happens if $#param == -1,1 thus no param was given to new!
$self->{config} = {}; $self->{config} = $this->_hashref();
$self->{parsed} = 1; $self->{parsed} = 1;
} }
@@ -207,7 +216,7 @@ sub new {
# process as usual # process as usual
if (!$self->{parsed}) { if (!$self->{parsed}) {
if ($self->{DefaultConfig} && $self->{InterPolateVars}) { if ($self->{DefaultConfig} && $self->{InterPolateVars}) {
$self->{DefaultConfig} = $self->_interpolate_hash($self->{DefaultConfig}); $self->{DefaultConfig} = $self->_interpolate_hash($self->{DefaultConfig}); # FIXME: _hashref() ?
} }
if (exists $self->{StringContent}) { if (exists $self->{StringContent}) {
# consider the supplied string as config file # consider the supplied string as config file
@@ -242,11 +251,12 @@ sub new {
} }
$self->_open($self->{configfile}); $self->_open($self->{configfile});
# now, we parse immdediately, getall simply returns the whole hash # now, we parse immdediately, getall simply returns the whole hash
$self->{config} = $self->_hashref();
$self->{config} = $self->_parse($self->{DefaultConfig}, $self->{content}); $self->{config} = $self->_parse($self->{DefaultConfig}, $self->{content});
} }
else { else {
# hm, no valid config file given, so try it as an empty object # hm, no valid config file given, so try it as an empty object
$self->{config} = {}; $self->{config} = $this->_hashref();
$self->{parsed} = 1; $self->{parsed} = 1;
} }
} }
@@ -301,8 +311,15 @@ sub _open {
} }
} }
local ($/) = $/;
unless ($/) {
carp("\$/ (INPUT_RECORD_SEPARATOR) is undefined. Guessing you want a line feed character");
$/ = "\n";
}
if (-e $configfile) { if (-e $configfile) {
open $fh, "<$configfile" or croak "Could not open $configfile!($!)\n"; open $fh, "<$configfile" or croak "Could not open $configfile!($!)\n";
binmode($fh);
$this->_read($fh); $this->_read($fh);
} }
else { else {
@@ -582,17 +599,17 @@ sub _parse {
} }
} }
} }
elsif (/^<([^\/]+?.*?)>$/) { # found a start block inside a block, don't forget it elsif (/^<([^\/]+?.*?)>$/) { # found a start block inside a block, don't forget it
$block_level++; # $block_level indicates wether we are still inside a node $block_level++; # $block_level indicates wether we are still inside a node
push @newcontent, $_; # push onto new content stack for later recursive call of _parse() push @newcontent, $_; # push onto new content stack for later recursive call of _parse()
} }
elsif (/^<\/(.+?)>$/) { elsif (/^<\/(.+?)>$/) {
if ($block_level) { # this endblock is not the one we are searching for, decrement and push if ($block_level) { # this endblock is not the one we are searching for, decrement and push
$block_level--; # if it is 0, then the endblock was the one we searched for, see below $block_level--; # if it is 0, then the endblock was the one we searched for, see below
push @newcontent, $_; # push onto new content stack push @newcontent, $_; # push onto new content stack
} }
else { # calling myself recursively, end of $block reached, $block_level is 0 else { # calling myself recursively, end of $block reached, $block_level is 0
if ($blockname) { # a named block, make it a hashref inside a hash within the current node if ($blockname) { # a named block, make it a hashref inside a hash within the current node
$this->_savelast($blockname); $this->_savelast($blockname);
if (exists $config->{$block}->{$blockname}) { # the named block already exists, make it an array if (exists $config->{$block}->{$blockname}) { # the named block already exists, make it an array
if ($this->{MergeDuplicateBlocks}) { if ($this->{MergeDuplicateBlocks}) {
@@ -614,7 +631,7 @@ sub _parse {
else { else {
push @ar, $savevalue; push @ar, $savevalue;
} }
push @ar, $this->_parse( {}, \@newcontent); # append it push @ar, $this->_parse( $this->_hashref(), \@newcontent); # append it
$config->{$block}->{$blockname} = \@ar; $config->{$block}->{$blockname} = \@ar;
} }
} }
@@ -625,7 +642,8 @@ sub _parse {
} }
else { else {
# the first occurence of this particular named block # the first occurence of this particular named block
$config->{$block}->{$blockname} = $this->_parse($config->{$block}->{$blockname}, \@newcontent); #### $config->{$block}->{$blockname} = $this->_parse($config->{$block}->{$blockname}, \@newcontent);
$config->{$block}->{$blockname} = $this->_parse($this->_hashref(), \@newcontent);
} }
$this->_backlast($blockname); $this->_backlast($blockname);
} }
@@ -651,14 +669,15 @@ sub _parse {
else { else {
push @ar, $savevalue; push @ar, $savevalue;
} }
push @ar, $this->_parse( {}, \@newcontent); push @ar, $this->_parse( $this->_hashref(), \@newcontent);
$config->{$block} = \@ar; $config->{$block} = \@ar;
} }
} }
} }
else { else {
# the first occurence of this particular block # the first occurence of this particular block
$config->{$block} = $this->_parse($config->{$block}, \@newcontent); #### $config->{$block} = $this->_parse($config->{$block}, \@newcontent);
$config->{$block} = $this->_parse($this->_hashref(), \@newcontent);
} }
$this->_backlast($block); $this->_backlast($block);
} }
@@ -925,6 +944,30 @@ sub _write_hash {
} }
sub _hashref {
#
# return a probably tied new empty hash ref
#
my($this) = @_;
my ($package, $filename, $line, $subroutine, $hasargs,
$wantarray, $evaltext, $is_require, $hints, $bitmask) = caller(0);
if ($this->{Tie}) {
eval {
eval "require $this->{Tie}";
};
if ($@) {
croak "Could not create a tied hash of type: " . $this->{Tie} . ": " . $@;
}
my %hash;
tie %hash, $this->{Tie};
return \%hash;
}
else {
return {};
}
}
# #
# Procedural interface # Procedural interface
@@ -1257,6 +1300,12 @@ This can be a hash reference or a simple scalar (string) of a config. This
causes the module to preset the resulting config hash with the given values, causes the module to preset the resulting config hash with the given values,
which allows you to set default values for particular config options directly. which allows you to set default values for particular config options directly.
=item B<-Tie>
B<-Tie> takes the name of a Tie class as argument that each new hash should be
based off of.
This hash will be used as the 'backing hash' instead of a standard perl hash, This hash will be used as the 'backing hash' instead of a standard perl hash,
which allows you to affect the way, variable storing will be done. You could, for which allows you to affect the way, variable storing will be done. You could, for
example supply a tied hash, say Tie::DxHash, which preserves ordering of the example supply a tied hash, say Tie::DxHash, which preserves ordering of the
@@ -1266,6 +1315,24 @@ a hash tied to a DBM file to save the parsed variables to disk.
There are many more things to do in tie-land, see L<tie> to get some interesting There are many more things to do in tie-land, see L<tie> to get some interesting
ideas. ideas.
If you want to use the B<-Tie> feature together with B<-DefaultConfig> make sure
that the hash supplied to B<-DefaultConfig> must be tied to the same Tie class.
Make sure that the hash which receives the generated hash structure (e.g. which
you are using in the assignment: %hash = $config->getall()) must be tied to
the same Tie class.
Example:
use Config::General;
use Tie::IxHash;
tie my %hash, "Tie::IxHash";
%hash = ParseConfig(
-ConfigFile => shift(),
-Tie => "Tie::IxHash"
);
=item B<-InterPolateVars> =item B<-InterPolateVars>
If set to a true value, variable interpolation will be done on your config If set to a true value, variable interpolation will be done on your config
@@ -1861,7 +1928,7 @@ Thomas Linden <tom@daemon.de>
=head1 VERSION =head1 VERSION
2.19 2.20
=cut =cut

11
General/Extended.pm
View File

@@ -1,7 +1,7 @@
# #
# Config::General::Extended - special Class based on Config::General # Config::General::Extended - special Class based on Config::General
# #
# Copyright (c) 2000-2001 Thomas Linden <tom@daemon.de>. # Copyright (c) 2000-2003 Thomas Linden <tom@daemon.de>.
# All Rights Reserved. Std. disclaimer applies. # All Rights Reserved. Std. disclaimer applies.
# Artificial License, same as perl itself. Have fun. # Artificial License, same as perl itself. Have fun.
# #
@@ -23,7 +23,7 @@ use vars qw(@ISA @EXPORT);
use strict; use strict;
$Config::General::Extended::VERSION = "1.9"; $Config::General::Extended::VERSION = "1.10";
sub new { sub new {
@@ -54,7 +54,8 @@ sub obj {
} }
} }
else { else {
return $this->SUPER::new( -ExtendedAccess => 1, -ConfigHash => $this->{config}, %{$this->{Params}} ); # even return an empty object if $key does not exist
return $this->SUPER::new( -ExtendedAccess => 1, -ConfigHash => {}, %{$this->{Params}} );
} }
} }
@@ -521,7 +522,7 @@ values under the given key will be overwritten.
=head1 COPYRIGHT =head1 COPYRIGHT
Copyright (c) 2000-2002 Thomas Linden Copyright (c) 2000-2003 Thomas Linden
This library is free software; you can redistribute it and/or This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. modify it under the same terms as Perl itself.
@@ -539,7 +540,7 @@ Thomas Linden <tom@daemon.de>
=head1 VERSION =head1 VERSION
1.9 1.10
=cut =cut

2
README
View File

@@ -104,4 +104,4 @@ AUTHOR
VERSION VERSION
2.19 2.20