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;
}
};
+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 {
#
# > 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;
$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;
}
my $r = $ua->get(@_) or die $!;
return undef if $r->code == 404;
$r->is_success or fail "failed to fetch $what: ".$r->status_line;
- return $r->decoded_content();
+ return $r->decoded_content(charset => 'none');
}
-our ($dscdata,$dscurl,$dsc,$skew_warning_vsn);
+our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
sub shellquote {
my @out;
{ 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";
}
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;
+ $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;
}
$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 ($$) {
my ($proto,$data) = @_;
sql_injection_check $isuite, $package;
my @rows = sshpsql($data, <<END);
- SELECT source.version, component.name, files.filename
+ SELECT source.version, component.name, files.filename, files.sha256sum
FROM source
JOIN src_associations ON source.id = src_associations.source
JOIN suite ON suite.id = src_associations.suite
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) = @$_;
- [ $vsn, "/pool/$component/$filename" ];
+ my ($vsn,$component,$filename,$sha256sum) = @$_;
+ [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
} @rows;
return @rows;
}
}
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 () {
canonicalise_suite();
my @vsns = archive_query('archive_query');
foreach my $vinfo (@vsns) {
- my ($vsn,$subpath) = @$vinfo;
+ my ($vsn,$subpath,$digester,$digest) = @$vinfo;
$dscurl = access_cfg('mirror').$subpath;
$dscdata = url_get($dscurl);
if (!$dscdata) {
$skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
next;
}
+ if ($digester) {
+ $digester->reset();
+ $digester->add($dscdata);
+ my $got = $digester->hexdigest();
+ $got eq $digest or
+ fail "$dscurl has hash $got but".
+ " archive told us to expect $digest";
+ }
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};
+ $dsc_checked = !!$digester;
return;
}
$dsc = undef;
print D $dscdata or die "$dscfn: $!";
close D or die "$dscfn: $!";
my @cmd = qw(dpkg-source);
+ push @cmd, '--no-check' if $dsc_checked;
push @cmd, qw(-x --), $dscfn;
runcmd @cmd;
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 $!;
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:
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";
}
#---------- 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;
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) {
$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;
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";
}
}
+sub cmd_clean () {
+ badusage "clean takes no additional arguments" if @ARGV;
+ clean_tree();
+}
+
sub build_prep () {
badusage "-p is not allowed when building" if defined $package;
check_not_dirty();
}
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 {
}
my $cmd = shift @ARGV;
$cmd =~ y/-/_/;
-{ no strict qw(refs); &{"cmd_$cmd"}(); }
+
+my $fn = ${*::}{"cmd_$cmd"};
+$fn or badusage "unknown operation $cmd";
+$fn->();
~ianmdlvl / dgit.git / blobdiff