X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=f571933a1a505a8717fc182a0df4b964c06170c4;hp=e3fc0eefd33bb6bf0372044f070cc7db03e0ad15;hb=14ff9fc653dffd7ed47dc582cedc5430e613950d;hpb=5e359c5927e8df1a0ce1652a4b83436e9d5d3410 diff --git a/dgit b/dgit index e3fc0eef..f571933a 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; @@ -212,17 +214,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 +278,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 +641,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 +766,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 +824,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 +882,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 () { @@ -1073,7 +1096,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 $!; @@ -1255,7 +1278,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 <&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 +1797,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 +1834,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"; @@ -2016,7 +2053,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 {