X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=dc2275da493fbd53315b80b501ca961720f60750;hb=e047a5c9931a260b730fe3beaae6eacd2c4ccec8;hp=84122dcaf76eb6979076d0173953f1c841eed7c0;hpb=2b428f38c41e7a5f3aaf867ff069632c9e33a8bd;p=dgit.git diff --git a/dgit b/dgit index 84122dca..dc2275da 100755 --- a/dgit +++ b/dgit @@ -5,21 +5,26 @@ 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 $mirror = 'http://mirror.relativity.greenend.org.uk/mirror/debian-ftp/'; our $suite = 'sid'; -our $package = '2vcard'; +our $package; our $aliothname = 'iwj@git.debian.org'; our $aliothpath = '/git/dgit-test'; -our $alioth_git = 'git+ssh://$aliothname/$aliothpath'; +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 uploadingbranch () { return "uploading/$suite"; } +sub uploadbranch () { return "upload/$suite"; } our $ua; @@ -28,104 +33,310 @@ sub url_get { $ua = LWP::UserAgent->new(); $ua->env_proxy; } -print DEBUG "fetching @_...\n"; + 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 $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"; - my $dscurl = $1; -print DEBUG Dumper($pdodata, $&, $dscurl); - my $dscdata = url_get($dscurl); + 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); - 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}; +#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'; - 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 $!; + 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;
+ return $r+0;
}
-sub runcmd {
- $!=0; $?=0;
- die "$! $?" if system @_;
+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);
}
-our ($dsc,$dsc_hash);
+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 <