X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=97bc187bfca9ab1e236ede6555d4a15c40659a19;hb=25be7c924fe6d7cc12725f54f1f1c78e5981df6f;hp=e3fc0eefd33bb6bf0372044f070cc7db03e0ad15;hpb=5e359c5927e8df1a0ce1652a4b83436e9d5d3410;p=dgit.git

diff --git a/dgit b/dgit
index e3fc0eef..97bc187b 100755
--- a/dgit
+++ b/dgit
@@ -34,6 +34,8 @@ use Config;
 
 our $our_version = 'UNRELEASED'; ###substituted###
 
+our $rpushprotovsn = 2;
+
 our $isuite = 'unstable';
 our $idistro;
 our $package;
@@ -117,9 +119,14 @@ sub stripepoch ($) {
     return $vsn;
 }
 
+sub srcfn ($$) {
+    my ($vsn,$sfx) = @_;
+    return "${package}_".(stripepoch $vsn).$sfx
+}
+
 sub dscfn ($) {
     my ($vsn) = @_;
-    return "${package}_".(stripepoch $vsn).".dsc";
+    return srcfn($vsn,".dsc");
 }
 
 our $us = 'dgit';
@@ -175,6 +182,13 @@ sub changedir ($) {
     chdir $newdir or die "chdir: $newdir: $!";
 }
 
+sub stat_exists ($) {
+    my ($f) = @_;
+    return 1 if stat $f;
+    return 0 if $!==&ENOENT;
+    die "stat $f: $!";
+}
+
 #---------- remote protocol support, common ----------
 
 # remote push initiator/responder protocol:
