#!/usr/bin/perl -w use strict; use IO::Handle; use Data::Dumper; use LWP::UserAgent; use Dpkg::Control::Hash; use File::Path; use POSIX; open DEBUG, ">&STDERR" or die $!; our $pdo = 'http://packages.debian.org/'; #our $mirror = 'http://mirror.relativity.greenend.org.uk/mirror/debian-ftp/'; our $suite = 'sid'; our $package = '2vcard'; our $aliothname = 'iwj@git.debian.org'; our $aliothpath = '/git/dgit-test'; our $alioth_git = 'git+ssh://$aliothname/$aliothpath'; our $alioth_sshtestbodge = [$aliothname,$aliothpath]; our $remotename = 'dgit'; sub mainbranch () { return "$suite"; } sub uploadbranch () { return "upload/$suite"; } our $ua; sub url_get { if (!$ua) { $ua = LWP::UserAgent->new(); $ua->env_proxy; } print DEBUG "fetching @_...\n"; my $r = $ua->get(@_) or die $!; die "$_[0]: ".$r->status_line."; failed.\n" unless $r->is_success; return $r->decoded_content(); } our ($dscdata,$dscurl); sub get_archive_dsc () { my $pdourl = "$pdo/source/$suite/$package"; my $pdodata = url_get($pdourl); # FFS. The Debian archive has no sane way to find what # version is currently the tip in any branch (aka, what # is the current version in any suite). $pdodata =~ m{ Download\ \Q$package\E .* \\2\ }msx or die "screenscraping of $pdourl failed :-(\n"; $dscurl = $1; print DEBUG Dumper($pdodata, $&, $dscurl); $dscdata = url_get($dscurl); my $dscfh = new IO::File \$dscdata, '<' or die $!; print DEBUG Dumper($dscdata, $dscfh); my $dscp = Dpkg::Control::Hash->new(allow_pgp=>1); $dscp->parse($dscfh, 'dsc') or die "parsing of $dscurl failed\n"; # my $dscf = $dscp->{'fields'}; my $dscf=$dscp; print DEBUG Dumper($dscp,$dscf); my $fmt = $dscf->{Format}; die "unsupported format $fmt, sorry\n" unless $fmt eq '1.0'; return $dscf; } sub check_for_git () { # returns 0 or 1 open P, "ssh $alioth_sshtestbodge->[0] '". "set -e; cd /git/dgit-test;". "if test -d $package.git; then echo 1; else echo 0; fi". "' |" or die $!; $!=0; $?=0; my $r =
; close P;
die "$r $! $?" unless $r =~ m/^[01]$/;
return !!$r;
}
sub runcmd {
$!=0; $?=0;
die "$! $?" if system @_;
}
our ($dsc,$dsc_hash,$lastupl_hash);
sub generate_commit_from_dsc () {
my $ud = '.git/dgit/unpack';
remove_tree($ud);
mkpath '.git/dgit';
mkdir $ud or die $!;
chdir $ud or die $!;
my @files;
foreach (split /\n/, ($dsch->{Checksums-Sha256} || $dsch->{Files})) {
next unless m/\S/;
m/^\w+ \d+ (\S+)$/ or die "$_ ?";
my $f = $1;
die if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
push @files, $f;
link "../../../$f", $f
or $!==&ENOENT
or die "$f $!";
}
runcmd qw(dget --), $dscurl;
foreach my $f (grep { m/\.tar\.gz$/ } @files) {
link $f, "../../../$f"
or $!==&EEXIST
or die "$f $!";
}
my (@dirs) = <*/.>;
die unless @dirs==1;
$dirs[0] =~ m#^([^/]+)/\.$# or die;
my $dir = $1;
chdir $dir or die "$dir $!";
die if stat '.git';
die $! unless $!==&ENOENT;
runcmd qw(git init);
remove_tree(.git/objects);
symlink '../../objects','.git/objects' or die $!;
runcmd qw(git add -Af);
my $tree = cmdoutput qw(git write-tree);
chomp $tree or die;
runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
my $clogp = Dpkg::Control::Hash->new();
$clogp->parse('../changelog.tmp','changelog') or die;
my $date = cmdoutput qw(date), '+%s %z', qw(-d),$clogp->{Date};
my $author = $clogp->{Maintainer};
$author =~ s#,.*##ms;
my $authline = "$author $date";
$authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or die $authline;
open C, ">../commit.tmp" or die $!;
print C "tree $tree\n" or die $!;
print C "parent $lastupl_hash\n" or die $! if defined $lastupl_hash;
print C <