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

fix rt.cpan.org#113671

Browse Source 
git-svn-id: http://dev.catalyst.perl.org/repos/Config-General/trunk@108 be1acefe-a474-0410-9a34-9b3221f2030f
This commit is contained in:
Thomas von Dein
2016-04-12 07:19:40 +00:00
parent 1875861621
commit 16947651e5
2 changed files with 331 additions and 328 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
Changelog
View File

@@ -1,3 +1,5 @@
next - fix rt.cpan.org#113671: ignore utf BOM, if any.
2.60 - fix rt.cpan.org#107929: added missing test config. 2.60 - fix rt.cpan.org#107929: added missing test config.
2.59 - fix rt.cpan.org#107108 by adding support for IncludeOptional. 2.59 - fix rt.cpan.org#107108 by adding support for IncludeOptional.

657
General.pm
View File

@@ -5,7 +5,7 @@
# config values from a given file and # config values from a given file and
# return it as hash structure # return it as hash structure
# #
# Copyright (c) 2000-2015 Thomas Linden <tlinden |AT| cpan.org>. # Copyright (c) 2000-2016 Thomas Linden <tlinden |AT| cpan.org>.
# All Rights Reserved. Std. disclaimer applies. # All Rights Reserved. Std. disclaimer applies.
# Artistic License, same as perl itself. Have fun. # Artistic License, same as perl itself. Have fun.
# #
@@ -32,7 +32,7 @@ use Carp::Heavy;
use Carp; use Carp;
use Exporter; use Exporter;
$Config::General::VERSION = "2.60"; $Config::General::VERSION = "2.61";
use vars qw(@ISA @EXPORT_OK); use vars qw(@ISA @EXPORT_OK);
use base qw(Exporter); use base qw(Exporter);
@@ -47,46 +47,46 @@ sub new {
# define default options # define default options
my $self = { my $self = {
# sha256 of current date # sha256 of current date
# hopefully this lowers the probability that # hopefully this lowers the probability that
# this matches any configuration key or value out there # this matches any configuration key or value out there
# bugfix for rt.40925 # bugfix for rt.40925
EOFseparator => 'ad7d7b87f5b81d2a0d5cb75294afeb91aa4801b1f8e8532dc1b633c0e1d47037', EOFseparator => 'ad7d7b87f5b81d2a0d5cb75294afeb91aa4801b1f8e8532dc1b633c0e1d47037',
SlashIsDirectory => 0, SlashIsDirectory => 0,
AllowMultiOptions => 1, AllowMultiOptions => 1,
MergeDuplicateOptions => 0, MergeDuplicateOptions => 0,
MergeDuplicateBlocks => 0, MergeDuplicateBlocks => 0,
LowerCaseNames => 0, LowerCaseNames => 0,
ApacheCompatible => 0, ApacheCompatible => 0,
UseApacheInclude => 0, UseApacheInclude => 0,
IncludeRelative => 0, IncludeRelative => 0,
IncludeDirectories => 0, IncludeDirectories => 0,
IncludeGlob => 0, IncludeGlob => 0,
IncludeAgain => 0, IncludeAgain => 0,
AutoLaunder => 0, AutoLaunder => 0,
AutoTrue => 0, AutoTrue => 0,
AutoTrueFlags => { AutoTrueFlags => {
true => '^(on|yes|true|1)$', true => '^(on|yes|true|1)$',
false => '^(off|no|false|0)$', false => '^(off|no|false|0)$',
}, },
DefaultConfig => {}, DefaultConfig => {},
String => '', String => '',
level => 1, level => 1,
InterPolateVars => 0, InterPolateVars => 0,
InterPolateEnv => 0, InterPolateEnv => 0,
ExtendedAccess => 0, ExtendedAccess => 0,
SplitPolicy => 'guess', # also possible: whitespace, equalsign and custom SplitPolicy => 'guess', # also possible: whitespace, equalsign and custom
SplitDelimiter => 0, # must be set by the user if SplitPolicy is 'custom' SplitDelimiter => 0, # must be set by the user if SplitPolicy is 'custom'
StoreDelimiter => 0, # will be set by me unless user uses 'custom' policy StoreDelimiter => 0, # will be set by me unless user uses 'custom' policy
CComments => 1, # by default turned on CComments => 1, # by default turned on
BackslashEscape => 0, # deprecated BackslashEscape => 0, # deprecated
StrictObjects => 1, # be strict on non-existent keys in OOP mode StrictObjects => 1, # be strict on non-existent keys in OOP mode
StrictVars => 1, # be strict on undefined variables in Interpolate mode StrictVars => 1, # be strict on undefined variables in Interpolate mode
Tie => q(), # could be set to a perl module for tie'ing new hashes Tie => q(), # could be set to a perl module for tie'ing new hashes
parsed => 0, # internal state stuff for variable interpolation parsed => 0, # internal state stuff for variable interpolation
files => {}, # which files we have read, if any files => {}, # which files we have read, if any
UTF8 => 0, UTF8 => 0,
SaveSorted => 0, SaveSorted => 0,
ForceArray => 0, # force single value array if value enclosed in [] ForceArray => 0, # force single value array if value enclosed in []
AllowSingleQuoteInterpolation => 0, AllowSingleQuoteInterpolation => 0,
NoEscape => 0, NoEscape => 0,
@@ -94,7 +94,7 @@ sub new {
NormalizeOption => 0, NormalizeOption => 0,
NormalizeValue => 0, NormalizeValue => 0,
Plug => {} Plug => {}
}; };
# create the class instance # create the class instance
bless $self, $class; bless $self, $class;
@@ -569,7 +569,7 @@ sub _read {
foreach (@stuff) { foreach (@stuff) {
if ($this->{AutoLaunder}) { if ($this->{AutoLaunder}) {
if (m/^(.*)$/) { if (m/^(.*)$/) {
$_ = $1; $_ = $1;
} }
} }
@@ -579,26 +579,26 @@ sub _read {
if ($hier) { if ($hier) {
# inside here-doc, only look for $hierend marker # inside here-doc, only look for $hierend marker
if (/^(\s*)\Q$hierend\E\s*$/) { if (/^(\s*)\Q$hierend\E\s*$/) {
my $indent = $1; # preserve indentation my $indent = $1; # preserve indentation
$hier .= ' ' . $this->{EOFseparator}; # bugfix of rt.40925 $hier .= ' ' . $this->{EOFseparator}; # bugfix of rt.40925
# _parse will also preserver indentation # _parse will also preserver indentation
if ($indent) { if ($indent) {
foreach (@hierdoc) { foreach (@hierdoc) {
s/^$indent//; # i.e. the end was: " EOF" then we remove " " from every here-doc line s/^$indent//; # i.e. the end was: " EOF" then we remove " " from every here-doc line
$hier .= $_ . "\n"; # and store it in $hier $hier .= $_ . "\n"; # and store it in $hier
} }
} }
else { else {
$hier .= join "\n", @hierdoc; # there was no indentation of the end-string, so join it 1:1 $hier .= join "\n", @hierdoc; # there was no indentation of the end-string, so join it 1:1
} }
push @{$this->{content}}, $hier; # push it onto the content stack push @{$this->{content}}, $hier; # push it onto the content stack
@hierdoc = (); @hierdoc = ();
undef $hier; undef $hier;
undef $hierend; undef $hierend;
} }
else { else {
# everything else onto the stack # everything else onto the stack
push @hierdoc, $_; push @hierdoc, $_;
} }
next; next;
} }
@@ -606,25 +606,25 @@ sub _read {
if ($this->{CComments}) { if ($this->{CComments}) {
# look for C-Style comments, if activated # look for C-Style comments, if activated
if (/(\s*\/\*.*\*\/\s*)/) { if (/(\s*\/\*.*\*\/\s*)/) {
# single c-comment on one line # single c-comment on one line
s/\s*\/\*.*\*\/\s*//; s/\s*\/\*.*\*\/\s*//;
} }
elsif (/^\s*\/\*/) { elsif (/^\s*\/\*/) {
# the beginning of a C-comment ("/*"), from now on ignore everything. # the beginning of a C-comment ("/*"), from now on ignore everything.
if (/\*\/\s*$/) { if (/\*\/\s*$/) {
# C-comment end is already there, so just ignore this line! # C-comment end is already there, so just ignore this line!
$c_comment = 0; $c_comment = 0;
} }
else { else {
$c_comment = 1; $c_comment = 1;
} }
} }
elsif (/\*\//) { elsif (/\*\//) {
if (!$c_comment) { if (!$c_comment) {
warn "invalid syntax: found end of C-comment without previous start!\n"; warn "invalid syntax: found end of C-comment without previous start!\n";
} }
$c_comment = 0; # the current C-comment ends here, go on $c_comment = 0; # the current C-comment ends here, go on
s/^.*\*\///; # if there is still stuff, it will be read s/^.*\*\///; # if there is still stuff, it will be read
} }
next if($c_comment); # ignore EVERYTHING from now on, IF it IS a C-Comment next if($c_comment); # ignore EVERYTHING from now on, IF it IS a C-Comment
} }
@@ -648,16 +648,16 @@ sub _read {
if (!$this->{ApacheCompatible} && /\s*<([^\/]+?.*?)\/>\s*$/) { if (!$this->{ApacheCompatible} && /\s*<([^\/]+?.*?)\/>\s*$/) {
my $block = $1; my $block = $1;
if ($block !~ /\"/) { if ($block !~ /\"/) {
if ($block !~ /\s[^\s]/) { if ($block !~ /\s[^\s]/) {
# fix of bug 7957, add quotation to pure slash at the # fix of bug 7957, add quotation to pure slash at the
# end of a block so that it will be considered as directory # end of a block so that it will be considered as directory
# unless the block is already quoted or contains whitespaces # unless the block is already quoted or contains whitespaces
# and no quotes. # and no quotes.
if ($this->{SlashIsDirectory}) { if ($this->{SlashIsDirectory}) {
push @{$this->{content}}, '<' . $block . '"/">'; push @{$this->{content}}, '<' . $block . '"/">';
next; next;
} }
} }
} }
my $orig = $_; my $orig = $_;
$orig =~ s/\/>$/>/; $orig =~ s/\/>$/>/;
@@ -670,24 +670,24 @@ sub _read {
# look for here-doc identifier # look for here-doc identifier
if ($this->{SplitPolicy} eq 'guess') { if ($this->{SplitPolicy} eq 'guess') {
if (/^\s*([^=]+?)\s*=\s*<<\s*(.+?)\s*$/) { if (/^\s*([^=]+?)\s*=\s*<<\s*(.+?)\s*$/) {
# try equal sign (fix bug rt#36607) # try equal sign (fix bug rt#36607)
$hier = $1; # the actual here-doc variable name $hier = $1; # the actual here-doc variable name
$hierend = $2; # the here-doc identifier, i.e. "EOF" $hierend = $2; # the here-doc identifier, i.e. "EOF"
next; next;
} }
elsif (/^\s*(\S+?)\s+<<\s*(.+?)\s*$/) { elsif (/^\s*(\S+?)\s+<<\s*(.+?)\s*$/) {
# try whitespace # try whitespace
$hier = $1; # the actual here-doc variable name $hier = $1; # the actual here-doc variable name
$hierend = $2; # the here-doc identifier, i.e. "EOF" $hierend = $2; # the here-doc identifier, i.e. "EOF"
next; next;
} }
} }
else { else {
# no guess, use one of the configured strict split policies # no guess, use one of the configured strict split policies
if (/^\s*(.+?)($this->{SplitDelimiter})<<\s*(.+?)\s*$/) { if (/^\s*(.+?)($this->{SplitDelimiter})<<\s*(.+?)\s*$/) {
$hier = $1; # the actual here-doc variable name $hier = $1; # the actual here-doc variable name
$hierend = $3; # the here-doc identifier, i.e. "EOF" $hierend = $3; # the here-doc identifier, i.e. "EOF"
next; next;
} }
} }
@@ -716,58 +716,58 @@ sub _read {
$path = $this->{CurrentConfigFilePath}; $path = $this->{CurrentConfigFilePath};
} }
elsif (defined $this->{ConfigPath}) { elsif (defined $this->{ConfigPath}) {
# fetch pathname of base config file, assuming the 1st one is the path of it # fetch pathname of base config file, assuming the 1st one is the path of it
$path = $this->{ConfigPath}->[0]; $path = $this->{ConfigPath}->[0];
} }
# bugfix rt.cpan.org#38635: support quoted filenames # bugfix rt.cpan.org#38635: support quoted filenames
if ($this->{UseApacheInclude}) { if ($this->{UseApacheInclude}) {
my $opt = ''; my $opt = '';
if (/^\s*(include|includeoptional)\s*(["'])(.*?)(?<!\\)\2$/i) { if (/^\s*(include|includeoptional)\s*(["'])(.*?)(?<!\\)\2$/i) {
$incl_file = $3; $incl_file = $3;
$opt = $1; $opt = $1;
} }
elsif (/^\s*(include|includeoptional)\s+(.+?)\s*$/i) { elsif (/^\s*(include|includeoptional)\s+(.+?)\s*$/i) {
$incl_file = $2; $incl_file = $2;
$opt = $1; $opt = $1;
} }
if ($incl_file) { if ($incl_file) {
if ($this->{IncludeGlob} && $opt =~ /opt/i && $incl_file !~ /[*?\[\{\\]/) { if ($this->{IncludeGlob} && $opt =~ /opt/i && $incl_file !~ /[*?\[\{\\]/) {
# fix rt#107108 # fix rt#107108
# glob enabled && optional include && file is not already a glob: # glob enabled && optional include && file is not already a glob:
# turn it into a singular matching glob, like: # turn it into a singular matching glob, like:
# "file" => "[f][i][l][e]" and: # "file" => "[f][i][l][e]" and:
# "dir/file" => "dir/[f][i][l][e]" # "dir/file" => "dir/[f][i][l][e]"
# which IS a glob but only matches that particular file. if it # which IS a glob but only matches that particular file. if it
# doesn't exist, it will be ignored by _open(), just what # doesn't exist, it will be ignored by _open(), just what
# we'd like to have when using IncludeOptional. # we'd like to have when using IncludeOptional.
my ($vol,$dirs,$file) = splitpath( $incl_file ); my ($vol,$dirs,$file) = splitpath( $incl_file );
$incl_file = catpath($vol, $dirs, join '', map { "[$_]" } split //, $file); $incl_file = catpath($vol, $dirs, join '', map { "[$_]" } split //, $file);
} }
} }
} }
else { else {
if (/^\s*<<include\s+(["'])(.+?)>>\\s*$/i) { if (/^\s*<<include\s+(["'])(.+?)>>\\s*$/i) {
$incl_file = $2; $incl_file = $2;
} }
elsif (/^\s*<<include\s+(.+?)>>\s*$/i) { elsif (/^\s*<<include\s+(.+?)>>\s*$/i) {
$incl_file = $1; $incl_file = $1;
} }
} }
if ($incl_file) { if ($incl_file) {
if ( $this->{IncludeRelative} && $path && !file_name_is_absolute($incl_file) ) { if ( $this->{IncludeRelative} && $path && !file_name_is_absolute($incl_file) ) {
# include the file from within location of $this->{configfile} # include the file from within location of $this->{configfile}
$this->_open( $incl_file, $path ); $this->_open( $incl_file, $path );
} }
else { else {
# include the file from within pwd, or absolute # include the file from within pwd, or absolute
$this->_open($incl_file); $this->_open($incl_file);
} }
} }
else { else {
# standard entry, (option = value) # standard entry, (option = value)
push @{$this->{content}}, $_; push @{$this->{content}}, $_;
} }
} }
@@ -795,24 +795,25 @@ sub _parse {
$chunk++; $chunk++;
$_ =~ s/^\s+//; # strip spaces @ end and begin $_ =~ s/^\s+//; # strip spaces @ end and begin
$_ =~ s/\s+$//; $_ =~ s/\s+$//;
$_ =~ s/^\x{ef}\x{bb}\x{bf}//; # strip utf BOM, if any, fix rt.cpan.org#113671
# #
# build option value assignment, split current input # build option value assignment, split current input
# using whitespace, equal sign or optionally here-doc # using whitespace, equal sign or optionally here-doc
# separator EOFseparator # separator EOFseparator
my ($option,$value); my ($option,$value);
if (/$this->{EOFseparator}/) { if (/$this->{EOFseparator}/) {
($option,$value) = split /\s*$this->{EOFseparator}\s*/, $_, 2; # separated by heredoc-finding in _open() ($option,$value) = split /\s*$this->{EOFseparator}\s*/, $_, 2; # separated by heredoc-finding in _open()
} }
else { else {
if ($this->{SplitPolicy} eq 'guess') { if ($this->{SplitPolicy} eq 'guess') {
# again the old regex. use equalsign SplitPolicy to get the # again the old regex. use equalsign SplitPolicy to get the
# 2.00 behavior. the new regexes were too odd. # 2.00 behavior. the new regexes were too odd.
($option,$value) = split /\s*=\s*|\s+/, $_, 2; ($option,$value) = split /\s*=\s*|\s+/, $_, 2;
} }
else { else {
# no guess, use one of the configured strict split policies # no guess, use one of the configured strict split policies
($option,$value) = split /$this->{SplitDelimiter}/, $_, 2; ($option,$value) = split /$this->{SplitDelimiter}/, $_, 2;
} }
} }
@@ -826,102 +827,102 @@ sub _parse {
} }
if (! defined $block) { # not inside a block @ the moment if (! defined $block) { # not inside a block @ the moment
if (/^<([^\/]+?.*?)>$/) { # look if it is a block if (/^<([^\/]+?.*?)>$/) { # look if it is a block
$block = $1; # store block name $block = $1; # store block name
if ($block =~ /^"([^"]+)"$/) { if ($block =~ /^"([^"]+)"$/) {
# quoted block, unquote it and do not split # quoted block, unquote it and do not split
$block =~ s/"//g; $block =~ s/"//g;
} }
else { else {
# If it is a named block store the name separately; allow the block and name to each be quoted # If it is a named block store the name separately; allow the block and name to each be quoted
if ($block =~ /^(?:"([^"]+)"|(\S+))(?:\s+(?:"([^"]+)"|(.*)))?$/) { if ($block =~ /^(?:"([^"]+)"|(\S+))(?:\s+(?:"([^"]+)"|(.*)))?$/) {
$block = $1 || $2; $block = $1 || $2;
$blockname = $3 || $4; $blockname = $3 || $4;
} }
} }
if($this->{NormalizeBlock}) { if($this->{NormalizeBlock}) {
$block = $this->{NormalizeBlock}($block); $block = $this->{NormalizeBlock}($block);
if (defined $blockname) { if (defined $blockname) {
$blockname = $this->{NormalizeBlock}($blockname); $blockname = $this->{NormalizeBlock}($blockname);
if($blockname eq "") { if($blockname eq "") {
# if, after normalization no blockname is left, remove it # if, after normalization no blockname is left, remove it
$blockname = undef; $blockname = undef;
} }
} }
} }
if ($this->{InterPolateVars}) { if ($this->{InterPolateVars}) {
# interpolate block(name), add "<" and ">" to the key, because # interpolate block(name), add "<" and ">" to the key, because
# it is sure that such keys does not exist otherwise. # it is sure that such keys does not exist otherwise.
$block = $this->_interpolate($config, "<$block>", $block); $block = $this->_interpolate($config, "<$block>", $block);
if (defined $blockname) { if (defined $blockname) {
$blockname = $this->_interpolate($config, "<$blockname>", "$blockname"); $blockname = $this->_interpolate($config, "<$blockname>", "$blockname");
} }
} }
if ($this->{LowerCaseNames}) { if ($this->{LowerCaseNames}) {
$block = lc $block; # only for blocks lc(), if configured via new() $block = lc $block; # only for blocks lc(), if configured via new()
} }
$this->{level} += 1; $this->{level} += 1;
undef @newcontent; undef @newcontent;
next; next;
} }
elsif (/^<\/(.+?)>$/) { # it is an end block, but we don't have a matching block! elsif (/^<\/(.+?)>$/) { # it is an end block, but we don't have a matching block!
croak "Config::General: EndBlock \"<\/$1>\" has no StartBlock statement (level: $this->{level}, chunk $chunk)!\n"; croak "Config::General: EndBlock \"<\/$1>\" has no StartBlock statement (level: $this->{level}, chunk $chunk)!\n";
} }
else { # insert key/value pair into actual node else { # insert key/value pair into actual node
if ($this->{LowerCaseNames}) { if ($this->{LowerCaseNames}) {
$option = lc $option; $option = lc $option;
} }
if (exists $config->{$option}) { if (exists $config->{$option}) {
if ($this->{MergeDuplicateOptions}) { if ($this->{MergeDuplicateOptions}) {
$config->{$option} = $this->_parse_value($config, $option, $value); $config->{$option} = $this->_parse_value($config, $option, $value);
# bugfix rt.cpan.org#33216 # bugfix rt.cpan.org#33216
if ($this->{InterPolateVars}) { if ($this->{InterPolateVars}) {
# save pair on local stack # save pair on local stack
$config->{__stack}->{$option} = $config->{$option}; $config->{__stack}->{$option} = $config->{$option};
} }
} }
else { else {
if (! $this->{AllowMultiOptions} ) { if (! $this->{AllowMultiOptions} ) {
# no, duplicates not allowed # no, duplicates not allowed
croak "Config::General: Option \"$option\" occurs more than once (level: $this->{level}, chunk $chunk)!\n"; croak "Config::General: Option \"$option\" occurs more than once (level: $this->{level}, chunk $chunk)!\n";
} }
else { else {
# yes, duplicates allowed # yes, duplicates allowed
if (ref($config->{$option}) ne 'ARRAY') { # convert scalar to array if (ref($config->{$option}) ne 'ARRAY') { # convert scalar to array
my $savevalue = $config->{$option}; my $savevalue = $config->{$option};
delete $config->{$option}; delete $config->{$option};
push @{$config->{$option}}, $savevalue; push @{$config->{$option}}, $savevalue;
} }
eval { eval {
# check if arrays are supported by the underlying hash # check if arrays are supported by the underlying hash
my $i = scalar @{$config->{$option}}; my $i = scalar @{$config->{$option}};
}; };
if ($EVAL_ERROR) { if ($EVAL_ERROR) {
$config->{$option} = $this->_parse_value($config, $option, $value); $config->{$option} = $this->_parse_value($config, $option, $value);
} }
else { else {
# it's already an array, just push # it's already an array, just push
push @{$config->{$option}}, $this->_parse_value($config, $option, $value); push @{$config->{$option}}, $this->_parse_value($config, $option, $value);
} }
} }
} }
} }
else { else {
if($this->{ForceArray} && defined $value && $value =~ /^\[\s*(.+?)\s*\]$/) { if($this->{ForceArray} && defined $value && $value =~ /^\[\s*(.+?)\s*\]$/) {
# force single value array entry # force single value array entry
push @{$config->{$option}}, $this->_parse_value($config, $option, $1); push @{$config->{$option}}, $this->_parse_value($config, $option, $1);
} }
else { else {
# standard config option, insert key/value pair into node # standard config option, insert key/value pair into node
$config->{$option} = $this->_parse_value($config, $option, $value); $config->{$option} = $this->_parse_value($config, $option, $value);
if ($this->{InterPolateVars}) { if ($this->{InterPolateVars}) {
# save pair on local stack # save pair on local stack
$config->{__stack}->{$option} = $config->{$option}; $config->{__stack}->{$option} = $config->{$option};
} }
} }
} }
} }
} }
elsif (/^<([^\/]+?.*?)>$/) { # found a start block inside a block, don't forget it elsif (/^<([^\/]+?.*?)>$/) { # found a start block inside a block, don't forget it
@@ -930,127 +931,127 @@ sub _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 (defined $blockname) { if (defined $blockname) {
# a named block, make it a hashref inside a hash within the current node # a named block, make it a hashref inside a hash within the current node
if (! exists $config->{$block}) { if (! exists $config->{$block}) {
# Make sure that the hash is not created implicitly # Make sure that the hash is not created implicitly
$config->{$block} = $this->_hashref(); $config->{$block} = $this->_hashref();
if ($this->{InterPolateVars}) { if ($this->{InterPolateVars}) {
# inherit current __stack to new block # inherit current __stack to new block
$config->{$block}->{__stack} = $this->_copy($config->{__stack}); $config->{$block}->{__stack} = $this->_copy($config->{__stack});
} }
} }
if (ref($config->{$block}) eq '') { if (ref($config->{$block}) eq '') {
croak "Config::General: Block <$block> already exists as scalar entry!\n"; croak "Config::General: Block <$block> already exists as scalar entry!\n";
} }
elsif (ref($config->{$block}) eq 'ARRAY') { elsif (ref($config->{$block}) eq 'ARRAY') {
croak "Config::General: Cannot append named block <$block $blockname> to array of scalars!\n" croak "Config::General: Cannot append named block <$block $blockname> to array of scalars!\n"
."Block <$block> or scalar '$block' occurs more than once.\n" ."Block <$block> or scalar '$block' occurs more than once.\n"
."Turn on -MergeDuplicateBlocks or make sure <$block> occurs only once in the config.\n"; ."Turn on -MergeDuplicateBlocks or make sure <$block> occurs only once in the config.\n";
} }
elsif (exists $config->{$block}->{$blockname}) { elsif (exists $config->{$block}->{$blockname}) {
# the named block already exists, make it an array # the named block already exists, make it an array
if ($this->{MergeDuplicateBlocks}) { if ($this->{MergeDuplicateBlocks}) {
# just merge the new block with the same name as an existing one into # just merge the new block with the same name as an existing one into
# this one. # this one.
$config->{$block}->{$blockname} = $this->_parse($config->{$block}->{$blockname}, \@newcontent); $config->{$block}->{$blockname} = $this->_parse($config->{$block}->{$blockname}, \@newcontent);
}
else {
if (! $this->{AllowMultiOptions}) {
croak "Config::General: Named block \"<$block $blockname>\" occurs more than once (level: $this->{level}, chunk $chunk)!\n";
}
else { # preserve existing data
my $savevalue = $config->{$block}->{$blockname};
delete $config->{$block}->{$blockname};
my @ar;
if (ref $savevalue eq 'ARRAY') {
push @ar, @{$savevalue}; # preserve array if any
}
else {
push @ar, $savevalue;
}
push @ar, $this->_parse( $this->_hashref(), \@newcontent); # append it
$config->{$block}->{$blockname} = \@ar;
}
}
}
else {
# the first occurrence of this particular named block
my $tmphash = $this->_hashref();
if ($this->{InterPolateVars}) {
# inherit current __stack to new block
$tmphash->{__stack} = $this->_copy($config->{__stack});
}
$config->{$block}->{$blockname} = $this->_parse($tmphash, \@newcontent);
}
}
else {
# standard block
if (exists $config->{$block}) {
if (ref($config->{$block}) eq '') {
croak "Config::General: Cannot create hashref from <$block> because there is\n"
."already a scalar option '$block' with value '$config->{$block}'\n";
}
# the block already exists, make it an array
if ($this->{MergeDuplicateBlocks}) {
# just merge the new block with the same name as an existing one into
# this one.
$config->{$block} = $this->_parse($config->{$block}, \@newcontent);
} }
else { else {
if (! $this->{AllowMultiOptions}) { if (! $this->{AllowMultiOptions}) {
croak "Config::General: Block \"<$block>\" occurs more than once (level: $this->{level}, chunk $chunk)!\n"; croak "Config::General: Named block \"<$block $blockname>\" occurs more than once (level: $this->{level}, chunk $chunk)!\n";
} }
else { else { # preserve existing data
my $savevalue = $config->{$block}; my $savevalue = $config->{$block}->{$blockname};
delete $config->{$block}; delete $config->{$block}->{$blockname};
my @ar; my @ar;
if (ref $savevalue eq "ARRAY") { if (ref $savevalue eq 'ARRAY') {
push @ar, @{$savevalue}; push @ar, @{$savevalue}; # preserve array if any
} }
else { else {
push @ar, $savevalue; push @ar, $savevalue;
} }
push @ar, $this->_parse( $this->_hashref(), \@newcontent); # append it
$config->{$block}->{$blockname} = \@ar;
}
}
}
else {
# the first occurrence of this particular named block
my $tmphash = $this->_hashref();
# fixes rt#31529 if ($this->{InterPolateVars}) {
my $tmphash = $this->_hashref(); # inherit current __stack to new block
if ($this->{InterPolateVars}) { $tmphash->{__stack} = $this->_copy($config->{__stack});
# inherit current __stack to new block }
$tmphash->{__stack} = $this->_copy($config->{__stack});
}
push @ar, $this->_parse( $tmphash, \@newcontent); $config->{$block}->{$blockname} = $this->_parse($tmphash, \@newcontent);
}
}
else {
# standard block
if (exists $config->{$block}) {
if (ref($config->{$block}) eq '') {
croak "Config::General: Cannot create hashref from <$block> because there is\n"
."already a scalar option '$block' with value '$config->{$block}'\n";
}
$config->{$block} = \@ar; # the block already exists, make it an array
} if ($this->{MergeDuplicateBlocks}) {
} # just merge the new block with the same name as an existing one into
} # this one.
else { $config->{$block} = $this->_parse($config->{$block}, \@newcontent);
# the first occurrence of this particular block }
my $tmphash = $this->_hashref(); else {
if (! $this->{AllowMultiOptions}) {
croak "Config::General: Block \"<$block>\" occurs more than once (level: $this->{level}, chunk $chunk)!\n";
}
else {
my $savevalue = $config->{$block};
delete $config->{$block};
my @ar;
if (ref $savevalue eq "ARRAY") {
push @ar, @{$savevalue};
}
else {
push @ar, $savevalue;
}
if ($this->{InterPolateVars}) { # fixes rt#31529
# inherit current __stack to new block my $tmphash = $this->_hashref();
$tmphash->{__stack} = $this->_copy($config->{__stack}); if ($this->{InterPolateVars}) {
} # inherit current __stack to new block
$tmphash->{__stack} = $this->_copy($config->{__stack});
}
$config->{$block} = $this->_parse($tmphash, \@newcontent); push @ar, $this->_parse( $tmphash, \@newcontent);
}
} $config->{$block} = \@ar;
undef $blockname; }
undef $block; }
$this->{level} -= 1; }
next; else {
# the first occurrence of this particular block
my $tmphash = $this->_hashref();
if ($this->{InterPolateVars}) {
# inherit current __stack to new block
$tmphash->{__stack} = $this->_copy($config->{__stack});
}
$config->{$block} = $this->_parse($tmphash, \@newcontent);
}
}
undef $blockname;
undef $block;
$this->{level} -= 1;
next;
} }
} }
else { # inside $block, just push onto new content stack else { # inside $block, just push onto new content stack
@@ -2774,7 +2775,7 @@ Thomas Linden <tlinden |AT| cpan.org>
=head1 VERSION =head1 VERSION
2.60 2.61
=cut =cut