Test::AutoBuild::Repository::Darcs - A repository for Darcs

  use Test::AutoBuild::Repository::Darcs

# -*- perl -*-
#
# Test::AutoBuild::Repository::Darcs by Daniel Berrange
#
# Copyright (C) 2004 Daniel Berrange
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# $Id: Darcs.pm,v 1.1 2007/12/10 04:45:18 danpb Exp $

package Test::AutoBuild::Repository::Darcs;

use base qw(Test::AutoBuild::Repository);
use warnings;
use strict;
use Log::Log4perl;
use XML::Simple;

use Test::AutoBuild::Change;
use Date::Manip;

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@_);

    bless $self, $class;

    return $self;
}


sub export {
    my $self = shift;
    my $runtime = shift;
    my $src = shift;
    my $dst = shift;
    my $logfile = shift;
    my $log = Log::Log4perl->get_logger();

    # Don't support using multiple paths yet
    my $changed = 0;
    my $current;
    if (-d $dst) {
	$current = $self->_get_current($dst, $logfile);
	$log->debug("Current changeset in $dst is $current");
	$self->_pull_repository($src, $dst, $logfile);
    } else {
	$self->_get_repository($src, $dst, $logfile);
	$changed = 1;
    }

    my %changes;

    my $all_changes = $self->_get_changes($dst, $logfile);

    my $sync_to;
    my $found = 0;
    # Find the first patch newer than our timestamp
    foreach (sort { $all_changes->{$a}->date <=> $all_changes->{$b}->date} keys %{$all_changes}) {
	#$log->debug("Compare changelist $_ at " . $all_changes->{$_}->date . " to " . $runtime->timestamp);
	if ($all_changes->{$_}->date > $runtime->timestamp) {
	    $sync_to = $_;
	    last;
	}
	if ($found) {
	    $changes{$all_changes->{$_}->number} = $all_changes->{$_};
	    $changed = 1;
	}
	$found = 1 if defined $current && $current eq $_;
    }

    if ($sync_to) {
	$log->debug("Sync to change $sync_to");

	# Revert any changed local files otherwise unpull will complain bitterly
	my ($output, $errors) = $self->_run(["darcs", "revert", "--all"], $dst, $logfile);

	# Suck suck suck. Darcs prompts interactively on unpull
	# if you've just donea revert, even if you tell it --all
	unlink "$dst/_darcs/patches/unrevert";

	# Finally unpull, upto the change we actually want
	($output, $errors) = $self->_run(["darcs", "unpull", "--all", "--match", "hash $sync_to"], $dst, $logfile);
    } else {
	$log->debug("Working directory already synced to neccessary change");
    }

    return ($changed, \%changes);
}

sub _get_repository {
    my $self = shift;
    my $path = shift;
    my $dest = shift;
    my $logfile = shift;
    my $log = Log::Log4perl->get_logger();

    my $base_url = $self->option("base-url");
    die "base-url option is required" unless $base_url;
    $base_url =~ s,\/$,,;
    $path =~ s,^/,,;
    my $url = "$base_url/$path";

    $log->info("Cloning repository at $url");
    my ($result, $errors) = $self->_run(["darcs", "get", "--complete", $url, $dest], undef, $logfile);
}

sub _pull_repository {
    my $self = shift;
    my $path = shift;
    my $dest = shift;
    my $logfile = shift;
    my $log = Log::Log4perl->get_logger();

    my $base_url = $self->option("base-url");
    die "base-url option is required" unless $base_url;
    $base_url =~ s,\/$,,;
    $path =~ s,^/,,;
    my $url = "$base_url/$path";

    $log->info("Pulling from repository at $url");
    my ($result, $errors) = $self->_run(["darcs", "pull", "--no-summary", "--all", "$url"], $dest, $logfile);
}

sub _get_current {
    my $self = shift;
    my $path = shift;
    my $logfile = shift;

    my $log = Log::Log4perl->get_logger();
    my ($output, $errors) = $self->_run(["darcs", "changes", "--xml-output", "--last=1"], $path, $logfile);

    my $xml = XMLin($output, ForceArray => 1);
    my $change = $xml->{patch}->[0];
    return $change->{hash};
}

sub _get_changes {
    my $self = shift;
    my $path = shift;
    my $logfile = shift;

    my $log = Log::Log4perl->get_logger();

    my ($output, $errors) = $self->_run(["darcs", "changes", "--xml-output"], $path, $logfile);

    my $xml = XMLin($output, ForceArray => 1);

    my %changes;
    foreach my $change (@{$xml->{patch}}) {
	my $date = ParseDateString($change->{date});
	die "cannot parse date '" . $change->{date} . "'" unless $date;
	my $time = UnixDate($date, "%o");

	$changes{$change->{hash}} = Test::AutoBuild::Change->new(number => $change->{date},
								 date => $time,
								 user => $change->{author},
								 description => $change->{name}->[0],
								 files => []);
    }
    return \%changes;
}

1 # So that the require or use succeeds.

__END__