use POSIX;
use IPC::Open2;
use Digest::SHA;
+use Config;
our $our_version = 'UNRELEASED'; ###substituted###
}
};
+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,$dsc_checked,$skew_warning_vsn);
{ 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;
+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;
}
}
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};
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";
}
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();
}
my $cmd = shift @ARGV;
$cmd =~ y/-/_/;
-{ no strict qw(refs); &{"cmd_$cmd"}(); }
+
+my $fn = ${*::}{"cmd_$cmd"};
+$fn or badusage "unknown operation $cmd";
+$fn->();