#!/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 $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 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; } sub parsecontrol { my $c = Dpkg::Control::Hash->new(); $c->load(@_) or return undef; return $c; } sub parsechangelog { my $c = Dpkg::Control::Hash->new(); my $p = new IO::File '-|', qw(dpkg-parsechangelog) or die $!; $c->parse($p); $?=0; $!=0; close $p or die "$! $?"; return $c; } sub get_archive_dsc () { my $rmad = cmdoutput qw(rmadison -asource),"-s$suite",$package; $rmad =~ m/^ \s*( [^ \t|]+ )\s* \| \s*( [^ \t|]+ )\s* \| \s*( [^ \t|]+ )\s* \| \s*( [^ \t|]+ )\s* /x or die "$rmad $?"; $1 eq $package or die "$rmad $package ?"; my $vsn = $2; $3 eq $suite or die "$rmad $suite ?"; $4 eq 'source' or die "$rmad ?"; # fixme it does not show us the component ? my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1); $dscurl = "$mirror/pool/main/$prefix/$package/${package}_$vsn.dsc"; #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;
}
our ($dsc_hash,$lastupl_hash);
our $ud = '.git/dgit/unpack';
sub prep_ud () {
rmtree($ud);
mkpath '.git/dgit';
mkdir $ud or die $!;
}
sub mktree_in_ud_from_only_subdir () {
# changes into the subdir
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 ?";
return ($tree,$dir);
}
sub generate_commit_from_dsc () {
prep_ud();
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 ($tree,$dir) = mktree_in_ud_from_only_subdir();
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 <