[Bps-public-commit] Config-GitLike branch, master, updated. 0e487599060f9ae2899744840045d80f862eb8f2
spang at bestpractical.com
spang at bestpractical.com
Mon Jun 22 16:17:44 EDT 2009
The branch, master has been updated
via 0e487599060f9ae2899744840045d80f862eb8f2 (commit)
via 0c930bcb6469cf579f80f8b10e64941164eb7795 (commit)
via 99fa4a1ea5e1e931ea19753c5876cb5c6f332496 (commit)
via 2fc2689e924ac4e7f2bfed98da056e993df5d1d7 (commit)
via e558b7d45886136f2b3bd44a833ed625d24a229e (commit)
via dd4e1a54d420742fda61e2ce926e941e70ba6103 (commit)
via fa171d7026bbd6229b4e26d0e0c282bfcb146b35 (commit)
via b22c2ebaf0b7b02f5f51123b695c25508b5b78bc (commit)
from 8c892b9bbedf513330585af340e6581d8e38e7ab (commit)
Summary of changes:
lib/Config/GitLike.pm | 528 +++++++++++++++++++++++++++-------------
lib/Config/GitLike/Cascaded.pm | 38 ++--
t/t1300-repo-config.t | 304 +++++++++++++++++++++++-
3 files changed, 679 insertions(+), 191 deletions(-)
- Log -----------------------------------------------------------------
commit b22c2ebaf0b7b02f5f51123b695c25508b5b78bc
Author: Christine Spang <spang at mit.edu>
Date: Wed Jun 17 12:17:44 2009 +0300
Move Config::GitLike::Cascaded doc to the end of its file.
diff --git a/lib/Config/GitLike/Cascaded.pm b/lib/Config/GitLike/Cascaded.pm
index f05936f..20ce740 100644
--- a/lib/Config/GitLike/Cascaded.pm
+++ b/lib/Config/GitLike/Cascaded.pm
@@ -9,6 +9,24 @@ use File::Spec;
extends 'Config::GitLike';
+sub load_dirs {
+ my $self = shift;
+ my $path = shift;
+ my($vol, $dirs, undef) = File::Spec->splitpath( $path, 1 );
+ my @dirs = File::Spec->splitdir( $dirs );
+ for my $i ( 1 .. $#dirs ) {
+ my $path = File::Spec->catpath( $vol, File::Spec->catdir(@dirs[0..$i]), $self->dir_file );
+ $self->load_file( $path ) if -e $path;
+ }
+}
+
+__PACKAGE__->meta->make_immutable;
+no Moose;
+
+1;
+
+__END__
+
=head1 NAME
Config::GitLike::Cascaded - git-like config file parsing with cascaded inheritance
@@ -41,26 +59,6 @@ if no config files are found.)
Returns nothing of note.
-=cut
-
-sub load_dirs {
- my $self = shift;
- my $path = shift;
- my($vol, $dirs, undef) = File::Spec->splitpath( $path, 1 );
- my @dirs = File::Spec->splitdir( $dirs );
- for my $i ( 1 .. $#dirs ) {
- my $path = File::Spec->catpath( $vol, File::Spec->catdir(@dirs[0..$i]), $self->dir_file );
- $self->load_file( $path ) if -e $path;
- }
-}
-
-__PACKAGE__->meta->make_immutable;
-no Moose;
-
-1;
-
-__END__
-
=head1 SEE ALSO
L<Config::GitLike|Config::GitLike>
commit fa171d7026bbd6229b4e26d0e0c282bfcb146b35
Author: Christine Spang <spang at mit.edu>
Date: Thu Jun 18 13:25:16 2009 +0300
Don't call these small internal subs as methods.
diff --git a/lib/Config/GitLike.pm b/lib/Config/GitLike.pm
index f99d041..6658c3b 100644
--- a/lib/Config/GitLike.pm
+++ b/lib/Config/GitLike.pm
@@ -117,7 +117,6 @@ sub load_user {
# returns undef if the file was unable to be opened
sub _read_config {
- my $self = shift;
my $filename = shift;
open(my $fh, "<", $filename) or return;
@@ -133,7 +132,7 @@ sub _read_config {
sub load_file {
my $self = shift;
my ($filename) = @_;
- my $c = $self->_read_config($filename);
+ my $c = _read_config($filename);
$self->parse_content(
content => $c,
@@ -444,7 +443,6 @@ sub get {
# all balanced quotes like this is not the right thing to do, but I don't
# see it actually being a problem in practice.
sub _remove_balanced_quotes {
- my $self = shift;
my $key = shift;
no warnings 'uninitialized';
@@ -749,7 +747,7 @@ sub set {
}
sub _unset_variables {
- my ($self, $variables, $c, $difference) = @_;
+ my ($variables, $c, $difference) = @_;
for my $var (@{$variables}) {
# start from either the last newline or the last section
@@ -823,11 +821,11 @@ sub rename_section {
die "No section to rename from given\n" unless defined $args{from};
- my $c = $self->_read_config($args{filename});
+ my ($c, $fh) = _read_config($args{filename}, 1);
# file couldn't be opened = nothing to rename
return if !defined($c);
- ($args{from}, $args{to}) = map { $self->_remove_balanced_quotes($_) }
+ ($args{from}, $args{to}) = map { _remove_balanced_quotes($_) }
grep { defined $_ } ($args{from}, $args{to});
my @replace;
commit dd4e1a54d420742fda61e2ce926e941e70ba6103
Author: Christine Spang <spang at mit.edu>
Date: Thu Jun 18 13:26:41 2009 +0300
Make set support setting a group of variables at once.
It seems dumb to have to write the same file five times
if I want to add five separate config variables.
diff --git a/lib/Config/GitLike.pm b/lib/Config/GitLike.pm
index 6658c3b..caccc26 100644
--- a/lib/Config/GitLike.pm
+++ b/lib/Config/GitLike.pm
@@ -7,7 +7,8 @@ use Cwd;
use File::HomeDir;
use Regexp::Common;
use Any::Moose;
-use Fcntl qw/O_CREAT O_EXCL O_WRONLY/;
+use Scalar::Util qw(openhandle);
+use Fcntl qw(:DEFAULT :flock);
use 5.008;
@@ -118,15 +119,27 @@ sub load_user {
# returns undef if the file was unable to be opened
sub _read_config {
my $filename = shift;
+ my $lock_and_return_fh = shift;
- open(my $fh, "<", $filename) or return;
+ my $fh;
+ if ( !open($fh, '<', $filename) && $lock_and_return_fh ) {
+ open($fh, '>', $filename);
+ flock($fh, LOCK_EX);
+ return ('', $fh);
+ }
+
+ # lock the filehandle because we want to write to it later and want to
+ # (try to) ensure that no one else writes to the file in the meantime so
+ # that we don't overwrite their update
+ flock($fh, LOCK_EX) if $lock_and_return_fh;
my $c = do {local $/; <$fh>};
+ close $fh unless $lock_and_return_fh;
+
$c =~ s/\n*$/\n/; # Ensure it ends with a newline
- close $fh;
- return $c;
+ return openhandle $fh ? ($c, $fh) : $c;
}
sub load_file {
@@ -591,159 +604,210 @@ sub format_definition {
return $ret;
}
-sub set {
- my $self = shift;
- my (%args) = (
- key => undef,
- value => undef,
- filename => undef,
- filter => undef,
- as => undef,
- multiple => undef,
- @_
- );
-
- die "No key given\n" unless defined $args{key};
+# Given a key, return its variable name, section, and subsection
+# parts. Doesn't do any lowercase transformation.
+sub _split_key {
+ my $key = shift;
- my ($section, $key);
+ my ($name, $section, $subsection);
# allow quoting of the key to, for example, preserve
# . characters in the key
- if ( $args{key} =~ s/\.["'](.*)["']$// ) {
- $key = $1;
- $section = $args{key};
+ if ( $key =~ s/\.["'](.*)["']$// ) {
+ $name = $1;
+ $section = $key;
}
else {
- $args{key} =~ /^(?:(.*)\.)?(.*)$/;
- ($section, $key) = map { $self->_remove_balanced_quotes($_) }
+ $key =~ /^(?:(.*)\.)?(.*)$/;
+ # If we wanted, we could interpret quoting of the section name to
+ # allow for setting keys with section names including . characters.
+ # But git-config doesn't do that, so we won't bother for now. (Right
+ # now it will read these section names correctly but won't set them.)
+ ($section, $name) = map { _remove_balanced_quotes($_) }
grep { defined $_ } ($1, $2);
}
- $args{multiple} = $self->is_multiple($key)
- unless defined $args{multiple};
-
- die "No section given in key or invalid key $args{key}\n"
- unless defined $section;
-
- die "Invalid key $key\n" if $self->_invalid_key($key);
-
- $args{value} = $self->cast(
- value => $args{value},
- as => $args{as},
- human => 1,
- ) if defined $args{value} && defined $args{as};
-
- unless (-f $args{filename}) {
- die "No occurrence of $args{key} found to unset in $args{filename}\n"
- unless defined $args{value};
- open(my $fh, ">", $args{filename})
- or die "Can't write to $args{filename}: $!\n";
- print $fh $self->format_section(section => $section);
- print $fh $self->format_definition( key => $key, value => $args{value} );
- close $fh;
- return;
+ # Make sure the section name we're comparing against has
+ # case-insensitive section names and case-sensitive subsection names.
+ if (defined $section) {
+ $section =~ m/^([^.]+)(?:\.(.*))?$/;
+ ($section, $subsection) = ($1, $2);
+ }
+ else {
+ ($section, $subsection) = (undef) x 2;
}
+ return ($section, $subsection, $name);
+}
- # returns if the file can't be opened, since this just means create a
- # new file
- my $c = $self->_read_config($args{filename});
+sub group_set {
+ my $self = shift;
+ my ($filename, $args_ref) = @_;
- my $new;
- my @replace;
- $self->parse_content(
- content => $c,
- callback => sub {
- my %got = @_;
- return unless lc($got{section}) eq lc($section);
- $new = $got{offset} + $got{length};
- return unless defined $got{name};
-
- my $matched = 0;
- if (lc $key eq lc $got{name}) {
- if (defined $args{filter}) {
- # copy the filter arg here since this callback may
- # be called multiple times and we don't want to
- # modify the original value
- my $filter = $args{filter};
- if ($filter =~ s/^!//) {
- $matched = 1 if ($got{value} !~ m/$filter/i);
+ my ($c, $fh) = _read_config($filename, 1); # undef if file doesn't exist
+
+ # loop through each value to set, modifying the content to be written
+ # or erroring out as we go
+ for my $args_hash (@{$args_ref}) {
+ my %args = %{$args_hash};
+
+ my ($section, $subsection, $name) = _split_key($args{key});
+ my $key = join( '.',
+ grep { defined } (lc $section, $subsection, lc $name),
+ );
+
+ $args{multiple} = $self->is_multiple($key)
+ unless defined $args{multiple};
+
+ die "No section given in key or invalid key $args{key}\n"
+ unless defined $section;
+
+ die "Invalid variable name $name\n" if _invalid_name($name);
+
+ $args{value} = $self->cast(
+ value => $args{value},
+ as => $args{as},
+ human => 1,
+ ) if defined $args{value} && defined $args{as};
+
+ my $new;
+ my @replace;
+
+ # use this for comparison
+ my $cmp_section
+ = defined $subsection ? join('.', lc $section, $subsection)
+ : lc $section;
+ # ...but this for writing (don't lowercase)
+ my $combined_section
+ = defined $subsection ? join('.', $section, $subsection)
+ : $section;
+
+ # There's not really a good, simple way to get around parsing the
+ # content for each of the values we're setting. If we wanted to
+ # extract the offsets for every single one using only a single parse
+ # run, we'd end up having to munge all the offsets afterwards as we
+ # did the actual replacement since every time we did a replacement it
+ # would change the offsets for anything that was formerly to be added
+ # at a later offset. Which I'm not sure is any better than just
+ # parsing it again.
+ $self->parse_content(
+ content => $c,
+ callback => sub {
+ my %got = @_;
+ return unless $got{section} eq $cmp_section;
+ $new = $got{offset} + $got{length};
+ return unless defined $got{name};
+
+ my $matched = 0;
+ # variable names are case-insensitive
+ if (lc $name eq $got{name}) {
+ if (defined $args{filter}) {
+ # copy the filter arg here since this callback may
+ # be called multiple times and we don't want to
+ # modify the original value
+ my $filter = $args{filter};
+ if ($filter =~ s/^!//) {
+ $matched = 1 if ($got{value} !~ m/$filter/i);
+ }
+ elsif ($got{value} =~ m/$filter/i) {
+ $matched = 1;
+ }
}
- elsif ($got{value} =~ m/$filter/i) {
+ else {
$matched = 1;
}
}
- else {
- $matched = 1;
- }
- }
- push @replace, {offset => $got{offset}, length => $got{length}}
- if $matched;
- },
- error => sub {
- die "Error parsing $args{filename}, near:\n at _\n";
- },
- );
+ push @replace, {offset => $got{offset}, length => $got{length}}
+ if $matched;
+ },
+ error => sub {
+ die "Error parsing $filename, near:\n at _\n";
+ },
+ );
- die "Multiple occurrences of non-multiple key?"
- if @replace > 1 && !$args{multiple};
-
- if (defined $args{value}) {
- if (@replace && (!$args{multiple} || $args{replace_all})) {
- # Replacing existing value(s)
-
- # if the string we're replacing with is not the same length as
- # what's being replaced, any offsets following will be wrong. save
- # the difference between the lengths here and add it to any offsets
- # that follow.
- my $difference = 0;
-
- # when replacing multiple values, we combine them all into one,
- # which is kept at the position of the last one
- my $last = pop @replace;
-
- # kill all values that are not last
- ($c, $difference) = $self->_unset_variables(\@replace, $c,
- $difference);
-
- # substitute the last occurrence with the new value
- substr(
- $c,
- $last->{offset}-$difference,
- $last->{length},
- $self->format_definition(
- key => $key,
+ die "Multiple occurrences of non-multiple key?"
+ if @replace > 1 && !$args{multiple};
+
+ if (defined $args{value}) {
+ if (@replace
+ && (!$args{multiple} || $args{replace_all})) {
+ # Replacing existing value(s)
+
+ # if the string we're replacing with is not the same length as
+ # what's being replaced, any offsets following will be wrong.
+ # save the difference between the lengths here and add it to
+ # any offsets that follow.
+ my $difference = 0;
+
+ # when replacing multiple values, we combine them all into one,
+ # which is kept at the position of the last one
+ my $last = pop @replace;
+
+ # kill all values that are not last
+ ($c, $difference) = _unset_variables(\@replace, $c,
+ $difference);
+
+ # substitute the last occurrence with the new value
+ substr(
+ $c,
+ $last->{offset}-$difference,
+ $last->{length},
+ $self->format_definition(
+ key => $name,
+ value => $args{value},
+ bare => 1,
+ ),
+ );
+ }
+ elsif (defined $new) {
+ # Adding a new value to the end of an existing block
+ substr(
+ $c,
+ index($c, "\n", $new)+1,
+ 0,
+ $self->format_definition(
+ key => $name,
+ value => $args{value}
+ )
+ );
+ }
+ else {
+ # Adding a new section
+ $c .= $self->format_section( section => $combined_section );
+ $c .= $self->format_definition(
+ key => $name,
value => $args{value},
- bare => 1,
- ),
);
- }
- elsif (defined $new) {
- # Adding a new value to the end of an existing block
- substr(
- $c,
- index($c, "\n", $new)+1,
- 0,
- $self->format_definition(
- key => $key,
- value => $args{value}
- )
- );
+ }
}
else {
- # Adding a new section
- $c .= $self->format_section( section => $section );
- $c .= $self->format_definition( key => $key, value => $args{value} );
+ # Removing an existing value (unset / unset-all)
+ die "No occurrence of $args{key} found to unset in $filename\n"
+ unless @replace;
+
+ ($c, undef) = _unset_variables(\@replace, $c, 0);
}
}
- else {
- # Removing an existing value (unset / unset-all)
- die "No occurrence of $args{key} found to unset in $args{filename}\n"
- unless @replace;
+ return _write_config( $filename, $c );
+ # release lock
+ close $fh;
+}
- ($c, undef) = $self->_unset_variables(\@replace, $c, 0);
- }
+sub set {
+ my $self = shift;
+ my (%args) = (
+ key => undef,
+ value => undef,
+ filename => undef,
+ filter => undef,
+ as => undef,
+ multiple => undef,
+ @_
+ );
- return $self->_write_config($args{filename}, $c);
+ my $filename = $args{filename};
+ delete $args{filename};
+
+ return $self->group_set( $filename, [ \%args ] );
}
sub _unset_variables {
@@ -788,23 +852,32 @@ sub _unset_variables {
# unlikely to ever actually come up, since you'd have to have
# a *need* to have two things like this that are very similar
# and yet different.
-sub _invalid_key {
- my $self = shift;
- my $key = shift;
+sub _invalid_name {
+ my $name = shift;
- return $key !~ /^[^=\n]*$/ || $key =~ /(?:^[ \t]+|[ \t+]$)/;
+ return $name !~ /^[^=\n]*$/ || $name =~ /(?:^[ \t]+|[ \t+]$)/;
}
# write config with locking
sub _write_config {
- my($self, $filename, $content) = @_;
+ my($filename, $content) = @_;
+
+ # allow nested symlinks but only within reason
+ my $max_depth = 5;
- # write new config file to disk
+ # resolve symlinks
+ while ($max_depth--) {
+ my $readlink = readlink $filename;
+ $filename = $readlink if defined $readlink;
+ }
+
+ # write new config file to temp file
sysopen(my $fh, "${filename}.lock", O_CREAT|O_EXCL|O_WRONLY)
or die "Can't open ${filename}.lock for writing: $!\n";
- syswrite($fh, $content);
- close($fh);
+ print $fh $content;
+ close $fh;
+ # atomic rename
rename("${filename}.lock", ${filename})
or die "Can't rename ${filename}.lock to ${filename}: $!\n";
}
@@ -906,7 +979,9 @@ sub rename_section {
$difference += (length($replace_with) - $header->{length});
}
- return $self->_write_config($args{filename}, $c);
+ return _write_config($args{filename}, $c);
+ # release lock
+ close $fh;
}
sub remove_section {
diff --git a/t/t1300-repo-config.t b/t/t1300-repo-config.t
index 299ac62..737d90e 100644
--- a/t/t1300-repo-config.t
+++ b/t/t1300-repo-config.t
@@ -1233,3 +1233,52 @@ is_deeply(
{ 'section.a' => 'off', 'section.b' => 'off', 'section.c' => 'true' },
'global config is loaded and user/repo configs override it'
);
+
+unlink $config_filename;
+
+# Tests for group_set, which git doesn't have.
+
+# Anything beyond the basics should be covered by the fact that
+# set is implemented in terms of group_set. We just want to
+# make sure that passing in multiple things to set works here,
+# since set only passes in one.
+
+$config->group_set(
+ $config_filename,
+ [
+ {
+ key => 'foo.test1',
+ value => '1',
+ as => 'bool',
+ },
+ {
+ key => 'foo.test2',
+ value => 'bar',
+ },
+ ]
+);
+
+$config->load;
+is( $config->get( key => 'foo.test1' ), 'true', 'basic group_set' );
+is( $config->get( key => 'foo.test2' ), 'bar', 'basic group_set' );
+
+unlink $global_config;
+unlink $user_config;
+unlink $repo_config;
+
+# Test to make sure subsection comparison is case-sensitive.
+burp(
+ $config_filename,
+ '[section "FOO"]
+ b = true
+[section "foo"]
+ b = yes
+'
+);
+
+$config->load;
+
+# If comparison were actually case-insensitive, this would blow
+# up on a multival.
+is( $config->get( key => 'section.FOO.b' ), 'true',
+ 'subsection comparison is case-sensitive' );
commit e558b7d45886136f2b3bd44a833ed625d24a229e
Author: Christine Spang <spang at mit.edu>
Date: Thu Jun 18 13:28:32 2009 +0300
Terminology cleanup + make sure to compare subsections
case-insensitively.
diff --git a/lib/Config/GitLike.pm b/lib/Config/GitLike.pm
index caccc26..4bddae7 100644
--- a/lib/Config/GitLike.pm
+++ b/lib/Config/GitLike.pm
@@ -166,7 +166,7 @@ sub load_file {
sub parse_content {
my $self = shift;
my %args = (
- content => "",
+ content => '',
callback => sub {},
error => sub {},
@_,
@@ -218,7 +218,7 @@ sub parse_content {
elsif ($c =~ s/\A([^=\n]+?)[\t ]*([#;].*)?$//im) {
$args{callback}->(
section => $section,
- name => $1,
+ name => lc $1,
offset => $offset,
length => ($length - length($c)) - $offset,
);
@@ -226,7 +226,7 @@ sub parse_content {
# key/value pairs (this particular regex matches only the key part and
# the =, with unlimited whitespace around the =)
elsif ($c =~ s/\A([^=\n]+?)[\t ]*=[\t ]*//im) {
- my $name = $1;
+ my $name = lc $1;
my $value = "";
# parse the value
while (1) {
@@ -431,7 +431,10 @@ sub get {
);
$self->load unless $self->is_loaded;
- $args{key} = lc $self->_remove_balanced_quotes($args{key});
+ my ($section, $subsection, $name) = _split_key($args{key});
+ $args{key} = join( '.',
+ grep { defined } (lc $section, $subsection, lc $name),
+ );
return undef unless exists $self->data->{$args{key}};
my $v = $self->data->{$args{key}};
@@ -473,7 +476,10 @@ sub get_all {
@_,
);
$self->load unless $self->is_loaded;
- $args{key} = lc $self->_remove_balanced_quotes($args{key});
+ my ($section, $subsection, $name) = _split_key($args{key});
+ $args{key} = join('.',
+ grep { defined } (lc $section, $subsection, lc $name),
+ );
return undef unless exists $self->data->{$args{key}};
my $v = $self->data->{$args{key}};
@@ -837,10 +843,10 @@ sub _unset_variables {
return ($c, $difference);
}
-# keys can contain any characters that aren't newlines or
+# variables names can contain any characters that aren't newlines or
# = characters, but cannot start or end with whitespace
#
-# Allowing . characters in key names actually makes it so you
+# Allowing . characters in variable names actually makes it so you
# can get collisions between identifiers for things that are not
# actually the same.
#
diff --git a/t/t1300-repo-config.t b/t/t1300-repo-config.t
index 737d90e..13b372d 100644
--- a/t/t1300-repo-config.t
+++ b/t/t1300-repo-config.t
@@ -2,7 +2,7 @@ use strict;
use warnings;
use File::Copy;
-use Test::More tests => 104;
+use Test::More tests => 106;
use Test::Exception;
use File::Spec;
use File::Temp;
@@ -405,7 +405,7 @@ throws_ok {
filename => $config_filename
);
}
-qr/invalid key/i, 'invalid key containing = char';
+qr/invalid variable name/i, 'invalid name containing = char';
throws_ok {
$config->set(
@@ -414,7 +414,7 @@ throws_ok {
filename => $config_filename
);
}
-qr/invalid key/i, 'invalid key starting with whitespace';
+qr/invalid variable name/i, 'invalid name starting with whitespace';
throws_ok {
$config->set(
@@ -423,7 +423,7 @@ throws_ok {
filename => $config_filename
);
}
-qr/invalid key/i, 'invalid key ending with whitespace';
+qr/invalid variable name/i, 'invalid name ending with whitespace';
throws_ok {
$config->set(
@@ -432,7 +432,7 @@ throws_ok {
filename => $config_filename
);
}
-qr/invalid key/i, 'invalid key containing newline';
+qr/invalid key/i, 'invalid name containing newline';
lives_ok {
$config->set(
commit 2fc2689e924ac4e7f2bfed98da056e993df5d1d7
Author: Christine Spang <spang at mit.edu>
Date: Thu Jun 18 13:34:56 2009 +0300
User doc for group_set.
diff --git a/lib/Config/GitLike.pm b/lib/Config/GitLike.pm
index 4bddae7..62bec25 100644
--- a/lib/Config/GitLike.pm
+++ b/lib/Config/GitLike.pm
@@ -1306,6 +1306,21 @@ values. To override this, pass in C<multiple =E<gt> 1>. If you want to replace
all instances of a multiple-valued key with a new value, you need to pass
in C<replace_all =E<gt> 1> as well.
+=head2 group_set
+
+Parameters:
+
+ filename => '/home/foo/.bar'
+ args_ref => $ref
+
+Same as L<"set">, but set a group of variables at the same time without
+writing to disk separately for each.
+
+C<args_ref> is an array reference containing a list of hash references which
+are essentially hashes of arguments to C<set>, excluding the C<filename>
+argument since that is specified separately and the same file is used for all
+variables to be set at once.
+
=head2 rename_section
Parameters:
commit 99fa4a1ea5e1e931ea19753c5876cb5c6f332496
Author: Christine Spang <spang at mit.edu>
Date: Sat Jun 20 18:05:33 2009 +0300
Allow enforcement of "only read/write things that git can" with
the parameter compatible => 1 to the constructor.
diff --git a/lib/Config/GitLike.pm b/lib/Config/GitLike.pm
index 62bec25..0170eae 100644
--- a/lib/Config/GitLike.pm
+++ b/lib/Config/GitLike.pm
@@ -46,6 +46,14 @@ has 'config_files' => (
default => sub { [] },
);
+# default to being more relaxed than git, but allow enforcement
+# of only-write-things-that-git-config-can-read if you want to
+has 'compatible' => (
+ is => 'rw',
+ isa => 'Bool',
+ default => sub { 0 },
+);
+
sub set_multiple {
my $self = shift;
my ($name, $mult) = @_, 1;
@@ -175,6 +183,18 @@ sub parse_content {
return if !$c; # nothing to do if content is empty
my $length = length $c;
+ my $section_regex
+ = $self->compatible ? qr/\A\[([0-9a-z.-]+)(?:[\t ]*"([^\n]*?)")?\]/im
+ : qr/\A\[([^\s\[\]"]+)(?:[\t ]*"([^\n]*?)")?\]/im;
+
+ my $key_regex
+ = $self->compatible ? qr/\A([a-z][0-9a-z-]*)[\t ]*([#;].*)?$/im
+ : qr/\A([^=\n]+?)[\t ]*([#;].*)?$/im;
+
+ my $key_value_regex
+ = $self->compatible ? qr/\A([a-z][0-9a-z-]*)[\t ]*=[\t ]*/im
+ : qr/\A([^=\n]+?)[\t ]*=[\t ]*/im;
+
my($section, $prev) = (undef, '');
while (1) {
# drop leading white space and blank lines
@@ -194,7 +214,7 @@ sub parse_content {
# contain any character except newline, " and \ must be escaped
# - rules for subsections with section.subsection alternate syntax:
# same rules as for sections
- elsif ($c =~ s/\A\[([0-9a-z.-]+)(?:[\t ]*"([^\n]*?)")?\]//im) {
+ elsif ($c =~ s/$section_regex//) {
$section = lc $1;
return $args{error}->(
content => $args{content},
@@ -213,9 +233,11 @@ sub parse_content {
# (no value)
#
# for keys, we allow any characters that won't screw up the parsing
- # (= and newline), and match non-greedily to allow any trailing
- # whitespace to be dropped
- elsif ($c =~ s/\A([^=\n]+?)[\t ]*([#;].*)?$//im) {
+ # (= and newline) in non-compatible mode, and match non-greedily to
+ # allow any trailing whitespace to be dropped
+ #
+ # in compatible mode, keys can contain only 0-9a-z-
+ elsif ($c =~ s/$key_regex//) {
$args{callback}->(
section => $section,
name => lc $1,
@@ -225,7 +247,7 @@ sub parse_content {
}
# key/value pairs (this particular regex matches only the key part and
# the =, with unlimited whitespace around the =)
- elsif ($c =~ s/\A([^=\n]+?)[\t ]*=[\t ]*//im) {
+ elsif ($c =~ s/$key_value_regex//) {
my $name = lc $1;
my $value = "";
# parse the value
@@ -666,7 +688,14 @@ sub group_set {
die "No section given in key or invalid key $args{key}\n"
unless defined $section;
- die "Invalid variable name $name\n" if _invalid_name($name);
+ die "Invalid variable name $name\n"
+ if $self->_invalid_variable_name($name);
+
+ die "Invalid section name $section\n"
+ if $self->_invalid_section_name($section);
+
+ die "Unescaped backslash or \" in subsection $subsection\n"
+ if defined $subsection && $subsection =~ /(?<!\\)(?:"|\\)/;
$args{value} = $self->cast(
value => $args{value},
@@ -843,8 +872,8 @@ sub _unset_variables {
return ($c, $difference);
}
-# variables names can contain any characters that aren't newlines or
-# = characters, but cannot start or end with whitespace
+# In non-git-compatible mode, variables names can contain any characters that
+# aren't newlines or = characters, but cannot start or end with whitespace.
#
# Allowing . characters in variable names actually makes it so you
# can get collisions between identifiers for things that are not
@@ -858,10 +887,27 @@ sub _unset_variables {
# unlikely to ever actually come up, since you'd have to have
# a *need* to have two things like this that are very similar
# and yet different.
-sub _invalid_name {
- my $name = shift;
+sub _invalid_variable_name {
+ my ($self, $name) = @_;
- return $name !~ /^[^=\n]*$/ || $name =~ /(?:^[ \t]+|[ \t+]$)/;
+ if ($self->compatible) {
+ return $name !~ /^[a-z][0-9a-z-]*$/i;
+ }
+ else {
+ return $name !~ /^[^=\n]*$/ || $name =~ /(?:^[ \t]+|[ \t+]$)/;
+ }
+}
+
+# section, NOT subsection!
+sub _invalid_section_name {
+ my ($self, $section) = @_;
+
+ if ($self->compatible) {
+ return $section !~ /^[0-9a-z-.]+$/i;
+ }
+ else {
+ return $section =~ /\s|\[|\]|"/;
+ }
}
# write config with locking
@@ -1187,6 +1233,11 @@ You can override these defaults by subclassing C<Config::GitLike> and
overriding the methods C<global_file>, C<user_file>, and C<dir_file>. (See
L<"METHODS YOU MAY WISH TO OVERRIDE"> for details.)
+If you wish to enforce only being able to read/write config files that
+git can read or write, pass in C<compatible =E<gt> 1> to this
+constructor. The default rules for some components of the config
+file are more permissive than git's (see L<"DIFFERENCES FROM GIT-CONFIG">).
+
=head2 confname
The configuration filename that you passed in when you created
@@ -1525,10 +1576,13 @@ followed by a newline.
This module does the following things differently from git-config:
-We are much more permissive about valid key names: instead of limiting
-key names to alphanumeric characters and -, we allow any characters
-except for = and newlines, including spaces as long as they are
-not leading or trailing, and . as long as the key name is quoted.
+We are much more permissive about valid key names and section names.
+For variables, instead of limiting variable names to alphanumeric characters
+and -, we allow any characters except for = and newlines, including spaces as
+long as they are not leading or trailing, and . as long as the key name is
+quoted. For sections, any characters but whitespace, [], and " are allowed.
+You can enforce reading/writing only git-compatible variable names and section
+headers by passing C<compatible =E<gt> 1> to the constructor.
When replacing variable values and renaming sections, we merely use
a substring replacement rather than writing out new lines formatted in the
diff --git a/t/t1300-repo-config.t b/t/t1300-repo-config.t
index 13b372d..55a173c 100644
--- a/t/t1300-repo-config.t
+++ b/t/t1300-repo-config.t
@@ -2,7 +2,7 @@ use strict;
use warnings;
use File::Copy;
-use Test::More tests => 106;
+use Test::More tests => 129;
use Test::Exception;
use File::Spec;
use File::Temp;
@@ -1282,3 +1282,218 @@ $config->load;
# up on a multival.
is( $config->get( key => 'section.FOO.b' ), 'true',
'subsection comparison is case-sensitive' );
+
+# Test section names with with weird characters in them (non git-compat)
+
+burp(
+ $config_filename,
+ '[http://www.example.com/test/]
+ admin = foo at bar.com
+[http://www.example.com/test/ "users"]
+ epe = Eddie P. Example
+'
+);
+
+lives_and {
+ $config->load;
+ is( $config->get( key => 'http://www.example.com/test/.admin' ),
+ 'foo at bar.com' );
+} 'parse weird characters in section in non-git compat mode';
+
+
+lives_and {
+ $config->set(
+ key => 'http://www.example.com/test/.devs.joe',
+ value => 'Joe Schmoe',
+ filename => $config_filename,
+ );
+ $config->load;
+ is( $config->get( key => 'http://www.example.com/test/.devs.joe' ),
+ 'Joe Schmoe',
+ );
+} 'set weird characters in section in non-git compat mode';
+
+# Test git compat flag.
+
+$config->compatible(1);
+
+# variables names that start with numbers or contain characters other
+# than a-zA-Z- are illegal
+
+burp(
+ $config_filename,
+ '[section "FOO"]
+ foo..bar = true
+'
+);
+
+throws_ok { $config->load; } qr/error parsing/im,
+ 'variable names cannot contain . in git-compat mode';
+
+burp(
+ $config_filename,
+ '[section "FOO"]
+ foo%@$#bar = true
+'
+);
+
+throws_ok { $config->load; } qr/error parsing/im,
+ 'variable names cannot contain symbols in git-compat mode';
+
+burp(
+ $config_filename,
+ '[section "FOO"]
+ 01inval = true
+'
+);
+
+throws_ok { $config->load; } qr/error parsing/im,
+ 'variable names cannot start with a number git-compat mode';
+
+burp(
+ $config_filename,
+ '[section "FOO"]
+ -inval = true
+'
+);
+
+throws_ok { $config->load; } qr/error parsing/im,
+ 'variable names cannot start with a dash git-compat mode';
+
+# set has a different check than the parsing code, so test it too
+throws_ok {
+ $config->set(
+ key => 'section.01inval',
+ value => 'none',
+ filename => $config_filename,
+ ) } qr/invalid variable name/im, 'variable names cannot start with a number in git-compat mode';
+
+throws_ok {
+ $config->set(
+ key => 'section.foo%$@bar',
+ value => 'none',
+ filename => $config_filename,
+ ) } qr/invalid variable name/im, 'variable names cannot contain symbols in git-compat mode';
+
+throws_ok {
+ $config->set(
+ key => 'section."foo..bar"',
+ value => 'none',
+ filename => $config_filename,
+ ) } qr/invalid variable name/im, 'variable names cannot contain . in git-compat mode';
+
+throws_ok {
+ $config->set(
+ key => 'section.-inval',
+ value => 'none',
+ filename => $config_filename,
+ ) } qr/invalid variable name/im, 'variable names cannot start with - in git-compat mode';
+
+# section names cannot contain characters other than a-zA-Z-. in compat mode
+
+burp(
+ $config_filename,
+ '[se$^%#& "FOO"]
+ a = b
+'
+);
+
+throws_ok { $config->load; } qr/error parsing/im,
+ 'section names cannot contain symbols in git-compat mode';
+
+burp(
+ $config_filename,
+ '[sec tion "FOO"]
+ a = b
+'
+);
+
+throws_ok { $config->load; } qr/error parsing/im,
+ 'section names cannot contain whitespace in git-compat mode';
+
+burp(
+ $config_filename,
+ '[-foo.bar-baz "FOO"]
+ a = b
+'
+);
+
+lives_ok { $config->load; }
+ 'section names can contain - and . in git-compat mode';
+
+# set has a different check than the parsing code, so test it too
+throws_ok {
+ $config->set(
+ key => 'sec tion.foo.baz',
+ value => 'none',
+ filename => $config_filename,
+ ) } qr/invalid section name/im,
+'section names cannot contain whitespace in git-compat mode';
+
+throws_ok {
+ $config->set(
+ key => 's^*&^#$.foo.baz',
+ value => 'none',
+ filename => $config_filename,
+ ) } qr/invalid section name/im, 'section names cannot contain symbols in git-compat mode';
+
+lives_and {
+ $config->set(
+ key => '-foo.bar-baz.foo.baz',
+ value => 'none',
+ filename => $config_filename,
+ );
+ $config->load;
+ is( $config->get( key => '-foo.bar-baz.foo.baz' ), 'none' );
+} 'section names can contain - and . while setting in git-compat mode';
+
+throws_ok {
+ $config->set(
+ key => 'section.foo\bar.baz',
+ value => 'none',
+ filename => $config_filename,
+ ) } qr/unescaped backslash or \" in subsection/im,
+'subsection names cannot contain unescaped backslash in compat mode';
+
+throws_ok {
+ $config->set(
+ key => 'section.foo"bar.baz',
+ value => 'none',
+ filename => $config_filename,
+ ) } qr/unescaped backslash or \" in subsection/im,
+'subsection names cannot contain unescaped " in compat mode';
+
+throws_ok {
+ $config->set(
+ key => "section.foo\nbar.baz",
+ value => 'none',
+ filename => $config_filename,
+ ) } qr/invalid key/im,
+'subsection names cannot contain unescaped newlines in compat mode';
+
+# these should be the case in no-compat mode too
+$config->compatible(0);
+throws_ok {
+ $config->set(
+ key => 'section.foo\bar.baz',
+ value => 'none',
+ filename => $config_filename,
+ ) } qr/unescaped backslash or \" in subsection/im,
+'subsection names cannot contain unescaped backslash in nocompat mode';
+
+throws_ok {
+ $config->set(
+ key => "section.foo\nbar.baz",
+ value => 'none',
+ filename => $config_filename,
+ ) } qr/invalid key/im,
+'subsection names cannot contain unescaped newlines in nocompat mode';
+
+throws_ok {
+ $config->set(
+ key => 'section.foo"bar.baz',
+ value => 'none',
+ filename => $config_filename,
+ ) } qr/unescaped backslash or \" in subsection/im,
+'subsection names cannot contain unescaped " in nocompat mode';
+
commit 0c930bcb6469cf579f80f8b10e64941164eb7795
Author: Christine Spang <spang at mit.edu>
Date: Mon Jun 22 13:30:33 2009 +0300
New error_callback function for parse_content.
It prints a better message on dying than just barfing up all the args it
was given.
diff --git a/lib/Config/GitLike.pm b/lib/Config/GitLike.pm
index 0170eae..f38490c 100644
--- a/lib/Config/GitLike.pm
+++ b/lib/Config/GitLike.pm
@@ -161,7 +161,7 @@ sub load_file {
$self->define(@_, origin => $filename);
},
error => sub {
- die "Error parsing $filename, near:\n at _\n";
+ error_callback( @_, filename => $filename );
},
);
@@ -171,6 +171,31 @@ sub load_file {
return $self->data;
}
+sub error_callback {
+ my %args = @_;
+
+ my $offset_of_prev_newline = rindex( $args{content}, "\n", $args{offset} );
+ my $offset_of_next_newline = index( $args{content}, "\n", $args{offset} );
+ my $line = substr(
+ $args{content},
+ $offset_of_prev_newline + 1,
+ $offset_of_next_newline - ($offset_of_prev_newline + 1),
+ );
+
+ my $line_number = 1;
+ my $current_offset = 0;
+
+ while ($current_offset <= $args{offset}) {
+ # nibble off a line of content
+ $args{content} =~ s/(.*\n)//;
+ $line_number++;
+ $current_offset += length $1;
+ }
+ my $position = (length $line) - ($current_offset - ($args{offset} + 1));
+ die "Error parsing $args{filename} at line $line_number, position $position."
+ ."\nBad line was: '$line'\n";
+}
+
sub parse_content {
my $self = shift;
my %args = (
@@ -755,7 +780,7 @@ sub group_set {
if $matched;
},
error => sub {
- die "Error parsing $filename, near:\n at _\n";
+ error_callback(@_, filename => $args{filename})
},
);
@@ -1002,7 +1027,7 @@ sub rename_section {
}
},
error => sub {
- die "Error parsing $args{filename}, near:\n at _\n";
+ error_callback( @_, filename => $args{filename} );
},
);
die "No such section '$args{from}'\n"
@@ -1498,6 +1523,29 @@ C<error> is called like:
Where C<offset> is the point in the content where the parse error occurred.
+If you need to use this method, you might be interested in L<"error_callback">
+as well.
+
+=head2 error_callback
+
+Parameters:
+
+ content => 'str'
+ offset => 45
+ filename => '/foo/bar/.baz'
+
+Made especially for passing to L<"parse_content">, passed through the
+C<error> parameter like this:
+
+ error => sub {
+ error_callback( @_, filename => '/file/you/were/parsing' )
+ }
+
+It's used internally wherever L<"parse_content"> is used and will throw
+an exception with a useful message detailing the line number, position on
+the line, and contents of the bad line; if you find the need to use
+L<"parse_content"> elsewhere, you may find it useful as well.
+
=head2 set_multiple( $name )
Mark the key string C<$name> as containing multiple values.
commit 0e487599060f9ae2899744840045d80f862eb8f2
Author: Christine Spang <spang at mit.edu>
Date: Mon Jun 22 13:31:11 2009 +0300
A bugfix and regression tests for permissive parsing
diff --git a/lib/Config/GitLike.pm b/lib/Config/GitLike.pm
index f38490c..d66492f 100644
--- a/lib/Config/GitLike.pm
+++ b/lib/Config/GitLike.pm
@@ -213,12 +213,12 @@ sub parse_content {
: qr/\A\[([^\s\[\]"]+)(?:[\t ]*"([^\n]*?)")?\]/im;
my $key_regex
- = $self->compatible ? qr/\A([a-z][0-9a-z-]*)[\t ]*([#;].*)?$/im
- : qr/\A([^=\n]+?)[\t ]*([#;].*)?$/im;
+ = $self->compatible ? qr/\A([a-z][0-9a-z-]*)[\t ]*(?:[#;].*)?$/im
+ : qr/\A([^\[=\n][^=\n]*?)[\t ]*(?:[#;].*)?$/im;
my $key_value_regex
= $self->compatible ? qr/\A([a-z][0-9a-z-]*)[\t ]*=[\t ]*/im
- : qr/\A([^=\n]+?)[\t ]*=[\t ]*/im;
+ : qr/\A([^\[=\n][^=\n]*?)[\t ]*=[\t ]*/im;
my($section, $prev) = (undef, '');
while (1) {
@@ -919,7 +919,7 @@ sub _invalid_variable_name {
return $name !~ /^[a-z][0-9a-z-]*$/i;
}
else {
- return $name !~ /^[^=\n]*$/ || $name =~ /(?:^[ \t]+|[ \t+]$)/;
+ return $name !~ /^[^=\n\[][^=\n]*$/ || $name =~ /(?:^[ \t]+|[ \t+]$)/;
}
}
diff --git a/t/t1300-repo-config.t b/t/t1300-repo-config.t
index 55a173c..af9cdc0 100644
--- a/t/t1300-repo-config.t
+++ b/t/t1300-repo-config.t
@@ -2,7 +2,7 @@ use strict;
use warnings;
use File::Copy;
-use Test::More tests => 129;
+use Test::More tests => 133;
use Test::Exception;
use File::Spec;
use File::Temp;
@@ -1497,3 +1497,33 @@ throws_ok {
) } qr/unescaped backslash or \" in subsection/im,
'subsection names cannot contain unescaped " in nocompat mode';
+# Make sure some bad configs throw errors.
+burp(
+ $config_filename,
+ '[testing "FOO"
+ a = b
+'
+);
+
+throws_ok { $config->load } qr/error parsing/i, 'invalid section (nocompat)';
+$config->compatible(1);
+throws_ok { $config->load } qr/error parsing/i, 'invalid section (compat)';
+
+# This should be OK since the variable name doesn't start with [
+burp(
+ $config_filename,
+ '[test]
+ a[] = b
+'
+);
+
+throws_ok { $config->load } qr/error parsing/i,
+ 'key cannot contain [] in compat mode';
+
+$config->compatible(0);
+
+lives_and {
+ $config->load;
+ is( $config->get( key => 'test.a[]' ), 'b' );
+} 'key can contain but not start with [ in nocompat mode';
+
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list