git-mirror.pl

#!/usr/bin/env perl
# Copyright (C) 2006, Shawn Pearce <[email protected]>
# This file is licensed under the GPL v2, or a later version
# at the discretion of Linus.

package Git;
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;
}

use warnings;
use strict;
use Git;

my $remote = shift || 'origin';
my $repo = Git->repository();

# 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;
}