X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=dc2275da493fbd53315b80b501ca961720f60750;hb=e047a5c9931a260b730fe3beaae6eacd2c4ccec8;hp=4d9a71a8c3682049aa23223f13e5f99be075d167;hpb=90d348ace9e603191cfc054fa0c432bfd56ae588;p=dgit.git diff --git a/dgit b/dgit index 4d9a71a8..dc2275da 100755 --- a/dgit +++ b/dgit @@ -10,10 +10,9 @@ 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'; @@ -42,24 +41,49 @@ sub url_get { 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"; - $dscurl = $1; + 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 $!; @@ -87,29 +111,36 @@ sub check_for_git () { 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'; +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})) { @@ -128,19 +159,7 @@ sub generate_commit_from_dsc () { 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 ?"; + 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}; @@ -197,6 +216,16 @@ END my $lastupl_ref = "refs/remotes/$remotename/upload/$suite"; +sub rev_parse ($) { + return cmdoutput qw(git rev-parse --), "$_[0]~0"; +} + +sub is_fast_fwd ($$) { + my ($ancestor,$child) = @_; + my $mb = cmdoutput qw(git merge-base), $dsc_hash, $lastupl_hash; + return rev_parse($mb) eq rev_parse($ancestor); +} + sub fetch_from_archive () { # ensures that $lastupl_ref is what is actually in the archive, # one way or another @@ -211,36 +240,15 @@ sub fetch_from_archive () { $hash = generate_commit_from_dsc(); } if ($lastupl_hash) { - my $mb = cmdoutput qw(git merge-base), $dsc_hash, $lastupl_hash; die "not fast forward on last upload branch!". " (archive's version left in DGIT_ARCHIVE)" - unless $mb eq $lastupl_hash; + unless is_fast_fwd($lastupl_hash, $dsc_hash); } if ($lastupl_ref ne $hash) { cmdoutput qw(git update-ref -m), 'dgit fetch', $lastupl_ref, $hash; } } -#sub combine () { -# if ( - -# runcmd qw(git write-tree - - - runcmd qw(mkdir -p ''); -# chdir '.git/dgit/unpack' or die $!; - - -# with_tmpdir($td,{ - -# }); - -# } - -# open P, "-|", qw(git rev-parse --), $dsc_hash; - -#} - sub clone () { get_archive_dsc(); $dsc_hash = $dsc->{'Vcs-git-master'}; @@ -280,6 +288,55 @@ sub clone () { sub fetch () { } - -#print Dumper(get_archive_dsc()); -clone(); + +sub push () { + runcmd qw(git diff --quiet HEAD); + my $clogp = parsechangelog(); + $package = $clogp->{Source}; + my $dscfn = "${package}_$clogp->{Version}.dsc"; + stat $dscfn or die "$dscfn $!"; + $dsc = parsecontrol("../$dscfn"); + prep_ud(); + chdir $ud or die $!; + print "checking that $dscfn corresponds to HEAD\n"; + runcmd qw(dpkg-source -x --), "../../../../$dscfn"; + my $tree = mktree_in_ud_from_only_subdir(); + chdir '../../../..' or die $!; + runcmd qw(git diff --exit-code), $tree; + runcmd qw(git fetch), $alioth_git, + map { "$_:refs/remotes/$remotename/$_" } + (mainbranch(), uploadbranch()); + die <