[PATCH] perl: add new module Git::Config for cached 'git config' access

[Sam Vilain <sam.vilain@catalyst.net.nz>]

Add a new module, Git::Config, for a better Git configuration API.

Signed-off-by: Sam Vilain <sam.vilain@catalyst.net.nz>
---
 perl/Git/Config.pm   |  465 ++++++++++++++++++++++++++++++++++++++++++++++++++
 perl/Makefile.PL     |    5 +-
 t/t9700-perl-git.sh  |    8 +
 t/t9700/TestUtils.pm |   77 +++++++++
 t/t9700/config.t     |  127 ++++++++++++++
 5 files changed, 681 insertions(+), 1 deletions(-)
 create mode 100644 perl/Git/Config.pm
 create mode 100644 t/t9700/TestUtils.pm
 create mode 100644 t/t9700/config.t

diff --git a/perl/Git/Config.pm b/perl/Git/Config.pm
new file mode 100644
index 0000000..a0a6a41
--- /dev/null
+++ b/perl/Git/Config.pm
@@ -0,0 +1,465 @@
+
+package Git::Config;
+
+use 5.006;
+use strict;
+use warnings;
+
+use Git;
+use Error qw(:try);
+
+=head1 NAME
+
+Git::Config - caching interface to git-config state
+
+=head1 SYNOPSIS
+
+  use Git::Config;
+
+  my $conf = Git::Config->new( $git );
+
+  # return single config items
+  my $value = $conf->config( VARIABLE );
+
+  # return multi-config items
+  my @values = $conf->config( VARIABLE );
+
+  # manipulate type of slot, for special interpretation
+  $conf->type( VARIABLE => $type );
+
+  # change value
+  $conf->config( VARIABLE => $value );
+
+  # read or configure a global or system variable
+  $conf->global( VARIABLE => $value );
+  $conf->system( VARIABLE => $value );
+
+  # default is to autoflush 
+  $conf->autoflush( 0 );
+
+  # if autoflush is disabled, flush explicitly.
+  $conf->flush;
+
+  # update cache
+  $conf->read;
+
+=head1 DESCRIPTION
+
+This module provides a cached interface to the B<git config> command
+in Perl.
+
+=head1 CONSTRUCTION
+
+=head2 B<Git::Config-E<gt>new( I<$git> )>
+
+Creates a new B<Git::Config> object.  Does not read the configuration
+file yet.
+
+=cut
+
+sub new {
+	my $class = shift;
+	my $git = shift || Git->repository;
+	my $self = bless { git => $git }, $class;
+	while ( my ($item, $value) = splice @_, 0, 2 ) {
+		try {
+			$self->$item($value);
+		}
+		catch {
+			throw Error::Simple (
+				"Invalid constructor arg '$item'",
+			       );
+		};
+	}
+	return $self;
+}
+
+=head1 METHODS
+
+=head2 B<$conf-E<gt>config( C<item> )>
+
+Reads the value of a particular configuration item.
+When called in B<list context>, returns all values of multiple value
+items.
+When called in B<scalar context>, raises an error if the item is
+specified multiple times.
+
+=head2 B<$conf-E<gt>config( C<item> =E<gt> I<$value> )>
+
+Sets the value of an item.
+If an B<array reference> is specified, the entire list of items is
+replaced with the values specified.
+If a single item is passed but the item is specified multiple times in
+the configuration file, raises an error.
+Returns the old value.
+
+=cut
+
+sub config {
+	return $_[0]->_config("", @_[1..$#_]);
+}
+
+sub _config {
+	my $self = shift;
+	my $which = shift;
+	my $item = shift;
+	my $value_passed = @_;
+	my $value = shift;
+
+	my $type = $self->type( $item );
+
+	my $_which = $which ? "${which}_" : "";
+	my $_read = "read_${_which}state";
+	my $_state = "${_which}state";
+
+	if (!$self->{$_read}) {
+		$self->read($which);
+	}
+
+	my $state;
+	if (exists $self->{$_state}{$item}) {
+		$state = $self->{$_state}{$item};
+	}
+	else {
+		$state = $self->{$_read}{$item};
+	}
+
+	if ($value_passed) {
+		if (!ref $value and defined $value and ref $state) {
+			throw Error::Simple (
+				"'$item' is specified multiple times",
+			       );
+		}
+		if ( $type ) {
+			if (ref $value) {
+				$value = [ map { $self->freeze($type, $_) }
+						   @$value ];
+			}
+			else {
+				$value = $self->freeze($type, $value);
+			}
+		}
+		$self->{$_state}{$item} = $value;
+		$self->flush() if $self->autoflush;
+	}
+
+	if (defined wantarray) {
+		my @values = ref $state ? @$state :
+			defined $state ? ($state) : ();
+
+		if ( my $type = $self->type( $item ) ) {
+			@values = map { $self->thaw($type, $_) }
+				@values;
+		}
+
+		if ( @values > 1 and
+			     ( ($value_passed and not ref $value) or
+				       (not $value_passed and not wantarray) )
+			    ) {
+			throw Error::Simple (
+				"'$item' is specified multiple times",
+			       );
+		}
+
+		return (wantarray ? @values : $values[0]);
+	}
+}
+
+=head2 B<$conf-E<gt>read()>
+
+Reads the current state of the configuration file.
+
+=cut
+
+sub read {
+	my $self = shift;
+	my $which = shift;
+
+	my $git = $self->{git};
+
+	my ($fh, $c) = $git->command_output_pipe(
+		'config', ( $which ? ("--$which") : () ),
+		'--list',
+	       );
+	my $read_state = {};
+
+	while (<$fh>) {
+		my ($item, $value) = m{(.*?)=(.*)};
+		my $sl = \( $read_state->{$item} );
+		if (!defined $$sl) {
+			$$sl = $value;
+		}
+		elsif (!ref $$sl) {
+			$$sl = [ $$sl, $value ];
+		}
+		else {
+			push @{ $$sl }, $value;
+		}
+	}
+
+	$git->command_close_pipe($fh, $c);
+
+	if ( $which ) {
+		$which .= "_";
+	}
+	else {
+		$which = "";
+	};
+
+	$self->{"read_${which}state"} = $read_state;
+}
+
+=head2 type( VARIABLE => $type )
+
+Specifies which set of rules to use when returning to and from the
+config file.  C<$type> may be C<string>, C<boolean> or C<integer>.
+Globs such as C<*> are allowed which match everything except C<.>
+(full stop).
+
+=head2 type( VARIABLE )
+
+Returns the first matching defined type rule.
+
+=cut
+
+sub type {
+	my $self = shift;
+	my $item = shift;
+	my $got_type = @_;
+	my $type = shift;
+	$type ||= "string";
+
+	my $types = $self->{types} ||= [];
+	if ( $got_type ) {
+		$item =~ s{([\.(?])}{\\$1}g;
+		$item =~ s{\*}{[^\\.]*}g;
+		$item = qr{^$item$};
+		@$types = grep { $_->[0] ne $item }
+			@$types;
+		push @$types, [ $item, $type ];
+	}
+	else {
+	type:
+		for (@$types) {
+			if ($item =~ m{$_->[0]}) {
+				$type = $_->[1];
+				last type;
+			}
+		}
+
+		$type;
+	}
+}
+
+=head2 global( VARIABLE )
+
+=head2 system( VARIABLE )
+
+Return the value of the given variable in the global or system
+configuration (F<~/.gitconfig> and F</etc/gitconfig> on Unix).
+
+=head2 global( VARIABLE => $value )
+
+=head2 system( VARIABLE => $value )
+
+Set the value of the given variable in the global or system
+configuration.
+
+=cut
+
+sub global { return $_[0]->_config("global", @_[1..$#_]) }
+sub system { return $_[0]->_config("system", @_[1..$#_]) }
+
+=head2 autoflush
+
+Returns 0 or 1 depending on whether autoflush is enabled.  Defaults to
+1.
+
+=head2 autoflush ( $value )
+
+Set the value of autoflush.  If set to 1, flushes immediately.
+
+=cut
+
+sub autoflush {
+	my $self = shift;
+	if (@_) {
+		$self->{autoflush} = shift;
+	}
+	not (defined $self->{autoflush} and not $self->{autoflush});
+}
+
+=head2 flush
+
+Flushes all changed configuration values to the config file(s).
+
+=cut
+
+sub flush {
+	my $self = shift;
+
+	for my $which ("", "global", "system") {
+		my $st = $which . ($which ? "_" : "") . "state";;
+		my $read = "read_$st";
+		if (my $new = delete $self->{$st}) {
+			$self->_write($which, $new, $self->{$read});
+			$self->read($which);
+		}
+	}
+}
+
+sub _write {
+	my $self = shift;
+	my $which = shift;
+	my $state = shift;
+	my $read_state = shift;
+
+	my $git = $self->{git};
+
+	while (my ($item, $value) = each %$state) {
+		my $old_value = $read_state->{$item};
+		my @cmd = ($which ? ("--$which") : () );
+		my $type = $self->type($item);
+		if ($type ne "string") {
+			push @cmd, "--$type";
+		}
+		if (ref $value) {
+			$git->command_oneline (
+				"config", @cmd, "--replace-all",
+				 $item, $value->[0],
+			       );
+			for my $i (1..$#$value) {
+				$git->command_oneline (
+					"config", @cmd, "--add",
+					$item, $value->[$i],
+				       );
+			};
+		}
+		elsif (defined $value) {
+			$git->command_oneline (
+				"config", @cmd, $item, $value,
+			       );
+		}
+		elsif ($read_state->{$item}) {
+			$git->command_oneline (
+				"config", "--unset-all", @cmd,
+				$item, $value,
+			       );
+		}
+		else {
+			# nothing to do - already not in config
+		}
+	}
+}
+
+sub _dispatch {
+	no strict 'refs';
+	my $self = shift;
+	my $func = shift;
+	my $type = shift;
+	my $sym = __PACKAGE__."::${type}::$func";
+	defined &{$sym}
+		or throw Error::Simple "Bad type '$type' in $func";
+	&{$sym}(@_, $self);
+}
+
+sub freeze {
+	my $self = shift;
+	$self->_dispatch("freeze", @_);
+}
+
+sub thaw {
+	my $self = shift;
+	$self->_dispatch("thaw", @_);
+}
+
+{
+	package Git::Config::string;
+	sub freeze { shift }
+	sub thaw   { shift }
+}
+{
+	package Git::Config::integer;
+	our @mul = ("", "k", "M", "G");
+	sub freeze {
+		my $val = shift;
+		my $scale = 0;
+		while ( (my $num = int($val/1024))*1024 == $val ) {
+			$scale++;
+		 	$val = $num;
+			last if $scale == $#mul;
+		}
+		$val.$mul[$scale];
+	}
+	our $mul_re = qr/^(\d+)\s*${\( "(".join("|", @mul).")" )}$/i;
+	sub thaw {
+		my $val = shift;
+		$val =~ m{$mul_re}
+			or throw Error::Simple "Bad value for integer: '$val'";
+		my $num = $1;
+		if ($2) {
+			my $scale = 0;
+			do { $num = $num * 1024 }
+				until (lc($mul[++$scale]) eq lc($2));
+		}
+		$num;
+	}
+}
+{
+	package Git::Config::boolean;
+	our @true = qw(true yes 1);
+	our @false = qw(false no 0);
+	our $true_re = qr/^${\( "(".join("|", @true).")" )}$/i;
+	our $false_re = qr/^${\( "(".join("|", @false).")" )}$/i;
+	sub freeze {
+		my $val = shift;
+		if (!!$val) {
+			$true[0];
+		}
+		else {
+			$false[0];
+		}
+	}
+	sub thaw {
+		my $val = shift;
+		if ($val =~ m{$true_re}) {
+			1;
+		}
+		elsif ($val =~ m{$false_re}) {
+			0;
+		}
+		else {
+			throw Error::Simple "Bad value for boolean: '$val'";
+		}
+	}
+}
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+L<Git>
+
+=head1 AUTHOR AND LICENSE
+
+Copyright 2009, Sam Vilain, L<sam@vilain.net>.  All Rights Reserved.
+This program is Free Software; you may use it under the terms of the
+Perl Artistic License 2.0 or later, or the GPL v2 or later.
+
+=cut
+
+# Local Variables:
+#   mode: cperl
+#   cperl-brace-offset: 0
+#   cperl-continued-brace-offset: 0
+#   cperl-indent-level: 8
+#   cperl-label-offset: -8
+#   cperl-merge-trailing-else: nil
+#   cperl-continued-statement-offset: 8
+#   cperl-indent-parens-as-block: t
+#   cperl-indent-wrt-brace: nil
+# End:
+#
+# vim: vim:tw=78:sts=0:noet
diff --git a/perl/Makefile.PL b/perl/Makefile.PL
index 320253e..80df0b0 100644
--- a/perl/Makefile.PL
+++ b/perl/Makefile.PL
@@ -8,7 +8,10 @@ instlibdir:
 MAKE_FRAG
 }
 
-my %pm = ('Git.pm' => '$(INST_LIBDIR)/Git.pm');
+my %pm = (map {( "$_.pm" => "\$(INST_LIBDIR)/$_.pm" )}
+	'Git',
+	'Git/Config',
+	);
 
 # We come with our own bundled Error.pm. It's not in the set of default
 # Perl modules so install it if it's not available on the system yet.
diff --git a/t/t9700-perl-git.sh b/t/t9700-perl-git.sh
index b81d5df..2f53d00 100755
--- a/t/t9700-perl-git.sh
+++ b/t/t9700-perl-git.sh
@@ -37,8 +37,16 @@ test_expect_success \
      git config --add test.int 2k
      '
 
+export PERL5LIB="$TEST_DIRECTORY/t9700:$GITPERLLIB:$PERL5LIB"
+
 test_external_without_stderr \
     'Perl API' \
     perl "$TEST_DIRECTORY"/t9700/test.pl
 
+rm -rf .git
+
+test_external_without_stderr \
+    'config API' \
+    perl "$TEST_DIRECTORY"/t9700/config.t
+
 test_done
diff --git a/t/t9700/TestUtils.pm b/t/t9700/TestUtils.pm
new file mode 100644
index 0000000..72a386d
--- /dev/null
+++ b/t/t9700/TestUtils.pm
@@ -0,0 +1,77 @@
+#!/usr/bin/perl
+
+package TestUtils;
+
+use Carp;
+use base qw(Exporter);
+BEGIN {
+	our @EXPORT = qw(mk_tmp_repo in_empty_repo tmp_git random_port_pair);
+	$SIG{__WARN__} = sub {
+	    my $i = 0;
+	    while (my $caller = caller($i)) {
+		    if ($caller eq "Test::More") {
+			    return 0;
+		    }
+		    $i++;
+	    }
+	    my $culprit = caller;
+	    if ($culprit =~ m{Class::C3}) {
+		return 1;
+	    }
+	    else {
+		print STDERR "*** WARNING FROM $culprit FOLLOWS ***\n";
+	    }
+	    Carp::cluck(@_);
+	    print STDERR "*** END OF STACK DUMP ***\n";
+	    1
+	}
+	unless $ENV{NO_WARNING_TRACES};
+}
+
+use Cwd qw(fast_abs_path);
+use File::Temp qw(tempdir);
+
+sub mk_tmp_repo {
+	my $temp_dir = tempdir( "tmpXXXXX", CLEANUP => 1 );
+	system("cd $temp_dir; git-init >/dev/null 2>&1") == 0
+		or die "git-init failed; rc=$?";
+	fast_abs_path($temp_dir);
+}
+
+use Cwd;
+
+sub in_empty_repo {
+	my $coderef = shift;
+	my $old_wd = getcwd;
+	my $path = mk_tmp_repo();
+	chdir($path);
+	$coderef->();
+	chdir($old_wd);
+}
+
+use Git;
+sub tmp_git {
+	Git->repository(mk_tmp_repo);
+}
+
+# return an array ref of two unprivileged ports
+sub random_port_pair {
+	my $port = int(rand(2**16-1024-1)+1024);
+	[ $port, $port + 1 ];
+}
+
+1;
+
+# Local Variables:
+#   mode: cperl
+#   cperl-brace-offset: 0
+#   cperl-continued-brace-offset: 0
+#   cperl-indent-level: 8
+#   cperl-label-offset: -8
+#   cperl-merge-trailing-else: nil
+#   cperl-continued-statement-offset: 8
+#   cperl-indent-parens-as-block: t
+#   cperl-indent-wrt-brace: nil
+# End:
+#
+# vim: vim:tw=78:sts=0:noet
diff --git a/t/t9700/config.t b/t/t9700/config.t
new file mode 100644
index 0000000..395a5c9
--- /dev/null
+++ b/t/t9700/config.t
@@ -0,0 +1,127 @@
+#!/usr/bin/env perl -- -w
+
+use TestUtils;
+use Test::More no_plan;
+use strict;
+
+use Error qw(:try);
+
+use_ok("Git::Config");
+
+in_empty_repo sub {
+	my $git = Git->repository;
+	$git->command_oneline("config", "foo.bar", "baz");
+	$git->command_oneline("config", "list.value", "one");
+	$git->command_oneline("config", "--add", "list.value", "two");
+	$git->command_oneline("config", "foo.intval", "12g");
+	$git->command_oneline("config", "foo.false.val", "false");
+	$git->command_oneline("config", "foo.true.val", "yes");
+
+	my $conf = Git::Config->new();
+	ok($conf, "constructed a new Git::Config");
+	isa_ok($conf, "Git::Config", "Git::Config->new()");
+
+	is($conf->config("foo.bar"), "baz", "read single line");
+	$conf->config("foo.bar", "frop");
+	like($git->command_oneline("config", "foo.bar"), qr/frop/,
+		"->config() has immediate effect");
+	$conf->autoflush(0);
+	is_deeply(
+		[$conf->config("list.value")],
+		[qw(one two)],
+		"read multi-value item",
+	);
+
+	eval {
+		my $val = $conf->config("list.value");
+	};
+	like ($@, qr{multiple}i,
+	      "produced an error reading a list into a scalar");
+
+	eval {
+		$conf->config("list.value" => "single");
+	};
+	like($@, qr{multiple}i,
+	     "produced an error replacing a list with a scalar");
+
+	ok(eval { $conf->config("foo.bar", [ "baz", "frop"]); 1 },
+		"no error replacing a scalar with a list");
+
+	like($git->command_oneline("config", "foo.bar"), qr/frop/,
+		"->config() no immediate effect with autoflush = 0");
+
+	$conf->flush;
+
+	like($git->command("config", "--get-all", "foo.bar"),
+		qr/baz\s*frop/,
+		"->flush()");
+
+	$conf->config("x.y$$" => undef);
+	my $x = $conf->config("x.y$$");
+	ok(!defined $x, "unset items return undef in scalar context");
+	my @x = $conf->config("x.y$$");
+	ok(@x == 0, "unset items return empty list in list context");
+
+	$conf->config("foo.bar" => undef);
+	@x = $conf->config("foo.bar");
+	ok(@x == 0, "deleted items appear empty immediately");
+	$conf->flush;
+	ok(!eval {
+		$git->command("config", "--get-all", "foo.bar");
+		1;
+	}, "deleted items are removed from the config file");
+
+	$conf->type("foo.intval", "integer");
+	is($conf->type("foo.intval"), "integer",
+	   "->type()");
+	is($conf->config("foo.intval"), 12*1024*1024*1024,
+	   "integer thaw");
+	$conf->config("foo.intval", 1025*1024);
+	$conf->type("foo.intval", "string");
+	is($conf->config("foo.intval"), "1025k",
+	   "integer freeze");
+
+	$conf->type("foo.*.val", "boolean");
+	is($conf->type("foo.this.val"), "boolean",
+	   "wildcard types");
+	is($conf->config("foo.true.val"), 1,
+	   "boolean thaw - 'yes'");
+	is($conf->config("foo.false.val"), 0,
+	   "boolean thaw - 'false'");
+	my $unset = $conf->config("foo.bar.val");
+	is($unset, undef,
+	   "boolean thaw - not present");
+
+	$git->command_oneline("config", "foo.intval", "12g");
+	$git->command_oneline("config", "foo.falseval", "false");
+	$git->command_oneline("config", "foo.trueval", "on");
+
+	SKIP:{
+		if (eval {
+			$git->command(
+				"config", "--global",
+				"--get-all", "foo.bar"
+			       );
+			1;
+		}) {
+			skip "someone set foo.bar in global config", 1;
+		}
+		my @foo_bar = $conf->global("foo.bar");
+		is_deeply(\@foo_bar, [], "->global() reading only");
+	}
+};
+
+
+# Local Variables:
+#   mode: cperl
+#   cperl-brace-offset: 0
+#   cperl-continued-brace-offset: 0
+#   cperl-indent-level: 8
+#   cperl-label-offset: -8
+#   cperl-merge-trailing-else: nil
+#   cperl-continued-statement-offset: 8
+#   cperl-indent-parens-as-block: t
+#   cperl-indent-wrt-brace: nil
+# End:
+#
+# vim: vim:tw=78:sts=0:noet
-- 
1.6.0