2.39

- fixed rt.cpan.org#35122. This one was one of the most intriguing bugs I've ever observed in my own code. The internal temporary __stack hashref were copied from one subhash to another to enable inheritance of variables. However, the hashes were copied by reference, so once a value changed later, that value were overwritten because the __stack in question were just a reference. I introduced a simple function _copy() which copies the contents of the __stack by value, which solved the bug. Conclusion: beware of perl hash refs! - fixed rt.cpan.org#36607, accept whitespaces in heredoc names if split delimiter is gues (equalsign or whitespace) - fixed rt.cpan.org#34080 (typo) - fixed rt.cpan.org#35766. Variables inside single quoted strings will no more interpolated (as the docu states). Also added test case for this. - fixed bug rt.cpan.org#33766. Checking for defined not true in ::Extended::AUTOLOAD(). - added -UTF8 flag, which opens files in utf8 mode (suggested by KAORU, rt.cpan.org#35583) I decided not to add a test case for this, since perls utf8 support is not stable with all versions. git-svn-id: http://dev.catalyst.perl.org/repos/Config-General/trunk@65 be1acefe-a474-0410-9a34-9b3221f2030f
2025-12-16 20:21:01 +01:00 · 2009-10-10 16:43:54 +00:00
parent 61397677d3
commit 5f92f52e0a
8 changed files with 170 additions and 22 deletions
--- a/30
+++ b/30
@@ -1,3 +1,33 @@
+ 2.39
+	- fixed rt.cpan.org#35122. This one was one of the most
+	  intriguing bugs I've ever observed in my own code. The
+	  internal temporary __stack hashref were copied from one
+	  subhash to another to enable inheritance of variables.
+	  However, the hashes were copied by reference, so once a
+	  value changed later, that value were overwritten because
+	  the __stack in question were just a reference. I introduced
+	  a simple function _copy() which copies the contents of
+	  the __stack by value, which solved the bug.
+	  Conclusion: beware of perl hash refs!
+
+	- fixed rt.cpan.org#36607, accept whitespaces in heredoc
+	  names if split delimiter is gues (equalsign or whitespace)
+
+	- fixed rt.cpan.org#34080 (typo)
+
+	- fixed rt.cpan.org#35766. Variables inside single quoted
+	  strings will no more interpolated (as the docu states).
+	  Also added test case for this.
+
+	- fixed bug rt.cpan.org#33766. Checking for defined not true
+	  in ::Extended::AUTOLOAD().
+
+	- added -UTF8 flag, which opens files in utf8 mode
+	  (suggested by KAORU, rt.cpan.org#35583)
+	  I decided not to add a test case for this, since perls
+	  utf8 support is not stable with all versions.
+
+
 2.38
 	- fixed rt.cpan.org#31529 variable inheritance failed
 	  with multiple named blocks.
--- a/General.pm
+++ b/General.pm
@@ -32,7 +32,7 @@ use Carp::Heavy;
 use Carp;
 use Exporter;

-$Config::General::VERSION = 2.38;
+$Config::General::VERSION = 2.39;

 use vars  qw(@ISA @EXPORT_OK);
 use base qw(Exporter);
@@ -80,6 +80,7 @@ sub new {
 	      Tie                   => q(),      # could be set to a perl module for tie'ing new hashes
 	      parsed                => 0,       # internal state stuff for variable interpolation
 	      files                 => {},      # which files we have read, if any
+	      UTF8                  => 0
 	     };

  # create the class instance
@@ -367,7 +368,7 @@ sub _prepare {
    $self->{IncludeRelative}    = 1;
    $self->{IncludeDirectories} = 1;
    $self->{IncludeGlob}        = 1;
-    $self->{SpashIsDirectory}   = 1;
+    $self->{SlashIsDirectory}   = 1;
    $self->{SplitPolicy}        = 'whitespace';
    $self->{CComments}          = 0;
    $self->{BackslashEscape}    = 1;
@@ -460,7 +461,14 @@ sub _open {
      my $file = catfile($configfile, $_);
      if (! exists $this->{files}->{$file} or $this->{IncludeAgain} ) {
        # support re-read if used urged us to do so, otherwise ignore the file
+	if ($this->{UTF8}) {
+	  $fh = new IO::File;
+	  open( $fh, "<:utf8", $file)
+	    or croak "Config::General: Could not open $file in UTF8 mode!($!)\n";
+	}
+	else {
 	  $fh = IO::File->new( $file, 'r') or croak "Config::General: Could not open $file!($!)\n";
+	}
 	$this->{files}->{"$file"} = 1;
 	$this->_read($fh);
      }
@@ -476,7 +484,15 @@ sub _open {
      return;
    }
    else {
-      $fh = IO::File->new( "$configfile", 'r') or croak "Config::General: Could not open $configfile!($!)\n";
+      if ($this->{UTF8}) {
+	$fh = new IO::File;
+	open( $fh, "<:utf8", $configfile)
+	  or croak "Config::General: Could not open $configfile in UTF8 mode!($!)\n";
+      }
+      else {
+	$fh = IO::File->new( "$configfile", 'r')
+	  or croak "Config::General: Could not open $configfile!($!)\n";
+      }

      $this->{files}->{$configfile}    = 1;

@@ -630,9 +646,16 @@ sub _read {

    # look for here-doc identifier
    if ($this->{SplitPolicy} eq 'guess') {
-      if (/^\s*(\S+?)(\s*=\s*|\s+)<<\s*(.+?)\s*$/) {
+      if (/^\s*([^=]+?)\s*=\s*<<\s*(.+?)\s*$/) {
+	# try equal sign (fix bug rt#36607)
 	$hier    = $1;  # the actual here-doc variable name
-	$hierend = $3;  # the here-doc identifier, i.e. "EOF"
+	$hierend = $2;  # the here-doc identifier, i.e. "EOF"
+	next;
+      }
+      elsif (/^\s*(\S+?)\s+<<\s*(.+?)\s*$/) {
+	# try whitespace
+	$hier    = $1;  # the actual here-doc variable name
+	$hierend = $2;  # the here-doc identifier, i.e. "EOF"
 	next;
      }
    }
@@ -837,7 +860,7 @@ sub _parse {

 	    if ($this->{InterPolateVars}) {
 	      # inherit current __stack to new block
-	      $config->{$block}->{__stack} = $config->{__stack};
+	      $config->{$block}->{__stack} = $this->_copy($config->{__stack});
 	    }
 	  }

@@ -881,7 +904,8 @@ sub _parse {

 	    if ($this->{InterPolateVars}) {
 	      # inherit current __stack to new block
-	      $tmphash->{__stack} = $config->{__stack};
+	      $tmphash->{__stack} = $this->_copy($config->{__stack});
+	      #$tmphash->{__stack} = $config->{$block}->{__stack};
 	    }

 	    $config->{$block}->{$blockname} = $this->_parse($tmphash, \@newcontent);
@@ -920,7 +944,7 @@ sub _parse {
 		my $tmphash = $this->_hashref();
 		if ($this->{InterPolateVars}) {
 		  # inherit current __stack to new block
-		  $tmphash->{__stack} = $config->{__stack};
+		  $tmphash->{__stack} = $this->_copy($config->{__stack});
 		}

 		push @ar, $this->_parse( $tmphash, \@newcontent);
@@ -935,7 +959,7 @@ sub _parse {

 	    if ($this->{InterPolateVars}) {
 	      # inherit current __stack to new block
-	      $tmphash->{__stack} = $config->{__stack};
+	      $tmphash->{__stack} = $this->_copy($config->{__stack});
 	    }

 	    $config->{$block} = $this->_parse($tmphash, \@newcontent);
@@ -960,6 +984,20 @@ sub _parse {
 }


+sub _copy {
+  #
+  # copy the contents of one hash into another
+  # to circumvent invalid references
+  # fixes rt.cpan.org bug #35122
+  my($this, $source) = @_;
+  my %hash = ();
+  foreach my $key (keys %{$source}) {
+    $hash{$key} = $source->{$key};
+  }
+  return \%hash;
+}
+
+
 sub _parse_value {
  #
  # parse the value if value parsing is turned on
@@ -1054,8 +1092,15 @@ sub save_file {
    croak "Config::General: Filename is required!";
  }
  else {
-    $fh = IO::File->new( "$file", 'w') or croak "Config::General: Could not open $file!($!)\n";
-
+    if ($this->{UTF8}) {
+      $fh = new IO::File;
+      open($fh, ">:utf8", $file)
+	or croak "Config::General: Could not open $file in UTF8 mode!($!)\n";
+    }
+    else {
+      $fh = IO::File->new( "$file", 'w')
+	or croak "Config::General: Could not open $file!($!)\n";
+    }
    if (!$config) {
      if (exists $this->{config}) {
 	$config_string = $this->_store(0, %{$this->{config}});
@@ -1709,6 +1754,9 @@ character within configurations.

 By default it is turned off.

+Be carefull with this option, as it removes all backslashes after parsing.
+
+B<This option might be removed in future versions>.

 =item B<-SlashIsDirectory>

@@ -1768,7 +1816,7 @@ The following options will be set:
 IncludeRelative    = 1
 IncludeDirectories = 1
 IncludeGlob        = 1
- SpashIsDirectory   = 1
+ SlashIsDirectory   = 1
 SplitPolicy        = 'equalsign'
 CComments          = 0
 BackslashEscape    = 1
@@ -1779,6 +1827,11 @@ those options are doing.
 Beside setting some options it also turns off support for
 explicit empty blocks.

+=item B<-UTF8>
+
+If turned on, all files will be opened in utf8 mode. This may
+not work properly with older versions of perl.
+
 =back


@@ -2409,7 +2462,7 @@ Thomas Linden <tlinden |AT| cpan.org>

 =head1 VERSION

-2.38
+2.39

 =cut

--- a/General/Extended.pm
+++ b/General/Extended.pm
@@ -1,7 +1,7 @@
 #
 # Config::General::Extended - special Class based on Config::General
 #
-# Copyright (c) 2000-2007 Thomas Linden <tlinden |AT| cpan.org>.
+# Copyright (c) 2000-2008 Thomas Linden <tlinden |AT| cpan.org>.
 # All Rights Reserved. Std. disclaimer applies.
 # Artificial License, same as perl itself. Have fun.
 #
@@ -23,7 +23,7 @@ use vars qw(@ISA @EXPORT);
 use strict;


-$Config::General::Extended::VERSION = "2.02";
+$Config::General::Extended::VERSION = "2.03";


 sub new {
@@ -294,7 +294,7 @@ sub AUTOLOAD {
  my $key = $Config::General::Extended::AUTOLOAD;  # get to know how we were called
  $key =~ s/.*:://; # remove package name!

-  if ($value) {
+  if (defined $value) {
    # just set $key to $value!
    $this->{config}->{$key} = $value;
  }
@@ -576,7 +576,7 @@ values under the given key will be overwritten.

 =head1 COPYRIGHT

-Copyright (c) 2000-2007 Thomas Linden
+Copyright (c) 2000-2008 Thomas Linden

 This library is free software; you can redistribute it and/or
 modify it under the same terms as Perl itself.
@@ -593,7 +593,7 @@ Thomas Linden <tlinden |AT| cpan.org>

 =head1 VERSION

-2.02
+2.03

 =cut

--- a/General/Interpolated.pm
+++ b/General/Interpolated.pm
@@ -66,6 +66,17 @@ sub _interpolate  {
  #
  my ($this, $config, $key, $value) = @_;

+  # 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;
+  $value =~ s/(\'[^\']+?\')/
+    my $key = "QUOTE" . int(rand(1000)) . "QUOTE";
+    $quotes{ $key } = $1;
+    $key;
+  /gex;
+
  $value =~ s{$this->{regex}}{
    my $con = $1;
    my $var = $3;
@@ -94,6 +105,12 @@ sub _interpolate  {
    }
  }egx;

+  # re-insert unaltered quotes
+  # fixes bug rt#35766
+  foreach my $quote (keys %quotes) {
+    $value =~ s/$quote/$quotes{$quote}/;
+  }
+
  return $value;
 };

@@ -170,6 +187,7 @@ 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};
--- a/2
+++ b/2
@@ -104,4 +104,4 @@ AUTHOR


 VERSION
-	2.38
+	2.39
--- a/t/cfg.45
+++ b/t/cfg.45
@@ -0,0 +1,14 @@
+param1 = value1
+param2 = value2
+
+<block1>
+ param2 = value3
+ param4 = $param1  # expect: "value1"
+ param5 = $param2  # expect: "value3"
+</block1>
+
+<block2>
+ param6 = $param1  # expect: "value1"
+ param7 = $param2  # expect: "value2"
+</block2>
+
--- a/t/cfg.46
+++ b/t/cfg.46
@@ -0,0 +1,3 @@
+foo  = bar
+blah = blubber
+test = $foo 'variable $blah should be kept' and '$foo too'
--- a/t/run.t
+++ b/t/run.t
@@ -8,7 +8,7 @@


 use Data::Dumper;
-use Test::More tests => 45;
+use Test::More tests => 47;
 #use Test::More qw(no_plan);

 ### 1
@@ -457,3 +457,33 @@ eval {
 };
 ok(! $@, "-String arrayref");
 is_deeply({ $conf44->getall }, { foo => 'bar' }, "-String arrayref contents");
+
+
+
+# verifies bug rt#35122
+my $conf45 = new Config::General(-ConfigFile => "t/cfg.45", -InterPolateVars => 1, -StrictVars => 0);
+my %conf45 = $conf45->getall();
+my $expect45 = {
+		'block1' => {
+			     'param5' => 'value3',
+			     'param4' => 'value1',
+			     'param2' => 'value3'
+			    },
+		'block2' => {
+			     'param7' => 'value2',
+			     'param6' => 'value1'
+			    },
+		'param2' => 'value2',
+		'param1' => 'value1'
+	       };
+is_deeply($expect45, \%conf45, "Variable precedence");
+
+# verifies bug rt#35766
+my $conf46 = new Config::General(-ConfigFile => "t/cfg.46", -InterPolateVars => 1, -StrictVars => 0);
+my %conf46 = $conf46->getall();
+my $expect46 = {
+		 'blah' => 'blubber',
+		 'test' => 'bar \'variable $blah should be kept\' and \'$foo too\'',
+		 'foo' => 'bar'
+		};
+is_deeply($expect46, \%conf46, "Variables inside single quotes");