use IPC::Open2;
use Digest::SHA;
use Digest::MD5;
-use Config;
use Debian::Dgit;
}
};
-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 fail {
- my $s = "@_\n";
- my $prefix = $us.($we_are_responder ? " (build host)" : "").": ";
- $s =~ s/^/$prefix/gm;
- die $s;
-}
-
sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
sub no_such_package () {
}
sub deliberately ($) {
- return !!grep { $_[0] eq $_ } @deliberatelies;
+ my ($enquiry) = @_;
+ return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
+}
+
+sub deliberately_not_fast_forward () {
+ deliberately('not-fast-forward') ||
+ deliberately('TEST-not-fast-forward-dgit-only');
}
#---------- remote protocol support, common ----------
our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
-sub failedcmd {
- { local ($!); printcmd \*STDERR, "$us: failed command:", @_ or die $!; };
- if ($!) {
- fail "failed to fork/exec: $!";
- } elsif ($?) {
- fail "subprocess ".waitstatusmsg();
- } else {
- fail "subprocess produced invalid output";
- }
-}
-
sub runcmd {
debugcmd "+",@_;
$!=0; $?=0;
}
}
-sub cmdoutput_errok {
- die Dumper(\@_)." ?" if grep { !defined } @_;
- debugcmd "|",@_;
- open P, "-|", @_ or die $!;
- my $d;
- $!=0; $?=0;
- { local $/ = undef; $d = <P>; }
- die $! if P->error;
- if (!close P) { printdebug "=>!$?\n"; return undef; }
- chomp $d;
- $d =~ m/^.*/;
- printdebug "=> \`$&'",(length $' ? '...' : ''),"\n" if $debuglevel>0; #';
- return $d;
-}
-
-sub cmdoutput {
- my $d = cmdoutput_errok @_;
- defined $d or failedcmd @_;
- return $d;
-}
-
sub dryrun_report {
printcmd(\*STDERR,$debugprefix."#",@_);
}
my @cmd = (@git, qw(config --), $c);
my $v;
{
- local ($Debian::Dgit::debuglevel) = $debuglevel-1;
- *debug = *Debian::Dgit::debuglevel; # nnng
+ local ($debuglevel) = $debuglevel-2;
$v = cmdoutput_errok @cmd;
};
if ($?==0) {
return $c;
}
-sub git_get_ref ($) {
- my ($refname) = @_;
- my $got = cmdoutput_errok @git, qw(show-ref --), $refname;
- if (!defined $got) {
- $?==256 or fail "git show-ref failed (status $?)";
- printdebug "ref $refname= [show-ref exited 1]\n";
- return '';
- }
- if ($got =~ m/^(\w+) \Q$refname\E$/m) {
- printdebug "ref $refname=$1\n";
- return $1;
- } else {
- printdebug "ref $refname= [no match]\n";
- return '';
- }
-}
-
sub must_getcwd () {
my $d = getcwd();
defined $d or fail "getcwd failed: $!";
}
}
-sub rev_parse ($) {
- return cmdoutput @git, qw(rev-parse), "$_[0]~0";
-}
-
-sub is_fast_fwd ($$) {
- my ($ancestor,$child) = @_;
- my @cmd = (@git, qw(merge-base), $ancestor, $child);
- my $mb = cmdoutput_errok @cmd;
- if (defined $mb) {
- return rev_parse($mb) eq rev_parse($ancestor);
- } else {
- $?==256 or failedcmd @cmd;
- return 0;
- }
-}
-
sub git_fetch_us () {
runcmd_ordryrun_local @git, qw(fetch),access_giturl(),fetchspec();
}
}
}
-sub dopush () {
+sub dopush ($) {
+ my ($forceflag) = @_;
printdebug "actually entering push\n";
prep_ud();
# runcmd @git, qw(fetch -p ), "$alioth_git/$package.git",
# map { lref($_).":".rref($_) }
# (uploadbranch());
- my $head = rev_parse('HEAD');
+ my $head = git_rev_parse('HEAD');
if (!$changesfile) {
my $multi = "$buildproductsdir/".
"${package}_".(stripepoch $cversion)."_multi.changes";
responder_send_command("param head $head");
responder_send_command("param csuite $csuite");
- my $forceflag = deliberately('not-fast-forward') ? '+' : '';
if ($forceflag && defined $lastpush_hash) {
git_for_each_tag_referring($lastpush_hash, sub {
- my ($objid,$fullrefname,$tagname) = @_;
- responder_send_command("supersedes $fullrefname=$objid");
- $supersedes{$fullrefname} = $objid;
+ my ($tagobjid,$refobjid,$fullrefname,$tagname) = @_;
+ responder_send_command("supersedes $fullrefname=$tagobjid");
+ $supersedes{$fullrefname} = $tagobjid;
});
}
if (check_for_git()) {
git_fetch_us();
}
+ my $forceflag = '';
if (fetch_from_archive()) {
- is_fast_fwd(lrref(), 'HEAD') or
+ if (is_fast_fwd(lrref(), 'HEAD')) {
+ # ok
+ } elsif (deliberately_not_fast_forward) {
+ $forceflag = '+';
+ } else {
fail "dgit push: HEAD is not a descendant".
" of the archive's version.\n".
- "$us: To overwrite it, use git merge -s ours ".lrref().".";
+ "dgit: To overwrite its contents,".
+ " use git merge -s ours ".lrref().".\n".
+ "dgit: To rewind history, if permitted by the archive,".
+ " use --deliberately-not-fast-forward";
+ }
} else {
$new_package or
fail "package appears to be new in this suite;".
" if this is intentional, use --new";
}
- dopush();
+ dopush($forceflag);
}
#---------- remote commands' implementation ----------
# offered several)
$debugprefix = ' ';
$we_are_responder = 1;
+ $us .= " (build host)";
open PI, "<&STDIN" or die $!;
open STDIN, "/dev/null" or die $!;
# 6. Back in the main tree, fast forward to the new HEAD
my $clogp = parsechangelog();
- my $headref = rev_parse('HEAD');
+ my $headref = git_rev_parse('HEAD');
prep_ud();
changedir $ud;
badusage "need only 1 subpath argument" unless @ARGV==1;
my ($subpath) = @ARGV;
my @cmd = archive_api_query_cmd($subpath);
+ debugcmd ">",@cmd;
exec @cmd or fail "exec curl: $!\n";
}
} elsif (m/^--no-rm-on-error$/s) {
push @ropts, $_;
$rmonerror = 0;
- } elsif (m/^--deliberately-($suite_re)$/s) {
+ } elsif (m/^--deliberately-($deliberately_re)$/s) {
push @ropts, $_;
push @deliberatelies, $&;
} else {
~ianmdlvl / dgit.git / blobdiff