[PATCH 1/4] Git.pm: config_boolean() -> config_bool()

@@ -297,9 +297,9 @@ sub update_remote {
 	} elsif ($name eq 'default') {
 		undef @remotes;
 		for (sort keys %$remote) {
-			my $do_fetch = $git->config_boolean("remote." . $_ .
+			my $do_fetch = $git->config_bool("remote." . $_ .
 						    ".skipDefaultUpdate");
-			if (!defined($do_fetch) || $do_fetch ne "true") {
+			unless ($do_fetch) {
 				push @remotes, $_;
 			}
 		}

@@ -516,9 +516,11 @@ sub config {
 }
 
 
-=item config_boolean ( VARIABLE )
+=item config_bool ( VARIABLE )
 
-Retrieve the boolean configuration C<VARIABLE>.
+Retrieve the bool configuration C<VARIABLE>. The return value
+is usable as a boolean in perl (and C<undef> if it's not defined,
+of course).
 
 Must be called on a repository instance.
 

@@ -526,14 +528,16 @@ This currently wraps command('config') s
 
 =cut
 
-sub config_boolean {
+sub config_bool {
 	my ($self, $var) = @_;
 	$self->repo_path()
 		or throw Error::Simple("not a repository");
 
 	try {
-		return $self->command_oneline('config', '--bool', '--get',
+		my $var = $self->command_oneline('config', '--bool', '--get',
 					      $var);
+		return undef unless defined $var;
+		return $var eq 'true';
 	} catch Git::Error::Command with {
 		my $E = shift;
 		if ($E->value() == 1) {

@@ -36,6 +36,7 @@ static int update_info_refs(int force)
 	info_ref_fp = fopen(path1, "w");
 	if (!info_ref_fp)
 		return error("unable to update %s", path0);
+	head_ref(add_info_ref, NULL);
 	for_each_ref(add_info_ref, NULL);
 	fclose(info_ref_fp);
 	rename(path1, path0);

@@ -80,6 +80,7 @@ git-merge-resolve
 git-merge-stupid
 git-merge-subtree
 git-mergetool
+git-mirror
 git-mktag
 git-mktree
 git-name-rev

@@ -513,6 +513,12 @@ log.showroot::
 	Tools like gitlink:git-log[1] or gitlink:git-whatchanged[1], which
 	normally hide the root commit will now show it. True by default.
 
+mirror.allowed::
+	If true, gitlink:git-mirror[1] will be allowed to run on the
+	repository.  Please see its documentation for all the implications.
+
+mirror.
+
 merge.summary::
 	Whether to include summaries of merged commits in newly created
 	merge commit messages. False by default.

@@ -0,0 +1,54 @@
+git-mirror(1)
+============
+
+NAME
+----
+git-mirror - Exactly mirror another repository
+
+
+SYNOPSIS
+--------
+'git-mirror' <repository>
+
+
+DESCRIPTION
+-----------
+Completely mirrors another repository into the local repository.
+
+All heads and tags from the other repository are copied to the
+local repository without any regard for merging.  This means
+that all heads and tags will be FORCIBLY CHANGED in the local
+repository to make them match the other repository.  Any local
+ref or tags which has been deleted from the other repository
+will also be deleted from the local repository.
+
+After mirroring is complete, in case the 'HEAD' symref does not
+seem to match locally the remote one, `git-mirror` will attempt
+to guess which head is now the 'HEAD'; if there are more candidates,
+one will be chosen roughly randomly.
+
+
+CONFIGURATION
+-------------
+
+Prior to updating the local repository 'git-mirror' requires
+that the user set 'mirror.allowed' to a true value in the local
+repository's config file.  This is considered to be a safety
+latch which is intended to prevent accidental overwriting of
+the local repository.
+
+
+SEE ALSO
+--------
+gitlink:git-fetch[1]
+gitlink:git-prune[1]
+gitlink:git-repack[1]
+
+
+Author
+------
+Written by Shawn Pearce <spearce@spearce.org> and Petr Baudis <pasky@suse.cz>
+
+GIT
+---
+Part of the gitlink:git[7] suite

@@ -208,7 +208,7 @@ SCRIPT_PERL = \
 	git-archimport.perl git-cvsimport.perl git-relink.perl \
 	git-cvsserver.perl git-remote.perl \
 	git-svnimport.perl git-cvsexportcommit.perl \
-	git-send-email.perl git-svn.perl
+	git-send-email.perl git-svn.perl git-mirror.perl
 
 SCRIPT_PYTHON = \
 	git-p4import.py

@@ -0,0 +1,110 @@
+#!/usr/bin/env perl
+# Copyright (C) 2006, Shawn Pearce <spearce@spearce.org>
+# This file is licensed under the GPL v2, or a later version
+# at the discretion of Linus.
+
+use warnings;
+use strict;
+use Git;
+
+my $remote = shift || 'origin';
+my $repo = Git->repository();
+
+# Verify its OK to execute in this repository.
+#
+unless ($repo->config_bool('mirror.allowed')) {
+	print STDERR <<EOF;
+Error: mirror.allowed is false.
+Error:
+Error: For safety reasons please set mirror.allowed in this repository's
+Error: config before using this command.
+Error:
+Error: Unless you are using this repository ONLY for mirroring another
+Error: repository you probably don't want to do this. Please see the
+Error: manpage for more details.
+EOF
+	exit 1;
+}
+
+# Build our list of refs.
+#
+my $remote_refs = ls_refs($repo, $remote);
+my $local_refs = ls_refs($repo, $repo->repo_path());
+my $remote_HEAD = $remote_refs->{'HEAD'};
+my $local_HEAD = $local_refs->{'HEAD'};
+delete $remote_refs->{'HEAD'};
+delete $local_refs->{'HEAD'};
+
+# Execute the fetch for any refs which differ from our own.
+# We don't worry about trying to optimize for rewinds or
+# exact branch copies as they are rather uncommon.
+#
+my @to_fetch;
+while (my ($ref, $hash) = each %$remote_refs) {
+	push(@to_fetch, "$ref:$ref")
+		if (!$local_refs->{$ref} || $local_refs->{$ref} ne $hash);
+}
+if (@to_fetch) {
+	git_cmd_try {
+		$repo->command_noisy('fetch',
+			'--force',
+			'--update-head-ok',
+			$remote, sort @to_fetch);
+	} '%s failed w/ code %d';
+} else {
+	print "No changed refs.  Skipping fetch.\n";
+}
+
+# See what the remote has HEAD pointing at and update our local
+# HEAD to point at some ref which points at the same hash.
+# Prefer to keep HEAD the same if possible to avoid HEAD drifting
+# between different branches.
+# Note that with dumb protocols, we don't get to *know* HEAD implicitly
+# with git-ls-remote...
+#
+git_cmd_try {
+	my $headref = $repo->command_oneline('symbolic-ref', 'HEAD');
+	my $HEAD;
+	if (not $remote_refs->{$headref}) {
+		$HEAD = 'refs/heads/master';
+		print "Local HEAD branch disappeared, falling back to refs/heads/master\n";
+	} elsif ($remote_HEAD and $remote_refs->{$headref} ne $remote_HEAD) {
+		my %by_hash = map {$remote_refs->{$_} => $_}
+			grep {m,^refs/heads/,}
+			sort keys %$remote_refs;
+		$HEAD = $by_hash{$remote_HEAD};
+		if ($HEAD) {
+			print "Setting HEAD to $HEAD ($remote_HEAD)\n";
+		} else {
+			print "Remote HEAD ($remote_HEAD) does not match any remote branch\n";
+		}
+	}
+	if ($HEAD) {
+		$repo->command_noisy('symbolic-ref', 'HEAD', $HEAD);
+	}
+} '%s failed w/ code %d';
+
+# Delete any local refs which the server no longer contains.
+#
+foreach my $ref (keys %$local_refs) {
+	next if $remote_refs->{$ref};
+	print "Removing $ref\n";
+	git_cmd_try {
+		$repo->command_noisy('update-ref', '-d', $ref, $local_refs->{$ref});
+	} '%s failed w/ code %d';
+}
+
+sub ls_refs {
+	my $repo = shift;
+	my $name = shift;
+	my $refs = $repo->remote_refs($name);
+	my @interesting = grep {
+		$_ eq 'HEAD' or (/^refs\// and not /\.\./ and not /\^{}$/);
+	} keys %$refs;
+
+	my %refs2;
+	# This funky-looking expression puts @interesting-subset of %$refs
+	# to %refs2.
+	@refs2{@interesting} = @{$refs}{@interesting};
+	\%refs2;
+}

@@ -128,10 +128,7 @@ sub update_ls_remote {
 	return if (($harder == 0) ||
 		   (($harder == 1) && exists $info->{'LS_REMOTE'}));
 
-	my @ref = map {
-		s|^[0-9a-f]{40}\s+refs/heads/||;
-		$_;
-	} $git->command(qw(ls-remote --heads), $info->{'URL'});
+	my @ref = keys %{$git->remote_refs($info->{'URL'}, [ 'heads' ])};
 	$info->{'LS_REMOTE'} = \@ref;
 }
 

@@ -51,7 +51,7 @@ require Exporter;
 # Methods which can be called as standalone functions as well:
 @EXPORT_OK = qw(command command_oneline command_noisy
                 command_output_pipe command_input_pipe command_close_pipe
-                version exec_path hash_object git_cmd_try);
+                version exec_path hash_object git_cmd_try remote_refs);
 
 
 =head1 DESCRIPTION

@@ -550,6 +550,59 @@ sub config_bool {
 }
 
 
+=item remote_refs ( REPOSITORY [, GROUPS [, REFGLOBS ] ] )
+
+This function returns a hashref of refs stored in a given remote repository.
+The hash is in the format C<refname =\> hash>. For tags, the C<refname> entry
+contains the tag object while a C<refname^{}> entry gives the tagged objects.
+
+C<REPOSITORY> has the same meaning as the appropriate C<git-ls-remote>
+argument; either an URL or a remote name (if called on a repository instance).
+C<GROUPS> is an optional arrayref that can contain 'tags' to return all the
+tags and/or 'heads' to return all the heads. C<REFGLOB> is an optional array
+of strings containing a shell-like glob to further limit the refs returned in
+the hash; the meaning is again the same as the appropriate C<git-ls-remote>
+argument.
+
+This function may or may not be called on a repository instance. In the former
+case, remote names as defined in the repository are recognized as repository
+specifiers.
+
+=cut
+
+sub remote_refs {
+	my ($self, $repo, $groups, $refglobs) = _maybe_self(@_);
+	my @args;
+	if (ref $groups eq 'ARRAY') {
+		foreach (@$groups) {
+			if ($_ eq 'heads') {
+				push (@args, '--heads');
+			} elsif ($_ eq 'tags') {
+				push (@args, '--tags');
+			} else {
+				# Ignore unknown groups for future
+				# compatibility
+			}
+		}
+	}
+	push (@args, $repo);
+	if (ref $refglobs eq 'ARRAY') {
+		push (@args, @$refglobs);
+	}
+
+	my @self = $self ? ($self) : (); # Ultra trickery
+	my ($fh, $ctx) = Git::command_output_pipe(@self, 'ls-remote', @args);
+	my %refs;
+	while (<$fh>) {
+		chomp;
+		my ($hash, $ref) = split(/\t/, $_, 2);
+		$refs{$ref} = $hash;
+	}
+	Git::command_close_pipe(@self, $fh, $ctx);
+	return \%refs;
+}
+
+
 =item ident ( TYPE | IDENTSTR )
 
 =item ident_person ( TYPE | IDENTSTR | IDENTARRAY )