# dgit
# Integration between git and Debian-style archives
#
-# Copyright (C)2013-2017 Ian Jackson
-# Copyright (C)2017 Sean Whitton
+# 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 = qr{orig(?:-$extra_orig_namepart_re)?};
-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 {
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 ($$) {
my $got = read PF, $d, 65536;
die "$ourfn: $!" unless defined $got;
last if !$got;
- print $fh "data-block ".length($d)."\n" or die $!;
- print $fh $d or die $!;
+ print $fh "data-block ".length($d)."\n" or confess $!;
+ print $fh $d or confess $!;
}
PF->error and die "$ourfn $!";
- print $fh "data-end\n" or die $!;
+ print $fh "data-end\n" or confess $!;
close PF;
}
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;
}
} $fh;
last unless $y;
my $d = protocol_read_bytes $fh, $l;
- print PF $d or die $!;
+ print PF $d or confess $!;
}
- close PF or die $!;
+ close PF or confess $!;
}
#---------- remote protocol support, responder ----------
return unless $we_are_responder;
# called even without $we_are_responder
printdebug ">> $command\n";
- print PO $command, "\n" or die $!;
+ print PO $command, "\n" or confess $!;
}
sub responder_send_file ($$) {
sub progress {
if ($we_are_responder) {
my $m = join '', @_;
- responder_send_command "progress ".length($m) or die $!;
- print PO $m or die $!;
+ responder_send_command "progress ".length($m) or confess $!;
+ print PO $m or confess $!;
} else {
print @_, "\n";
}
}
my $what = $_[$#_];
progress "downloading $what...";
- my $r = $ua->get(@_) or die $!;
+ my $r = $ua->get(@_) or confess $!;
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 ...
-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 confess $!;
+ 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 confess $!;
+ 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;
} elsif ($protovsn >= 3) {
responder_send_command "supplementary-message ".length($msg)
- or die $!;
- print PO $msg or die $!;
+ or confess $!;
+ print PO $msg or confess $!;
}
}
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 parse_dscdata () {
- my $dscfh = new IO::File \$dscdata, '<' or die $!;
+ my $dscfh = new IO::File \$dscdata, '<' or confess $!;
printdebug Dumper($dscdata) if $debuglevel>1;
$dsc = parsecontrolfh($dscfh,$dscurl,1);
printdebug Dumper($dsc) if $debuglevel>1;
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,
access_cfg('aptget-components')
- or die $!;
+ or confess $!;
ensuredir "$aptget_base/cache";
ensuredir "$aptget_base/lists";
- open CONF, ">", $aptget_configpath or die $!;
+ open CONF, ">", $aptget_configpath or confess $!;
print CONF <<END;
Debug::NoLocking "true";
APT::Get::List-Cleanup "false";
Dir::Etc::preferencesparts
)) {
ensuredir "$aptget_base/$key";
- print CONF "$key \"$quoted_base/$key\";\n" or die $!;
+ print CONF "$key \"$quoted_base/$key\";\n" or confess $!;
};
- my $oldatime = (time // die $!) - 1;
+ my $oldatime = (time // confess $!) - 1;
foreach my $oldlist (<$aptget_base/lists/*Release>) {
next unless stat_exists $oldlist;
my ($mtime) = (stat _)[9];
}
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 @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
+ qw(x), $mirror, @$argl);
+ debugcmd "-|", @cmd;
+ open FIA, "-|", @cmd or confess $!;
+ 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;
- my @cmd = (qw(sh -ec), '
- cd "$1"
- find -name "$2" -print0 |
+ dummycatapi_run_in_mirror '
+ find -name "$1" -print0 |
xargs -0r sha256sum
- ', qw(x), $mirror, $filename);
- 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;
+ ', [$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) = @_;
" export LC_MESSAGES=C; export LC_CTYPE=C;".
" ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
debugcmd "|",@cmd;
- open P, "-|", @cmd or die $!;
+ open P, "-|", @cmd or confess $!;
while (<P>) {
chomp or die;
printdebug(">|$_|\n");
}
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;
}
}
my ($what) = @_;
my @gitscmd = qw(find -name .git -prune -print0);
debugcmd "|",@gitscmd;
- open GITS, "-|", @gitscmd or die $!;
+ open GITS, "-|", @gitscmd or confess $!;
{
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$/;
- return 1;
-}
-
# This function determines whether a .changes file is source-only from
# the point of view of dak. Thus, it permits *_source.buildinfo
# 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 "purportedly source-only changes polluted by $&\n";
+ print f_ "purportedly source-only changes polluted by %s\n", $&;
return 0;
}
}
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";
}
new Dpkg::Compression::Process compression => $cname;
@compr_cmd = $compr_proc->get_uncompress_cmdline();
my $compr_fh = new IO::Handle;
- my $compr_pid = open $compr_fh, "-|" // die $!;
+ my $compr_pid = open $compr_fh, "-|" // confess $!;
if (!$compr_pid) {
- open STDIN, "<&", $input or die $!;
+ open STDIN, "<&", $input or confess $!;
exec @compr_cmd;
die "dgit (child): exec $compr_cmd[0]: $!\n";
}
}
rmtree "_unpack-tar";
- mkdir "_unpack-tar" or die $!;
+ mkdir "_unpack-tar" or confess $!;
my @tarcmd = qw(tar -x -f -
--no-same-owner --no-same-permissions
--no-acls --no-xattrs --no-selinux);
- my $tar_pid = fork // die $!;
+ my $tar_pid = fork // confess $!;
if (!$tar_pid) {
- chdir "_unpack-tar" or die $!;
- open STDIN, "<&", $input or die $!;
+ chdir "_unpack-tar" or confess $!;
+ open STDIN, "<&", $input or confess $!;
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 $!;
+ $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess $!;
!$? or failedcmd @tarcmd;
close $input or
(@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
- : die $!);
+ : confess $!);
# finally, we have the results in "tarball", but maybe
# with the wrong permissions
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
printdebug "import main commit\n";
- open C, ">../commit.tmp" or die $!;
- print C <<END or die $!;
+ open C, ">../commit.tmp" or confess $!;
+ print C <<END or confess $!;
tree $tree
END
- print C <<END or die $! foreach @tartrees;
+ print C <<END or confess $! foreach @tartrees;
parent $_->{Commit}
END
- print C <<END or die $!;
+ print C <<END or confess $!;
author $authline
committer $authline
[dgit import $treeimporthow $package $cversion]
END
- close C or die $!;
+ close C or confess $!;
my $rawimport_hash = make_commit qw(../commit.tmp);
if (madformat $dsc->{format}) {
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 $!;
+ or confess $!;
}
eval {
die "forbid absurd git-apply\n" if $use_absurd
'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 confess $!;
@output = $lastpush_mergeinput;
} else {
# Same version. Use what's in the server git branch,
open F, "<", "$tf" or die "$tf: $!";
$fi->{Digester}->reset();
$fi->{Digester}->addfile(*F);
- F->error and die $!;
+ F->error and confess $!;
$got = $fi->{Digester}->hexdigest();
return $got eq $fi->{Hash};
};
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;
debugcmd "|",@lcmd;
my %wantr;
- open GITLS, "-|", @lcmd or die $!;
+ open GITLS, "-|", @lcmd or confess $!;
while (<GITLS>) {
printdebug "=> ", $_;
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...
} elsif ($here{$lref} eq $objid) {
lrfetchref_used $fullrefname;
} else {
- print STDERR
- "Not updating $lref from $here{$lref} to $objid.\n";
+ print STDERR f_ "Not updating %s from %s to %s.\n",
+ $lref, $here{$lref}, $objid;
}
});
}
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 (!defined $f) {
- progress "$what: NO git hash";
+ progress f_ "%s: NO git hash", $what;
parse_dsc_field_def_dsc_distro();
} elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
= $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
- progress "$what: specified git info ($dsc_distro)";
+ progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
$dsc_hint_tag = [ $dsc_hint_tag ];
} elsif ($f =~ m/^\w+\s*$/) {
$dsc_hash = $&;
parse_dsc_field_def_dsc_distro();
$dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
$dsc_distro ];
- progress "$what: specified git hash";
+ progress f_ "%s: specified git hash", $what;
} else {
- fail "$what: invalid Dgit info";
+ fail f_ "%s: invalid Dgit info", $what;
}
}
my $lrf = lrfetchrefs;
if (!$chase_dsc_distro) {
- progress
- "not chasing .dsc distro $dsc_distro: not fetching $what";
+ progress f_ "not chasing .dsc distro %s: not fetching %s",
+ $dsc_distro, $what;
return 0;
}
- progress
- ".dsc names distro $dsc_distro: fetching $what";
+ progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
my $url = access_giturl();
if (!defined $url) {
- defined $dsc_hint_url or fail <<END;
-.dsc Dgit metadata is in context of distro $dsc_distro
+ defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
+.dsc Dgit metadata is in context of distro %s
for which we have no configured url and .dsc provides no hint
END
my $proto =
parse_cfg_bool "dsc-url-proto-ok", 'false',
cfg("dgit.dsc-url-proto-ok.$proto",
"dgit.default.dsc-url-proto-ok")
- or fail <<END;
-.dsc Dgit metadata is in context of distro $dsc_distro
+ or fail f_ <<END, $dsc_distro, $proto;
+.dsc Dgit metadata is in context of distro %s
for which we have no configured url;
-.dsc provides hinted url with protocol $proto which is unsafe.
+.dsc provides hinted url with protocol %s which is unsafe.
(can be overridden by config - consult documentation)
END
$url = $dsc_hint_url;
if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
if (!defined $mapref) {
- my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
+ my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
$mapref = $lrf.'/'.$rewritemap;
}
my $rewritemapdata = git_cat_file $mapref.':map';
if (defined $rewritemapdata
&& $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
- progress
+ progress __
"server's git history rewrite map contains a relevant entry!";
$dsc_hash = $1;
if (defined $dsc_hash) {
- progress "using rewritten git hash in place of .dsc value";
+ progress __ "using rewritten git hash in place of .dsc value";
} else {
- progress "server data says .dsc hash is to be disregarded";
+ progress __ "server data says .dsc hash is to be disregarded";
}
}
}
if (!defined git_cat_file $dsc_hash) {
my @tags = map { "tags/".$_ } @$dsc_hint_tag;
- my $lrf = $do_fetch->("additional commits", @tags) &&
+ my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
defined git_cat_file $dsc_hash
- or fail <<END;
-.dsc Dgit metadata requires commit $dsc_hash
+ or fail f_ <<END, $dsc_hash;
+.dsc Dgit metadata requires commit %s
but we could not obtain that object anywhere.
END
foreach my $t (@tags) {
get_archive_dsc();
if ($dsc) {
- parse_dsc_field($dsc, 'last upload to archive');
+ parse_dsc_field($dsc, __ 'last upload to archive');
resolve_dsc_field_commit access_basedistro,
lrfetchrefs."/".$rewritemap
} else {
- progress "no version available from the archive";
+ progress __ "no version available from the archive";
}
# If the archive's .dsc has a Dgit field, there are three
printdebug "previous reference hash=$lastpush_hash\n";
$lastpush_mergeinput = $lastpush_hash && {
Commit => $lastpush_hash,
- Info => "dgit suite branch on dgit git server",
+ Info => (__ "dgit suite branch on dgit git server"),
};
my $lastfetch_hash = git_get_ref(lrref());
printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
my $lastfetch_mergeinput = $lastfetch_hash && {
Commit => $lastfetch_hash,
- Info => "dgit client's archive history view",
+ Info => (__ "dgit client's archive history view"),
};
my $dsc_mergeinput = $dsc_hash && {
Commit => $dsc_hash,
- Info => "Dgit field in .dsc from archive",
+ Info => (__ "Dgit field in .dsc from archive"),
};
my $cwd = getcwd();
printdebug "del_lrfetchrefs: $objid $fullrefname\n";
if (!$gur) {
$gur ||= new IO::Handle;
- open $gur, "|-", qw(git update-ref --stdin) or die $!;
+ open $gur, "|-", qw(git update-ref --stdin) or confess $!;
}
printf $gur "delete %s %s\n", $fullrefname, $objid;
}
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 confess $!;
@mergeinputs = ($lastpush_mergeinput);
} else {
# Archive has .dsc which is not a descendant of the last dgit
# push. This can happen if the archive moves .dscs about.
# Just follow its lead.
if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
- progress "archive .dsc names newer git commit";
+ progress __ "archive .dsc names newer git commit";
@mergeinputs = ($dsc_mergeinput);
} else {
- progress "archive .dsc names other git commit, fixing up";
+ progress __ "archive .dsc names other git commit, fixing up";
@mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
}
}
} 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 confess $!;
} else {
printdebug "nothing found!\n";
if (defined $skew_warning_vsn) {
- print STDERR <<END or die $!;
+ print STDERR f_ <<END, $skew_warning_vsn or confess $!;
Warning: relevant archive skew detected.
-Archive allegedly contains $skew_warning_vsn
+Archive allegedly contains %s
But we were not able to obtain any version from the archive or git.
END
# 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
my $mcf = dgit_privdir()."/mergecommit";
open MC, ">", $mcf or die "$mcf $!";
- print MC <<END or die $!;
+ print MC <<END or confess $!;
tree $tree
END
my @parents = grep { $_->{Commit} } @mergeinputs;
@parents = reverse @parents if $compat_info->{ReverseParents};
- print MC <<END or die $! foreach @parents;
+ print MC <<END or confess $! foreach @parents;
parent $_->{Commit}
END
- print MC <<END or die $!;
+ print MC <<END or confess $!;
author $author
committer $author
END
if (defined $compat_info->{Message}) {
- print MC $compat_info->{Message} or die $!;
+ print MC $compat_info->{Message} or confess $!;
} else {
- print MC <<END or die $!;
-Record $package ($cversion) in archive suite $csuite
+ print MC f_ <<END, $package, $cversion, $csuite or confess $!;
+Record %s (%s) in archive suite %s
Record that
END
my ($mi) = (@_);
my $mversion = mergeinfo_version $mi;
printf MC " %-20s %s\n", $mversion, $mi->{Info}
- or die $!;
+ or confess $!;
};
$message_add_info->($mergeinputs[0]);
- print MC <<END or die $!;
+ print MC __ <<END or confess $!;
should be treated as descended from
END
$message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
}
- close MC or die $!;
+ close MC or confess $!;
$hash = make_commit $mcf;
} else {
$hash = $mergeinputs[0]{Commit};
my $chkff = sub {
my ($lasth, $what) = @_;
return unless $lasth;
- die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
+ confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
};
- $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
+ $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
if $lastpush_hash;
- $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
+ $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
fetch_from_archive_record_1($hash);
my $got_vsn = getfield $gotclogp, 'Version';
printdebug "SKEW CHECK GOT $got_vsn\n";
if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
- print STDERR <<END or die $!;
+ print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess $!;
Warning: archive skew detected. Using the available version:
-Archive allegedly contains $skew_warning_vsn
-We were able to obtain only $got_vsn
+Archive allegedly contains %s
+We were able to obtain only %s
END
}
lrfetchref_used lrfetchref();
- check_gitattrs($hash, "fetched source tree");
+ check_gitattrs($hash, __ "fetched source tree");
unshift @end, $del_lrfetchrefs;
return $hash;
while (<ATTRS>) {
chomp;
next if m{^debian/changelog\s};
- print NATTRS $_, "\n" or die $!;
+ print NATTRS $_, "\n" or confess $!;
}
- ATTRS->error and die $!;
+ ATTRS->error and confess $!;
close ATTRS;
}
- print NATTRS "debian/changelog merge=$driver\n" or die $!;
+ print NATTRS "debian/changelog merge=$driver\n" or confess $!;
close NATTRS;
- set_local_git_config "$cb.name", 'debian/changelog merge driver';
+ set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
rename "$attrs.new", "$attrs" or die "$attrs: $!";
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;
+ $gai->error and confess $!;
+ 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()) {
- progress <<END;
-[attr]dgit-defuse-attrs already found in .git/info/attributes
+ my $already = is_gitattrs_setup();
+ if ($already) {
+ progress __ <<END;
+[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 $!;
+
+ open GAO, "> $af.new" or confess $!;
+ print GAO <<END, __ <<ENDT or confess $! unless defined $already;
* dgit-defuse-attrs
-[attr]dgit-defuse-attrs $negate_harmful_gitattrs
-# ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
+$new
END
+# ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
+ENDT
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 $!;
+ print GAO $_, "\n" or confess $!;
}
- $gai->error and die $!;
+ $gai->error and confess $!;
}
- close GAO or die $!;
- rename "$af.new", "$af" or die "install $af: $!";
+ close GAO or confess $!;
+ rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
}
sub setup_new_tree () {
my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
debugcmd "|",@cmd;
my $gafl = new IO::File;
- open $gafl, "-|", @cmd or die $!;
+ open $gafl, "-|", @cmd or confess $!;
while (<$gafl>) {
chomp or die;
s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
next unless m{(?:^|/)\.gitattributes$};
# oh dear, found one
- print STDERR <<END;
-dgit: warning: $what contains .gitattributes
-dgit: .gitattributes have not been defused. Recommended: dgit setup-new-tree.
+ print STDERR f_ <<END, $what;
+dgit: warning: %s contains .gitattributes
+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;
- my $pid = fork // die $!;
+ my $pid = fork // confess $!;
if (!$pid) {
forkcheck_setup();
$isuite = $tsuite;
$us .= " [$isuite]";
$debugprefix .= " ";
- progress "fetching $tsuite...";
+ progress f_ "fetching %s...", $tsuite;
canonicalise_suite();
- print $canonsuitefh $csuite, "\n" or die $!;
- close $canonsuitefh or die $!;
+ print $canonsuitefh $csuite, "\n" or confess $!;
+ close $canonsuitefh or confess $!;
$fn->();
return undef;
}
- waitpid $pid,0 == $pid or die $!;
- fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
- seek $canonsuitefh,0,0 or die $!;
+ waitpid $pid,0 == $pid or confess $!;
+ fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
+ if $? && $?!=256*4;
+ seek $canonsuitefh,0,0 or confess $!;
local $csuite = <$canonsuitefh>;
- die $! unless defined $csuite && chomp $csuite;
+ confess $! unless defined $csuite && chomp $csuite;
if ($? == 256*4) {
printdebug "multisuite $tsuite missing\n";
return $csuite;
}
printdebug "multisuite $tsuite ok (canon=$csuite)\n";
- push @$merginputs, {
+ push @$mergeinputs, {
Ref => lrref,
Info => $csuite,
};
sub { });
return 0 unless defined $cbasesuite;
- fail "package $package missing in (base suite) $cbasesuite"
+ fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
unless @mergeinputs;
my @csuites = ($cbasesuite);
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;
if ($previous) {
unshift @mergeinputs, {
Commit => $previous,
- Info => "local combined tracking branch",
- Warning =>
- "archive seems to have rewound: local tracking branch is ahead!",
+ Info => (__ "local combined tracking branch"),
+ Warning => (__
+ "archive seems to have rewound: local tracking branch is ahead!"),
};
}
my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
my $commit = "tree $tree\n";
- my $msg = "Combine archive branches $csuite [dgit]\n\n".
- "Input branches:\n";
+ my $msg = f_ "Combine archive branches %s [dgit]\n\n".
+ "Input branches:\n",
+ $csuite;
foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
printdebug "multisuite merge include $mi->{Info}\n";
$mi->{Info};
}
my $authline = clogp_authline mergeinfo_getclogp $needed[0];
- $msg .= "\nKey\n".
+ $msg .= __ "\nKey\n".
" * marks the highest version branch, which choose to use\n".
- " + marks each branch which was not already an ancestor\n\n".
+ " + marks each branch which was not already an ancestor\n\n";
+ $msg .=
"[dgit multi-suite $csuite]\n";
$commit .=
"author $authline\n".
fetch_from_archive_record_1($output);
fetch_from_archive_record_2($output);
- progress "calculated combined tracking suite $csuite";
+ progress f_ "calculated combined tracking suite %s", $csuite;
return 1;
}
sub clone_set_head () {
- open H, "> .git/HEAD" or die $!;
- print H "ref: ".lref()."\n" or die $!;
- close H or die $!;
+ open H, "> .git/HEAD" or confess $!;
+ print H "ref: ".lref()."\n" or confess $!;
+ close H or confess $!;
}
sub clone_finish ($) {
my ($dstdir) = @_;
git ls-tree -r --name-only -z HEAD | \
xargs -0r touch -h -r . --
END
- printdone "ready for work in $dstdir";
+ printdone f_ "ready for work in %s", $dstdir;
}
sub clone ($) {
# once in parent after first suite fetched,
# and then again in child after everything is finished
my ($dstdir) = @_;
- badusage "dry run makes no sense with clone" unless act_local();
+ badusage __ "dry run makes no sense with clone" unless act_local();
my $multi_fetched = fork_for_multisuite(sub {
printdebug "multi clone before fetch merge\n";
canonicalise_suite();
my $hasgit = check_for_git();
- mkdir $dstdir or fail "create \`$dstdir': $!";
+ mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
changedir $dstdir;
runcmd @git, qw(init -q);
record_maindir();
runcmd @git, qw(remote add), 'origin', $giturl;
}
if ($hasgit) {
- progress "fetching existing git history";
+ progress __ "fetching existing git history";
git_fetch_us();
runcmd_ordryrun_local @git, qw(fetch origin);
} else {
- progress "starting new git history";
+ progress __ "starting new git history";
}
fetch_from_archive() or no_such_package;
my $vcsgiturl = $dsc->{'Vcs-Git'};
clone_finish($dstdir);
}
-sub fetch () {
+sub fetch_one () {
canonicalise_suite();
if (check_for_git()) {
git_fetch_us();
}
fetch_from_archive() or no_such_package();
- printdone "fetched into ".lrref();
+
+ 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 f_ <<END, $csuite;
+FYI: Vcs-Git in %s 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 f_ "fetched into %s", lrref();
}
-sub pull () {
+sub dofetch () {
my $multi_fetched = fork_for_multisuite(sub { });
- fetch() unless $multi_fetched; # parent
- return if $multi_fetched eq '0'; # child
- runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
+ fetch_one() unless $multi_fetched; # parent
+ finish 0 if $multi_fetched eq '0'; # child
+}
+
+sub pull () {
+ dofetch();
+ runcmd_ordryrun_local @git, qw(merge -m),
+ (f_ "Merge from %s [dgit]", $csuite),
lrref();
- printdone "fetched to ".lrref()." and merged into HEAD";
+ printdone f_ "fetched to %s and merged into HEAD", lrref();
}
sub check_not_dirty () {
foreach my $f (qw(local-options local-patch-header)) {
if (stat_exists "debian/source/$f") {
- fail "git tree contains debian/source/$f";
+ fail f_ "git tree contains debian/source/%s", $f;
}
}
- 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 f_
+ "quilt fixup required but quilt mode is \`nofix'\n".
+ "HEAD commit%s differs from tree implied by debian/patches%s",
+ $headinfo, $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}++;
}
}
delete $adds{'.pc'}; # if there wasn't one before, don't add it
if (!%adds) {
- progress "nothing quilty to commit, ok.";
+ 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
+ commit_admin +(__ <<ENDT).<<END
Commit Debian 3.0 (quilt) metadata
+ENDT
[dgit ($our_version) quilt-fixup]
END
}
$options{$_} = 1;
}
}
- F->error and die $!;
+ F->error and confess $!;
close F;
} else {
- die $! unless $!==&ENOENT;
+ confess $! unless $!==&ENOENT;
}
if (!open F, "debian/source/format") {
- die $! unless $!==&ENOENT;
+ confess $! unless $!==&ENOENT;
return '';
}
$_ = <F>;
- F->error and die $!;
+ F->error and confess $!;
chomp;
return ($_, \%options);
}
return 0 unless $format eq '3.0 (quilt)';
our $quilt_mode_warned;
if ($quilt_mode eq 'nocheck') {
- progress "Not doing any fixup of \`$format' due to".
- " ----no-quilt-fixup or --quilt=nocheck"
+ progress f_ "Not doing any fixup of \`%s'".
+ " due to ----no-quilt-fixup or --quilt=nocheck", $format
unless $quilt_mode_warned++;
return 0;
}
- progress "Format \`$format', need to check/update patch stack"
+ progress f_ "Format \`%s', need to check/update patch stack", $format
unless $quilt_mode_warned++;
return 1;
}
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;
+ # (used inside parens, in the English texts)
+ my $save = $internal_object_save{'dgit-view'};
+ return f_ "commit id %s", $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 f_ "and left in %s", $save;
}
# An "infopair" is a tuple [ $thing, $what ]
printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
return [ git_rev_parse($tagobj), $what ];
}
- fail @tagnames==1 ? <<END : <<END;
-Wanted tag $what (@tagnames) on dgit server, but not found
+ fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
+Wanted tag %s (%s) on dgit server, but not found
END
-Wanted tag $what (one of: @tagnames) on dgit server, but not found
+ : (f_ <<END, $what, "@tagnames");
+Wanted tag %s (one of: %s) on dgit server, but not found
END
}
sub infopair_cond_ff ($$) {
my ($anc,$desc) = @_;
- is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
-$anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
+ is_fast_fwd($anc->[0], $desc->[0]) or
+ fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
+%s (%s) .. %s (%s) is not fast forward
END
};
my $arch_clogp = commit_getclogp $archive_hash;
my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
- 'version currently in archive' ];
+ __ 'version currently in archive' ];
if (defined $overwrite_version) {
if (length $overwrite_version) {
infopair_cond_equal([ $overwrite_version,
$i_arch_v);
} else {
my $v = $i_arch_v->[0];
- progress "Checking package changelog for archive version $v ...";
+ progress f_
+ "Checking package changelog for archive version %s ...", $v;
my $cd;
eval {
my @xa = ("-f$v", "-t$v");
my $gf = sub {
my ($fn) = @_;
[ (getfield $vclogp, $fn),
- "$fn field from dpkg-parsechangelog @xa" ];
+ (f_ "%s field from dpkg-parsechangelog %s",
+ $fn, "@xa") ];
};
my $cv = $gf->('Version');
infopair_cond_equal($i_arch_v, $cv);
if ($@) {
$@ =~ s/^dgit: //gm;
fail "$@".
- "Perhaps debian/changelog does not mention $v ?";
+ f_ "Perhaps debian/changelog does not mention %s ?", $v;
}
- fail <<END if $cd->[0] =~ m/UNRELEASED/;
-$cd->[1] is $cd->[0]
-Your tree seems to based on earlier (not uploaded) $v.
+ fail f_ <<END, $cd->[1], $cd->[0], $v
+%s is %s
+Your tree seems to based on earlier (not uploaded) %s.
END
+ if $cd->[0] =~ m/UNRELEASED/;
}
}
sub pseudomerge_make_commit ($$$$ $$) {
my ($clogp, $dgitview, $archive_hash, $i_arch_v,
$msg_cmd, $msg_msg) = @_;
- progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
+ progress f_ "Declaring that HEAD inciudes all changes in %s...",
+ $i_arch_v->[0];
my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
my $authline = clogp_authline $clogp;
: !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 $!;
+ print MC <<END or confess $!;
tree $tree
parent $dgitview
parent $archive_hash
[$msg_cmd]
END
- close MC or die $!;
+ close MC or confess $!;
return make_commit($pmf);
}
my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
if (!defined $overwrite_version) {
- progress "Checking that HEAD inciudes all changes in archive...";
+ progress __ "Checking that HEAD inciudes all changes in archive...";
}
return $dgitview if is_fast_fwd $archive_hash, $dgitview;
if (defined $overwrite_version) {
} elsif (!eval {
my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
- my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
+ my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
+ __ "maintainer view tag");
my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
- my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
- my $i_archive = [ $archive_hash, "current archive contents" ];
+ my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
+ my $i_archive = [ $archive_hash, __ "current archive contents" ];
printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
1;
}) {
- print STDERR <<END;
-$us: check failed (maybe --overwrite is needed, consult documentation)
+ $@ =~ s/^\n//; chomp $@;
+ print STDERR <<END.(__ <<ENDT);
+$@
END
- die "$@";
+| Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
+ENDT
+ finish -1;
}
+ my $arch_v = $i_arch_v->[0];
my $r = pseudomerge_make_commit
$clogp, $dgitview, $archive_hash, $i_arch_v,
"dgit --quilt=$quilt_mode",
- (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
-Declare fast forward from $i_arch_v->[0]
-END_OVERWR
-Make fast forward from $i_arch_v->[0]
-END_MAKEFF
+ (defined $overwrite_version
+ ? f_ "Declare fast forward from %s\n", $arch_v
+ : f_ "Make fast forward from %s\n", $arch_v);
maybe_split_brain_save $maintview, $r, "pseudomerge";
- progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
+ progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
return $r;
}
return $head if is_fast_fwd $archive_hash, $head;
- my $m = "Declare fast forward from $i_arch_v->[0]";
+ my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
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.";
+ progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
return $r;
}
my $clogpackage = getfield $clogp, 'Source';
$package //= $clogpackage;
- fail "-p specified $package but changelog specified $clogpackage"
+ fail f_ "-p specified %s but changelog specified %s",
+ $package, $clogpackage
unless $package eq $clogpackage;
my $cversion = getfield $clogp, 'Version';
my $dversion = getfield $dsc, 'Version';
my $dscpackage = getfield $dsc, 'Source';
($dscpackage eq $package && $dversion eq $cversion) or
- fail "$dscfn is for $dscpackage $dversion".
- " but debian/changelog is for $package $cversion";
+ fail f_ "%s is for %s %s but debian/changelog is for %s %s",
+ $dscfn, $dscpackage, $dversion,
+ $package, $cversion;
}
sub push_tagwants ($$$$) {
$dsc->{$ourdscfield[0]} = join " ",
$tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
$reader_giturl;
- $dsc->save("$dscfn.tmp") or die $!;
+ $dsc->save("$dscfn.tmp") or confess $!;
my $changes = parsecontrol($changesfile,$changesfilewhat);
foreach my $field (qw(Source Distribution Version)) {
$changes->{$field} eq $clogp->{$field} or
- fail "changes field $field \`$changes->{$field}'".
- " does not match changelog \`$clogp->{$field}'";
+ fail f_ "changes field %s \`%s' does not match changelog \`%s'",
+ $field, $changes->{$field}, $clogp->{$field};
}
my $cversion = getfield $clogp, 'Version';
my $head = $tw->{Objid};
my $tag = $tw->{Tag};
- open TO, '>', $tfn->('.tmp') or die $!;
- print TO <<END or die $!;
+ open TO, '>', $tfn->('.tmp') or confess $!;
+ print TO <<END or confess $!;
object $head
type commit
tag $tag
END
if ($tw->{View} eq 'dgit') {
- print TO <<END or die $!;
-$package release $cversion for $clogsuite ($csuite) [dgit]
+ print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
+%s release %s for %s (%s) [dgit]
+ENDT
+ or confess $!;
+ print TO <<END or confess $!;
[dgit distro=$declaredistro$delibs]
END
foreach my $ref (sort keys %previously) {
- print TO <<END or die $!;
+ print TO <<END or confess $!;
[dgit previously:$ref=$previously{$ref}]
END
}
} elsif ($tw->{View} eq 'maint') {
- print TO <<END or die $!;
-$package release $cversion for $clogsuite ($csuite)
-(maintainer view tag generated by dgit --quilt=$quilt_mode)
+ print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
+%s release %s for %s (%s)
+(maintainer view tag generated by dgit --quilt=%s)
END
+ $quilt_mode
+ or confess $!;
} else {
- die Dumper($tw)."?";
+ confess Dumper($tw)."?";
}
- close TO or die $!;
+ close TO or confess $!;
my $tagobjfn = $tfn->('.tmp');
if ($sign) {
if (!defined $keyid) {
$keyid = getfield $clogp, 'Maintainer';
}
- unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
+ unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess $!;
my @sign_cmd = (@gpg, qw(--detach-sign --armor));
push @sign_cmd, qw(-u),$keyid if defined $keyid;
push @sign_cmd, $tfn->('.tmp');
sub dopush () {
printdebug "actually entering push\n";
- supplementary_message(<<'END');
+ supplementary_message(__ <<'END');
Push failed, while checking state of the archive.
You can retry the push, after fixing the problem, if you like.
END
my $archive_hash = fetch_from_archive();
if (!$archive_hash) {
$new_package or
- fail "package appears to be new in this suite;".
- " if this is intentional, use --new";
+ fail __ "package appears to be new in this suite;".
+ " if this is intentional, use --new";
}
- supplementary_message(<<'END');
+ supplementary_message(__ <<'END');
Push failed, while preparing your push.
You can retry the push, after fixing the problem, if you like.
END
my $dscpath = "$buildproductsdir/$dscfn";
stat_exists $dscpath or
- fail "looked for .dsc $dscpath, but $!;".
- " maybe you forgot to build";
+ fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
+ $dscpath, $!;
responder_send_file('dsc', $dscpath);
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 f_ <<END, $ffq_prev, $quilt_mode;
+Branch is managed by git-debrebase (%s
+exists), but quilt mode (%s) 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;
my $cachekey;
($dgithead, $cachekey) =
quilt_check_splitbrain_cache($actualhead, $upstreamversion);
- $dgithead or fail
- "--quilt=$quilt_mode but no cached dgit view:
- perhaps HEAD changed since dgit build[-source] ?";
+ $dgithead or fail f_
+ "--quilt=%s but no cached dgit view:
+ perhaps HEAD changed since dgit build[-source] ?",
+ $quilt_mode;
$split_brain = 1;
$dgithead = splitbrain_pseudomerge($clogp,
$actualhead, $dgithead,
}
}
- if (defined $overwrite_version && !defined $maintviewhead) {
+ if (defined $overwrite_version && !defined $maintviewhead
+ && $archive_hash) {
$dgithead = plain_overwrite_pseudomerge($clogp,
$dgithead,
$archive_hash);
} elsif (deliberately_not_fast_forward) {
$forceflag = '+';
} else {
- fail "dgit push: HEAD is not a descendant".
+ fail __ "dgit push: HEAD is not a descendant".
" of the archive's version.\n".
"To overwrite the archive's contents,".
" pass --overwrite[=VERSION].\n".
}
changedir $playground;
- progress "checking that $dscfn corresponds to HEAD";
+ progress f_ "checking that %s corresponds to HEAD", $dscfn;
runcmd qw(dpkg-source -x --),
$dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
}
}
if (@mode_changes) {
- fail <<END.(join '', @mode_changes).<<END;
-HEAD specifies a different tree to $dscfn:
+ fail +(f_ <<ENDT, $dscfn).<<END
+HEAD specifies a different tree to %s:
+ENDT
$diffs
END
+ .(join '', @mode_changes)
+ .(f_ <<ENDT, $tree, $referent);
There is a problem with your source tree (see dgit(7) for some hints).
-To see a full diff, run git diff $tree $referent
-END
+To see a full diff, run git diff %s %s
+ENDT
}
- fail <<END;
-HEAD specifies a different tree to $dscfn:
+ fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
+HEAD specifies a different tree to %s:
+ENDT
$diffs
+END
Perhaps you forgot to build. Or perhaps there is a problem with your
source tree (see dgit(7) for some hints). To see a full diff, run
- git diff $tree $referent
-END
+ git diff %s %s
+ENDT
} else {
failedcmd @diffcmd;
}
if (!$changesfile) {
my $pat = changespat $cversion;
my @cs = glob "$buildproductsdir/$pat";
- fail "failed to find unique changes file".
- " (looked for $pat in $buildproductsdir);".
- " perhaps you need to use dgit -C"
+ fail f_ "failed to find unique changes file".
+ " (looked for %s in %s);".
+ " perhaps you need to use dgit -C",
+ $pat, $buildproductsdir
unless @cs==1;
($changesfile) = @cs;
} else {
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)],
+ f_ "source-only upload, even though package is entirely NEW\n".
+ "(this is contrary to policy in %s)",
+ access_nomdistro()
+ if !$hasdebs
+ && $new_package
+ && !(archive_query('package_not_wholly_new', $package) // 1);
+ } else {
+ badcfg f_ "unknown source-only-uploads policy \`%s'",
+ $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");
}
dgit_privdir()."/tag");
my @tagobjfns;
- supplementary_message(<<'END');
+ supplementary_message(__ <<'END');
Push failed, while signing the tag.
You can retry the push, after fixing the problem, if you like.
END
$changesfile,$changesfile,
\@tagwants);
}
- supplementary_message(<<'END');
+ supplementary_message(__ <<'END');
Push failed, *after* signing the tag.
If you want to try again, you should use a new version number.
END
@git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
}
- supplementary_message(<<'END');
+ supplementary_message(__ <<'END');
Push failed, while updating the remote git repository - see messages above.
If you want to try again, you should use a new version number.
END
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');
+ 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) {
if (act_local()) {
rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
} else {
- progress "[new .dsc left in $dscpath.tmp]";
+ progress f_ "[new .dsc left in %s.tmp]", $dscpath;
}
sign_changes $changesfile;
}
- supplementary_message(<<END);
+ supplementary_message(f_ <<END, $changesfile);
Push failed, while uploading package(s) to the archive server.
You can retry the upload of exactly these same files with dput of:
- $changesfile
+ %s
If that .changes file is broken, you will need to use a new version
number for your next attempt at the upload.
END
my $host = access_cfg('upload-host','RETURN-UNDEF');
my @hostarg = defined($host) ? ($host,) : ();
runcmd_ordryrun @dput, @hostarg, $changesfile;
- printdone "pushed and uploaded $cversion";
+ printdone f_ "pushed and uploaded %s", $cversion;
supplementary_message('');
responder_send_command("complete");
sub cmd_clone {
parseopts();
my $dstdir;
- badusage "-p is not allowed with clone; specify as argument instead"
+ badusage __ "-p is not allowed with clone; specify as argument instead"
if defined $package;
if (@ARGV==1) {
($package) = @ARGV;
} elsif (@ARGV==3) {
($package,$isuite,$dstdir) = @ARGV;
} else {
- badusage "incorrect arguments to dgit clone";
+ badusage __ "incorrect arguments to dgit clone";
}
notpushing();
$dstdir ||= "$package";
if (stat_exists $dstdir) {
- fail "$dstdir already exists";
+ fail f_ "%s already exists", $dstdir;
}
my $cwd_remove;
return unless defined $cwd_remove;
if (!chdir "$cwd_remove") {
return if $!==&ENOENT;
- die "chdir $cwd_remove: $!";
+ confess "chdir $cwd_remove: $!";
}
printdebug "clone rmonerror removing $dstdir\n";
if (stat $dstdir) {
- rmtree($dstdir) or die "remove $dstdir: $!\n";
+ rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
} elsif (grep { $! == $_ }
(ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
} else {
- print STDERR "check whether to remove $dstdir: $!\n";
+ print STDERR f_ "check whether to remove %s: %s\n",
+ $dstdir, $!;
}
};
}
}
}
-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) {
} elsif (@ARGV==1) {
($isuite) = @ARGV;
} else {
- badusage "incorrect arguments to dgit fetch or dgit pull";
+ badusage __ "incorrect arguments to dgit fetch or dgit pull";
}
notpushing();
}
sub cmd_fetch {
parseopts();
fetchpullargs();
- my $multi_fetched = fork_for_multisuite(sub { });
- exit 0 if $multi_fetched;
- fetch();
+ dofetch();
}
sub cmd_pull {
fetchpullargs();
if (quiltmode_splitbrain()) {
my ($format, $fopts) = get_source_format();
- madformat($format) and fail <<END
-dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
+ madformat($format) and fail f_ <<END, $quilt_mode
+dgit pull not yet supported in split view mode (--quilt=%s)
END
}
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 f_ "setting up vcs-git: %s\n", $url;
+ @cmd = (@git, qw(remote add vcs-git), $url);
+ } elsif ($orgurl eq $url) {
+ print STDERR f_ "vcs git already configured: %s\n", $url;
+ } else {
+ print STDERR f_ "changing vcs-git url to: %s\n", $url;
+ @cmd = (@git, qw(remote set-url vcs-git), $url);
+ }
+ runcmd_ordryrun_local @cmd;
+ if ($dofetch) {
+ print f_ "fetching (%s)\n", "@ARGV";
+ runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
+ }
+}
+
sub prep_push () {
parseopts();
build_or_push_prep_early();
} elsif (@ARGV==1) {
($specsuite) = (@ARGV);
} else {
- badusage "incorrect arguments to dgit $subcommand";
+ badusage f_ "incorrect arguments to dgit %s", $subcommand;
}
if ($new_package) {
local ($package) = $existing_package; # this is a hack
if (defined $specsuite &&
$specsuite ne $isuite &&
$specsuite ne $csuite) {
- fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
- " but command line specifies $specsuite";
+ fail f_ "dgit %s: changelog specifies %s (%s)".
+ " but command line specifies %s",
+ $subcommand, $isuite, $csuite, $specsuite;
}
}
dopush();
}
-sub cmd_push_source {
- prep_push();
- 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_for_push();
- }
- dopush();
-}
-
#---------- remote commands' implementation ----------
sub pre_remote_push_build_host {
$we_are_responder = 1;
$us .= " (build host)";
- open PI, "<&STDIN" or die $!;
- open STDIN, "/dev/null" or die $!;
- open PO, ">&STDOUT" or die $!;
+ open PI, "<&STDIN" or confess $!;
+ open STDIN, "/dev/null" or confess $!;
+ open PO, ">&STDOUT" or confess $!;
autoflush PO 1;
- open STDOUT, ">&STDERR" or die $!;
+ open STDOUT, ">&STDERR" or confess $!;
autoflush STDOUT 1;
$vsnwant //= 1;
$vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
} @rpushprotovsn_support;
- fail "build host has dgit rpush protocol versions ".
- (join ",", @rpushprotovsn_support).
- " but invocation host has $vsnwant"
+ fail f_ "build host has dgit rpush protocol versions %s".
+ " but invocation host has %s",
+ (join ",", @rpushprotovsn_support), $vsnwant
unless defined $protovsn;
changedir $dir;
if (defined $initiator_tempdir) {
rmtree $initiator_tempdir;
- mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
+ mkdir $initiator_tempdir, 0700
+ or fail f_ "create %s: %s", $initiator_tempdir, $!;
$i_tmp = $initiator_tempdir;
} else {
$i_tmp = tempdir();
$i_child_pid = undef; # prevents killing some other process with same pid
printdebug "waiting for build host child $pid...\n";
my $got = waitpid $pid, 0;
- die $! unless $got == $pid;
- die "build host child failed $?" if $?;
+ confess $! unless $got == $pid;
+ fail f_ "build host child failed: %s", waitstatusmsg() if $?;
i_cleanup();
- printdebug "all done\n";
- exit 0;
+ printdebug __ "all done\n";
+ finish 0;
}
sub i_resp_file ($) {
my $localname = i_method "i_localname", $keyword;
my $localpath = "$i_tmp/$localname";
stat_exists $localpath and
- badproto \*RO, "file $keyword ($localpath) twice";
+ badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
protocol_receive_file \*RO, $localpath;
i_method "i_file", $keyword;
}
our %i_param;
sub i_resp_param ($) {
- $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
+ $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
$i_param{$1} = $2;
}
sub i_resp_previously ($) {
$_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
- or badproto \*RO, "bad previously spec";
+ or badproto \*RO, __ "bad previously spec";
my $r = system qw(git check-ref-format), $1;
- die "bad previously ref spec ($r)" if $r;
+ confess "bad previously ref spec ($r)" if $r;
$previously{$1} = $2;
}
pushing();
rpush_handle_protovsn_bothends();
- fail "rpush negotiated protocol version $protovsn".
- " which does not support quilt mode $quilt_mode"
+ fail f_ "rpush negotiated protocol version %s".
+ " which does not support quilt mode %s",
+ $protovsn, $quilt_mode
if quiltmode_splitbrain;
my @localpaths = i_method "i_want", $keyword;
foreach my $localpath (@localpaths) {
protocol_send_file \*RI, $localpath;
}
- print RI "files-end\n" or die $!;
+ print RI "files-end\n" or confess $!;
}
our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
if (!forceing [qw(buildinfo-changes-mismatch)]) {
files_compare_inputs($bd, $ch);
(getfield $bd, $_) eq (getfield $ch, $_) or
- fail "buildinfo mismatch $_"
+ fail f_ "buildinfo mismatch in field %s", $_
foreach qw(Source Version);
!defined $bd->{$_} or
- fail "buildinfo contains $_"
+ fail f_ "buildinfo contains forbidden field %s", $_
foreach qw(Changes Changed-by Distribution);
}
push @i_buildinfos, $bi;
return
push_mktags $i_clogp, $i_dscfn,
- $i_changesfn, 'remote changes',
+ $i_changesfn, (__ 'remote changes file'),
\@tagwants;
}
mkpath '.git/dgit'; # we are in playtree
my $descfn = ".git/dgit/quilt-description.tmp";
- open O, '>', $descfn or die "$descfn: $!";
+ open O, '>', $descfn or confess "$descfn: $!";
$msg =~ s/\n+/\n\n/;
- print O <<END or die $!;
+ print O <<END or confess $!;
From: $author
${xinfo}Subject: $msg
---
END
- close O or die $!;
+ close O or confess $!;
{
local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
if ($unrepres) {
eval {
- die "not a plain file or symlink\n"
+ die __ "not a plain file or symlink\n"
unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
$oldmode =~ m/^(?:10|12)\d{4}$/;
if ($oldmode =~ m/[^0]/ &&
$newmode =~ m/[^0]/) {
# both old and new files exist
- die "mode or type changed\n" if $oldmode ne $newmode;
- die "modified symlink\n" unless $newmode =~ m/^10/;
+ die __ "mode or type changed\n" if $oldmode ne $newmode;
+ die __ "modified symlink\n" unless $newmode =~ m/^10/;
} elsif ($oldmode =~ m/[^0]/) {
# deletion
- die "deletion of symlink\n"
+ die __ "deletion of symlink\n"
unless $oldmode =~ m/^10/;
} else {
# creation
- die "creation with non-default mode\n"
+ die __ "creation with non-default mode\n"
unless $newmode =~ m/^100644$/ or
$newmode =~ m/^120000$/;
}
sub quiltify_splitbrain_needed () {
if (!$split_brain) {
- progress "dgit view: changes are required...";
+ progress __ "dgit view: changes are required...";
runcmd @git, qw(checkout -q -b dgit-view);
$split_brain = 1;
}
}
-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 f_ "\nFor full diff showing the problem(s), type:\n %s\n",
+ $cmd;
+ };
+
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.";
+ my $msg = f_
+ "--quilt=%s specified, implying patches-unapplied git tree\n".
+ " but git tree differs from orig in upstream files.",
+ $quilt_mode;
+ $msg .= $fulldiffhint->($unapplied, 'HEAD');
if (!stat_exists "debian/patches") {
- $msg .=
+ $msg .= __
"\n ... debian/patches is missing; perhaps this is a patch queue branch?";
}
fail $msg;
}
if ($quilt_mode =~ m/dpm/ &&
($diffbits->{H2A} & 01)) {
- fail <<END;
---quilt=$quilt_mode specified, implying patches-applied git tree
+ fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
+--quilt=%s specified, implying patches-applied git tree
but git tree differs from result of applying debian/patches to upstream
END
}
if ($quilt_mode =~ m/gbp|unapplied/ &&
($diffbits->{O2A} & 01)) { # some patches
quiltify_splitbrain_needed();
- progress "dgit view: creating patches-applied version using gbp pq";
+ progress __ "dgit view: creating patches-applied version using gbp pq";
runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
# gbp pq import creates a fresh branch; push back to dgit-view
runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
}
if ($quilt_mode =~ m/gbp|dpm/ &&
($diffbits->{O2A} & 02)) {
- fail <<END
---quilt=$quilt_mode specified, implying that HEAD is for use with a
+ fail f_ <<END, $quilt_mode;
+--quilt=%s 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.
END
if (($diffbits->{O2H} & 02) && # user has modified .gitignore
!($diffbits->{O2A} & 02)) { # patches do not change .gitignore
quiltify_splitbrain_needed();
- progress "dgit view: creating patch to represent .gitignore changes";
+ progress __
+ "dgit view: creating patch to represent .gitignore changes";
ensuredir "debian/patches";
my $gipatch = "debian/patches/auto-gitignore";
- open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
- stat GIPATCH or die "$gipatch: $!";
- fail "$gipatch already exists; but want to create it".
- " to record .gitignore changes" if (stat _)[7];
- print GIPATCH <<END or die "$gipatch: $!";
+ open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
+ stat GIPATCH or confess "$gipatch: $!";
+ fail f_ "%s already exists; but want to create it".
+ " to record .gitignore changes",
+ $gipatch
+ if (stat _)[7];
+ print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
Subject: Update .gitignore from Debian packaging branch
The Debian packaging git branch contains these updates to the upstream
.gitignore file(s). This patch is autogenerated, to provide these
updates to users of the official Debian archive view of the package.
+END
[dgit ($our_version) update-gitignore]
---
-END
+ENDU
close GIPATCH or die "$gipatch: $!";
runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
$unapplied, $headref, "--", sort keys %$editedignores;
- open SERIES, "+>>", "debian/patches/series" or die $!;
- defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
+ open SERIES, "+>>", "debian/patches/series" or confess $!;
+ defined seek SERIES, -1, 2 or $!==EINVAL or confess $!;
my $newline;
- defined read SERIES, $newline, 1 or die $!;
- print SERIES "\n" or die $! unless $newline eq "\n";
- print SERIES "auto-gitignore\n" or die $!;
+ defined read SERIES, $newline, 1 or confess $!;
+ print SERIES "\n" or confess $! unless $newline eq "\n";
+ print SERIES "auto-gitignore\n" or confess $!;
close SERIES or die $!;
- runcmd @git, qw(add -- debian/patches/series), $gipatch;
- commit_admin <<END
+ runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
+ commit_admin +(__ <<END).<<ENDU
Commit patch to update .gitignore
+END
[dgit ($our_version) update-gitignore-quilt-fixup]
-END
+ENDU
}
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";
- my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
- progress "dgit view: created ($saved)";
+ my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
+ progress f_ "dgit view: created (%s)", $saved;
}
sub quiltify ($$$$) {
my $c = shift @todo;
next if $considered{$c->{Commit}}++;
- $not->($c, "maximum search space exceeded") if --$max_work <= 0;
+ $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
printdebug "quiltify investigate $c->{Commit}\n";
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;
}
my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
- $not->($c, "has $c_sentinels not $t_sentinels")
+ $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
if $c_sentinels ne $t_sentinels;
my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
@parents = map { { Commit => $_, Child => $c } } @parents;
- $not->($c, "root commit") if !@parents;
+ $not->($c, __ "root commit") if !@parents;
foreach my $p (@parents) {
$p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
}
my $ndiffers = grep { $_->{Nontrivial} } @parents;
- $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
+ $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
+ if $ndiffers > 1;
foreach my $p (@parents) {
printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
my $patchstackchange = cmdoutput @cmd;
if (length $patchstackchange) {
$patchstackchange =~ s/\n/,/g;
- $not->($p, "changed $patchstackchange");
+ $not->($p, f_ "changed %s", $patchstackchange);
}
printdebug " search queue P=$p->{Commit} ",
$x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
return $x;
};
- my $reportnot = sub {
- my ($notp) = @_;
- my $s = $abbrev->($notp);
- my $c = $notp->{Child};
- $s .= "..".$abbrev->($c) if $c;
- $s .= ": ".$notp->{Whynot};
- return $s;
- };
if ($quilt_mode eq 'linear') {
- print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
+ print STDERR f_
+ "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
+ $us;
+ my $all_gdr = !!@nots;
foreach my $notp (@nots) {
- print STDERR "$us: ", $reportnot->($notp), "\n";
+ my $c = $notp->{Child};
+ my $cprange = $abbrev->($notp);
+ $cprange .= "..".$abbrev->($c) if $c;
+ print STDERR f_ "%s: %s: %s\n",
+ $us, $cprange, $notp->{Whynot};
+ $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...";
+ progress __ "quilt fixup cannot be linear, smashing...";
} else {
- die "$quilt_mode ?";
+ confess "$quilt_mode ?";
}
my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
quiltify_dpkg_commit "auto-$version-$target-$time",
(getfield $clogp, 'Maintainer'),
- "Automatically generated patch ($clogp->{Version})\n".
- "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
+ (f_ "Automatically generated patch (%s)\n".
+ "Last (up to) %s git changes, FYI:\n\n",
+ $clogp->{Version}, $ncommits).
+ $msg;
return;
}
- progress "quiltify linearisation planning successful, executing...";
+ progress __ "quiltify linearisation planning successful, executing...";
for (my $p = $sref_S;
my $c = $p->{Child};
my ($what) = @_;
eval {
- die "contains unexpected slashes\n" if m{//} || m{/$};
- die "contains leading punctuation\n" if m{^\W} || m{/\W};
- die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
- die "is series file\n" if m{$series_filename_re}o;
- die "too long" if length > 200;
+ die __ "contains unexpected slashes\n" if m{//} || m{/$};
+ die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
+ die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
+ die __ "is series file\n" if m{$series_filename_re}o;
+ die __ "too long\n" if length > 200;
};
return $_ unless $@;
- print STDERR "quiltifying commit $cc:".
- " ignoring/dropping Gbp-Pq $what: $@";
+ print STDERR f_
+ "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
+ $cc, $what, $@;
return undef;
};
$patchname = $translitname;
};
print STDERR
- "dgit: patch title transliteration error: $@"
+ +(f_ "dgit: patch title transliteration error: %s", $@)
if $@;
$patchname =~ y/ A-Z/-a-z/;
$patchname =~ y/-a-z0-9_.+=~//cd;
for ($index='';
stat "debian/patches/$patchname$index";
$index++) { }
- $!==ENOENT or die "$patchname$index $!";
+ $!==ENOENT or confess "$patchname$index $!";
runcmd @git, qw(checkout -q), $cc;
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 not ($? == 7*256 or
+ $? == -1 && $!==ENOENT);
+ } 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 $!;
+ mkdir "work" or confess $!;
changedir "work";
mktree_in_ud_here();
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 () {
runcmd @git, qw(rm -rqf .pc);
- commit_admin <<END
+ commit_admin +(__ <<END).<<ENDU
Commit removal of .pc (quilt series tracking data)
+END
[dgit ($our_version) upgrade quilt-remove-pc]
-END
+ENDU
}
sub quilt_fixup_singlepatch ($$$) {
my ($clogp, $headref, $upstreamversion) = @_;
- progress "starting quiltify (single-debian-patch)";
+ progress __ "starting quiltify (single-debian-patch)";
# dpkg-source --commit generates new patches even if
# single-debian-patch is in debian/source/options. In order to
# 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");
my $fakeversion="$upstreamversion-~~DGITFAKE";
- my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
- print $fakedsc <<END or die $!;
+ my $fakedsc=new IO::File 'fake.dsc', '>' or confess $!;
+ print $fakedsc <<END or confess $!;
Format: 3.0 (quilt)
Source: $package
Version: $fakeversion
my $md = new Digest::MD5;
my $fh = new IO::File $b, '<' or die "$b $!";
- stat $fh or die $!;
+ stat $fh or confess $!;
my $size = -s _;
$md->addfile($fh);
- print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
+ print $fakedsc " ".$md->hexdigest." $size $b\n" or confess $!;
};
- quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
+ unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
my @files=qw(debian/source/format debian/rules
debian/control debian/changelog);
runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
$dscaddfile->($debtar);
- close $fakedsc or die $!;
+ close $fakedsc or confess $!;
}
+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.
my $splitbrain_cachekey;
- progress
- "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
+ progress f_
+ "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
+ $quilt_mode;
# we look in the reflog of dgit-intern/quilt-cache
# we look for an entry whose message is the key for the cache lookup
my @cachekey = (qw(dgit), $our_version);
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 f_ "dgit view: found cached (%s)", $saved;
runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
$split_brain = 1;
return ($cachehit, $splitbrain_cachekey);
}
- progress "dgit view: found cached, no changes required";
+ 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);
sub quilt_fixup_multipatch ($$$) {
my ($clogp, $headref, $upstreamversion) = @_;
- progress "examining quilt state (multiple patches, $quilt_mode mode)";
+ progress f_ "examining quilt state (multiple patches, %s mode)",
+ $quilt_mode;
# Our objective is:
# - honour any existing .pc in case it has any strangeness
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';
$!=0; $?=-1;
if (system @bbcmd) {
failedcmd @bbcmd if $? < 0;
- fail <<END;
+ fail __ <<END;
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") {
-d _ or die;
- progress "Tree already contains .pc - will use it then delete it.";
+ progress __ "Tree already contains .pc - will use it then delete it.";
$mustdeletepc=1;
} else {
- rename '../fake/.pc','.pc' or die $!;
+ rename '../fake/.pc','.pc' or confess $!;
}
changedir '../fake';
}
printdebug "differences \@dl @dl.\n";
- progress sprintf
-"$us: base trees orig=%.20s o+d/p=%.20s",
- $unapplied, $oldtiptree;
- progress sprintf
-"$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
-"$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
- $dl[0], $dl[1], $dl[3], $dl[4],
- $dl[2], $dl[5];
+ progress f_
+"%s: base trees orig=%.20s o+d/p=%.20s",
+ $us, $unapplied, $oldtiptree;
+ progress f_
+"%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
+"%s: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
+ $us, $dl[0], $dl[1], $dl[3], $dl[4],
+ $us, $dl[2], $dl[5];
if (@unrepres) {
- print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
+ print STDERR f_ "dgit: cannot represent change: %s: %s\n",
+ $_->[1], $_->[0]
foreach @unrepres;
- forceable_fail [qw(unrepresentable)], <<END;
+ forceable_fail [qw(unrepresentable)], __ <<END;
HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
END
}
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;
}
- progress "starting quiltify (multiple patches, $quilt_mode mode)";
+ progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
if (!open P, '>>', ".pc/applied-patches") {
- $!==&ENOENT or die $!;
+ $!==&ENOENT or confess $!;
} else {
close P;
}
sub quilt_fixup_editor () {
my $descfn = $ENV{$fakeeditorenv};
my $editing = $ARGV[$#ARGV];
- open I1, '<', $descfn or die "$descfn: $!";
- open I2, '<', $editing or die "$editing: $!";
- unlink $editing or die "$editing: $!";
- open O, '>', $editing or die "$editing: $!";
- while (<I1>) { print O or die $!; } I1->error and die $!;
+ open I1, '<', $descfn or confess "$descfn: $!";
+ open I2, '<', $editing or confess "$editing: $!";
+ unlink $editing or confess "$editing: $!";
+ open O, '>', $editing or confess "$editing: $!";
+ while (<I1>) { print O or confess $!; } I1->error and confess $!;
my $copying = 0;
while (<I2>) {
$copying ||= m/^\-\-\- /;
next unless $copying;
- print O or die $!;
+ print O or confess $!;
}
- I2->error and die $!;
+ I2->error and confess $!;
close O or die $1;
- exit 0;
+ finish 0;
}
sub maybe_apply_patches_dirtily () {
return unless $quilt_mode =~ m/gbp|unapplied/;
- print STDERR <<END or die $!;
+ print STDERR __ <<END or confess $!;
dgit: Building, or cleaning with rules target, in patches-unapplied tree.
dgit: Have to apply the patches - making the tree dirty.
}
sub maybe_unapply_patches_again () {
- progress "dgit: Unapplying patches again to tidy up the tree."
+ progress __ "dgit: Unapplying patches again to tidy up the tree."
if $patches_applied_dirtily;
runcmd qw(dpkg-source --after-build .)
if $patches_applied_dirtily & 01;
} elsif ($cleanmode eq 'check') {
my $leftovers = cmdoutput @git, qw(clean -xdn);
if (length $leftovers) {
- print STDERR $leftovers, "\n" or die $!;
- fail "tree contains uncommitted files and --clean=check specified";
+ print STDERR $leftovers, "\n" or confess $!;
+ fail __
+ "tree contains uncommitted files and --clean=check specified";
}
} elsif ($cleanmode eq 'none') {
} else {
}
sub cmd_clean () {
- badusage "clean takes no additional arguments" if @ARGV;
+ badusage __ "clean takes no additional arguments" if @ARGV;
notpushing();
clean_tree();
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++;
- badusage "-p is not allowed with dgit $subcommand" if defined $package;
+ badusage f_ "-p is not allowed with dgit %s", $subcommand
+ if defined $package;
my $clogp = parsechangelog();
$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;
foreach my $f (glob "$buildproductsdir/$pat") {
if (act_local()) {
- unlink $f or fail "remove old changes file $f: $!";
+ unlink $f or
+ fail f_ "remove old changes file %s: %s", $f, $!;
} else {
- progress "would remove $f";
+ progress f_ "would remove %s", $f;
}
}
}
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;
@vsns = sort { -version_compare($a, $b) } @vsns;
$changes_since_version = $vsns[0];
- progress "changelog will contain changes since $vsns[0]";
+ progress f_ "changelog will contain changes since %s", $vsns[0];
} else {
$changes_since_version = '_';
- progress "package seems new, not specifying -v<version>";
+ progress __ "package seems new, not specifying -v<version>";
}
}
if ($changes_since_version ne '_') {
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 :
+ confess "$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
} @changesfiles;
my $result;
if (@changesfiles==1) {
- fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
-only one changes file from build (@changesfiles)
+ fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
+only one changes file from build (%s)
END
+ if defined $msg_if_onlyone;
$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"
+ fail f_ "%s found in binaries changes file %s", $l, $binchanges
if $l =~ m/\.dsc$/;
}
runcmd_ordryrun_local @mergechanges, @changesfiles;
my $multichanges = changespat $version,'multi';
if (act_local()) {
- stat_exists $multichanges or fail "$multichanges: $!";
+ stat_exists $multichanges or fail f_
+ "%s unexpectedly not created by build", $multichanges;
foreach my $cf (glob $pat) {
next if $cf eq $multichanges;
- rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
+ rename "$cf", "$cf.inmulti" or fail f_
+ "install new changes %s\{,.inmulti}: %s", $cf, $!;
}
}
$result = $multichanges;
} else {
- fail "wrong number of different changes files (@changesfiles)";
+ fail f_ "wrong number of different changes files (%s)",
+ "@changesfiles";
}
- printdone "build successful, results in $result\n" or die $!;
+ printdone f_ "build successful, results in %s\n", $result
+ or confess $!;
}
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.
+ my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
+ @unwanted = grep {
+ $_ ne changespat $version,'source' and
+ $_ ne changespat $version,'multi'
+ } @unwanted;
+ fail +(f_ <<END, $pat, "@unwanted")
+changes files other than source matching %s already present; building would result in ambiguity about the intended results.
+Suggest you delete %s.
END
if @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 {
- printdone "build successful\n";
+ printdone __ "build successful\n";
}
}
sub cmd_build {
build_prep_early();
+ $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
+%s: warning: build-products-dir set, but not supported by dpkg-buildpackage
+%s: 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 ($gbp_make_orig) {
my $priv = dgit_privdir();
my $ok = "$priv/origs-gen-ok";
- unlink $ok or $!==&ENOENT or die $!;
+ unlink $ok or $!==&ENOENT or confess $!;
my @origs_cmd = @cmd;
push @origs_cmd, qw(--git-cleaner=true);
push @origs_cmd, "--git-prebuild=".
}
}
- 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 build_source_for_push {
- build_source();
- maybe_unapply_patches_again();
- $changesfile = $sourcechanges;
+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();
- build_prep();
$sourcechanges = changespat $version,'source';
if (act_local()) {
- unlink "../$sourcechanges" or $!==ENOENT
- or fail "remove $sourcechanges: $!";
+ unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
+ or fail f_ "remove %s: %s", $sourcechanges, $!;
}
- $dscfn = dscfn($version);
my @cmd = (@dpkgsource, qw(-b --));
- if ($split_brain) {
+ 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;
- 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): $!";
+ unless ($split_brain) {
+ my $upstreamversion = upstreamversion $version;
+ unpack_playtree_linkorigs($upstreamversion, sub { });
+ unpack_playtree_mkwork($headref);
+ changedir '..';
}
} else {
- my $pwd = must_getcwd();
- my $leafdir = basename $pwd;
- changedir "..";
- runcmd_ordryrun_local @cmd, $leafdir;
- changedir $pwd;
+ $leafdir = basename $maindir;
+ changedir '..';
}
+ runcmd_ordryrun_local @cmd, $leafdir;
+
+ changedir $leafdir;
runcmd_ordryrun_local qw(sh -ec),
- 'exec >$1; shift; exec "$@"','x',
- "../$sourcechanges",
+ '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 f_ "put in place new built file (%s): %s", $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;
+ 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";
+ printdone f_ "source built, results in %s and %s",
+ $dscfn, $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();
+ confess "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 $sourcechanges
- or fail "$sourcechanges (in parent directory): $!";
+ stat_exists $dscfn or fail f_
+ "%s (in build products dir): %s", $dscfn, $!;
+ stat_exists $sourcechanges or fail f_
+ "%s (in build products dir): %s", $sourcechanges, $!;
}
- 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 confess $!;
+}
+
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");
+ check_gitattrs($newhash, __ "source tree");
- progress "dgit: import-dsc: $what_msg";
+ progress f_ "dgit: import-dsc: %s", $what_msg;
}
sub cmd_import_dsc {
if (m/^--require-valid-signature$/) {
$needsig = 1;
} else {
- badusage "unknown dgit import-dsc sub-option \`$_'";
+ badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
}
}
- badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
+ badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
+ unless @ARGV==2;
my ($dscfn, $dstbranch) = @ARGV;
- badusage "dry run makes no sense with import-dsc" unless act_local();
+ badusage __ "dry run makes no sense with import-dsc"
+ unless act_local();
my $force = $dstbranch =~ s/^\+// ? +1 :
$dstbranch =~ s/^\.\.// ? -1 :
my $chead = cmdoutput_errok @symcmd;
defined $chead or $?==256 or failedcmd @symcmd;
- fail "$dstbranch is checked out - will not update it"
+ fail f_ "%s is checked out - will not update it", $dstbranch
if defined $chead and $chead eq $dstbranch;
my $oldhash = git_get_ref $dstbranch;
- open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
+ open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
$dscdata = do { local $/ = undef; <D>; };
- D->error and fail "read $dscfn: $!";
+ D->error and fail f_ "read %s: %s", $dscfn, $!;
close C;
# we don't normally need this so import it here
local $SIG{__WARN__} = sub {
print STDERR $_[0];
return unless $needsig;
- fail "import-dsc signature check failed";
+ fail __ "import-dsc signature check failed";
};
if (!$dp->is_signed()) {
- warn "$us: warning: importing unsigned .dsc\n";
+ warn f_ "%s: warning: importing unsigned .dsc\n", $us;
} else {
my $r = $dp->check_signature();
- die "->check_signature => $r" if $needsig && $r;
+ confess "->check_signature => $r" if $needsig && $r;
}
}
$package = getfield $dsc, 'Source';
- parse_dsc_field($dsc, "Dgit metadata in .dsc")
+ parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
unless forceing [qw(import-dsc-with-dgit-field)];
parse_dsc_field_def_dsc_distro();
notpushing();
if (defined $dsc_hash) {
- progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
+ progress __
+ "dgit: import-dsc of .dsc with Dgit field, using git hash";
resolve_dsc_field_commit undef, undef;
}
if (defined $dsc_hash) {
"echo $dsc_hash | git cat-file --batch-check");
my $objgot = cmdoutput @cmd;
if ($objgot =~ m#^\w+ missing\b#) {
- fail <<END
-.dsc contains Dgit field referring to object $dsc_hash
+ fail f_ <<END, $dsc_hash
+.dsc contains Dgit field referring to object %s
Your git tree does not have that object. Try `git fetch' from a
plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
END
}
if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
if ($force > 0) {
- progress "Not fast forward, forced update.";
+ progress __ "Not fast forward, forced update.";
} else {
- fail "Not fast forward to $dsc_hash";
+ fail f_ "Not fast forward to %s", $dsc_hash;
}
}
import_dsc_result $dstbranch, $dsc_hash,
"dgit import-dsc (Dgit): $info",
- "updated git ref $dstbranch";
+ f_ "updated git ref %s", $dstbranch;
return 0;
}
- fail <<END
-Branch $dstbranch already exists
-Specify ..$specbranch for a pseudo-merge, binding in existing history
-Specify +$specbranch to overwrite, discarding existing history
+ fail f_ <<END, $dstbranch, $specbranch, $specbranch
+Branch %s already exists
+Specify ..%s for a pseudo-merge, binding in existing history
+Specify +%s to overwrite, discarding existing history
END
if $oldhash && !$force;
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 $! !";
+ fail f_ "lstat %s works but stat gives %s !", $here, $!;
}
- fail "stat $here: $!" unless $! == ENOENT;
+ fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
my $there = $dscfn;
if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
$there = $';
} elsif ($dscfn =~ m#^/#) {
$there = $dscfn;
} else {
- fail "cannot import $dscfn which seems to be inside working tree!";
+ fail f_
+ "cannot import %s which seems to be inside working tree!",
+ $dscfn;
}
- $there =~ s#/+[^/]+$## or
- fail "import $dscfn requires ../$f, but it does not exist";
+ $there =~ s#/+[^/]+$## or fail f_
+ "import %s requires .../%s, but it does not exist",
+ $dscfn, $f;
$there .= "/$f";
my $test = $there =~ m{^/} ? $there : "../$there";
- stat $test or fail "import $dscfn requires $test, but: $!";
- symlink $there, $here or fail "symlink $there to $here: $!";
- progress "made symlink $here -> $there";
+ stat $test or fail f_
+ "import %s requires %s, but: %s", $dscfn, $test, $!;
+ symlink $there, $here or fail f_
+ "symlink %s to %s: %s", $there, $here, $!;
+ progress f_ "made symlink %s -> %s", $here, $there;
# print STDERR Dumper($fi);
}
my @mergeinputs = generate_commits_from_dsc();
if ($oldhash) {
if ($force > 0) {
- progress "Import, forced update - synthetic orphan git history.";
+ progress __
+ "Import, forced update - synthetic orphan git history.";
} elsif ($force < 0) {
- progress "Import, merging.";
+ progress __ "Import, merging.";
my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
my $version = getfield $dsc, 'Version';
my $clogp = commit_getclogp $newhash;
my $authline = clogp_authline $clogp;
- $newhash = make_commit_text <<END;
+ $newhash = make_commit_text <<ENDU
tree $tree
parent $newhash
parent $oldhash
author $authline
committer $authline
-Merge $package ($version) import into $dstbranch
+ENDU
+ .(f_ <<END, $package, $version, $dstbranch);
+Merge %s (%s) import into %s
END
} else {
die; # caught earlier
import_dsc_result $dstbranch, $newhash,
"dgit import-dsc: $info",
- "results are in in git ref $dstbranch";
+ f_ "results are in in git ref %s", $dstbranch;
}
sub pre_archive_api_query () {
not_necessarily_a_tree();
}
sub cmd_archive_api_query {
- badusage "need only 1 subpath argument" unless @ARGV==1;
+ 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;
- exec @cmd or fail "exec curl: $!\n";
+ exec @cmd or fail f_ "exec curl: %s\n", $!;
}
sub repos_server_url () {
not_necessarily_a_tree();
}
sub cmd_clone_dgit_repos_server {
- badusage "need destination argument" unless @ARGV==1;
+ badusage __ "need destination argument" unless @ARGV==1;
my ($destdir) = @ARGV;
my $url = repos_server_url();
my @cmd = (@git, qw(clone), $url, $destdir);
debugcmd ">",@cmd;
- exec @cmd or fail "exec git clone: $!\n";
+ exec @cmd or fail f_ "exec git clone: %s\n", $!;
}
sub pre_print_dgit_repos_server_source_url () {
not_necessarily_a_tree();
}
sub cmd_print_dgit_repos_server_source_url {
- badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
+ badusage __
+ "no arguments allowed to dgit print-dgit-repos-server-source-url"
if @ARGV;
my $url = repos_server_url();
- print $url, "\n" or die $!;
+ print $url, "\n" or confess $!;
}
sub pre_print_dpkg_source_ignores {
not_necessarily_a_tree();
}
sub cmd_print_dpkg_source_ignores {
- badusage "no arguments allowed to dgit print-dpkg-source-ignores"
+ badusage __
+ "no arguments allowed to dgit print-dpkg-source-ignores"
if @ARGV;
- print "@dpkg_source_ignores\n" or die $!;
+ print "@dpkg_source_ignores\n" or confess $!;
}
sub cmd_setup_mergechangelogs {
- badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
+ badusage __ "no arguments allowed to dgit setup-mergechangelogs"
+ if @ARGV;
local $isuite = 'DGIT-SETUP-TREE';
setup_mergechangelogs(1);
}
sub cmd_setup_useremail {
- badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
+ badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
local $isuite = 'DGIT-SETUP-TREE';
setup_useremail(1);
}
sub cmd_setup_gitattributes {
- badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
+ badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
local $isuite = 'DGIT-SETUP-TREE';
setup_gitattrs(1);
}
sub cmd_setup_new_tree {
- badusage "no arguments allowed to dgit setup-tree" if @ARGV;
+ badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
local $isuite = 'DGIT-SETUP-TREE';
setup_new_tree();
}
#---------- argument parsing and main program ----------
sub cmd_version {
- print "dgit version $our_version\n" or die $!;
- exit 0;
+ print "dgit version $our_version\n" or confess $!;
+ finish 0;
}
our (%valopts_long, %valopts_short);
defvalopt '--initiator-tempdir','','.*', sub {
($initiator_tempdir) = (@_);
$initiator_tempdir =~ m#^/# or
- badusage "--initiator-tempdir must be used specify an".
- " absolute, not relative, directory."
+ badusage __ "--initiator-tempdir must be used specify an".
+ " absolute, not relative, directory."
};
sub defoptmodes ($@) {
my ($what) = @_;
@rvalopts = ($_);
if (!defined $val) {
- badusage "$what needs a value" unless @ARGV;
+ badusage f_ "%s needs a value", $what unless @ARGV;
$val = shift @ARGV;
push @rvalopts, $val;
}
- badusage "bad value \`$val' for $what" unless
+ badusage f_ "bad value \`%s' for %s", $val, $what unless
$val =~ m/^$oi->{Re}$(?!\n)/s;
my $how = $oi->{How};
if (ref($how) eq 'SCALAR') {
} 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;
$_='';
} elsif (m/^--force-/) {
print STDERR
- "$us: warning: ignoring unknown force option $_\n";
+ f_ "%s: warning: ignoring unknown force option %s\n",
+ $us, $_;
$_='';
} elsif (m/^--dgit-tag-format=(old|new)$/s) {
# undocumented, for testing
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, $_;
push @ropts, $_;
$funcopts_long{$_}();
} else {
- badusage "unknown long option \`$_'";
+ badusage f_ "unknown long option \`%s'", $_;
}
} else {
while (m/^-./s) {
$valopt->($oi->{Short});
$_ = '';
} else {
- badusage "unknown short option \`$_'";
+ badusage f_ "unknown short option \`%s'", $_;
}
}
}
sub check_env_sanity () {
my $blocked = new POSIX::SigSet;
- sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
+ sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess $!;
eval {
foreach my $name (qw(PIPE CHLD)) {
my $signame = "SIG$name";
my $signum = eval "POSIX::$signame" // die;
- ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
- die "$signame is set to something other than SIG_DFL\n";
+ die f_ "%s is set to something other than SIG_DFL\n",
+ $signame
+ if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
$blocked->ismember($signum) and
- die "$signame is blocked\n";
+ die f_ "%s is blocked\n", $signame;
}
};
return unless $@;
chomp $@;
- fail <<END;
-On entry to dgit, $@
+ fail f_ <<END, $@;
+On entry to dgit, %s
This is a bug produced by something in in your execution environment.
Giving up.
END
my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
if (defined $v) {
- badcfg "cannot set command for $k"
+ badcfg f_ "cannot set command for %s", $k
unless length $om->[0];
$om->[0] = $v;
}
printdebug "CL $c ", (join " ", map { shellquote } @vl),
"\n" if $debuglevel >= 4;
next unless @vl;
- badcfg "cannot configure options for $k"
+ badcfg f_ "cannot configure options for %s", $k
if $opts_opt_cmdonly{$k};
my $insertpos = $opts_cfg_insertpos{$k};
@$om = ( @$om[0..$insertpos-1],
// access_cfg('quilt-mode', 'RETURN-UNDEF')
// 'linear';
$quilt_mode =~ m/^($quilt_modes_re)$/
- or badcfg "unknown quilt-mode \`$quilt_mode'";
+ or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
$quilt_mode = $1;
}
next if defined $$vr;
$$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
my $v = $moc->{Vals}{$$vr};
- badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
+ badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
+ unless defined $v;
$$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;
$cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
$cleanmode //= 'dpkg-source';
- badcfg "unknown clean-mode \`$cleanmode'" unless
+ badcfg f_ "unknown clean-mode \`%s'", $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();
parseopts();
check_env_sanity();
-print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
-print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
+print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
+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 confess $!;
+ finish 8;
}
$cmd = $subcommand = shift @ARGV;
$cmd =~ y/-/_/;
git_slurp_config();
my $fn = ${*::}{"cmd_$cmd"};
-$fn or badusage "unknown operation $cmd";
+$fn or badusage f_ "unknown operation %s", $cmd;
$fn->();
+
+finish 0;
~ianmdlvl / dgit.git / blobdiff