@@ -212,17 +226,39 @@ sub changedir ($) {
 #
 #  > complete
 
+our $i_child_pid;
+
+sub i_child_report () {
+    # Sees if our child has died, and reap it if so.  Returns a string
+    # describing how it died if it failed, or undef otherwise.
+    return undef unless $i_child_pid;
+    my $got = waitpid $i_child_pid, WNOHANG;
+    return undef if $got <= 0;
+    die unless $got == $i_child_pid;
+    $i_child_pid = undef;
+    return undef unless $?;
+    return "build host child ".waitstatusmsg();
+}
+
 sub badproto ($$) {
     my ($fh, $m) = @_;
     fail "connection lost: $!" if $fh->error;
     fail "protocol violation; $m not expected";
 }
 
+sub badproto_badread ($$) {
+    my ($fh, $wh) = @_;
+    fail "connection lost: $!" if $!;
+    my $report = i_child_report();
+    fail $report if defined $report;
+    badproto $fh, "eof (reading $wh)";
+}
+
 sub protocol_expect (&$) {
     my ($match, $fh) = @_;
     local $_;
     $_ = <$fh>;
-    defined && chomp or badproto $fh, "eof";
+    defined && chomp or badproto_badread $fh, "protocol message";
     if (wantarray) {
 	my @r = &$match;
 	return @r if @r;
@@ -254,7 +290,7 @@ sub protocol_read_bytes ($$) {
     $nbytes =~ m/^[1-9]\d{0,5}$/ or badproto \*RO, "bad byte count";
     my $d;
     my $got = read $fh, $d, $nbytes;
-    $got==$nbytes or badproto $fh, "eof during data block";
+    $got==$nbytes or badproto_badread $fh, "data block";
     return $d;
 }
 
@@ -617,7 +653,6 @@ sub parsecontrolfh ($$;$) {
     for (;;) {
 	my %opts = ('name' => $desc);
 	$opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
-print STDERR Dumper(\%opts);
 	$c = Dpkg::Control::Hash->new(%opts);
 	$c->parse($fh,$desc) or die "parsing of $desc failed";
 	last if $allowsigned;
@@ -743,7 +778,7 @@ sub madison_parse ($) {
 	$5 eq 'source' or die "$rmad ?";
 	push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
     }
-    return sort { -version_compare_string($a->[0],$b->[0]); } @out;
+    return sort { -version_compare($a->[0],$b->[0]); } @out;
 }
 
 sub canonicalise_suite_madison ($$) {
@@ -801,7 +836,7 @@ sub archive_query_sshpsql ($$) {
            AND source.source='$package'
            AND files.filename LIKE '%.dsc';
 END
-    @rows = sort { -version_compare_string($a->[0],$b->[0]) } @rows;
+    @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
     my $digester = Digest::SHA->new(256);
     @rows = map {
 	my ($vsn,$component,$filename,$sha256sum) = @$_;
@@ -859,7 +894,7 @@ sub archive_query_dummycat ($$) {
     }
     C->error and die "$dpath: $!";
     close C;
-    return sort { -version_compare_string($a->[0],$b->[0]); } @rows;
+    return sort { -version_compare($a->[0],$b->[0]); } @rows;
 }
 
 sub canonicalise_suite () {
@@ -946,6 +981,12 @@ sub prep_ud () {
     mkdir $ud or die $!;
 }
 
+sub mktree_in_ud_here () {
+    runcmd qw(git init -q);
+    rmtree('.git/objects');
+    symlink '../../../../objects','.git/objects' or die $!;
+}
+
 sub mktree_in_ud_from_only_subdir () {
     # changes into the subdir
     my (@dirs) = <*/.>;
@@ -953,11 +994,8 @@ sub mktree_in_ud_from_only_subdir () {
     $dirs[0] =~ m#^([^/]+)/\.$# or die;
     my $dir = $1;
     changedir $dir;
-    fail "source package contains .git directory" if stat '.git';
-    die $! unless $!==&ENOENT;
-    runcmd qw(git init -q);
-    rmtree('.git/objects');
-    symlink '../../../../objects','.git/objects' or die $!;
+    fail "source package contains .git directory" if stat_exists '.git';
+    mktree_in_ud_here();
     runcmd @git, qw(add -Af);
     my $tree = cmdoutput @git, qw(write-tree);
     $tree =~ m/^\w+$/ or die "$tree ?";
@@ -995,9 +1033,12 @@ sub dsc_files () {
     map { $_->{Filename} } dsc_files_info();
 }
 
-sub is_orig_file ($) {
-    local ($_) = @_;
-    m/\.orig(?:-\w+)?\.tar\.\w+$/;
+sub is_orig_file ($;$) {
+    local ($_) = $_[0];
+    my $base = $_[1];
+    m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
+    defined $base or return 1;
+    return $` eq $base;
 }
 
 sub make_commit ($) {
@@ -1073,7 +1114,7 @@ END
 	my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
 	my $oversion = getfield $oldclogp, 'Version';
 	my $vcmp =
-	    version_compare_string($oversion, $cversion);
+	    version_compare($oversion, $cversion);
 	if ($vcmp < 0) {
 	    # git upload/ is earlier vsn than archive, use archive
 	    open C, ">../commit2.tmp" or die $!;
@@ -1117,11 +1158,9 @@ sub complete_file_from_dsc ($$) {
     my $tf = "$dstdir/$f";
     my $downloaded = 0;
 
-    if (stat $tf) {
+    if (stat_exists $tf) {
 	progress "using existing $f";
     } else {
-	die "$tf $!" unless $!==&ENOENT;
-
 	my $furl = $dscurl;
 	$furl =~ s{/[^/]+$}{};
 	$furl .= "/$f";
@@ -1255,7 +1294,7 @@ END
 	my $gotclogp = parsechangelog("-l$clogf");
 	my $got_vsn = getfield $gotclogp, 'Version';
 	printdebug "SKEW CHECK GOT $got_vsn\n";
-	if (version_compare_string($got_vsn, $skew_warning_vsn) < 0) {
+	if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
 	    print STDERR <<END or die $!;
 
 Warning: archive skew detected.  Using the available version:
@@ -1332,6 +1371,12 @@ sub check_not_dirty () {
     }
 }
 
+sub commit_admin ($) {
+    my ($m) = @_;
+    progress "$m";
+    runcmd_ordryrun_local @git, qw(commit -m), $m;
+}
+
 sub commit_quilty_patch () {
     my $output = cmdoutput @git, qw(status --porcelain);
     my %adds;
@@ -1346,9 +1391,18 @@ sub commit_quilty_patch () {
 	return;
     }
     runcmd_ordryrun_local @git, qw(add), sort keys %adds;
-    my $m = "Commit Debian 3.0 (quilt) metadata";
-    progress "$m";
-    runcmd_ordryrun_local @git, qw(commit -m), $m;
+    commit_admin "Commit Debian 3.0 (quilt) metadata";
+}
+
+sub get_source_format () {
+    if (!open F, "debian/source/format") {
+	die $! unless $!==&ENOENT;
+	return '';
+    }
+    $_ = <F>;
+    F->error and die $!;
+    chomp;
+    return $_;
 }
 
 sub madformat ($) {
@@ -1467,7 +1521,7 @@ sub dopush () {
 	push_parse_changelog("$clogpfn");
 
     my $dscpath = "$buildproductsdir/$dscfn";
-    stat $dscpath or
+    stat_exists $dscpath or
 	fail "looked for .dsc $dscfn, but $!;".
 	    " maybe you forgot to build";
 
@@ -1512,10 +1566,9 @@ sub dopush () {
     if (!$changesfile) {
 	my $multi = "$buildproductsdir/".
 	    "${package}_".(stripepoch $cversion)."_multi.changes";
-	if (stat "$multi") {
+	if (stat_exists "$multi") {
 	    $changesfile = $multi;
 	} else {
-	    $!==&ENOENT or die "$multi: $!";
 	    my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
 	    my @cs = glob "$buildproductsdir/$pat";
 	    fail "failed to find unique changes file".
@@ -1598,10 +1651,8 @@ sub cmd_clone {
     }
     $dstdir ||= "$package";
 
-    if (stat $dstdir) {
+    if (stat_exists $dstdir) {
 	fail "$dstdir already exists";
-    } elsif ($! != &ENOENT) {
-	die "$dstdir: $!";
     }
 
     my $cwd_remove;
@@ -1705,12 +1756,15 @@ sub cmd_push {
 
 #---------- remote commands' implementation ----------
 
-sub cmd_remote_push_responder {
+sub cmd_remote_push_build_host {
     my ($nrargs) = shift @ARGV;
     my (@rargs) = @ARGV[0..$nrargs-1];
     @ARGV = @ARGV[$nrargs..$#ARGV];
     die unless @rargs;
-    my ($dir) = @rargs;
+    my ($dir,$vsnwant) = @rargs;
+    # vsnwant is a comma-separated list; we report which we have
+    # chosen in our ready response (so other end can tell if they
+    # offered several)
     $debugprefix = ' ';
     $we_are_responder = 1;
 
@@ -1721,19 +1775,30 @@ sub cmd_remote_push_responder {
     open STDOUT, ">&STDERR" or die $!;
     autoflush STDOUT 1;
 
-    responder_send_command("dgit-remote-push-ready");
+    $vsnwant //= 1;
+    fail "build host has dgit rpush protocol version".
+	" $rpushprotovsn but invocation host has $vsnwant"
+	unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
+
+    responder_send_command("dgit-remote-push-ready $rpushprotovsn");
 
     changedir $dir;
     &cmd_push;
 }
 
+sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
+# ... for compatibility with proto vsn.1 dgit (just so that user gets
+#     a good error message)
+
 our $i_tmp;
-our $i_child_pid;
 
 sub i_cleanup {
-    local ($@);
-    if ($i_child_pid) {
-	printdebug "(killing remote child $i_child_pid)\n";
+    local ($@, $?);
+    my $report = i_child_report();
+    if (defined $report) {
+	printdebug "($report)\n";
+    } elsif ($i_child_pid) {
+	printdebug "(killing build host child $i_child_pid)\n";
 	kill 15, $i_child_pid;
     }
     if (defined $i_tmp && !defined $initiator_tempdir) {
@@ -1760,11 +1825,11 @@ sub cmd_rpush {
 	$dir = nextarg;
     }
     $dir =~ s{^-}{./-};
-    my @rargs = ($dir);
+    my @rargs = ($dir,$rpushprotovsn);
     my @rdgit;
     push @rdgit, @dgit;
     push @rdgit, @ropts;
-    push @rdgit, qw(remote-push-responder), (scalar @rargs), @rargs;
+    push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
     push @rdgit, @ARGV;
     my @cmd = (@ssh, $host, shellquote @rdgit);
     printcmd \*DEBUG,$debugprefix."+",@cmd;
@@ -1797,10 +1862,10 @@ sub i_resp_progress ($) {
 sub i_resp_complete {
     my $pid = $i_child_pid;
     $i_child_pid = undef; # prevents killing some other process with same pid
-    printdebug "waiting for remote child $pid...\n";
+    printdebug "waiting for build host child $pid...\n";
     my $got = waitpid $pid, 0;
     die $! unless $got == $pid;
-    die "remote child failed $?" if $?;
+    die "build host child failed $?" if $?;
 
     i_cleanup();
     printdebug "all done\n";
@@ -1811,7 +1876,8 @@ sub i_resp_file ($) {
     my ($keyword) = @_;
     my $localname = i_method "i_localname", $keyword;
     my $localpath = "$i_tmp/$localname";
-    stat $localpath and badproto \*RO, "file $keyword ($localpath) twice";
+    stat_exists $localpath and
+	badproto \*RO, "file $keyword ($localpath) twice";
     protocol_receive_file \*RO, $localpath;
     i_method "i_file", $keyword;
 }
@@ -1897,14 +1963,8 @@ our $dscfn;
 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
 
 sub build_maybe_quilt_fixup () {
-    if (!open F, "debian/source/format") {
-	die $! unless $!==&ENOENT;
-	return;
-    }
-    $_ = <F>;
-    F->error and die $!;
-    chomp;
-    return unless madformat($_);
+    my $format=get_source_format;
+    return unless madformat $format;
     # sigh
     
     my @cmd = (@git, qw(ls-files --exclude-standard -iodm));
@@ -2016,7 +2076,7 @@ sub changesopts () {
 	}
 	if (@vsns) {
 	    @vsns = map { $_->[0] } @vsns;
-	    @vsns = sort { -version_compare_string($a, $b) } @vsns;
+	    @vsns = sort { -version_compare($a, $b) } @vsns;
 	    $changes_since_version = $vsns[0];
 	    progress "changelog will contain changes since $vsns[0]";
 	} else {
@@ -2081,8 +2141,9 @@ sub cmd_sbuild {
     changedir "..";
     my $pat = "${package}_".(stripepoch $version)."_*.changes";
     if (act_local()) {
-	stat $dscfn or fail "$dscfn (in parent directory): $!";
-	stat $sourcechanges or fail "$sourcechanges (in parent directory): $!";
+	stat_exist $dscfn or fail "$dscfn (in parent directory): $!";
+	stat_exists $sourcechanges
+	    or fail "$sourcechanges (in parent directory): $!";
 	foreach my $cf (glob $pat) {
 	    next if $cf eq $sourcechanges;
 	    unlink $cf or fail "remove $cf: $!";
@@ -2099,7 +2160,7 @@ sub cmd_sbuild {
     runcmd_ordryrun_local @mergechanges, @changesfiles;
     my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
     if (act_local()) {
-	stat $multichanges or fail "$multichanges: $!";
+	stat_exists $multichanges or fail "$multichanges: $!";
     }
     printdone "build successful, results in $multichanges\n" or die $!;
 }