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"
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
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;
}
# 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
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;
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,
return $r;
}
+sub in_parent (&) {
+ my ($fn) = @_;
+ my $wasdir = must_getcwd();
+ changedir "..";
+ $fn->();
+ changedir $wasdir;
+}
+
+sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
+ my ($msg_if_onlyone) = @_;
+ # If there is only one .changes file, fail with $msg_if_onlyone,
+ # or if that is undef, be a no-op.
+ # Returns the changes file to report to the user.
+ my $pat = changespat $version;
+ my @changesfiles = glob $pat;
+ @changesfiles = sort {
+ ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
+ or $a cmp $b
+ } @changesfiles;
+ my $result;
+ if (@changesfiles==1) {
+ fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
+only one changes file from build (@changesfiles)
+END
+ $result = $changesfiles[0];
+ } elsif (@changesfiles==2) {
+ my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
+ foreach my $l (split /\n/, getfield $binchanges, 'Files') {
+ fail "$l found in binaries changes file $binchanges"
+ if $l =~ m/\.dsc$/;
+ }
+ runcmd_ordryrun_local @mergechanges, @changesfiles;
+ my $multichanges = changespat $version,'multi';
+ if (act_local()) {
+ stat_exists $multichanges or fail "$multichanges: $!";
+ foreach my $cf (glob $pat) {
+ next if $cf eq $multichanges;
+ rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
+ }
+ }
+ $result = $multichanges;
+ } else {
+ fail "wrong number of different changes files (@changesfiles)";
+ }
+ printdone "build successful, results in $result\n" or die $!;
+}
+
+sub midbuild_checkchanges () {
+ my $pat = changespat $version;
+ return if $rmchanges;
+ my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
+ @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
+ fail <<END
+changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
+Suggest you delete @unwanted.
+END
+ if @unwanted;
+}
+
+sub midbuild_checkchanges_vanilla ($) {
+ my ($wantsrc) = @_;
+ midbuild_checkchanges() if $wantsrc == 1;
+}
+
+sub postbuild_mergechanges_vanilla ($) {
+ my ($wantsrc) = @_;
+ if ($wantsrc == 1) {
+ in_parent {
+ postbuild_mergechanges(undef);
+ };
+ } else {
+ printdone "build successful\n";
+ }
+}
+
sub cmd_build {
my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
my $wantsrc = massage_dbp_args \@dbp;
if ($wantsrc > 0) {
build_source();
+ midbuild_checkchanges_vanilla $wantsrc;
} else {
build_prep();
}
runcmd_ordryrun_local @dbp;
}
maybe_unapply_patches_again();
- printdone "build successful\n";
+ postbuild_mergechanges_vanilla $wantsrc;
}
sub pre_gbp_build {
if ($wantsrc > 0) {
build_source();
+ midbuild_checkchanges_vanilla $wantsrc;
} else {
if (!$clean_using_builder) {
push @cmd, '--git-cleaner=true';
push @cmd, changesopts();
runcmd_ordryrun_local @cmd, @ARGV;
}
- printdone "build successful\n";
+ postbuild_mergechanges_vanilla $wantsrc;
}
sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
sub cmd_sbuild {
build_source();
- my $pat = changespat $version;
- if (!$rmchanges) {
- my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
- @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
- fail <<END
-changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
-Suggest you delete @unwanted.
-END
- if @unwanted;
- }
- my $wasdir = must_getcwd();
- changedir "..";
- if (act_local()) {
- stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
- stat_exists $sourcechanges
- or fail "$sourcechanges (in parent directory): $!";
- }
- runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
- my @changesfiles = glob $pat;
- @changesfiles = sort {
- ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
- or $a cmp $b
- } @changesfiles;
- fail <<END if @changesfiles==1;
-only one changes file from sbuild (@changesfiles)
+ midbuild_checkchanges();
+ in_parent {
+ if (act_local()) {
+ stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
+ stat_exists $sourcechanges
+ or fail "$sourcechanges (in parent directory): $!";
+ }
+ runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
+ };
+ maybe_unapply_patches_again();
+ in_parent {
+ postbuild_mergechanges(<<END);
perhaps you need to pass -A ? (sbuild's default is to build only
arch-specific binaries; dgit 1.4 used to override that.)
END
- fail "wrong number of different changes files (@changesfiles)"
- unless @changesfiles==2;
- my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
- foreach my $l (split /\n/, getfield $binchanges, 'Files') {
- fail "$l found in binaries changes file $binchanges"
- if $l =~ m/\.dsc$/;
- }
- runcmd_ordryrun_local @mergechanges, @changesfiles;
- my $multichanges = changespat $version,'multi';
- if (act_local()) {
- stat_exists $multichanges or fail "$multichanges: $!";
- foreach my $cf (glob $pat) {
- next if $cf eq $multichanges;
- rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
- }
- }
- changedir $wasdir;
- maybe_unapply_patches_again();
- printdone "build successful, results in $multichanges\n" or die $!;
+ };
}
sub cmd_quilt_fixup {
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, $_;
~ianmdlvl / dgit.git / blobdiff