X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=4cc568457a8305b83dfd83024c909d0dd19654fb;hp=adf125abc8086e5062bb2e9f453dda7457ce7a2b;hb=707e502d2fb71f98f990edc12bd5fbd3d32dae52;hpb=fc8a490c9eda9c4c16303362d1d0b20fb54b22ec diff --git a/dgit b/dgit index adf125ab..4cc56845 100755 --- a/dgit +++ b/dgit @@ -2,8 +2,8 @@ # 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 @@ -20,6 +20,7 @@ END { $? = $Debian::Dgit::ExitStatus::desired // -1; }; use Debian::Dgit::ExitStatus; +use Debian::Dgit::I18n; use strict; @@ -37,6 +38,7 @@ use Dpkg::Version; use Dpkg::Compression; use Dpkg::Compression::Process; use POSIX; +use Locale::gettext; use IPC::Open2; use Digest::SHA; use Digest::MD5; @@ -64,8 +66,9 @@ our $sign = 1; our $dryrun_level = 0; our $changesfile; our $buildproductsdir; +our $bpd_glob; our $new_package = 0; -our $ignoredirty = 0; +our $includedirty = 0; our $rmonerror = 1; our @deliberatelies; our %previously; @@ -77,7 +80,7 @@ our $overwrite_version; # undef: not specified; '': check changelog 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; @@ -99,9 +102,6 @@ our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)"); 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'; @@ -115,7 +115,7 @@ our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L)); 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); @@ -128,6 +128,8 @@ our (@mergechanges) = qw(mergechanges -f); 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, @@ -147,7 +149,9 @@ our %opts_opt_map = ('dget' => \@dget, # accept for compatibility '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 { @@ -165,7 +169,6 @@ our $keyid; autoflush STDOUT 1; our $supplementary_message = ''; -our $need_split_build_invocation = 0; our $split_brain = 0; END { @@ -197,15 +200,13 @@ sub lref () { return "refs/heads/".lbranch(); } 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 ($) { @@ -218,12 +219,6 @@ sub changespat ($;$) { return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes"; } -sub upstreamversion ($) { - my ($vsn) = @_; - $vsn =~ s/-[^-]+$//; - return $vsn; -} - our $us = 'dgit'; initdebug(''); @@ -237,24 +232,29 @@ END { } }; -sub badcfg { print STDERR "$us: invalid configuration: @_\n"; finish 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"; + print STDERR f_ "%s: package %s does not exist in suite %s\n", + $us, $package, $isuite; finish 4; } @@ -274,20 +274,36 @@ sub quiltmode_splitbrain () { } 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) = @@ -299,21 +315,91 @@ sub branch_gdr_info ($$) { return ($ffq_prev, $gdrlast); } -sub branch_is_gdr ($$) { - my ($symref, $head) = @_; - my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head); - return 0 unless $ffq_prev || $gdrlast; - return 1; -} - 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 is_fast_fwd $ancestor, $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: @@ -386,28 +472,28 @@ sub i_child_report () { 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; @@ -415,7 +501,7 @@ sub protocol_expect (&$) { my $r = &$match; return $r if $r; } - badproto $fh, "\`$_'"; + badproto $fh, f_ "\`%s'", $_; } sub protocol_send_file ($$) { @@ -426,20 +512,20 @@ 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; } @@ -455,9 +541,9 @@ sub protocol_receive_file ($$) { } $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 ---------- @@ -467,7 +553,7 @@ sub responder_send_command ($) { 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 ($$) { @@ -502,8 +588,8 @@ sub initiator_expect (&) { 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"; } @@ -518,9 +604,10 @@ sub url_get { } 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'); } @@ -531,9 +618,9 @@ sub act_scary () { return !$dryrun_level; } 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)", "@_"; } } @@ -557,12 +644,13 @@ sub runcmd_ordryrun_local { } } -our $helpmsg = <= set git config option (used directly by dgit too) END -our $later_warning_msg = <= 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; @@ -714,8 +803,10 @@ sub cfg { 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 () { @@ -754,7 +845,8 @@ sub access_nomdistro () { 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; } @@ -768,7 +860,7 @@ sub access_quirk () { $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); } @@ -784,7 +876,8 @@ sub parse_cfg_bool ($$$) { 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 () { @@ -802,7 +895,8 @@ 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 () { @@ -811,11 +905,12 @@ 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 @@ -833,8 +928,8 @@ sub supplementary_message ($) { 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 $!; } } @@ -971,7 +1066,7 @@ sub commit_getclogp ($) { } 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; @@ -981,7 +1076,7 @@ our %rmad; 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'"; @@ -1027,8 +1122,9 @@ sub archive_api_query_cmd ($) { 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 @@ -1047,7 +1143,7 @@ sub archive_api_query_cmd ($) { 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]; @@ -1055,11 +1151,11 @@ sub api_query ($$;$) { 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); } @@ -1075,15 +1171,17 @@ sub canonicalise_suite_ftpmasterapi { } 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; } @@ -1097,18 +1195,18 @@ sub archive_query_ftpmasterapi { 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; @@ -1147,15 +1245,15 @@ sub aptget_cache_clean { 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"; @@ -1170,7 +1268,7 @@ sub aptget_prep ($) { 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; @@ -1186,17 +1284,17 @@ sub aptget_prep ($) { 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 <) { next unless stat_exists $oldlist; my ($mtime) = (stat _)[9]; @@ -1238,13 +1336,13 @@ END my @inreleasefiles = grep { m#/InRelease$# } @releasefiles; @releasefiles = @inreleasefiles if @inreleasefiles; if (!@releasefiles) { - fail <{$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 @@ -1288,8 +1387,9 @@ sub archive_query_aptget { 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; @@ -1303,6 +1403,7 @@ 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 @_; } @@ -1316,7 +1417,7 @@ sub dummycatapi_run_in_mirror ($@) { my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune, qw(x), $mirror, @$argl); debugcmd "-|", @cmd; - open FIA, "-|", @cmd or die $!; + open FIA, "-|", @cmd or confess $!; my $r = $fn->(); close FIA or ($!==0 && $?==141) or die failedcmd @cmd; return $r; @@ -1391,10 +1492,11 @@ sub madison_get_parse { 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]; } @@ -1402,6 +1504,7 @@ 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) = @_; @@ -1417,7 +1520,7 @@ sub sshpsql ($$$) { " 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 (

) { chomp or die; printdebug(">|$_|\n"); @@ -1480,6 +1583,7 @@ 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) = @_; @@ -1525,6 +1629,7 @@ 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'); @@ -1579,12 +1684,12 @@ sub select_tagformat () { 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; } } @@ -1604,13 +1709,13 @@ sub get_archive_dsc () { $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"; @@ -1637,7 +1742,8 @@ sub check_for_git () { # 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]$/; @@ -1653,7 +1759,7 @@ sub check_for_git () { # 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') { @@ -1668,7 +1774,7 @@ sub check_for_git () { } elsif ($how eq 'false') { return 0; } else { - badcfg "unknown git-check \`$how'"; + badcfg f_ "unknown git-check \`%s'", $how; } } @@ -1683,7 +1789,7 @@ sub create_remote_git_repo () { } elsif ($how eq 'true') { # nothing to do } else { - badcfg "unknown git-create \`$how'"; + badcfg f_ "unknown git-create \`%s'", $how; } } @@ -1715,13 +1821,13 @@ sub remove_stray_gits ($) { 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 () { 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 $_; } } @@ -1733,7 +1839,7 @@ sub mktree_in_ud_from_only_subdir ($;$) { # 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; @@ -1766,7 +1872,7 @@ sub dsc_files_info () { 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, @@ -1777,8 +1883,8 @@ sub dsc_files_info () { } 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 () { @@ -1822,8 +1928,9 @@ sub files_compare_inputs (@) { 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; } @@ -1831,17 +1938,18 @@ sub files_compare_inputs (@) { @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 ($$) { @@ -1853,13 +1961,6 @@ 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. @@ -1887,7 +1988,7 @@ sub test_source_only_changes ($) { $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; } } @@ -1900,7 +2001,7 @@ sub changes_update_origs_from_dsc ($$$$) { 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"; @@ -1912,7 +2013,7 @@ sub changes_update_origs_from_dsc ($$$$) { printdebug "origs $file is_orig\n"; my $have = archive_query('file_in_archive', $file); if (!defined $have) { - print STDERR <{$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 @@ -1965,7 +2068,7 @@ END $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"; @@ -1974,7 +2077,7 @@ END } if (%changed) { foreach my $file (keys %changed) { - progress sprintf + progress f_ "edited .changes for archive .orig contents: %s %s", $changed{$file}, $file; } @@ -1983,10 +2086,11 @@ END 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; } } @@ -1995,28 +2099,6 @@ sub make_commit ($) { 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'; @@ -2031,8 +2113,9 @@ sub clogp_authline ($) { 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; } @@ -2045,14 +2128,14 @@ sub vendor_patches_distro ($$) { printdebug "checking for vendor-specific $series ($what)\n"; if (!open SERIES, "<", $series) { - die "$series $!" unless $!==ENOENT; + confess "$series $!" unless $!==ENOENT; return; } while () { next unless m/\S/; next if m/^\s+\#/; - print STDERR <error; close SERIES; @@ -2095,11 +2179,11 @@ sub check_for_vendor_patches () { 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 () { @@ -2112,7 +2196,7 @@ 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: "; @@ -2120,12 +2204,12 @@ sub generate_commits_from_dsc () { 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"; } @@ -2140,14 +2224,14 @@ sub generate_commits_from_dsc () { 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"; } @@ -2194,9 +2278,9 @@ sub generate_commits_from_dsc () { 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"; } @@ -2204,23 +2288,23 @@ sub generate_commits_from_dsc () { } 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 @@ -2277,7 +2361,7 @@ sub generate_commits_from_dsc () { 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(); } @@ -2295,7 +2379,7 @@ sub generate_commits_from_dsc () { my $r1clogp; printdebug "import clog search...\n"; - parsechangelog_loop \@clogcmd, "package changelog", sub { + parsechangelog_loop \@clogcmd, (__ "package changelog"), sub { my ($thisstanza, $desc) = @_; no warnings qw(exiting); @@ -2335,7 +2419,7 @@ sub generate_commits_from_dsc () { printdebug "import clog $r1clogp->{version} becomes r1\n"; }; - $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'; @@ -2354,12 +2438,13 @@ sub generate_commits_from_dsc () { 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} ? <{Tree} author $r1authline committer $r1authline -Import $tt->{F} +$mbody [dgit import orig $tt->{F}] END_O @@ -2367,7 +2452,7 @@ tree $tt->{Tree} author $authline committer $authline -Import $tt->{F} +$mbody [dgit import tarball $package $cversion $tt->{F}] END_T @@ -2376,14 +2461,14 @@ END_T printdebug "import main commit\n"; - open C, ">../commit.tmp" or die $!; - print C <../commit.tmp" or confess $!; + print C <{Commit} END - print C <{format}) { @@ -2434,10 +2519,10 @@ END 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 @@ -2453,19 +2538,19 @@ END '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 < $rawimport_hash, - Info => "Import of source package", + Info => __ "Import of source package", }; my @output = ($rawimport_mergeinput); @@ -2492,16 +2577,18 @@ END version_compare($oversion, $cversion); if ($vcmp < 0) { @output = ($rawimport_mergeinput, $lastpush_mergeinput, - { Message => < 1 }); -Record $package ($cversion) in archive suite $csuite + { ReverseParents => 1, + Message => (f_ < 0) { - print STDERR <{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 { @@ -2562,9 +2649,9 @@ sub complete_file_from_dsc ($$;$) { 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; } @@ -2574,7 +2661,7 @@ sub ensure_we_have_orig () { 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; } } @@ -2657,7 +2744,7 @@ sub git_lrfetch_sane { 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; @@ -2665,14 +2752,14 @@ sub git_lrfetch_sane { debugcmd "|",@lcmd; my %wantr; - open GITLS, "-|", @lcmd or die $!; + open GITLS, "-|", @lcmd or confess $!; while () { printdebug "=> ", $_; m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?"; my ($objid,$rrefname) = ($1,$2); if (!$wanted_rref->($rrefname)) { - print STDERR <("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 < $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(); @@ -3087,7 +3173,7 @@ sub fetch_from_archive () { 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; } @@ -3101,23 +3187,24 @@ sub fetch_from_archive () { if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) { @mergeinputs = $dsc_mergeinput } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) { - print STDERR <", $mcf or die "$mcf $!"; - print MC <{Commit} } @mergeinputs; @parents = reverse @parents if $compat_info->{ReverseParents}; - print MC <{Commit} END - print MC <{Message}) { - print MC $compat_info->{Message} or die $!; + print MC $compat_info->{Message} or confess $!; } else { - print MC <{Info} - or die $!; + or confess $!; }; $message_add_info->($mergeinputs[0]); - print MC <($_) foreach @mergeinputs[1..$#mergeinputs]; } - close MC or die $!; + close MC or confess $!; $hash = make_commit $mcf; } else { $hash = $mergeinputs[0]{Commit}; @@ -3262,12 +3347,12 @@ END 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); @@ -3277,11 +3362,11 @@ END my $got_vsn = getfield $gotclogp, 'Version'; printdebug "SKEW CHECK GOT $got_vsn\n"; if (version_compare($got_vsn, $skew_warning_vsn) < 0) { - print STDERR <) { 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: $!"; @@ -3382,7 +3467,7 @@ sub is_gitattrs_setup () { printdebug "is_gitattrs_setup: found old macro\n"; return 0; } - $gai->error and die $!; + $gai->error and confess $!; printdebug "is_gitattrs_setup: found nothing\n"; return undef; } @@ -3393,7 +3478,7 @@ sub setup_gitattrs (;$) { my $already = is_gitattrs_setup(); if ($already) { - progress < $af.new" or die $!; - print GAO < $af.new" or confess $!; + print GAO <) { @@ -3417,12 +3503,12 @@ END $_ = $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 () { @@ -3440,7 +3526,7 @@ sub check_gitattrs ($$) { 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; @@ -3448,8 +3534,8 @@ sub check_gitattrs ($$) { next unless m{(?:^|/)\.gitattributes$}; # oh dear, found one - print STDERR <(), 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, }; @@ -3517,7 +3604,7 @@ sub fork_for_multisuite ($) { 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); @@ -3532,7 +3619,6 @@ sub fork_for_multisuite ($) { fetch_one(); finish 0; }); - # xxx collecte the ref here $csubsuite =~ s/^\Q$cbasesuite\E-/-/; push @csuites, $csubsuite; @@ -3550,9 +3636,9 @@ sub fork_for_multisuite ($) { 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!"), }; } @@ -3591,8 +3677,9 @@ sub fork_for_multisuite ($) { 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"; @@ -3604,9 +3691,10 @@ sub fork_for_multisuite ($) { $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". @@ -3618,15 +3706,15 @@ sub fork_for_multisuite ($) { 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) = @_; @@ -3636,7 +3724,7 @@ sub clone_finish ($) { 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 ($) { @@ -3644,7 +3732,7 @@ 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"; @@ -3661,7 +3749,7 @@ sub clone ($) { 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(); @@ -3672,11 +3760,11 @@ sub clone ($) { 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'}; @@ -3701,13 +3789,13 @@ sub fetch_one () { cfg 'dgit.vcs-git.suites')) { my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF'; if (defined $current && $current ne $vcsgiturl) { - print STDERR <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->error and die $!; + F->error and confess $!; chomp; return ($_, \%options); } @@ -3810,12 +3901,12 @@ sub madformat_wantfixup ($) { 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; } @@ -3823,13 +3914,15 @@ sub madformat_wantfixup ($) { 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_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 ] @@ -3854,17 +3947,19 @@ sub infopair_lrf_tag_lookup ($$) { printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n"; return [ git_rev_parse($tagobj), $what ]; } - fail @tagnames==1 ? <[0], $desc->[0]) or fail <[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward + is_fast_fwd($anc->[0], $desc->[0]) or + fail f_ <[1], $anc->[0], $desc->[1], $desc->[0]; +%s (%s) .. %s (%s) is not fast forward END }; @@ -3873,7 +3968,7 @@ sub pseudomerge_version_check ($$) { 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, @@ -3881,7 +3976,8 @@ sub pseudomerge_version_check ($$) { $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"); @@ -3889,7 +3985,8 @@ sub pseudomerge_version_check ($$) { 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); @@ -3898,12 +3995,13 @@ sub pseudomerge_version_check ($$) { if ($@) { $@ =~ s/^dgit: //gm; fail "$@". - "Perhaps debian/changelog does not mention $v ?"; + f_ "Perhaps debian/changelog does not mention %s ?", $v; } - fail <[0] =~ m/UNRELEASED/; -$cd->[1] is $cd->[0] -Your tree seems to based on earlier (not uploaded) $v. + fail f_ <[1], $cd->[0], $v +%s is %s +Your tree seems to based on earlier (not uploaded) %s. END + if $cd->[0] =~ m/UNRELEASED/; } } @@ -3914,7 +4012,8 @@ END 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; @@ -3929,7 +4028,7 @@ sub pseudomerge_make_commit ($$$$ $$) { # git rev-list --first-parent DTRT. my $pmf = dgit_privdir()."/pseudomerge"; open MC, ">", $pmf or die "$pmf $!"; - print MC <[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"; @@ -3990,25 +4090,25 @@ sub splitbrain_pseudomerge ($$$$) { 1; }) { $@ =~ s/^\n//; chomp $@; - print STDERR <[0]; my $r = pseudomerge_make_commit $clogp, $dgitview, $archive_hash, $i_arch_v, "dgit --quilt=$quilt_mode", - (defined $overwrite_version ? <[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; } @@ -4021,7 +4121,7 @@ sub plain_overwrite_pseudomerge ($$$) { 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, @@ -4029,7 +4129,7 @@ sub plain_overwrite_pseudomerge ($$$) { 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; } @@ -4041,7 +4141,8 @@ sub push_parse_changelog ($) { 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'; @@ -4062,8 +4163,9 @@ sub push_parse_dsc ($$$) { 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 ($$$$) { @@ -4117,13 +4219,13 @@ sub push_mktags ($$ $$ $) { $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'; @@ -4140,8 +4242,8 @@ sub push_mktags ($$ $$ $) { my $head = $tw->{Objid}; my $tag = $tw->{Tag}; - open TO, '>', $tfn->('.tmp') or die $!; - print TO <', $tfn->('.tmp') or confess $!; + print TO <{View} eq 'dgit') { - print TO <{View} eq 'maint') { - print TO <('.tmp'); if ($sign) { @@ -4177,7 +4284,7 @@ END 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'); @@ -4209,7 +4316,7 @@ sub sign_changes ($) { 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 @@ -4219,11 +4326,11 @@ 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 @@ -4247,8 +4354,8 @@ 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); @@ -4261,6 +4368,15 @@ END 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_ <= 4; + confess "internal error (protovsn=$protovsn)" + if defined $protovsn and $protovsn < 4; responder_send_command("param maint-view $maintviewhead"); } @@ -4451,7 +4577,7 @@ END 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 @@ -4464,7 +4590,7 @@ 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 @@ -4481,7 +4607,7 @@ 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 @@ -4498,12 +4624,11 @@ END qw(-c push.followTags=false push), access_giturl(), @pushrefs; 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) { @@ -4516,22 +4641,22 @@ END 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(<&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; @@ -4791,9 +4903,9 @@ sub pre_remote_push_build_host { $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; @@ -4870,7 +4982,8 @@ sub cmd_rpush { 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(); @@ -4906,11 +5019,11 @@ sub i_resp_complete { $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"; + printdebug __ "all done\n"; finish 0; } @@ -4919,7 +5032,7 @@ 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; } @@ -4927,15 +5040,15 @@ sub i_resp_file ($) { 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; } @@ -4952,8 +5065,9 @@ sub i_resp_want ($) { 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; @@ -4961,7 +5075,7 @@ sub i_resp_want ($) { 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); @@ -4996,10 +5110,10 @@ sub i_file_buildinfo { 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; @@ -5040,7 +5154,7 @@ sub i_want_signed_tag { return push_mktags $i_clogp, $i_dscfn, - $i_changesfn, 'remote changes', + $i_changesfn, (__ 'remote changes file'), \@tagwants; } @@ -5066,15 +5180,15 @@ sub quiltify_dpkg_commit ($$$;$) { 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 <{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 <($oldtiptree,'HEAD'); ---quilt=$quilt_mode specified, implying patches-applied git tree + fail +(f_ <($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); @@ -5221,8 +5337,8 @@ END } if ($quilt_mode =~ m/gbp|dpm/ && ($diffbits->{O2A} & 02)) { - fail <{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 <>", "$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 +(__ <>$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 -f -- debian/patches/series), $gipatch; - commit_admin <>' - 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 < 1000000000 +0000 -committer Dgit 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 ($$$$) { @@ -5360,7 +5459,7 @@ 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"; @@ -5378,7 +5477,7 @@ sub quiltify ($$$$) { } 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}; @@ -5387,13 +5486,14 @@ sub quiltify ($$$$) { 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"; @@ -5403,7 +5503,7 @@ sub quiltify ($$$$) { 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} ", @@ -5420,28 +5520,33 @@ sub quiltify ($$$$) { $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 "\n$us: error: 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 history linearisation failed. Search \`quilt fixup' in dgit(7).\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; @@ -5451,12 +5556,14 @@ sub quiltify ($$$$) { 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}; @@ -5490,15 +5597,16 @@ sub quiltify ($$$$) { 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; }; @@ -5526,7 +5634,7 @@ sub quiltify ($$$$) { $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; @@ -5548,7 +5656,7 @@ sub quiltify ($$$$) { for ($index=''; stat "debian/patches/$patchname$index"; $index++) { } - $!==ENOENT or die "$patchname$index $!"; + $!==ENOENT or confess "$patchname$index $!"; runcmd @git, qw(checkout -q), $cc; @@ -5590,7 +5698,7 @@ END if ($quilt_mode eq 'linear' && !$fopts->{'single-debian-patch'} - && branch_is_gdr($symref, $headref)) { + && branch_is_gdr($headref)) { # This is much faster. It also makes patches that gdr # likes better for future updates without laundering. # @@ -5607,7 +5715,10 @@ END if (act_local()) { debugcmd "+",@cmd; $!=0; $?=-1; - failedcmd @cmd if system @cmd and $?!=7*256; + failedcmd @cmd + if system @cmd + and not ($? == 7*256 or + $? == -1 && $!==ENOENT); } else { dryrun_report @cmd; } @@ -5625,28 +5736,28 @@ END 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"; @@ -5656,29 +5767,32 @@ sub quilt_fixup_linkorigs ($$) { 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 <' or die $!; - print $fakedsc <' or confess $!; + print $fakedsc <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); @@ -5732,9 +5846,34 @@ END 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. @@ -5744,8 +5883,9 @@ sub quilt_check_splitbrain_cache ($$) { 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); @@ -5766,39 +5906,23 @@ sub quilt_check_splitbrain_cache ($$) { 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"; - finish 0; - } - exec @cmd; die $!; - } - while () { - 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); @@ -5807,7 +5931,8 @@ sub quilt_check_splitbrain_cache ($$) { 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 @@ -5888,24 +6013,7 @@ sub quilt_fixup_multipatch ($$$) { 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'; - - 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"; + my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion); ensuredir '.pc'; @@ -5913,7 +6021,7 @@ sub quilt_fixup_multipatch ($$$) { $!=0; $?=-1; if (system @bbcmd) { failedcmd @bbcmd if $? < 0; - fail <[1]: $_->[0]\n" + print STDERR f_ "dgit: cannot represent change: %s: %s\n", + $_->[1], $_->[0] foreach @unrepres; - forceable_fail [qw(unrepresentable)], <{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, $oldtiptree, @@ -5997,11 +6115,11 @@ END 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; } @@ -6016,25 +6134,25 @@ END 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 () { 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 () { print O or confess $!; } I1->error and confess $!; my $copying = 0; while () { $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; finish 0; } sub maybe_apply_patches_dirtily () { return unless $quilt_mode =~ m/gbp|unapplied/; - print STDERR <[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"; + progress __ "package seems new, not specifying -v"; } } if ($changes_since_version ne '_') { @@ -6172,28 +6301,11 @@ sub changesopts () { 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: @@ -6204,17 +6316,26 @@ sub massage_dbp_args ($;$) { 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; @@ -6222,92 +6343,105 @@ sub massage_dbp_args ($;$) { 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 < 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; @@ -6331,12 +6465,11 @@ sub cmd_gbp_build { # 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; @@ -6350,7 +6483,7 @@ sub cmd_gbp_build { $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)); @@ -6358,7 +6491,7 @@ sub cmd_gbp_build { 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=". @@ -6374,17 +6507,17 @@ sub cmd_gbp_build { } } - 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; } @@ -6392,77 +6525,164 @@ sub cmd_gbp_build { } 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(<; }; - 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 @@ -6531,13 +6772,13 @@ sub cmd_import_dsc { 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; } } @@ -6545,7 +6786,7 @@ sub cmd_import_dsc { $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(); @@ -6555,7 +6796,8 @@ sub cmd_import_dsc { 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) { @@ -6563,56 +6805,61 @@ sub cmd_import_dsc { "echo $dsc_hash | git cat-file --batch-check"); my $objgot = cmdoutput @cmd; if ($objgot =~ m#^\w+ missing\b#) { - fail < 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 <{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(); @@ -6622,21 +6869,24 @@ END 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 <",@cmd; - exec @cmd or fail "exec curl: $!\n"; + exec @cmd or fail f_ "exec curl: %s\n", $!; } sub repos_server_url () { @@ -6672,53 +6922,56 @@ sub pre_clone_dgit_repos_server () { 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(); } @@ -6726,7 +6979,7 @@ sub cmd_setup_new_tree { #---------- argument parsing and main program ---------- sub cmd_version { - print "dgit version $our_version\n" or die $!; + print "dgit version $our_version\n" or confess $!; finish 0; } @@ -6765,8 +7018,8 @@ defvalopt '', '-C', '.+', sub { 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 ($@) { @@ -6804,11 +7057,11 @@ sub parseopts () { 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') { @@ -6853,9 +7106,9 @@ sub parseopts () { } 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'; @@ -6874,10 +7127,13 @@ sub parseopts () { } 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; @@ -6890,17 +7146,14 @@ sub parseopts () { $_=''; } 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, $_; @@ -6913,7 +7166,7 @@ sub parseopts () { push @ropts, $_; $funcopts_long{$_}(); } else { - badusage "unknown long option \`$_'"; + badusage f_ "unknown long option \`%s'", $_; } } else { while (m/^-./s) { @@ -6966,7 +7219,7 @@ sub parseopts () { $valopt->($oi->{Short}); $_ = ''; } else { - badusage "unknown short option \`$_'"; + badusage f_ "unknown short option \`%s'", $_; } } } @@ -6975,22 +7228,23 @@ sub parseopts () { 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 <[0]; $om->[0] = $v; } @@ -7020,7 +7274,7 @@ sub parseopts_late_defaults () { 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], @@ -7040,7 +7294,7 @@ sub parseopts_late_defaults () { // 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; } @@ -7050,25 +7304,32 @@ sub parseopts_late_defaults () { 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(); @@ -7077,11 +7338,11 @@ if ($ENV{$fakeeditorenv}) { 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 $!; + print STDERR __ $helpmsg or confess $!; finish 8; } $cmd = $subcommand = shift @ARGV; @@ -7094,7 +7355,7 @@ record_maindir if $invoked_in_git_tree; git_slurp_config(); my $fn = ${*::}{"cmd_$cmd"}; -$fn or badusage "unknown operation $cmd"; +$fn or badusage f_ "unknown operation %s", $cmd; $fn->(); finish 0;