use Debian::Dgit;
our $our_version = 'UNRELEASED'; ###substituted###
+our $absurdity = undef; ###substituted###
our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
our $protovsn;
our $tagformat;
our $tagformatfn;
+our %forceopts = map { $_=>0 }
+ qw(unrepresentable unsupported-source-format
+ dsc-changes-mismatch
+ import-gitapply-absurd
+ import-gitapply-no-absurd);
+
our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
our $suite_re = '[-+.0-9a-z]+';
our (@git) = qw(git);
our (@dget) = qw(dget);
-our (@curl) = qw(curl -f);
+our (@curl) = qw(curl);
our (@dput) = qw(dput);
our (@debsign) = qw(debsign);
our (@gpg) = qw(gpg);
our $csuite;
our $instead_distro;
+if (!defined $absurdity) {
+ $absurdity = $0;
+ $absurdity =~ s{/[^/]+$}{/absurd} or die;
+}
+
sub debiantag ($$) {
my ($v,$distro) = @_;
return $tagformatfn->($v, $distro);
sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
+sub forceable_fail ($$) {
+ my ($forceoptsl, $msg) = @_;
+ fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
+ print STDERR "warning: overriding problem due to --force:\n". $msg;
+}
+
+sub forceing ($) {
+ my ($forceoptsl) = @_;
+ my @got = grep { $forceopts{$_} } @$forceoptsl;
+ return 0 unless @got;
+ print STDERR
+ "warning: skipping checks or functionality due to --force-$got[0]\n";
+}
+
sub no_such_package () {
print STDERR "$us: package $package does not exist in suite $isuite\n";
exit 4;
'dgit.default.ssh' => 'ssh',
'dgit.default.archive-query' => 'madison:',
'dgit.default.sshpsql-dbname' => 'service=projectb',
- 'dgit.default.dgit-tag-format' => 'old,new,maint',
+ 'dgit.default.dgit-tag-format' => 'new,old,maint',
# old means "repo server accepts pushes with old dgit tags"
# new means "repo server accepts pushes with new dgit tags"
# maint means "repo server accepts split brain pushes"
'dgit-distro.debian.git-check' => 'url',
'dgit-distro.debian.git-check-suffix' => '/info/refs',
'dgit-distro.debian.new-private-pushers' => 't',
- 'dgit-distro.debian.dgit-tag-format' => 'new',
'dgit-distro.debian/push.git-url' => '',
'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
'dgit-distro.debian/push.git-user-force' => 'dgit',
sub archive_api_query_cmd ($) {
my ($subpath) = @_;
- my @cmd = qw(curl -sS);
+ my @cmd = (@curl, qw(-sS));
my $url = access_cfg('archive-query-url');
if ($url =~ m#^https://([-.0-9a-z]+)/#) {
my $host = $1;
badcfg "ftpmasterapi archive query method takes no data part"
if length $data;
my @cmd = archive_api_query_cmd($subpath);
+ my $url = $cmd[$#cmd];
+ push @cmd, qw(-w %{http_code});
my $json = cmdoutput @cmd;
+ unless ($json =~ s/\d+\d+\d$//) {
+ failedcmd_report_cmd undef, @cmd;
+ fail "curl failed to print 3-digit HTTP code";
+ }
+ my $code = $&;
+ fail "fetch of $url gave HTTP code $code"
+ unless $url =~ m#^file://# or $code =~ m/^2/;
return decode_json($json);
}
$dsc = parsecontrolfh($dscfh,$dscurl,1);
printdebug Dumper($dsc) if $debuglevel>1;
my $fmt = getfield $dsc, 'Format';
- fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
+ $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
+ "unsupported source format $fmt, sorry";
+
$dsc_checked = !!$digester;
printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
return;
my $suffix = access_cfg('git-check-suffix','git-suffix',
'RETURN-UNDEF') // '.git';
my $url = "$prefix/$package$suffix";
- my @cmd = (qw(curl -sS -I), $url);
+ my @cmd = (@curl, qw(-sS -I), $url);
my $result = cmdoutput @cmd;
$result =~ s/^\S+ 200 .*\n\r?\n//;
# curl -sS -I with https_proxy prints
printdebug "import clog $r1clogp->{version} becomes r1\n";
}
die $! if CLOGS->error;
- close CLOGS or $?==(SIGPIPE<<8) or failedcmd @clogcmd;
+ close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
$clogp or fail "package changelog has no entries!";
local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
local $ENV{GIT_AUTHOR_DATE} = $authline[2];
- eval {
- runcmd shell_cmd 'exec >/dev/null 2>../../gbp-pq-output',
- gbp_pq, qw(import);
- };
- if ($@) {
- { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
- die $@;
- }
+ my $path = $ENV{PATH} or die;
+
+ foreach my $use_absurd (qw(0 1)) {
+ local $ENV{PATH} = $path;
+ if ($use_absurd) {
+ chomp $@;
+ progress "warning: $@";
+ $path = "$absurdity:$path";
+ progress "$us: trying slow absurd-git-apply...";
+ rename "../../gbp-pq-output","../../gbp-pq-output.0"
+ or $!==ENOENT
+ or die $!;
+ }
+ eval {
+ die "forbid absurd git-apply\n" if $use_absurd
+ && forceing [qw(import-gitapply-no-absurd)];
+ die "only absurd git-apply!\n" if !$use_absurd
+ && forceing [qw(import-gitapply-absurd)];
+
+ local $ENV{PATH} = $path if $use_absurd;
+
+ my @showcmd = (gbp_pq, qw(import));
+ my @realcmd = shell_cmd
+ 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
+ debugcmd "+",@realcmd;
+ if (system @realcmd) {
+ die +(shellquote @showcmd).
+ " failed: ".
+ failedcmd_waitstatus()."\n";
+ }
- my $gapplied = git_rev_parse('HEAD');
- my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
- $gappliedtree eq $dappliedtree or
- fail <<END;
+ my $gapplied = git_rev_parse('HEAD');
+ my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
+ $gappliedtree eq $dappliedtree or
+ fail <<END;
gbp-pq import and dpkg-source disagree!
gbp-pq import gave commit $gapplied
gbp-pq import gave tree $gappliedtree
dpkg-source --before-build gave tree $dappliedtree
END
- $rawimport_hash = $gapplied;
+ $rawimport_hash = $gapplied;
+ };
+ last unless $@;
+ }
+ if ($@) {
+ { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
+ die $@;
+ }
}
progress "synthesised git commit from .dsc $cversion";
$furl .= "/$f";
die "$f ?" unless $f =~ m/^\Q${package}\E_/;
die "$f ?" if $f =~ m#/#;
- runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
+ runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
return 0 if !act_local();
$downloaded = 1;
}
return $dgitview if is_fast_fwd $archive_hash, $dgitview;
- my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
- my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
- my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
- my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
- my $i_archive = [ $archive_hash, "current archive contents" ];
-
- printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
-
- infopair_cond_equal($i_dgit, $i_archive);
- infopair_cond_ff($i_dep14, $i_dgit);
- $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
+ if (defined $overwrite_version) {
+ } elsif (!eval {
+ my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
+ my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
+ my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
+ my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
+ my $i_archive = [ $archive_hash, "current archive contents" ];
+
+ printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
+
+ infopair_cond_equal($i_dgit, $i_archive);
+ infopair_cond_ff($i_dep14, $i_dgit);
+ infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
+ 1;
+ }) {
+ print STDERR <<END;
+$us: check failed (maybe --overwrite is needed, consult documentation)
+END
+ die "$@";
+ }
my $r = pseudomerge_make_commit
$clogp, $dgitview, $archive_hash, $i_arch_v,
"dgit --quilt=$quilt_mode",
(defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
-Declare fast forward from $overwrite_version
+Declare fast forward from $i_arch_v->[0]
END_OVERWR
Make fast forward from $i_arch_v->[0]
END_MAKEFF
my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
- my @tagformats = access_cfg_tagformats();
- my @t_overwr =
- map { $_->($i_arch_v->[0], access_basedistro) }
- (grep { m/^(?:old|hist)$/ } @tagformats)
- ? \&debiantags : \&debiantag_new;
- my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
- my $i_archive = [ $archive_hash, "current archive contents" ];
-
- infopair_cond_equal($i_overwr, $i_archive);
-
return $head if is_fast_fwd $archive_hash, $head;
my $m = "Declare fast forward from $i_arch_v->[0]";
$upstreamversion =~ s/-[^-]*$//;
changedir $ud;
quilt_make_fake_dsc($upstreamversion);
- my ($dgitview, $cachekey) =
+ my $cachekey;
+ ($dgithead, $cachekey) =
quilt_check_splitbrain_cache($actualhead, $upstreamversion);
- $dgitview or fail
+ $dgithead or fail
"--quilt=$quilt_mode but no cached dgit view:
perhaps tree changed since dgit build[-source] ?";
$split_brain = 1;
$dgithead = splitbrain_pseudomerge($clogp,
- $actualhead, $dgitview,
+ $actualhead, $dgithead,
$archive_hash);
$maintviewhead = $actualhead;
changedir '../../../..';
# Check that changes and .dsc agree enough
$changesfile =~ m{[^/]*$};
- files_compare_inputs($dsc, parsecontrol($changesfile,$&));
+ files_compare_inputs($dsc, parsecontrol($changesfile,$&))
+ unless forceing [qw(dsc-changes-mismatch)];
# Checks complete, we're going to try and go ahead:
END
}
- my $dgitview = git_rev_parse 'refs/heads/dgit-view';
+ my $dgitview = git_rev_parse 'HEAD';
changedir '../../../..';
+ # When we no longer need to support squeeze, use --create-reflog
+ # instead of this:
ensuredir ".git/logs/refs/dgit-intern";
my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
or die $!;
+
+ my $oldcache = git_get_ref "refs/$splitbraincache";
+ if ($oldcache eq $dgitview) {
+ my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
+ # git update-ref doesn't always update, in this case. *sigh*
+ my $dummy = make_commit_text <<END;
+tree $tree
+parent $dgitview
+author Dgit <dgit\@example.com> 1000000000 +0000
+committer Dgit <dgit\@example.com> 1000000000 +0000
+
+Dummy commit - do not use
+END
+ runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
+ "refs/$splitbraincache", $dummy;
+ }
runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
$dgitview;
my $srcshash = Digest::SHA->new(256);
my %sfs = ( %INC, '$0(dgit)' => $0 );
foreach my $sfk (sort keys %sfs) {
- next unless m/^\$0\b/ || m{^Debian/Dgit\b};
+ next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
$srcshash->add($sfk," ");
$srcshash->add(hashfile($sfs{$sfk}));
$srcshash->add("\n");
push @cachekey, $srcshash->hexdigest();
$splitbrain_cachekey = "@cachekey";
- my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
+ my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
$splitbraincache);
printdebug "splitbrain cachekey $splitbrain_cachekey\n";
debugcmd "|(probably)",@cmd;
if (@unrepres) {
print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
foreach @unrepres;
- fail <<END;
+ forceable_fail [qw(unrepresentable)], <<END;
HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
END
}
push @failsuggestion, "This might be a patches-applied branch.";
}
push @failsuggestion, "Maybe you need to specify one of".
- " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
+ " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
if (quiltmode_splitbrain()) {
quiltify_splitbrain($clogp, $unapplied, $headref,
}
maybe_unapply_patches_again();
if ($wantsrc < 2) {
- unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
- canonicalise_suite();
- push @cmd, "--git-debian-branch=".lbranch();
- }
push @cmd, changesopts();
runcmd_ordryrun_local @cmd, @ARGV;
}
badusage "need only 1 subpath argument" unless @ARGV==1;
my ($subpath) = @ARGV;
my @cmd = archive_api_query_cmd($subpath);
+ push @cmd, qw(-f);
debugcmd ">",@cmd;
exec @cmd or fail "exec curl: $!\n";
}
($om = $opts_opt_map{$1})) {
push @ropts, $_;
push @$om, $2;
+ } elsif (m/^--(gbp|dpm)$/s) {
+ push @ropts, "--quilt=$1";
+ $quilt_mode = $1;
} elsif (m/^--ignore-dirty$/s) {
push @ropts, $_;
$ignoredirty = 1;
} elsif (m/^--deliberately-($deliberately_re)$/s) {
push @ropts, $_;
push @deliberatelies, $&;
+ } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
+ push @ropts, $&;
+ $forceopts{$1} = 1;
+ $_='';
+ } elsif (m/^--force-/) {
+ print STDERR
+ "$us: warning: ignoring unknown force option $_\n";
+ $_='';
} elsif (m/^--dgit-tag-format=(old|new)$/s) {
# undocumented, for testing
push @ropts, $_;
}
}
+sub check_env_sanity () {
+ my $blocked = new POSIX::SigSet;
+ sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
+
+ eval {
+ foreach my $name (qw(PIPE CHLD)) {
+ my $signame = "SIG$name";
+ my $signum = eval "POSIX::$signame" // die;
+ ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
+ die "$signame is set to something other than SIG_DFL\n";
+ $blocked->ismember($signum) and
+ die "$signame is blocked\n";
+ }
+ };
+ return unless $@;
+ chomp $@;
+ fail <<END;
+On entry to dgit, $@
+This is a bug produced by something in in your execution environment.
+Giving up.
+END
+}
+
+
sub finalise_opts_opts () {
foreach my $k (keys %opts_opt_map) {
my $om = $opts_opt_map{$k};
}
parseopts();
+check_env_sanity();
git_slurp_config();
print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;