#!/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; our $aliothname = 'iwj@git.debian.org'; our $aliothpath = '/git/dgit-test'; our $alioth_git = "git+ssh://$aliothname/$aliothpath"; our $alioth_sshtestbodge = [$aliothname,$aliothpath]; our (@dget_opts) = qw(-u); 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,$dsc); sub parsecontrol { my $c = Dpkg::Control::Hash->new(); $c->load(@_) or return undef; return $c; } 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); $dsc = Dpkg::Control::Hash->new(allow_pgp=>1); $dsc->parse($dscfh, 'dsc') or die "parsing of $dscurl failed\n"; #print DEBUG Dumper($dsc); my $fmt = $dsc->{Format}; die "unsupported format $fmt, sorry\n" unless $fmt eq '1.0'; } sub check_for_git () { # returns 0 or 1 my $cmd= "ssh $alioth_sshtestbodge->[0] '". " set -e; cd /git/dgit-test;". " if test -d $package.git; then echo 1; else echo 0; fi". "'"; #print DEBUG "$cmd\n"; open P, "$cmd |" or die $!; $!=0; $?=0; my $r =
; close P; #print STDERR ">$r<\n"; die "$r $! $?" unless $r =~ m/^[01]$/; return $r+0; } sub runcmd { $!=0; $?=0; die "@_ $! $?" if system @_; } sub cmdoutput { open P, "-|", @_ or die $!; my $d; $!=0; $?=0; { local $/ = undef; $d =
; }
die if P->error;
close P or die "@_ $? $!";
chomp $d;
return $d;
}
our ($dsc_hash,$lastupl_hash);
sub generate_commit_from_dsc () {
my $ud = '.git/dgit/unpack';
rmtree($ud);
mkpath '.git/dgit';
mkdir $ud or die $!;
chdir $ud or die $!;
my @files;
foreach (split /\n/, ($dsc->{'Checksums-Sha256'} || $dsc->{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), @dget_opts, qw(--), $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 -q);
rmtree('.git/objects');
symlink '../../../../objects','.git/objects' or die $!;
runcmd qw(git add -Af);
my $tree = cmdoutput qw(git write-tree);
chomp $tree; $tree =~ m/^\w+$/ or die "$tree ?";
runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
my $clogp = parsecontrol('../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 <