# dgit
# Integration between git and Debian-style archives
#
-# Copyright (C)2013-2016 Ian Jackson
+# Copyright (C)2013-2018 Ian Jackson
+# Copyright (C)2017-2018 Sean Whitton
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
+END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
+use Debian::Dgit::ExitStatus;
+use Debian::Dgit::I18n;
+
use strict;
use Debian::Dgit qw(:DEFAULT :playground);
use Dpkg::Compression;
use Dpkg::Compression::Process;
use POSIX;
+use Locale::gettext;
use IPC::Open2;
use Digest::SHA;
use Digest::MD5;
our $sign = 1;
our $dryrun_level = 0;
our $changesfile;
-our $buildproductsdir = '..';
+our $buildproductsdir;
+our $bpd_glob;
our $new_package = 0;
-our $ignoredirty = 0;
+our $includedirty = 0;
our $rmonerror = 1;
our @deliberatelies;
our %previously;
our $quilt_mode;
our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
our $dodep14tag;
-our $split_brain_save;
+our %internal_object_save;
our $we_are_responder;
our $we_are_initiator;
our $initiator_tempdir;
our %forceopts = map { $_=>0 }
qw(unrepresentable unsupported-source-format
dsc-changes-mismatch changes-origs-exactly
+ uploading-binaries uploading-source-only
import-gitapply-absurd
import-gitapply-no-absurd
import-dsc-with-dgit-field);
our $suite_re = '[-+.0-9a-z]+';
our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
-our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
-our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
-our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
our $splitbraincache = 'dgit-intern/quilt-cache';
our (@dput) = qw(dput);
our (@debsign) = qw(debsign);
our (@gpg) = qw(gpg);
-our (@sbuild) = qw(sbuild);
+our (@sbuild) = (qw(sbuild --no-source));
our (@ssh) = 'ssh';
our (@dgit) = qw(dgit);
+our (@git_debrebase) = qw(git-debrebase);
our (@aptget) = qw(apt-get);
our (@aptcache) = qw(apt-cache);
our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
our (@gbp_build) = ('');
our (@gbp_pq) = ('gbp pq');
our (@changesopts) = ('');
+our (@pbuilder) = ("sudo -E pbuilder");
+our (@cowbuilder) = ("sudo -E cowbuilder");
our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
'curl' => \@curl,
'ssh' => \@ssh,
'dgit' => \@dgit,
'git' => \@git,
+ 'git-debrebase' => \@git_debrebase,
'apt-get' => \@aptget,
'apt-cache' => \@aptcache,
'dpkg-source' => \@dpkgsource,
'gbp-build' => \@gbp_build,
'gbp-pq' => \@gbp_pq,
'ch' => \@changesopts,
- 'mergechanges' => \@mergechanges);
+ 'mergechanges' => \@mergechanges,
+ 'pbuilder' => \@pbuilder,
+ 'cowbuilder' => \@cowbuilder);
our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
our %opts_cfg_insertpos = map {
sub setup_gitattrs(;$);
sub check_gitattrs($$);
+our $playground;
our $keyid;
autoflush STDOUT 1;
our $supplementary_message = '';
-our $need_split_build_invocation = 0;
our $split_brain = 0;
END {
return $tagformatfn->($v, $distro);
}
-sub debiantag_maintview ($$) {
- my ($v,$distro) = @_;
- return "$distro/".dep14_version_mangle $v;
-}
-
sub madformat ($) { $_[0] eq '3.0 (quilt)' }
sub lbranch () { return "$branchprefix/$csuite"; }
sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
sub rrref () { return server_ref($csuite); }
-sub stripepoch ($) {
- my ($vsn) = @_;
- $vsn =~ s/^\d+\://;
- return $vsn;
-}
-
sub srcfn ($$) {
- my ($vsn,$sfx) = @_;
- return "${package}_".(stripepoch $vsn).$sfx
+ my ($vsn, $sfx) = @_;
+ return &source_file_leafname($package, $vsn, $sfx);
+}
+sub is_orig_file_of_vsn ($$) {
+ my ($f, $upstreamvsn) = @_;
+ return is_orig_file_of_p_v($f, $package, $upstreamvsn);
}
sub dscfn ($) {
return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
}
-sub upstreamversion ($) {
- my ($vsn) = @_;
- $vsn =~ s/-[^-]+$//;
- return $vsn;
-}
-
our $us = 'dgit';
initdebug('');
}
};
-sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
+sub badcfg {
+ print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
+ finish 12;
+}
sub forceable_fail ($$) {
my ($forceoptsl, $msg) = @_;
fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
- print STDERR "warning: overriding problem due to --force:\n". $msg;
+ 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";
+ print STDERR f_
+ "warning: skipping checks or functionality due to --force-%s\n",
+ $got[0];
}
sub no_such_package () {
- print STDERR "$us: package $package does not exist in suite $isuite\n";
- exit 4;
+ print STDERR f_ "%s: package %s does not exist in suite %s\n",
+ $us, $package, $isuite;
+ finish 4;
}
sub deliberately ($) {
}
sub opts_opt_multi_cmd {
+ my $extra = shift;
my @cmd;
push @cmd, split /\s+/, shift @_;
+ push @cmd, @$extra;
push @cmd, @_;
@cmd;
}
sub gbp_pq {
- return opts_opt_multi_cmd @gbp_pq;
+ return opts_opt_multi_cmd [], @gbp_pq;
}
sub dgit_privdir () {
our $dgit_privdir_made //= ensure_a_playground 'dgit';
}
+sub bpd_abs () {
+ my $r = $buildproductsdir;
+ $r = "$maindir/$r" unless $r =~ m{^/};
+ return $r;
+}
+
+sub get_tree_of_commit ($) {
+ my ($commitish) = @_;
+ my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
+ $cdata =~ m/\n\n/; $cdata = $`;
+ $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
+ return $1;
+}
+
+sub branch_gdr_info ($$) {
+ my ($symref, $head) = @_;
+ my ($status, $msg, $current, $ffq_prev, $gdrlast) =
+ gdr_ffq_prev_branchinfo($symref);
+ return () unless $status eq 'branch';
+ $ffq_prev = git_get_ref $ffq_prev;
+ $gdrlast = git_get_ref $gdrlast;
+ $gdrlast &&= is_fast_fwd $gdrlast, $head;
+ return ($ffq_prev, $gdrlast);
+}
+
+sub branch_is_gdr_unstitched_ff ($$$) {
+ my ($symref, $head, $ancestor) = @_;
+ my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
+ return 0 unless $ffq_prev;
+ return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
+ return 1;
+}
+
+sub branch_is_gdr ($) {
+ my ($head) = @_;
+ # This is quite like git-debrebase's keycommits.
+ # We have our own implementation because:
+ # - our algorighm can do fewer tests so is faster
+ # - it saves testing to see if gdr is installed
+
+ # NB we use this jsut for deciding whether to run gdr make-patches
+ # Before reusing this algorithm for somthing else, its
+ # suitability should be reconsidered.
+
+ my $walk = $head;
+ local $Debian::Dgit::debugcmd_when_debuglevel = 3;
+ printdebug "branch_is_gdr $head...\n";
+ my $get_patches = sub {
+ my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
+ return $t // '';
+ };
+ my $tip_patches = $get_patches->($head);
+ WALK:
+ for (;;) {
+ my $cdata = git_cat_file $walk, 'commit';
+ my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
+ if ($msg =~ m{^\[git-debrebase\ (
+ anchor | changelog | make-patches |
+ merged-breakwater | pseudomerge
+ ) [: ] }mx) {
+ # no need to analyse this - it's sufficient
+ # (gdr classifications: Anchor, MergedBreakwaters)
+ # (made by gdr: Pseudomerge, Changelog)
+ printdebug "branch_is_gdr $walk gdr $1 YES\n";
+ return 1;
+ }
+ my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
+ if (@parents==2) {
+ my $walk_tree = get_tree_of_commit $walk;
+ foreach my $p (@parents) {
+ my $p_tree = get_tree_of_commit $p;
+ if ($p_tree eq $walk_tree) { # pseudomerge contriburor
+ # (gdr classification: Pseudomerge; not made by gdr)
+ printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
+ if $debuglevel >= 2;
+ $walk = $p;
+ next WALK;
+ }
+ }
+ # some other non-gdr merge
+ # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
+ printdebug "branch_is_gdr $walk ?-2-merge NO\n";
+ return 0;
+ }
+ if (@parents>2) {
+ # (gdr classification: ?)
+ printdebug "branch_is_gdr $walk ?-octopus NO\n";
+ return 0;
+ }
+ if ($get_patches->($walk) ne $tip_patches) {
+ # Our parent added, removed, or edited patches, and wasn't
+ # a gdr make-patches commit. gdr make-patches probably
+ # won't do that well, then.
+ # (gdr classification of parent: AddPatches or ?)
+ printdebug "branch_is_gdr $walk ?-patches NO\n";
+ return 0;
+ }
+ if ($tip_patches eq '' and
+ !defined git_cat_file "$walk:debian") {
+ # (gdr classification of parent: BreakwaterStart
+ printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
+ return 1;
+ }
+ # (gdr classification: Upstream Packaging Mixed Changelog)
+ printdebug "branch_is_gdr $walk plain\n"
+ if $debuglevel >= 2;
+ $walk = $parents[0];
+ }
+}
+
#---------- remote protocol support, common ----------
# remote push initiator/responder protocol:
die unless $got == $i_child_pid;
$i_child_pid = undef;
return undef unless $?;
- return "build host child ".waitstatusmsg();
+ return f_ "build host child %s", waitstatusmsg();
}
sub badproto ($$) {
my ($fh, $m) = @_;
- fail "connection lost: $!" if $fh->error;
- fail "protocol violation; $m not expected";
+ fail f_ "connection lost: %s", $! if $fh->error;
+ fail f_ "protocol violation; %s not expected", $m;
}
sub badproto_badread ($$) {
my ($fh, $wh) = @_;
- fail "connection lost: $!" if $!;
+ fail f_ "connection lost: %s", $! if $!;
my $report = i_child_report();
fail $report if defined $report;
- badproto $fh, "eof (reading $wh)";
+ badproto $fh, f_ "eof (reading %s)", $wh;
}
sub protocol_expect (&$) {
my ($match, $fh) = @_;
local $_;
$_ = <$fh>;
- defined && chomp or badproto_badread $fh, "protocol message";
+ defined && chomp or badproto_badread $fh, __ "protocol message";
if (wantarray) {
my @r = &$match;
return @r if @r;
my $r = &$match;
return $r if $r;
}
- badproto $fh, "\`$_'";
+ badproto $fh, f_ "\`%s'", $_;
}
sub protocol_send_file ($$) {
sub protocol_read_bytes ($$) {
my ($fh, $nbytes) = @_;
- $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
+ $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
my $d;
my $got = read $fh, $d, $nbytes;
- $got==$nbytes or badproto_badread $fh, "data block";
+ $got==$nbytes or badproto_badread $fh, __ "data block";
return $d;
}
progress "downloading $what...";
my $r = $ua->get(@_) or die $!;
return undef if $r->code == 404;
- $r->is_success or fail "failed to fetch $what: ".$r->status_line;
+ $r->is_success or fail f_ "failed to fetch %s: %s",
+ $what, $r->status_line;
return $r->decoded_content(charset => 'none');
}
sub printdone {
if (!$dryrun_level) {
- progress "$us ok: @_";
+ progress f_ "%s ok: %s", $us, "@_";
} else {
- progress "would be ok: @_ (but dry run only)";
+ progress f_ "would be ok: %s (but dry run only)", "@_";
}
}
}
}
-sub shell_cmd {
- my ($first_shell, @cmd) = @_;
- return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
-}
-
-our $helpmsg = <<END;
+our $helpmsg = i_ <<END;
main usages:
dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
dgit [dgit-opts] build [dpkg-buildpackage-opts]
dgit [dgit-opts] sbuild [sbuild-opts]
+ dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
dgit [dgit-opts] push [dgit-opts] [suite]
+ dgit [dgit-opts] push-source [dgit-opts] [suite]
dgit [dgit-opts] rpush build-host:build-dir ...
important dgit options:
-k<keyid> sign tag and package with <keyid> instead of default
-c<name>=<value> set git config option (used directly by dgit too)
END
-our $later_warning_msg = <<END;
+our $later_warning_msg = i_ <<END;
Perhaps the upload is stuck in incoming. Using the version from git.
END
sub badusage {
- print STDERR "$us: @_\n", $helpmsg or die $!;
- exit 8;
+ print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or die $!;
+ finish 8;
}
sub nextarg {
- @ARGV or badusage "too few arguments";
+ @ARGV or badusage __ "too few arguments";
return scalar shift @ARGV;
}
not_necessarily_a_tree();
}
sub cmd_help () {
- print $helpmsg or die $!;
- exit 0;
+ print __ $helpmsg or die $!;
+ finish 0;
}
our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
'dgit.default.sshpsql-dbname' => 'service=projectb',
'dgit.default.aptget-components' => 'main',
'dgit.default.dgit-tag-format' => 'new,old,maint',
+ 'dgit.default.source-only-uploads' => 'ok',
'dgit.dsc-url-proto-ok.http' => 'true',
'dgit.dsc-url-proto-ok.https' => 'true',
'dgit.dsc-url-proto-ok.git' => 'true',
+ 'dgit.vcs-git.suites', => 'sid', # ;-separated
'dgit.default.dsc-url-proto-ok' => 'false',
# old means "repo server accepts pushes with old dgit tags"
# new means "repo server accepts pushes with new dgit tags"
'dgit-distro.debian.git-check' => 'url',
'dgit-distro.debian.git-check-suffix' => '/info/refs',
'dgit-distro.debian.new-private-pushers' => 't',
+ 'dgit-distro.debian.source-only-uploads' => 'not-wholly-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',
"undef")."\n"
if $debuglevel >= 4;
$l or next;
- @$l==1 or badcfg "multiple values for $c".
- " (in $src git config)" if @$l > 1;
+ @$l==1 or badcfg
+ f_ "multiple values for %s (in %s git config)", $c, $src
+ if @$l > 1;
return $l->[0];
}
return undef;
return $dv;
}
}
- badcfg "need value for one of: @_\n".
- "$us: distro or suite appears not to be (properly) supported";
+ badcfg f_
+ "need value for one of: %s\n".
+ "%s: distro or suite appears not to be (properly) supported",
+ "@_", $us;
}
sub not_necessarily_a_tree () {
my $base = access_basedistro();
my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
$r =~ m/^$distro_re$/ or badcfg
- "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
+ f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
+ $r, "/^$distro_re$/";
return $r;
}
$re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
$re =~ s/\*/.*/g;
$re =~ s/\%/([-0-9a-z_]+)/
- or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
+ or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
if ($isuite =~ m/^$re$/) {
return ('backports',"$basedistro-backports",$1);
}
return
$v =~ m/^[ty1]/ ? 1 :
$v =~ m/^[fn0]/ ? 0 :
- badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
+ badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
+ $what, $v;
}
sub access_forpush_config () {
$v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
$v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
$v =~ m/^[a]/ ? '' : # auto, forpush = ''
- badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
+ badcfg __
+ "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
}
sub access_forpush () {
}
sub pushing () {
- die "$access_forpush ?" if ($access_forpush // 1) ne 1;
- badcfg "pushing but distro is configured readonly"
+ confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
+ defined $access_forpush and !$access_forpush;
+ badcfg __ "pushing but distro is configured readonly"
if access_forpush_config() eq '0';
$access_forpush = 1;
- $supplementary_message = <<'END' unless $we_are_responder;
+ $supplementary_message = __ <<'END' unless $we_are_responder;
Push failed, before we got started.
You can retry the push, after fixing the problem, if you like.
END
return "$url/$package$suffix";
}
-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;
-}
-
-sub parsecontrol {
- my ($file, $desc, $allowsigned) = @_;
- my $fh = new IO::Handle;
- open $fh, '<', $file or die "$file: $!";
- my $c = parsecontrolfh($fh,$desc,$allowsigned);
- $fh->error and die $!;
- close $fh;
- return $c;
-}
-
-sub getfield ($$) {
- my ($dctrl,$field) = @_;
- my $v = $dctrl->{$field};
- return $v if defined $v;
- fail "missing field $field in ".$dctrl->get_option('name');
-}
-
-sub parsechangelog {
- my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
- my $p = new IO::Handle;
- my @cmd = (qw(dpkg-parsechangelog), @_);
- open $p, '-|', @cmd or die $!;
- $c->parse($p);
- $?=0; $!=0; close $p or failedcmd @cmd;
- return $c;
-}
-
sub commit_getclogp ($) {
# Returns the parsed changelog hashref for a particular commit
my ($objid) = @_;
sub archive_query ($;@) {
my ($method) = shift @_;
- fail "this operation does not support multiple comma-separated suites"
+ fail __ "this operation does not support multiple comma-separated suites"
if $isuite =~ m/,/;
my $query = access_cfg('archive-query','RETURN-UNDEF');
$query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
fail "for $url: stat $key: $!" unless $!==ENOENT;
next;
}
- fail "config requested specific TLS key but do not know".
- " how to get curl to use exactly that EE key ($key)";
+ fail f_ "config requested specific TLS key but do not know".
+ " how to get curl to use exactly that EE key (%s)",
+ $key;
# push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
# # Sadly the above line does not work because of changes
# # to gnutls. The real fix for #790093 may involve
sub api_query ($$;$) {
use JSON;
my ($data, $subpath, $ok404) = @_;
- badcfg "ftpmasterapi archive query method takes no data part"
+ badcfg __ "ftpmasterapi archive query method takes no data part"
if length $data;
my @cmd = archive_api_query_cmd($subpath);
my $url = $cmd[$#cmd];
my $json = cmdoutput @cmd;
unless ($json =~ s/\d+\d+\d$//) {
failedcmd_report_cmd undef, @cmd;
- fail "curl failed to print 3-digit HTTP code";
+ fail __ "curl failed to print 3-digit HTTP code";
}
my $code = $&;
return undef if $code eq '404' && $ok404;
- fail "fetch of $url gave HTTP code $code"
+ fail f_ "fetch of %s gave HTTP code %s", $url, $code
unless $url =~ m#^file://# or $code =~ m/^2/;
return decode_json($json);
}
} qw(codename name);
push @matched, $entry;
}
- fail "unknown suite $isuite" unless @matched;
+ fail f_ "unknown suite %s, maybe -d would help", $isuite
+ unless @matched;
my $cn;
eval {
- @matched==1 or die "multiple matches for suite $isuite\n";
+ @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
$cn = "$matched[0]{codename}";
- defined $cn or die "suite $isuite info has no codename\n";
- $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
+ defined $cn or die f_ "suite %s info has no codename\n", $isuite;
+ $cn =~ m/^$suite_re$/
+ or die f_ "suite %s maps to bad codename\n", $isuite;
};
- die "bad ftpmaster api response: $@\n".Dumper(\@matched)
+ die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
if length $@;
return $cn;
}
eval {
my $vsn = "$entry->{version}";
my ($ok,$msg) = version_check $vsn;
- die "bad version: $msg\n" unless $ok;
+ die f_ "bad version: %s\n", $msg unless $ok;
my $component = "$entry->{component}";
- $component =~ m/^$component_re$/ or die "bad component";
+ $component =~ m/^$component_re$/ or die __ "bad component";
my $filename = "$entry->{filename}";
$filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
- or die "bad filename";
+ or die __ "bad filename";
my $sha256sum = "$entry->{sha256sum}";
- $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
+ $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
push @rows, [ $vsn, "/pool/$component/$filename",
$digester, $sha256sum ];
};
- die "bad ftpmaster api response: $@\n".Dumper($entry)
+ die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
if length $@;
}
@rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
my $info = api_query($data, "file_in_archive/$pat", 1);
}
+sub package_not_wholly_new_ftpmasterapi {
+ my ($proto,$data,$pkg) = @_;
+ my $info = api_query($data,"madison?package=${pkg}&f=json");
+ return !!@$info;
+}
+
#---------- `aptget' archive query method ----------
our $aptget_base;
sub aptget_lock_acquire () {
my $lockfile = "$aptget_base/lock";
- open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
- flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
+ open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
+ flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
}
sub aptget_prep ($) {
my ($data) = @_;
return if defined $aptget_base;
- badcfg "aptget archive query method takes no data part"
+ badcfg __ "aptget archive query method takes no data part"
if length $data;
my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
ensuredir $aptget_base;
my $quoted_base = $aptget_base;
- die "$quoted_base contains bad chars, cannot continue"
+ confess "$quoted_base contains bad chars, cannot continue"
if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
ensuredir $aptget_base;
cfg_apply_map(\$aptsuites, 'suite map',
access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
- open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
+ open SRCS, ">", "$aptget_base/$sourceslist" or confess $!;
printf SRCS "deb-src %s %s %s\n",
access_cfg('mirror'),
$aptsuites,
}
my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
@releasefiles = @inreleasefiles if @inreleasefiles;
- die "apt updated wrong number of Release files (@releasefiles), erk"
+ if (!@releasefiles) {
+ fail f_ <<END, $isuite, $cache;
+apt seemed to not to update dgit's cached Release files for %s.
+(Perhaps %s
+ is on a filesystem mounted `noatime'; if so, please use `relatime'.)
+END
+ }
+ confess "apt updated too many Release files (@releasefiles), erk"
unless @releasefiles == 1;
($aptget_releasefile) = @releasefiles;
my $val = $release->{$name};
if (defined $val) {
printdebug "release file $name: $val\n";
- $val =~ m/^$suite_re$/o or fail
- "Release file ($aptget_releasefile) specifies intolerable $name";
+ $val =~ m/^$suite_re$/o or fail f_
+ "Release file (%s) specifies intolerable %s",
+ $aptget_releasefile, $name;
cfg_apply_map(\$val, 'suite rmap',
access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
return $val
aptget_aptget(), qw(--download-only --only-source source), $package;
my @dscs = <$aptget_base/source/*.dsc>;
- fail "apt-get source did not produce a .dsc" unless @dscs;
- fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
+ fail __ "apt-get source did not produce a .dsc" unless @dscs;
+ fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
+ unless @dscs==1;
my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
}
sub file_in_archive_aptget () { return undef; }
+sub package_not_wholly_new_aptget () { return undef; }
#---------- `dummyapicat' archive query method ----------
+# (untranslated, because this is for testing purposes etc.)
sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
-sub file_in_archive_dummycatapi ($$$) {
- my ($proto,$data,$filename) = @_;
+sub dummycatapi_run_in_mirror ($@) {
+ # runs $fn with FIA open onto rune
+ my ($rune, $argl, $fn) = @_;
+
my $mirror = access_cfg('mirror');
$mirror =~ s#^file://#/# or die "$mirror ?";
- my @out;
- my @cmd = (qw(sh -ec), '
- cd "$1"
- find -name "$2" -print0 |
- xargs -0r sha256sum
- ', qw(x), $mirror, $filename);
+ my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
+ qw(x), $mirror, @$argl);
debugcmd "-|", @cmd;
open FIA, "-|", @cmd or die $!;
- while (<FIA>) {
- chomp or die;
- printdebug "| $_\n";
- m/^(\w+) (\S+)$/ or die "$_ ?";
- push @out, { sha256sum => $1, filename => $2 };
- }
- close FIA or die failedcmd @cmd;
+ my $r = $fn->();
+ close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
+ return $r;
+}
+
+sub file_in_archive_dummycatapi ($$$) {
+ my ($proto,$data,$filename) = @_;
+ my @out;
+ dummycatapi_run_in_mirror '
+ find -name "$1" -print0 |
+ xargs -0r sha256sum
+ ', [$filename], sub {
+ while (<FIA>) {
+ chomp or die;
+ printdebug "| $_\n";
+ m/^(\w+) (\S+)$/ or die "$_ ?";
+ push @out, { sha256sum => $1, filename => $2 };
+ }
+ };
return \@out;
}
+sub package_not_wholly_new_dummycatapi {
+ my ($proto,$data,$pkg) = @_;
+ dummycatapi_run_in_mirror "
+ find -name ${pkg}_*.dsc
+ ", [], sub {
+ local $/ = undef;
+ !!<FIA>;
+ };
+}
+
#---------- `madison' archive query method ----------
sub archive_query_madison {
sub canonicalise_suite_madison {
# madison canonicalises for us
my @r = madison_get_parse(@_);
- @r or fail
- "unable to canonicalise suite using package $package".
- " which does not appear to exist in suite $isuite;".
- " --existing-package may help";
+ @r or fail f_
+ "unable to canonicalise suite using package %s".
+ " which does not appear to exist in suite %s;".
+ " --existing-package may help",
+ $package, $isuite;
return $r[0][2];
}
sub file_in_archive_madison { return undef; }
+sub package_not_wholly_new_madison { return undef; }
#---------- `sshpsql' archive query method ----------
+# (untranslated, because this is obsolete)
sub sshpsql ($$$) {
my ($data,$runeinfo,$sql) = @_;
}
sub file_in_archive_sshpsql ($$$) { return undef; }
+sub package_not_wholly_new_sshpsql ($$$) { return undef; }
#---------- `dummycat' archive query method ----------
+# (untranslated, because this is for testing purposes etc.)
sub canonicalise_suite_dummycat ($$) {
my ($proto,$data) = @_;
}
sub file_in_archive_dummycat () { return undef; }
+sub package_not_wholly_new_dummycat () { return undef; }
#---------- tag format handling ----------
+# (untranslated, because everything should be new tag format by now)
sub access_cfg_tagformats () {
split /\,/, access_cfg('dgit-tag-format');
sub canonicalise_suite () {
return if defined $csuite;
- fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
+ fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
$csuite = archive_query('canonicalise_suite');
if ($isuite ne $csuite) {
- progress "canonical suite name for $isuite is $csuite";
+ progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
} else {
- progress "canonical suite name is $csuite";
+ progress f_ "canonical suite name is %s", $csuite;
}
}
$digester->add($dscdata);
my $got = $digester->hexdigest();
$got eq $digest or
- fail "$dscurl has hash $got but".
- " archive told us to expect $digest";
+ fail f_ "%s has hash %s but archive told us to expect %s",
+ $dscurl, $got, $digest;
}
parse_dscdata();
my $fmt = getfield $dsc, 'Format';
$format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
- "unsupported source format $fmt, sorry";
+ f_ "unsupported source format %s, sorry", $fmt;
$dsc_checked = !!$digester;
printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
# NB that if we are pushing, $usedistro will be $distro/push
$instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
$instead_distro =~ s{^/}{ access_basedistro()."/" }e;
- progress "diverting to $divert (using config for $instead_distro)";
+ progress f_ "diverting to %s (using config for %s)",
+ $divert, $instead_distro;
return check_for_git();
}
failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
# curl -sS -I with https_proxy prints
# HTTP/1.0 200 Connection established
$result =~ m/^\S+ (404|200) /s or
- fail "unexpected results from git check query - ".
+ fail +(__ "unexpected results from git check query - ").
Dumper($prefix, $result);
my $code = $1;
if ($code eq '404') {
} elsif ($how eq 'false') {
return 0;
} else {
- badcfg "unknown git-check \`$how'";
+ badcfg f_ "unknown git-check \`%s'", $how;
}
}
} elsif ($how eq 'true') {
# nothing to do
} else {
- badcfg "unknown git-create \`$how'";
+ badcfg f_ "unknown git-create \`%s'", $how;
}
}
sub prep_ud () {
dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
- fresh_playground 'dgit/unpack';
+ $playground = fresh_playground 'dgit/unpack';
}
sub mktree_in_ud_here () {
local $/="\0";
while (<GITS>) {
chomp or die;
- print STDERR "$us: warning: removing from $what: ",
- (messagequote $_), "\n";
+ print STDERR f_ "%s: warning: removing from %s: %s\n",
+ $us, $what, (messagequote $_);
rmtree $_;
}
}
# changes into the subdir
my (@dirs) = <*/.>;
- die "expected one subdir but found @dirs ?" unless @dirs==1;
+ confess "expected one subdir but found @dirs ?" unless @dirs==1;
$dirs[0] =~ m#^([^/]+)/\.$# or die;
my $dir = $1;
changedir $dir;
foreach (split /\n/, $field) {
next unless m/\S/;
m/^(\w+) (\d+) (\S+)$/ or
- fail "could not parse .dsc $fname line \`$_'";
+ fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
my $digester = eval "$module"."->$method;" or die $@;
push @out, {
Hash => $1,
}
return @out;
}
- fail "missing any supported Checksums-* or Files field in ".
- $dsc->get_option('name');
+ fail f_ "missing any supported Checksums-* or Files field in %s",
+ $dsc->get_option('name');
}
sub dsc_files () {
if (defined $$re) {
$fchecked{$f}{$in_name} = 1;
$$re eq $info or
- fail "hash or size of $f varies in $fname fields".
- " (between: ".$showinputs->().")";
+ fail f_
+ "hash or size of %s varies in %s fields (between: %s)",
+ $f, $fname, $showinputs->();
} else {
$$re = $info;
}
@files = sort @files;
$expected_files //= \@files;
"@$expected_files" eq "@files" or
- fail "file list in $in_name varies between hash fields!";
+ fail f_ "file list in %s varies between hash fields!",
+ $in_name;
}
$expected_files or
- fail "$in_name has no files list field(s)";
+ fail f_ "%s has no files list field(s)", $in_name;
}
printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
if $debuglevel>=2;
grep { keys %$_ == @$inputs-1 } values %fchecked
- or fail "no file appears in all file lists".
- " (looked in: ".$showinputs->().")";
+ or fail f_ "no file appears in all file lists (looked in: %s)",
+ $showinputs->();
}
sub is_orig_file_in_dsc ($$) {
return 1;
}
-sub is_orig_file_of_vsn ($$) {
- my ($f, $upstreamvsn) = @_;
- my $base = srcfn $upstreamvsn, '';
- return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
+# This function determines whether a .changes file is source-only from
+# the point of view of dak. Thus, it permits *_source.buildinfo
+# files.
+#
+# It does not, however, permit any other buildinfo files. After a
+# source-only upload, the buildds will try to upload files like
+# foo_1.2.3_amd64.buildinfo. If the package maintainer included files
+# named like this in their (otherwise) source-only upload, the uploads
+# of the buildd can be rejected by dak. Fixing the resultant
+# situation can require manual intervention. So we block such
+# .buildinfo files when the user tells us to perform a source-only
+# upload (such as when using the push-source subcommand with the -C
+# option, which calls this function).
+#
+# Note, though, that when dgit is told to prepare a source-only
+# upload, such as when subcommands like build-source and push-source
+# without -C are used, dgit has a more restrictive notion of
+# source-only .changes than dak: such uploads will never include
+# *_source.buildinfo files. This is because there is no use for such
+# files when using a tool like dgit to produce the source package, as
+# dgit ensures the source is identical to git HEAD.
+sub test_source_only_changes ($) {
+ my ($changes) = @_;
+ foreach my $l (split /\n/, getfield $changes, 'Files') {
+ $l =~ m/\S+$/ or next;
+ # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
+ unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
+ print f_ "purportedly source-only changes polluted by %s\n", $&;
+ return 0;
+ }
+ }
return 1;
}
printdebug "checking origs needed ($upstreamvsn)...\n";
$_ = getfield $changes, 'Files';
m/^\w+ \d+ (\S+ \S+) \S+$/m or
- fail "cannot find section/priority from .changes Files field";
+ fail __ "cannot find section/priority from .changes Files field";
my $placementinfo = $1;
my %changed;
printdebug "checking origs needed placement '$placementinfo'...\n";
printdebug "origs $file is_orig\n";
my $have = archive_query('file_in_archive', $file);
if (!defined $have) {
- print STDERR <<END;
+ print STDERR __ <<END;
archive does not support .orig check; hope you used --ch:--sa/-sd if needed
END
return;
$_ = $dsc->{$fname};
next unless defined;
m/^(\w+) .* \Q$file\E$/m or
- fail ".dsc $fname missing entry for $file";
+ fail f_ ".dsc %s missing entry for %s", $fname, $file;
if ($h->{$archivefield} eq $1) {
$same++;
} else {
- push @differ,
- "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
+ push @differ, f_
+ "%s: %s (archive) != %s (local .dsc)",
+ $archivefield, $h->{$archivefield}, $1;
}
}
- die "$file ".Dumper($h)." ?!" if $same && @differ;
+ confess "$file ".Dumper($h)." ?!" if $same && @differ;
$found_same++
if $same;
- push @found_differ, "archive $h->{filename}: ".join "; ", @differ
+ push @found_differ,
+ f_ "archive %s: %s", $h->{filename}, join "; ", @differ
if @differ;
}
printdebug "origs $file f.same=$found_same".
" #f._differ=$#found_differ\n";
if (@found_differ && !$found_same) {
fail join "\n",
- "archive contains $file with different checksum",
+ (f_ "archive contains %s with different checksum", $file),
@found_differ;
}
# Now we edit the changes file to add or remove it
if ($found_same) {
# in archive, delete from .changes if it's there
$changed{$file} = "removed" if
- $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
- } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
+ $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
+ } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
# not in archive, but it's here in the .changes
} else {
my $dsc_data = getfield $dsc, $fname;
- $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
+ $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
my $extra = $1;
$extra =~ s/ \d+ /$&$placementinfo /
- or die "$fname $extra >$dsc_data< ?"
+ or confess "$fname $extra >$dsc_data< ?"
if $fname eq 'Files';
$changes->{$fname} .= "\n". $extra;
$changed{$file} = "added";
}
if (%changed) {
foreach my $file (keys %changed) {
- progress sprintf
+ progress f_
"edited .changes for archive .orig contents: %s %s",
$changed{$file}, $file;
}
if (act_local()) {
rename $chtmp,$changesfile or die "$changesfile $!";
} else {
- progress "[new .changes left in $changesfile]";
+ progress f_ "[new .changes left in %s]", $changesfile;
}
} else {
- progress "$changesfile already has appropriate .orig(s) (if any)";
+ progress f_ "%s already has appropriate .orig(s) (if any)",
+ $changesfile;
}
}
return cmdoutput @git, qw(hash-object -w -t commit), $file;
}
-sub make_commit_text ($) {
- my ($text) = @_;
- my ($out, $in);
- my @cmd = (@git, qw(hash-object -w -t commit --stdin));
- debugcmd "|",@cmd;
- print Dumper($text) if $debuglevel > 1;
- my $child = open2($out, $in, @cmd) or die $!;
- my $h;
- eval {
- print $in $text or die $!;
- close $in or die $!;
- $h = <$out>;
- $h =~ m/^\w+$/ or die;
- $h = $&;
- printdebug "=> $h\n";
- };
- close $out;
- waitpid $child, 0 == $child or die "$child $!";
- $? and failedcmd @cmd;
- return $h;
-}
-
sub clogp_authline ($) {
my ($clogp) = @_;
my $author = getfield $clogp, 'Maintainer';
my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
my $authline = "$author $date";
$authline =~ m/$git_authline_re/o or
- fail "unexpected commit author line format \`$authline'".
- " (was generated from changelog Maintainer field)";
+ fail f_ "unexpected commit author line format \`%s'".
+ " (was generated from changelog Maintainer field)",
+ $authline;
return ($1,$2,$3) if wantarray;
return $authline;
}
printdebug "checking for vendor-specific $series ($what)\n";
if (!open SERIES, "<", $series) {
- die "$series $!" unless $!==ENOENT;
+ confess "$series $!" unless $!==ENOENT;
return;
}
while (<SERIES>) {
next unless m/\S/;
next if m/^\s+\#/;
- print STDERR <<END;
+ print STDERR __ <<END;
Unfortunately, this source package uses a feature of dpkg-source where
the same source package unpacks to different source code on different
different code).
END
- fail "Found active distro-specific series file for".
- " $checkdistro ($what): $series, cannot continue";
+ fail f_ "Found active distro-specific series file for".
+ " %s (%s): %s, cannot continue",
+ $checkdistro, $what, $series;
}
die "$series $!" if SERIES->error;
close SERIES;
use Dpkg::Vendor;
vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
- "Dpkg::Vendor \`current vendor'");
+ __ "Dpkg::Vendor \`current vendor'");
vendor_patches_distro(access_basedistro(),
- "(base) distro being accessed");
+ __ "(base) distro being accessed");
vendor_patches_distro(access_nomdistro(),
- "(nominal) distro being accessed");
+ __ "(nominal) distro being accessed");
}
sub generate_commits_from_dsc () {
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
- my $upper_f = "$maindir/../$f";
+ my $upper_f = (bpd_abs()."/$f");
printdebug "considering reusing $f: ";
printdebug "linked (using ...,fetch).\n";
} elsif ((printdebug "($!) "),
$! != ENOENT) {
- fail "accessing ../$f,fetch: $!";
+ fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
} elsif (link_ltarget $upper_f, $f) {
printdebug "linked.\n";
} elsif ((printdebug "($!) "),
$! != ENOENT) {
- fail "accessing ../$f: $!";
+ fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
} else {
printdebug "absent.\n";
}
printdebug "linked.\n";
} elsif ((printdebug "($!) "),
$! != EEXIST) {
- fail "saving ../$f: $!";
+ fail f_ "saving %s: %s", "$buildproductsdir/$f", $!;
} elsif (!$refetched) {
printdebug "no need.\n";
} elsif (link $f, "$upper_f,fetch") {
printdebug "linked (using ...,fetch).\n";
} elsif ((printdebug "($!) "),
$! != EEXIST) {
- fail "saving ../$f,fetch: $!";
+ fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $!;
} else {
printdebug "cannot.\n";
}
chdir "_unpack-tar" or die $!;
open STDIN, "<&", $input or die $!;
exec @tarcmd;
- die "dgit (child): exec $tarcmd[0]: $!";
+ die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
}
$!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
!$? or failedcmd @tarcmd;
push @cmd, qw(-x --), $dscfn;
runcmd @cmd;
- my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
+ my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
if (madformat $dsc->{format}) {
check_for_vendor_patches();
}
}
my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
- debugcmd "|",@clogcmd;
- open CLOGS, "-|", @clogcmd or die $!;
-
my $clogp;
my $r1clogp;
printdebug "import clog search...\n";
+ parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
+ my ($thisstanza, $desc) = @_;
+ no warnings qw(exiting);
- for (;;) {
- my $stanzatext = do { local $/=""; <CLOGS>; };
- printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
- last if !defined $stanzatext;
-
- my $desc = "package changelog, entry no.$.";
- open my $stanzafh, "<", \$stanzatext or die;
- my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
$clogp //= $thisstanza;
printdebug "import clog $thisstanza->{version} $desc...\n";
# version). Then it remains to choose between the physically
# last entry in the file, and the one with the lowest version
# number. If these are not the same, we guess that the
- # versions were created in a non-monotic order rather than
+ # versions were created in a non-monotonic order rather than
# that the changelog entries have been misordered.
printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
$r1clogp = $thisstanza;
printdebug "import clog $r1clogp->{version} becomes r1\n";
- }
- die $! if CLOGS->error;
- close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
+ };
- $clogp or fail "package changelog has no entries!";
+ $clogp or fail __ "package changelog has no entries!";
my $authline = clogp_authline $clogp;
my $changes = getfield $clogp, 'Changes';
foreach my $tt (@tartrees) {
printdebug "import tartree $tt->{F} $tt->{Tree}\n";
+ my $mbody = f_ "Import %s", $tt->{F};
$tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
tree $tt->{Tree}
author $r1authline
committer $r1authline
-Import $tt->{F}
+$mbody
[dgit import orig $tt->{F}]
END_O
author $authline
committer $authline
-Import $tt->{F}
+$mbody
[dgit import tarball $package $cversion $tt->{F}]
END_T
chomp $@;
progress "warning: $@";
$path = "$absurdity:$path";
- progress "$us: trying slow absurd-git-apply...";
+ progress f_ "%s: trying slow absurd-git-apply...", $us;
rename "../../gbp-pq-output","../../gbp-pq-output.0"
or $!==ENOENT
or die $!;
'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
debugcmd "+",@realcmd;
if (system @realcmd) {
- die +(shellquote @showcmd).
- " failed: ".
- failedcmd_waitstatus()."\n";
+ die f_ "%s failed: %s\n",
+ +(shellquote @showcmd),
+ failedcmd_waitstatus();
}
my $gapplied = git_rev_parse('HEAD');
my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
$gappliedtree eq $dappliedtree or
- fail <<END;
+ fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
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
+ gbp-pq import gave commit %s
+ gbp-pq import gave tree %s
+ dpkg-source --before-build gave tree %s
END
$rawimport_hash = $gapplied;
};
}
}
- progress "synthesised git commit from .dsc $cversion";
+ progress f_ "synthesised git commit from .dsc %s", $cversion;
my $rawimport_mergeinput = {
Commit => $rawimport_hash,
- Info => "Import of source package",
+ Info => __ "Import of source package",
};
my @output = ($rawimport_mergeinput);
version_compare($oversion, $cversion);
if ($vcmp < 0) {
@output = ($rawimport_mergeinput, $lastpush_mergeinput,
- { Message => <<END, ReverseParents => 1 });
-Record $package ($cversion) in archive suite $csuite
+ { ReverseParents => 1,
+ Message => (f_ <<END, $package, $cversion, $csuite) });
+Record %s (%s) in archive suite %s
END
} elsif ($vcmp > 0) {
- print STDERR <<END or die $!;
+ print STDERR f_ <<END, $cversion, $oversion,
-Version actually in archive: $cversion (older)
-Last version pushed with dgit: $oversion (newer or same)
-$later_warning_msg
+Version actually in archive: %s (older)
+Last version pushed with dgit: %s (newer or same)
+%s
END
+ __ $later_warning_msg or die $!;
@output = $lastpush_mergeinput;
} else {
# Same version. Use what's in the server git branch,
if (stat_exists $tf) {
if ($checkhash->()) {
- progress "using existing $f";
+ progress f_ "using existing %s", $f;
return 1;
}
if (!$refetched) {
- fail "file $f has hash $got but .dsc".
- " demands hash $fi->{Hash} ".
- "(perhaps you should delete this file?)";
+ fail f_ "file %s has hash %s but .dsc demands hash %s".
+ " (perhaps you should delete this file?)",
+ $f, $got, $fi->{Hash};
}
- progress "need to fetch correct version of $f";
+ progress f_ "need to fetch correct version of %s", $f;
unlink $tf or die "$tf $!";
$$refetched = 1;
} else {
return 0 if !act_local();
$checkhash->() or
- fail "file $f has hash $got but .dsc".
- " demands hash $fi->{Hash} ".
- "(got wrong file from archive!)";
+ fail f_ "file %s has hash %s but .dsc demands hash %s".
+ " (got wrong file from archive!)",
+ $f, $got, $fi->{Hash};
return 1;
}
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
next unless is_orig_file_in_dsc($f, \@dfi);
- complete_file_from_dsc('..', $fi)
+ complete_file_from_dsc($buildproductsdir, $fi)
or next;
}
}
for (;;) {
printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
if (++$fetch_iteration > 10) {
- fail "too many iterations trying to get sane fetch!";
+ fail __ "too many iterations trying to get sane fetch!";
}
my @look = map { "refs/$_" } @specs;
m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
my ($objid,$rrefname) = ($1,$2);
if (!$wanted_rref->($rrefname)) {
- print STDERR <<END;
-warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
+ print STDERR f_ <<END, "@look", $rrefname;
+warning: git ls-remote %s reported %s; this is silly, ignoring it.
END
next;
}
git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
END
} else {
- print STDERR <<END
-warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
+ print STDERR f_ <<END, "@fspecs", $lrefname
+warning: git fetch %s created %s; this is silly, deleting it.
END
}
runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
my $want = $wantr{$rrefname};
next if $got eq $want;
if (!defined $objgot{$want}) {
- print STDERR <<END;
-warning: git ls-remote suggests we want $lrefname
-warning: and it should refer to $want
+ fail __ <<END unless act_local();
+--dry-run specified but we actually wanted the results of git fetch,
+so this is not going to work. Try running dgit fetch first,
+or using --damp-run instead of --dry-run.
+END
+ print STDERR f_ <<END, $lrefname, $want;
+warning: git ls-remote suggests we want %s
+warning: and it should refer to %s
warning: but git fetch didn't fetch that object to any relevant ref.
warning: This may be due to a race with someone updating the server.
warning: Will try again...
sub fetch_from_archive_record_1 ($) {
my ($hash) = @_;
- runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
- 'DGIT_ARCHIVE', $hash;
+ runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
cmdoutput @git, qw(log -n2), $hash;
# ... gives git a chance to complain if our commit is malformed
}
sub fetch_from_archive_record_2 ($) {
my ($hash) = @_;
- my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
+ my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
if (act_local()) {
cmdoutput @upd_cmd;
} else {
if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
@mergeinputs = $dsc_mergeinput
} elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
- print STDERR <<END or die $!;
+ print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
Git commit in archive is behind the last version allegedly pushed/uploaded.
-Commit referred to by archive: $dsc_hash
-Last version pushed with dgit: $lastpush_hash
-$later_warning_msg
+Commit referred to by archive: %s
+Last version pushed with dgit: %s
+%s
END
+ __ $later_warning_msg or die $!;
@mergeinputs = ($lastpush_mergeinput);
} else {
# Archive has .dsc which is not a descendant of the last dgit
} elsif ($lastpush_hash) {
# only in git, not in the archive yet
@mergeinputs = ($lastpush_mergeinput);
- print STDERR <<END or die $!;
+ print STDERR f_ <<END,
Package not found in the archive, but has allegedly been pushed using dgit.
-$later_warning_msg
+%s
END
+ __ $later_warning_msg or die $!;
} else {
printdebug "nothing found!\n";
if (defined $skew_warning_vsn) {
# here we go, then:
my $tree_commit = $mergeinputs[0]{Commit};
- my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
- $tree =~ m/\n\n/; $tree = $`;
- $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
- $tree = $1;
+ my $tree = get_tree_of_commit $tree_commit;;
# We use the changelog author of the package in question the
# author of this pseudo-merge. This is (roughly) correct if
return $gai;
}
+our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
+
sub is_gitattrs_setup () {
+ # return values:
+ # trueish
+ # 1: gitattributes set up and should be left alone
+ # falseish
+ # 0: there is a dgit-defuse-attrs but it needs fixing
+ # undef: there is none
my $gai = open_main_gitattrs();
return 0 unless $gai;
while (<$gai>) {
- return 1 if m{^\[attr\]dgit-defuse-attrs\s};
+ next unless m{$gitattrs_ourmacro_re};
+ return 1 if m{\s-working-tree-encoding\s};
+ printdebug "is_gitattrs_setup: found old macro\n";
+ return 0;
}
$gai->error and die $!;
- return 0;
+ printdebug "is_gitattrs_setup: found nothing\n";
+ return undef;
}
sub setup_gitattrs (;$) {
my ($always) = @_;
return unless $always || access_cfg_bool(1, 'setup-gitattributes');
- if (is_gitattrs_setup()) {
+ my $already = is_gitattrs_setup();
+ if ($already) {
progress <<END;
-[attr]dgit-defuse-attrs already found in .git/info/attributes
+[attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
not doing further gitattributes setup
END
return;
}
+ my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
my $af = "$maindir_gitcommon/info/attributes";
ensuredir "$maindir_gitcommon/info";
+
open GAO, "> $af.new" or die $!;
- print GAO <<END or die $!;
+ print GAO <<END or die $! unless defined $already;
* dgit-defuse-attrs
-[attr]dgit-defuse-attrs $negate_harmful_gitattrs
+$new
# ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
END
my $gai = open_main_gitattrs();
if ($gai) {
while (<$gai>) {
+ if (m{$gitattrs_ourmacro_re}) {
+ die unless defined $already;
+ $_ = $new;
+ }
chomp;
print GAO $_, "\n" or die $!;
}
# oh dear, found one
print STDERR <<END;
dgit: warning: $what contains .gitattributes
-dgit: .gitattributes have not been defused. Recommended: dgit setup-new-tree.
+dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
END
close $gafl;
return;
sub multisuite_suite_child ($$$) {
- my ($tsuite, $merginputs, $fn) = @_;
+ my ($tsuite, $mergeinputs, $fn) = @_;
# in child, sets things up, calls $fn->(), and returns undef
# in parent, returns canonical suite name for $tsuite
my $canonsuitefh = IO::File::new_tmpfile;
return $csuite;
}
printdebug "multisuite $tsuite ok (canon=$csuite)\n";
- push @$merginputs, {
+ push @$mergeinputs, {
Ref => lrref,
Info => $csuite,
};
my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
sub {
@end = ();
- fetch();
- exit 0;
+ fetch_one();
+ finish 0;
});
- # xxx collecte the ref here
$csubsuite =~ s/^\Q$cbasesuite\E-/-/;
push @csuites, $csubsuite;
clone_finish($dstdir);
}
-sub fetch () {
+sub fetch_one () {
canonicalise_suite();
if (check_for_git()) {
git_fetch_us();
}
fetch_from_archive() or no_such_package();
+
+ my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
+ if (length $vcsgiturl and
+ (grep { $csuite eq $_ }
+ split /\;/,
+ cfg 'dgit.vcs-git.suites')) {
+ my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
+ if (defined $current && $current ne $vcsgiturl) {
+ print STDERR <<END;
+FYI: Vcs-Git in $csuite has different url to your vcs-git remote.
+ Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
+END
+ }
+ }
printdone "fetched into ".lrref();
}
-sub pull () {
+sub dofetch () {
my $multi_fetched = fork_for_multisuite(sub { });
- fetch() unless $multi_fetched; # parent
- return if $multi_fetched eq '0'; # child
+ fetch_one() unless $multi_fetched; # parent
+ finish 0 if $multi_fetched eq '0'; # child
+}
+
+sub pull () {
+ dofetch();
runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
lrref();
printdone "fetched to ".lrref()." and merged into HEAD";
}
}
- return if $ignoredirty;
+ return if $includedirty;
- my @cmd = (@git, qw(diff --quiet HEAD));
- debugcmd "+",@cmd;
- $!=0; $?=-1; system @cmd;
- return if !$?;
- if ($?==256) {
- fail "working tree is dirty (does not match HEAD)";
- } else {
- failedcmd @cmd;
- }
+ git_check_unmodified();
}
sub commit_admin ($) {
runcmd_ordryrun_local @git, qw(commit -m), $m;
}
+sub quiltify_nofix_bail ($$) {
+ my ($headinfo, $xinfo) = @_;
+ if ($quilt_mode eq 'nofix') {
+ fail "quilt fixup required but quilt mode is \`nofix'\n".
+ "HEAD commit".$headinfo." differs from tree implied by ".
+ " debian/patches".$xinfo;
+ }
+}
+
sub commit_quilty_patch () {
- my $output = cmdoutput @git, qw(status --porcelain);
+ my $output = cmdoutput @git, qw(status --ignored --porcelain);
my %adds;
foreach my $l (split /\n/, $output) {
next unless $l =~ m/\S/;
- if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
+ if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
$adds{$1}++;
}
}
progress "nothing quilty to commit, ok.";
return;
}
+ quiltify_nofix_bail "", " (wanted to commit patch update)";
my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
runcmd_ordryrun_local @git, qw(add -f), @adds;
commit_admin <<END
sub maybe_split_brain_save ($$$) {
my ($headref, $dgitview, $msg) = @_;
# => message fragment "$saved" describing disposition of $dgitview
- return "commit id $dgitview" unless defined $split_brain_save;
+ my $save = $internal_object_save{'dgit-view'};
+ return "commit id $dgitview" unless defined $save;
my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
- @git, qw(update-ref -m),
+ git_update_ref_cmd
"dgit --dgit-view-save $msg HEAD=$headref",
- $split_brain_save, $dgitview);
+ $save, $dgitview);
runcmd @cmd;
- return "and left in $split_brain_save";
+ return "and left in $save";
}
# An "infopair" is a tuple [ $thing, $what ]
: !length $overwrite_version ? " --overwrite"
: " --overwrite=".$overwrite_version;
+ # Contributing parent is the first parent - that makes
+ # git rev-list --first-parent DTRT.
my $pmf = dgit_privdir()."/pseudomerge";
open MC, ">", $pmf or die "$pmf $!";
print MC <<END or die $!;
infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
1;
}) {
+ $@ =~ s/^\n//; chomp $@;
print STDERR <<END;
-$us: check failed (maybe --overwrite is needed, consult documentation)
+$@
+| Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
END
- die "$@";
+ finish -1;
}
my $r = pseudomerge_make_commit
$clogp, $head, $archive_hash, $i_arch_v,
"dgit", $m;
- runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
+ runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
return $r;
my $format = getfield $dsc, 'Format';
printdebug "format $format\n";
+ my $symref = git_get_symref();
my $actualhead = git_rev_parse('HEAD');
+
+ if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
+ if (quiltmode_splitbrain()) {
+ my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
+ fail <<END;
+Branch is managed by git-debrebase ($ffq_prev
+exists), but quilt mode ($quilt_mode) implies a split view.
+Pass the right --quilt option or adjust your git config.
+Or, maybe, run git-debrebase forget-was-ever-debrebase.
+END
+ }
+ runcmd_ordryrun_local @git_debrebase, 'stitch';
+ $actualhead = git_rev_parse('HEAD');
+ }
+
my $dgithead = $actualhead;
my $maintviewhead = undef;
}
}
- if (defined $overwrite_version && !defined $maintviewhead) {
+ if (defined $overwrite_version && !defined $maintviewhead
+ && $archive_hash) {
$dgithead = plain_overwrite_pseudomerge($clogp,
$dgithead,
$archive_hash);
files_compare_inputs($dsc, $changes)
unless forceing [qw(dsc-changes-mismatch)];
+ # Check whether this is a source only upload
+ my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
+ my $sourceonlypolicy = access_cfg 'source-only-uploads';
+ if ($sourceonlypolicy eq 'ok') {
+ } elsif ($sourceonlypolicy eq 'always') {
+ forceable_fail [qw(uploading-binaries)],
+ "uploading binaries, although distroy policy is source only"
+ if $hasdebs;
+ } elsif ($sourceonlypolicy eq 'never') {
+ forceable_fail [qw(uploading-source-only)],
+ "source-only upload, although distroy policy requires .debs"
+ if !$hasdebs;
+ } elsif ($sourceonlypolicy eq 'not-wholly-new') {
+ forceable_fail [qw(uploading-source-only)],
+ "source-only upload, even though package is entirely NEW\n".
+ "(this is contrary to policy in ".(access_nomdistro()).")"
+ if !$hasdebs
+ && $new_package
+ && !(archive_query('package_not_wholly_new', $package) // 1);
+ } else {
+ badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'";
+ }
+
# Perhaps adjust .dsc to contain right set of origs
changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
$changesfile)
responder_send_command("param isuite $isuite");
responder_send_command("param tagformat $tagformat");
if (defined $maintviewhead) {
- die unless ($protovsn//4) >= 4;
+ confess "internal error (protovsn=$protovsn)"
+ if defined $protovsn and $protovsn < 4;
responder_send_command("param maint-view $maintviewhead");
}
runcmd_ordryrun @git,
qw(-c push.followTags=false push), access_giturl(), @pushrefs;
- runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
+ runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
supplementary_message(<<'END');
Push failed, while obtaining signatures on the .changes and .dsc.
If it was just that the signature failed, you may try again by using
-debsign by hand to sign the changes
- $changesfile
-and then dput to complete the upload.
+debsign by hand to sign the changes file (see the command dgit tried,
+above), and then dput that changes file to complete the upload.
If you need to change the package, you must use a new version number.
END
if ($we_are_responder) {
}
sub branchsuite () {
- my @cmd = (@git, qw(symbolic-ref -q HEAD));
- my $branch = cmdoutput_errok @cmd;
- if (!defined $branch) {
- $?==256 or failedcmd @cmd;
- return undef;
- }
- if ($branch =~ m#$lbranch_re#o) {
+ my $branch = git_get_symref();
+ if (defined $branch && $branch =~ m#$lbranch_re#o) {
return $1;
} else {
return undef;
}
}
-sub fetchpullargs () {
+sub package_from_d_control () {
if (!defined $package) {
my $sourcep = parsecontrol('debian/control','debian/control');
$package = getfield $sourcep, 'Source';
}
+}
+
+sub fetchpullargs () {
+ package_from_d_control();
if (@ARGV==0) {
$isuite = branchsuite();
if (!$isuite) {
sub cmd_fetch {
parseopts();
fetchpullargs();
- my $multi_fetched = fork_for_multisuite(sub { });
- exit 0 if $multi_fetched;
- fetch();
+ dofetch();
}
sub cmd_pull {
pull();
}
+sub cmd_checkout {
+ parseopts();
+ package_from_d_control();
+ @ARGV==1 or badusage "dgit checkout needs a suite argument";
+ ($isuite) = @ARGV;
+ notpushing();
+
+ foreach my $canon (qw(0 1)) {
+ if (!$canon) {
+ $csuite= $isuite;
+ } else {
+ undef $csuite;
+ canonicalise_suite();
+ }
+ if (length git_get_ref lref()) {
+ # local branch already exists, yay
+ last;
+ }
+ if (!length git_get_ref lrref()) {
+ if (!$canon) {
+ # nope
+ next;
+ }
+ dofetch();
+ }
+ # now lrref exists
+ runcmd (@git, qw(update-ref), lref(), lrref(), '');
+ last;
+ }
+ local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
+ "dgit checkout $isuite";
+ runcmd (@git, qw(checkout), lbranch());
+}
+
+sub cmd_update_vcs_git () {
+ my $specsuite;
+ if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
+ ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
+ } else {
+ ($specsuite) = (@ARGV);
+ shift @ARGV;
+ }
+ my $dofetch=1;
+ if (@ARGV) {
+ if ($ARGV[0] eq '-') {
+ $dofetch = 0;
+ } elsif ($ARGV[0] eq '-') {
+ shift;
+ }
+ }
+
+ package_from_d_control();
+ my $ctrl;
+ if ($specsuite eq '.') {
+ $ctrl = parsecontrol 'debian/control', 'debian/control';
+ } else {
+ $isuite = $specsuite;
+ get_archive_dsc();
+ $ctrl = $dsc;
+ }
+ my $url = getfield $ctrl, 'Vcs-Git';
+
+ my @cmd;
+ my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
+ if (!defined $orgurl) {
+ print STDERR "setting up vcs-git: $url\n";
+ @cmd = (@git, qw(remote add vcs-git), $url);
+ } elsif ($orgurl eq $url) {
+ print STDERR "vcs git already configured: $url\n";
+ } else {
+ print STDERR "changing vcs-git url to: $url\n";
+ @cmd = (@git, qw(remote set-url vcs-git), $url);
+ }
+ runcmd_ordryrun_local @cmd;
+ if ($dofetch) {
+ print "fetching (@ARGV)\n";
+ runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
+ }
+}
+
sub prep_push () {
parseopts();
build_or_push_prep_early();
i_cleanup();
printdebug "all done\n";
- exit 0;
+ finish 0;
}
sub i_resp_file ($) {
}
}
-sub quiltify_splitbrain ($$$$$$) {
- my ($clogp, $unapplied, $headref, $diffbits,
+sub quiltify_splitbrain ($$$$$$$) {
+ my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
$editedignores, $cachekey) = @_;
+ my $gitignore_special = 1;
if ($quilt_mode !~ m/gbp|dpm/) {
# treat .gitignore just like any other upstream file
$diffbits = { %$diffbits };
$_ = !!$_ foreach values %$diffbits;
+ $gitignore_special = 0;
}
# We would like any commits we generate to be reproducible
my @authline = clogp_authline($clogp);
local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
local $ENV{GIT_AUTHOR_DATE} = $authline[2];
+ my $fulldiffhint = sub {
+ my ($x,$y) = @_;
+ my $cmd = "git diff $x $y -- :/ ':!debian'";
+ $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
+ return "\nFor full diff showing the problem(s), type:\n $cmd\n";
+ };
+
if ($quilt_mode =~ m/gbp|unapplied/ &&
($diffbits->{O2H} & 01)) {
my $msg =
"--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
" but git tree differs from orig in upstream files.";
+ $msg .= $fulldiffhint->($unapplied, 'HEAD');
if (!stat_exists "debian/patches") {
$msg .=
"\n ... debian/patches is missing; perhaps this is a patch queue branch?";
}
if ($quilt_mode =~ m/dpm/ &&
($diffbits->{H2A} & 01)) {
- fail <<END;
+ fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
--quilt=$quilt_mode specified, implying patches-applied git tree
but git tree differs from result of applying debian/patches to upstream
END
}
if ($quilt_mode =~ m/gbp|dpm/ &&
($diffbits->{O2A} & 02)) {
- fail <<END
+ fail <<END;
--quilt=$quilt_mode specified, implying that HEAD is for use with a
tool which does not create patches for changes to upstream
.gitignores: but, such patches exist in debian/patches.
print SERIES "\n" or die $! unless $newline eq "\n";
print SERIES "auto-gitignore\n" or die $!;
close SERIES or die $!;
- runcmd @git, qw(add -- debian/patches/series), $gipatch;
+ runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
commit_admin <<END
Commit patch to update .gitignore
my $dgitview = git_rev_parse 'HEAD';
changedir $maindir;
- # When we no longer need to support squeeze, use --create-reflog
- # instead of this:
- ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
- my $makelogfh = new IO::File "$maindir_gitcommon/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;
+ reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
changedir "$playground/work";
last;
}
- if ($quilt_mode eq 'nofix') {
- fail "quilt fixup required but quilt mode is \`nofix'\n".
- "HEAD commit $c->{Commit} differs from tree implied by ".
- " debian/patches (tree object $oldtiptree)";
- }
+ quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
if ($quilt_mode eq 'smash') {
printdebug " search quitting smash\n";
last;
return $s;
};
if ($quilt_mode eq 'linear') {
- print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
+ print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
+ my $all_gdr = !!@nots;
foreach my $notp (@nots) {
print STDERR "$us: ", $reportnot->($notp), "\n";
+ $all_gdr &&= $notp->{Child} &&
+ (git_cat_file $notp->{Child}{Commit}, 'commit')
+ =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
}
- print STDERR "$us: $_\n" foreach @$failsuggestion;
- fail "quilt fixup naive history linearisation failed.\n".
- "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
+ print STDERR "\n";
+ $failsuggestion =
+ [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
+ if $all_gdr;
+ print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
+ fail
+ "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
} elsif ($quilt_mode eq 'smash') {
} elsif ($quilt_mode eq 'auto') {
progress "quilt fixup cannot be linear, smashing...";
my $clogp = parsechangelog();
my $headref = git_rev_parse('HEAD');
+ my $symref = git_get_symref();
+
+ if ($quilt_mode eq 'linear'
+ && !$fopts->{'single-debian-patch'}
+ && branch_is_gdr($headref)) {
+ # This is much faster. It also makes patches that gdr
+ # likes better for future updates without laundering.
+ #
+ # However, it can fail in some casses where we would
+ # succeed: if there are existing patches, which correspond
+ # to a prefix of the branch, but are not in gbp/gdr
+ # format, gdr will fail (exiting status 7), but we might
+ # be able to figure out where to start linearising. That
+ # will be slower so hopefully there's not much to do.
+ my @cmd = (@git_debrebase,
+ qw(--noop-ok -funclean-mixed -funclean-ordering
+ make-patches --quiet-would-amend));
+ # We tolerate soe snags that gdr wouldn't, by default.
+ if (act_local()) {
+ debugcmd "+",@cmd;
+ $!=0; $?=-1;
+ failedcmd @cmd if system @cmd and $?!=7*256;
+ } else {
+ dryrun_report @cmd;
+ }
+ $headref = git_rev_parse('HEAD');
+ }
prep_ud();
changedir $playground;
quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
}
- die 'bug' if $split_brain && !$need_split_build_invocation;
-
changedir $maindir;
runcmd_ordryrun_local
@git, qw(pull --ff-only -q), "$playground/work", qw(master);
}
-sub quilt_fixup_mkwork ($) {
+sub unpack_playtree_mkwork ($) {
my ($headref) = @_;
mkdir "work" or die $!;
runcmd @git, qw(reset -q --hard), $headref;
}
-sub quilt_fixup_linkorigs ($$) {
+sub unpack_playtree_linkorigs ($$) {
my ($upstreamversion, $fn) = @_;
# calls $fn->($leafname);
- foreach my $f (<$maindir/../*>) { #/){
- my $b=$f; $b =~ s{.*/}{};
+ my $bpd_abs = bpd_abs();
+ opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
+ while ($!=0, defined(my $b = readdir QFD)) {
+ my $f = bpd_abs()."/".$b;
{
local ($debuglevel) = $debuglevel-1;
printdebug "QF linkorigs $b, $f ?\n";
link_ltarget $f, $b or die "$b $!";
$fn->($b);
}
+ die "$buildproductsdir: $!" if $!;
+ closedir QFD;
}
sub quilt_fixup_delete_pc () {
# get it to generate debian/patches/debian-changes, it is
# necessary to build the source package.
- quilt_fixup_linkorigs($upstreamversion, sub { });
- quilt_fixup_mkwork($headref);
+ unpack_playtree_linkorigs($upstreamversion, sub { });
+ unpack_playtree_mkwork($headref);
rmtree("debian/patches");
print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
};
- quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
+ unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
my @files=qw(debian/source/format debian/rules
debian/control debian/changelog);
close $fakedsc or die $!;
}
+sub quilt_fakedsc2unapplied ($$) {
+ my ($headref, $upstreamversion) = @_;
+ # must be run in the playground
+ # quilt_make_fake_dsc must have been called
+
+ runcmd qw(sh -ec),
+ 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
+
+ my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
+ rename $fakexdir, "fake" or die "$fakexdir $!";
+
+ changedir 'fake';
+
+ remove_stray_gits("source package");
+ mktree_in_ud_here();
+
+ rmtree '.pc';
+
+ rmtree 'debian'; # git checkout commitish paths does not delete!
+ runcmd @git, qw(checkout -f), $headref, qw(-- debian);
+ my $unapplied=git_add_write_tree();
+ printdebug "fake orig tree object $unapplied\n";
+ return $unapplied;
+}
+
sub quilt_check_splitbrain_cache ($$) {
my ($headref, $upstreamversion) = @_;
# Called only if we are in (potentially) split brain mode.
push @cachekey, $srcshash->hexdigest();
$splitbrain_cachekey = "@cachekey";
- my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
- $splitbraincache);
printdebug "splitbrain cachekey $splitbrain_cachekey\n";
- debugcmd "|(probably)",@cmd;
- my $child = open GC, "-|"; defined $child or die $!;
- if (!$child) {
- chdir $maindir or die $!;
- if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
- $! == ENOENT or die $!;
- printdebug ">(no reflog)\n";
- exit 0;
- }
- exec @cmd; die $!;
- }
- while (<GC>) {
- chomp;
- printdebug ">| ", $_, "\n" if $debuglevel > 1;
- next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
-
- my $cachehit = $1;
- quilt_fixup_mkwork($headref);
+
+ my $cachehit = reflog_cache_lookup
+ "refs/$splitbraincache", $splitbrain_cachekey;
+
+ if ($cachehit) {
+ unpack_playtree_mkwork($headref);
my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
if ($cachehit ne $headref) {
progress "dgit view: found cached ($saved)";
progress "dgit view: found cached, no changes required";
return ($headref, $splitbrain_cachekey);
}
- die $! if GC->error;
- failedcmd unless close GC;
printdebug "splitbrain cache miss\n";
return (undef, $splitbrain_cachekey);
quilt_check_splitbrain_cache($headref, $upstreamversion);
return if $cachehit;
}
-
- runcmd qw(sh -ec),
- 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
-
- my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
- rename $fakexdir, "fake" or die "$fakexdir $!";
-
- changedir 'fake';
-
- remove_stray_gits("source package");
- mktree_in_ud_here();
-
- rmtree '.pc';
-
- runcmd @git, qw(checkout -f), $headref, qw(-- debian);
- my $unapplied=git_add_write_tree();
- printdebug "fake orig tree object $unapplied\n";
+ my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
ensuredir '.pc';
failed to apply your git tree's patch stack (from debian/patches/) to
the corresponding upstream tarball(s). Your source tree and .orig
are probably too inconsistent. dgit can only fix up certain kinds of
- anomaly (depending on the quilt mode). See --quilt= in dgit(1).
+ anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
END
}
changedir '..';
- quilt_fixup_mkwork($headref);
+ unpack_playtree_mkwork($headref);
my $mustdeletepc=0;
if (stat_exists ".pc") {
my @failsuggestion;
if (!($diffbits->{O2H} & $diffbits->{O2A})) {
- push @failsuggestion, "This might be a patches-unapplied branch.";
- } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
- push @failsuggestion, "This might be a patches-applied branch.";
+ push @failsuggestion, [ 'unapplied',
+ "This might be a patches-unapplied branch." ];
+ } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
+ push @failsuggestion, [ 'applied',
+ "This might be a patches-applied branch." ];
}
- push @failsuggestion, "Maybe you need to specify one of".
- " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
+ push @failsuggestion, [ 'quilt-mode',
+ "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
+
+ push @failsuggestion, [ 'gitattrs',
+ "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
+ if stat_exists '.gitattributes';
+
+ push @failsuggestion, [ 'origs',
+ "Maybe orig tarball(s) are not identical to git representation?" ];
if (quiltmode_splitbrain()) {
- quiltify_splitbrain($clogp, $unapplied, $headref,
+ quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
$diffbits, \%editedignores,
$splitbrain_cachekey);
return;
}
I2->error and die $!;
close O or die $1;
- exit 0;
+ finish 0;
}
sub maybe_apply_patches_dirtily () {
maybe_unapply_patches_again();
}
+# return values from massage_dbp_args are one or both of these flags
+sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
+sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
+
sub build_or_push_prep_early () {
our $build_or_push_prep_early_done //= 0;
return if $build_or_push_prep_early_done++;
$isuite = getfield $clogp, 'Distribution';
$package = getfield $clogp, 'Source';
$version = getfield $clogp, 'Version';
+ $dscfn = dscfn($version);
}
sub build_prep_early () {
check_not_dirty();
}
-sub build_prep () {
+sub build_prep ($) {
+ my ($wantsrc) = @_;
build_prep_early();
- clean_tree();
+ # clean the tree if we're trying to include dirty changes in the
+ # source package, or we are running the builder in $maindir
+ clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
build_maybe_quilt_fixup();
if ($rmchanges) {
my $pat = changespat $version;
sub changesopts_version () {
if (!defined $changes_since_version) {
- my @vsns = archive_query('archive_query');
- my @quirk = access_quirk();
- if ($quirk[0] eq 'backports') {
- local $isuite = $quirk[2];
- local $csuite;
- canonicalise_suite();
- push @vsns, archive_query('archive_query');
+ my @vsns;
+ unless (eval {
+ @vsns = archive_query('archive_query');
+ my @quirk = access_quirk();
+ if ($quirk[0] eq 'backports') {
+ local $isuite = $quirk[2];
+ local $csuite;
+ canonicalise_suite();
+ push @vsns, archive_query('archive_query');
+ }
+ 1;
+ }) {
+ print STDERR $@;
+ fail
+ "archive query failed (queried because --since-version not specified)";
}
if (@vsns) {
@vsns = map { $_->[0] } @vsns;
sub massage_dbp_args ($;$) {
my ($cmd,$xargs) = @_;
- # We need to:
- #
- # - if we're going to split the source build out so we can
- # do strange things to it, massage the arguments to dpkg-buildpackage
- # so that the main build doessn't build source (or add an argument
- # to stop it building source by default).
- #
- # - add -nc to stop dpkg-source cleaning the source tree,
- # unless we're not doing a split build and want dpkg-source
- # as cleanmode, in which case we can do nothing
- #
- # return values:
- # 0 - source will NOT need to be built separately by caller
- # +1 - source will need to be built separately by caller
- # +2 - source will need to be built separately by caller AND
- # dpkg-buildpackage should not in fact be run at all!
+ # Since we split the source build out so we can do strange things
+ # to it, massage the arguments to dpkg-buildpackage so that the
+ # main build doessn't build source (or add an argument to stop it
+ # building source by default).
debugcmd '#massaging#', @$cmd if $debuglevel>1;
-#print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
- if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
- $clean_using_builder = 1;
- return 0;
- }
# -nc has the side effect of specifying -b if nothing else specified
# and some combinations of -S, -b, et al, are errors, rather than
# later simply overriding earlie. So we need to:
my $dmode = '-F';
foreach my $l ($cmd, $xargs) {
next unless $l;
- @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
+ @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
}
push @$cmd, '-nc';
#print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
- my $r = 0;
- if ($need_split_build_invocation) {
- printdebug "massage split $dmode.\n";
- $r = $dmode =~ m/[S]/ ? +2 :
- $dmode =~ y/gGF/ABb/ ? +1 :
- $dmode =~ m/[ABb]/ ? 0 :
- die "$dmode ?";
+ my $r = WANTSRC_BUILDER;
+ printdebug "massage split $dmode.\n";
+ if ($dmode =~ s/^--build=//) {
+ $r = 0;
+ my @d = split /,/, $dmode;
+ $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
+ $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
+ $r |= WANTSRC_BUILDER if grep { m/./ } @d;
+ fail "Wanted to build nothing!" unless $r;
+ $dmode = '--build='. join ',', grep m/./, @d;
+ } else {
+ $r =
+ $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
+ $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
+ $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
+ die "$dmode ?";
}
printdebug "massage done $r $dmode.\n";
push @$cmd, $dmode;
return $r;
}
-sub in_parent (&) {
+sub in_bpd (&) {
my ($fn) = @_;
my $wasdir = must_getcwd();
- changedir "..";
+ changedir $buildproductsdir;
$fn->();
changedir $wasdir;
}
-sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
+# this sub must run with CWD=$buildproductsdir (eg in in_bpd)
+sub postbuild_mergechanges ($) {
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;
+ my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
@changesfiles = sort {
($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
or $a cmp $b
sub midbuild_checkchanges () {
my $pat = changespat $version;
return if $rmchanges;
- my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
- @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
+ my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
+ @unwanted = grep {
+ $_ ne changespat $version,'source' and
+ $_ ne changespat $version,'multi'
+ } @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.
sub midbuild_checkchanges_vanilla ($) {
my ($wantsrc) = @_;
- midbuild_checkchanges() if $wantsrc == 1;
+ midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
}
sub postbuild_mergechanges_vanilla ($) {
my ($wantsrc) = @_;
- if ($wantsrc == 1) {
- in_parent {
+ if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
+ in_bpd {
postbuild_mergechanges(undef);
};
} else {
sub cmd_build {
build_prep_early();
+ $buildproductsdir eq '..' or print STDERR <<END;
+$us: warning: build-products-dir set, but not supported by dpkg-buildpackage
+$us: warning: build-products-dir will be ignored; files will go to ..
+END
+ $buildproductsdir = '..';
my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
my $wantsrc = massage_dbp_args \@dbp;
- if ($wantsrc > 0) {
+ build_prep($wantsrc);
+ if ($wantsrc & WANTSRC_SOURCE) {
build_source();
midbuild_checkchanges_vanilla $wantsrc;
- } else {
- build_prep();
}
- if ($wantsrc < 2) {
+ if ($wantsrc & WANTSRC_BUILDER) {
push @dbp, changesopts_version();
maybe_apply_patches_dirtily();
runcmd_ordryrun_local @dbp;
# orig is absent.
my $upstreamversion = upstreamversion $version;
my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
- my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
+ my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
if ($gbp_make_orig) {
clean_tree();
$cleanmode = 'none'; # don't do it again
- $need_split_build_invocation = 1;
}
my @dbp = @dpkgbuildpackage;
$gbp_build[0] = 'gbp buildpackage';
}
}
- my @cmd = opts_opt_multi_cmd @gbp_build;
+ my @cmd = opts_opt_multi_cmd [], @gbp_build;
push @cmd, (qw(-us -uc --git-no-sign-tags),
"--git-builder=".(shellquote @dbp));
}
}
- if ($wantsrc > 0) {
+ build_prep($wantsrc);
+ if ($wantsrc & WANTSRC_SOURCE) {
build_source();
midbuild_checkchanges_vanilla $wantsrc;
} else {
if (!$clean_using_builder) {
push @cmd, '--git-cleaner=true';
}
- build_prep();
}
maybe_unapply_patches_again();
- if ($wantsrc < 2) {
+ if ($wantsrc & WANTSRC_BUILDER) {
push @cmd, changesopts();
runcmd_ordryrun_local @cmd, @ARGV;
}
}
sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
+sub building_source_in_playtree {
+ # If $includedirty, we have to build the source package from the
+ # working tree, not a playtree, so that uncommitted changes are
+ # included (copying or hardlinking them into the playtree could
+ # cause trouble).
+ #
+ # Note that if we are building a source package in split brain
+ # mode we do not support including uncommitted changes, because
+ # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
+ # building a source package)) => !$includedirty
+ return !$includedirty;
+}
+
sub build_source {
- build_prep_early();
- my $our_cleanmode = $cleanmode;
- if ($need_split_build_invocation) {
- # Pretend that clean is being done some other way. This
- # forces us not to try to use dpkg-buildpackage to clean and
- # build source all in one go; and instead we run dpkg-source
- # (and build_prep() will do the clean since $clean_using_builder
- # is false).
- $our_cleanmode = 'ELSEWHERE';
- }
- if ($our_cleanmode =~ m/^dpkg-source/) {
- # dpkg-source invocation (below) will clean, so build_prep shouldn't
- $clean_using_builder = 1;
- }
- build_prep();
$sourcechanges = changespat $version,'source';
if (act_local()) {
- unlink "../$sourcechanges" or $!==ENOENT
+ unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
or fail "remove $sourcechanges: $!";
}
- $dscfn = dscfn($version);
- if ($our_cleanmode eq 'dpkg-source') {
- maybe_apply_patches_dirtily();
- runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
- changesopts();
- } elsif ($our_cleanmode eq 'dpkg-source-d') {
- maybe_apply_patches_dirtily();
- runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
- changesopts();
+ my @cmd = (@dpkgsource, qw(-b --));
+ my $leafdir;
+ if (building_source_in_playtree()) {
+ $leafdir = 'work';
+ my $headref = git_rev_parse('HEAD');
+ # If we are in split brain, there is already a playtree with
+ # the thing we should package into a .dsc (thanks to quilt
+ # fixup). If not, make a playtree
+ prep_ud() unless $split_brain;
+ changedir $playground;
+ unless ($split_brain) {
+ my $upstreamversion = upstreamversion $version;
+ unpack_playtree_linkorigs($upstreamversion, sub { });
+ unpack_playtree_mkwork($headref);
+ changedir '..';
+ }
} else {
- my @cmd = (@dpkgsource, qw(-b --));
- if ($split_brain) {
- changedir $playground;
- runcmd_ordryrun_local @cmd, "work";
- my @udfiles = <${package}_*>;
- changedir $maindir;
- foreach my $f (@udfiles) {
- printdebug "source copy, found $f\n";
- next unless
- $f eq $dscfn or
- ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
- $f eq srcfn($version, $&));
- printdebug "source copy, found $f - renaming\n";
- rename "$playground/$f", "../$f" or $!==ENOENT
- or fail "put in place new source file ($f): $!";
- }
- } else {
- my $pwd = must_getcwd();
- my $leafdir = basename $pwd;
- changedir "..";
- runcmd_ordryrun_local @cmd, $leafdir;
- changedir $pwd;
- }
- runcmd_ordryrun_local qw(sh -ec),
- 'exec >$1; shift; exec "$@"','x',
- "../$sourcechanges",
- @dpkggenchanges, qw(-S), changesopts();
+ $leafdir = basename $maindir;
+ changedir '..';
+ }
+ runcmd_ordryrun_local @cmd, $leafdir;
+
+ changedir $leafdir;
+ runcmd_ordryrun_local qw(sh -ec),
+ 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
+ @dpkggenchanges, qw(-S), changesopts();
+ changedir '..';
+
+ printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
+ $dsc = parsecontrol($dscfn, "source package");
+
+ my $mv = sub {
+ my ($why, $l) = @_;
+ printdebug " renaming ($why) $l\n";
+ rename "$l", bpd_abs()."/$l"
+ or fail "put in place new built file ($l): $!";
+ };
+ foreach my $l (split /\n/, getfield $dsc, 'Files') {
+ $l =~ m/\S+$/ or next;
+ $mv->('Files', $&);
}
+ $mv->('dsc', $dscfn);
+ $mv->('changes', $sourcechanges);
+
+ changedir $maindir;
}
sub cmd_build_source {
- build_prep_early();
badusage "build-source takes no additional arguments" if @ARGV;
+ build_prep(WANTSRC_SOURCE);
build_source();
maybe_unapply_patches_again();
printdone "source built, results in $dscfn and $sourcechanges";
}
-sub cmd_sbuild {
+sub cmd_push_source {
+ prep_push();
+ fail "dgit push-source: --include-dirty/--ignore-dirty does not make".
+ "sense with push-source!" if $includedirty;
+ build_maybe_quilt_fixup();
+ if ($changesfile) {
+ my $changes = parsecontrol("$buildproductsdir/$changesfile",
+ "source changes file");
+ unless (test_source_only_changes($changes)) {
+ fail "user-specified changes file is not source-only";
+ }
+ } else {
+ # Building a source package is very fast, so just do it
+ build_source();
+ die "er, patches are applied dirtily but shouldn't be.."
+ if $patches_applied_dirtily;
+ $changesfile = $sourcechanges;
+ }
+ dopush();
+}
+
+sub binary_builder {
+ my ($bbuilder, $pbmc_msg, @args) = @_;
+ build_prep(WANTSRC_SOURCE);
build_source();
midbuild_checkchanges();
- in_parent {
+ in_bpd {
if (act_local()) {
- stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
+ stat_exists $dscfn or fail "$dscfn (in build products dir): $!";
stat_exists $sourcechanges
- or fail "$sourcechanges (in parent directory): $!";
+ or fail "$sourcechanges (in build products dir): $!";
}
- runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
+ runcmd_ordryrun_local @$bbuilder, @args;
};
maybe_unapply_patches_again();
- in_parent {
- postbuild_mergechanges(<<END);
+ in_bpd {
+ postbuild_mergechanges($pbmc_msg);
+ };
+}
+
+sub cmd_sbuild {
+ build_prep_early();
+ binary_builder(\@sbuild, <<END, qw(-d), $isuite, @ARGV, $dscfn);
perhaps you need to pass -A ? (sbuild's default is to build only
arch-specific binaries; dgit 1.4 used to override that.)
END
- };
-}
+}
+
+sub pbuilder ($) {
+ my ($pbuilder) = @_;
+ build_prep_early();
+ # @ARGV is allowed to contain only things that should be passed to
+ # pbuilder under debbuildopts; just massage those
+ my $wantsrc = massage_dbp_args \@ARGV;
+ fail "you asked for a builder but your debbuildopts didn't ask for".
+ " any binaries -- is this really what you meant?"
+ unless $wantsrc & WANTSRC_BUILDER;
+ fail "we must build a .dsc to pass to the builder but your debbuiltopts".
+ " forbids the building of a source package; cannot continue"
+ unless $wantsrc & WANTSRC_SOURCE;
+ # We do not want to include the verb "build" in @pbuilder because
+ # the user can customise @pbuilder and they shouldn't be required
+ # to include "build" in their customised value. However, if the
+ # user passes any additional args to pbuilder using the dgit
+ # option --pbuilder:foo, such args need to come after the "build"
+ # verb. opts_opt_multi_cmd does all of that.
+ binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
+ qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
+ $dscfn);
+}
+
+sub cmd_pbuilder {
+ pbuilder(\@pbuilder);
+}
+
+sub cmd_cowbuilder {
+ pbuilder(\@cowbuilder);
+}
sub cmd_quilt_fixup {
badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
build_maybe_quilt_fixup();
}
+sub cmd_print_unapplied_treeish {
+ badusage "incorrect arguments to dgit print-unapplied-treeish" if @ARGV;
+ my $headref = git_rev_parse('HEAD');
+ my $clogp = commit_getclogp $headref;
+ $package = getfield $clogp, 'Source';
+ $version = getfield $clogp, 'Version';
+ $isuite = getfield $clogp, 'Distribution';
+ $csuite = $isuite; # we want this to be offline!
+ notpushing();
+
+ prep_ud();
+ changedir $playground;
+ my $uv = upstreamversion $version;
+ quilt_make_fake_dsc($uv);
+ my $u = quilt_fakedsc2unapplied($headref, $uv);
+ print $u, "\n" or die $!;
+}
+
sub import_dsc_result {
my ($dstref, $newhash, $what_log, $what_msg) = @_;
- my @cmd = (@git, qw(update-ref -m), $what_log, $dstref, $newhash);
+ my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
runcmd @cmd;
check_gitattrs($newhash, "source tree");
my @dfi = dsc_files_info();
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
- my $here = "../$f";
+ my $here = "$buildproductsdir/$f";
if (lstat $here) {
next if stat $here;
fail "lstat $here works but stat gives $! !";
sub cmd_archive_api_query {
badusage "need only 1 subpath argument" unless @ARGV==1;
my ($subpath) = @ARGV;
+ local $isuite = 'DGIT-API-QUERY-CMD';
my @cmd = archive_api_query_cmd($subpath);
push @cmd, qw(-f);
debugcmd ">",@cmd;
sub cmd_version {
print "dgit version $our_version\n" or die $!;
- exit 0;
+ finish 0;
}
our (%valopts_long, %valopts_short);
} elsif (m/^--(gbp|dpm)$/s) {
push @ropts, "--quilt=$1";
$quilt_mode = $1;
- } elsif (m/^--ignore-dirty$/s) {
+ } elsif (m/^--(?:ignore|include)-dirty$/s) {
push @ropts, $_;
- $ignoredirty = 1;
+ $includedirty = 1;
} elsif (m/^--no-quilt-fixup$/s) {
push @ropts, $_;
$quilt_mode = 'nocheck';
} elsif (m/^--delayed=(\d+)$/s) {
push @ropts, $_;
push @dput, $_;
- } elsif (m/^--dgit-view-save=(.+)$/s) {
+ } elsif (my ($k,$v) =
+ m/^--save-(dgit-view)=(.+)$/s ||
+ m/^--(dgit-view)-save=(.+)$/s
+ ) {
push @ropts, $_;
- $split_brain_save = $1;
- $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
+ $v =~ s#^(?!refs/)#refs/heads/#;
+ $internal_object_save{$k} = $v;
} elsif (m/^--(no-)?rm-old-changes$/s) {
push @ropts, $_;
$rmchanges = !$1;
push @ropts, $_;
$tagformat_want = [ $1, 'command line', 1 ];
# 1 menas overrides distro configuration
- } elsif (m/^--always-split-source-build$/s) {
- # undocumented, for testing
- push @ropts, $_;
- $need_split_build_invocation = 1;
} elsif (m/^--config-lookup-explode=(.+)$/s) {
# undocumented, for testing
push @ropts, $_;
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";
+ die "$signame is set to something other than SIG_DFL\n"
+ if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
$blocked->ismember($signum) and
die "$signame is blocked\n";
}
$$vr = $v;
}
- $need_split_build_invocation ||= quiltmode_splitbrain();
+ fail __ "dgit: --include-dirty is not supported in split view quilt mode"
+ if $split_brain && $includedirty;
if (!defined $cleanmode) {
local $access_forpush;
badcfg "unknown clean-mode \`$cleanmode'" unless
$cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
}
+
+ $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
+ $buildproductsdir //= '..';
+ $bpd_glob = $buildproductsdir;
+ $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
}
+setlocale(LC_MESSAGES, "");
+textdomain("dgit");
+
if ($ENV{$fakeeditorenv}) {
git_slurp_config();
quilt_fixup_editor();
print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
if $dryrun_level == 1;
if (!@ARGV) {
- print STDERR $helpmsg or die $!;
- exit 8;
+ print STDERR __ $helpmsg or die $!;
+ finish 8;
}
$cmd = $subcommand = shift @ARGV;
$cmd =~ y/-/_/;
my $fn = ${*::}{"cmd_$cmd"};
$fn or badusage "unknown operation $cmd";
$fn->();
+
+finish 0;
~ianmdlvl / dgit.git / blobdiff