X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=53ca56c0bc014a5d89fca5180524db39e5ab8fa6;hb=5ee107579037882ae549f35e9bc1b30e0acdb1ab;hp=5f1ef2e59bc3864faf7f5d4abcd27409018ee9f3;hpb=07261afb451ed4420d3dbda87613fa1229130276;p=dgit.git diff --git a/dgit b/dgit index 5f1ef2e5..53ca56c0 100755 --- a/dgit +++ b/dgit @@ -30,9 +30,12 @@ use Dpkg::Version; use POSIX; use IPC::Open2; use Digest::SHA; +use Config; our $our_version = 'UNRELEASED'; ###substituted### +our $rpushprotovsn = 2; + our $isuite = 'unstable'; our $idistro; our $package; @@ -133,6 +136,23 @@ END { } }; +our @signames = split / /, $Config{sig_name}; + +sub waitstatusmsg () { + if (!$?) { + return "terminated, reporting successful completion"; + } elsif (!($? & 255)) { + return "failed with error exit status ".WEXITSTATUS($?); + } elsif (WIFSIGNALED($?)) { + my $signum=WTERMSIG($?); + return "died due to fatal signal ". + ($signames[$signum] // "number $signum"). + ($? & 128 ? " (core dumped)" : ""); # POSIX(3pm) has no WCOREDUMP + } else { + return "failed with unknown wait status ".$?; + } +} + sub printdebug { print DEBUG $debugprefix, @_ or die $!; } sub fail { @@ -194,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; @@ -236,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; } @@ -350,10 +392,8 @@ sub failedcmd { { local ($!); printcmd \*STDERR, "$us: failed command:", @_ or die $!; }; if ($!) { fail "failed to fork/exec: $!"; - } elsif (!($? & 0xff)) { - fail "subprocess failed with error exit status ".($?>>8); } elsif ($?) { - fail "subprocess crashed (wait status $?)"; + fail "subprocess ".waitstatusmsg(); } else { fail "subprocess produced invalid output"; } @@ -594,11 +634,30 @@ sub access_giturl () { return "$url/$package.git"; } -sub parsecontrolfh ($$@) { - my ($fh, $desc, @opts) = @_; - my %opts = ('name' => $desc, @opts); - my $c = Dpkg::Control::Hash->new(%opts); - $c->parse($fh) or die "parsing of $desc failed"; +sub parsecontrolfh ($$;$) { + my ($fh, $desc, $allowsigned) = @_; + our $dpkgcontrolhash_noissigned; + my $c; + 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; + last if $dpkgcontrolhash_noissigned; + my $issigned= $c->get_option('is_pgp_signed'); + if (!defined $issigned) { + $dpkgcontrolhash_noissigned= 1; + seek $fh, 0,0 or die "seek $desc: $!"; + } elsif ($issigned) { + fail "control file $desc is (already) PGP-signed. ". + " Note that dgit push needs to modify the .dsc and then". + " do the signature itself"; + } else { + last; + } + } return $c; } @@ -857,7 +916,7 @@ sub get_archive_dsc () { } my $dscfh = new IO::File \$dscdata, '<' or die $!; printdebug Dumper($dscdata) if $debug>1; - $dsc = parsecontrolfh($dscfh,$dscurl, allow_pgp=>1); + $dsc = parsecontrolfh($dscfh,$dscurl,1); printdebug Dumper($dsc) if $debug>1; my $fmt = getfield $dsc, 'Format'; fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt}; @@ -1261,6 +1320,10 @@ sub clone ($) { progress "starting new git history"; } fetch_from_archive() or no_such_package; + my $vcsgiturl = $dsc->{'Vcs-Git'}; + if (length $vcsgiturl) { + runcmd @git, qw(remote add vcs-git), $vcsgiturl; + } runcmd @git, qw(reset --hard), lrref(); printdone "ready for work in $dstdir"; } @@ -1666,12 +1729,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; @@ -1682,19 +1748,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) { @@ -1721,11 +1798,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; @@ -1758,10 +1835,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";