use LWP::UserAgent;
use Dpkg::Control::Hash;
use File::Path;
+use File::Spec;
use File::Temp qw(tempdir);
use File::Basename;
use Dpkg::Version;
our $our_version = 'UNRELEASED'; ###substituted###
our $absurdity = undef; ###substituted###
-our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
+our @rpushprotovsn_support = qw(4 5); # 5 drops tag format specification
our $protovsn;
our $cmd;
our $rmchanges;
our $overwrite_version; # undef: not specified; '': check changelog
our $quilt_mode;
-our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
+our $quilt_upstream_commitish;
+our $quilt_upstream_commitish_used;
+our $quilt_upstream_commitish_message;
+our $quilt_options_re = 'gbp|dpm|baredebian(?:\+tarball|\+git)?';
+our $quilt_modes_re = "linear|smash|auto|nofix|nocheck|unapplied|$quilt_options_re";
+our $splitview_mode;
+our $splitview_modes_re = qr{auto|always|never};
our $dodep14tag;
our %internal_object_save;
our $we_are_responder;
our $we_are_initiator;
our $initiator_tempdir;
our $patches_applied_dirtily = 00;
-our $tagformat_want;
-our $tagformat;
-our $tagformatfn;
our $chase_dsc_distro=1;
our %forceopts = map { $_=>0 }
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 $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
+ | (?: git | git-ff ) (?: ,always )?
+ | check (?: ,ignores )?
+ | none
+ )}x;
our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
our $splitbraincache = 'dgit-intern/quilt-cache';
our (@gbp_build) = ('');
our (@gbp_pq) = ('gbp pq');
our (@changesopts) = ('');
-our (@pbuilder) = ("sudo -E pbuilder");
-our (@cowbuilder) = ("sudo -E cowbuilder");
+our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
+our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
'curl' => \@curl,
} keys %opts_opt_map;
sub parseopts_late_defaults();
+sub quiltify_trees_differ ($$;$$$);
sub setup_gitattrs(;$);
sub check_gitattrs($$);
autoflush STDOUT 1;
our $supplementary_message = '';
-our $split_brain = 0;
+our $made_split_brain = 0;
+our $do_split_brain;
+
+# Interactions between quilt mode and split brain
+# (currently, split brain only implemented iff
+# madformat_wantfixup && quiltmode_splitting)
+#
+# source format sane `3.0 (quilt)'
+# madformat_wantfixup()
+#
+# quilt mode normal quiltmode
+# (eg linear) _splitbrain
+#
+# ------------ ------------------------------------------------
+#
+# no split no q cache no q cache forbidden,
+# brain PM on master q fixup on master prevented
+# !do_split_brain() PM on master
+#
+# split brain no q cache q fixup cached, to dgit view
+# PM in dgit view PM in dgit view
+#
+# PM = pseudomerge to make ff, due to overwrite (or split view)
+# "no q cache" = do not record in cache on build, do not check cache
+# `3.0 (quilt)' with --quilt=nocheck is treated as sane format
END {
local ($@, $?);
$absurdity =~ s{/[^/]+$}{/absurd} or die;
}
-sub debiantag ($$) {
- my ($v,$distro) = @_;
- return $tagformatfn->($v, $distro);
-}
-
sub madformat ($) { $_[0] eq '3.0 (quilt)' }
sub lbranch () { return "$branchprefix/$csuite"; }
}
sub no_such_package () {
- print STDERR f_ "%s: package %s does not exist in suite %s\n",
+ print STDERR f_ "%s: source package %s does not exist in suite %s\n",
$us, $package, $isuite;
finish 4;
}
}
}
-sub quiltmode_splitbrain () {
- $quilt_mode =~ m/gbp|dpm|unapplied/;
+sub quiltmode_splitting () {
+ $quilt_mode =~ m/gbp|dpm|unapplied|baredebian/;
+}
+sub format_quiltmode_splitting ($) {
+ my ($format) = @_;
+ return madformat_wantfixup($format) && quiltmode_splitting();
}
+sub do_split_brain () { !!($do_split_brain // confess) }
+
sub opts_opt_multi_cmd {
my $extra = shift;
my @cmd;
printdebug "branch_is_gdr $walk ?-octopus NO\n";
return 0;
}
+ if (!@parents) {
+ printdebug "branch_is_gdr $walk origin\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
return 0;
}
if ($tip_patches eq '' and
- !defined git_cat_file "$walk:debian") {
+ !defined git_cat_file "$walk~:debian" and
+ !quiltify_trees_differ "$walk~", $walk
+ ) {
# (gdr classification of parent: BreakwaterStart
printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
return 1;
# > progress NBYTES
# [NBYTES message]
#
-# > supplementary-message NBYTES # $protovsn >= 3
+# > supplementary-message NBYTES
# [NBYTES message]
#
# main sequence:
#
# > param head DGIT-VIEW-HEAD
# > param csuite SUITE
-# > param tagformat old|new
+# > param tagformat new # $protovsn == 4
# > param maint-view MAINT-VIEW-HEAD
#
# > param buildinfo-filename P_V_X.buildinfo # zero or more times
my $got = read PF, $d, 65536;
die "$ourfn: $!" unless defined $got;
last if !$got;
- print $fh "data-block ".length($d)."\n" or confess $!;
- print $fh $d or confess $!;
+ 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 confess $!;
+ print $fh "data-end\n" or confess "$!";
close PF;
}
} $fh;
last unless $y;
my $d = protocol_read_bytes $fh, $l;
- print PF $d or confess $!;
+ print PF $d or confess "$!";
}
- close PF or confess $!;
+ close PF or confess "$!";
}
#---------- remote protocol support, responder ----------
return unless $we_are_responder;
# called even without $we_are_responder
printdebug ">> $command\n";
- print PO $command, "\n" or confess $!;
+ print PO $command, "\n" or confess "$!";
}
sub responder_send_file ($$) {
sub progress {
if ($we_are_responder) {
my $m = join '', @_;
- responder_send_command "progress ".length($m) or confess $!;
- print PO $m or confess $!;
+ responder_send_command "progress ".length($m) or confess "$!";
+ print PO $m or confess "$!";
} else {
print @_, "\n";
}
}
my $what = $_[$#_];
progress "downloading $what...";
- my $r = $ua->get(@_) or confess $!;
+ my $r = $ua->get(@_) or confess "$!";
return undef if $r->code == 404;
$r->is_success or fail f_ "failed to fetch %s: %s",
$what, $r->status_line;
END
sub badusage {
- print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess $!;
+ print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
finish 8;
}
not_necessarily_a_tree();
}
sub cmd_help () {
- print __ $helpmsg or confess $!;
+ print __ $helpmsg or confess "$!";
finish 0;
}
'dgit.default.archive-query' => 'madison:',
'dgit.default.sshpsql-dbname' => 'service=projectb',
'dgit.default.aptget-components' => 'main',
- 'dgit.default.dgit-tag-format' => 'new,old,maint',
'dgit.default.source-only-uploads' => 'ok',
'dgit.dsc-url-proto-ok.http' => 'true',
'dgit.dsc-url-proto-ok.https' => 'true',
@$l==1 or badcfg
f_ "multiple values for %s (in %s git config)", $c, $src
if @$l > 1;
+ $l->[0] =~ m/\n/ and badcfg f_
+ "value for config option %s (in %s git config) contains newline(s)!",
+ $c, $src;
return $l->[0];
}
return undef;
return $access_forpush;
}
+sub default_from_access_cfg ($$$;$) {
+ my ($var, $keybase, $defval, $permit_re) = @_;
+ return if defined $$var;
+
+ $$var = access_cfg("$keybase-newer", 'RETURN-UNDEF');
+ $$var = undef if $$var && $$var !~ m/^$permit_re$/;
+
+ $$var //= access_cfg($keybase, 'RETURN-UNDEF');
+ $$var //= $defval;
+
+ badcfg f_ "unknown %s \`%s'", $keybase, $$var
+ if defined $permit_re and $$var !~ m/$permit_re/;
+}
+
sub pushing () {
confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
defined $access_forpush and !$access_forpush;
parseopts_late_defaults();
}
+sub determine_whether_split_brain () {
+ my ($format,) = get_source_format();
+
+ {
+ local $access_forpush;
+ default_from_access_cfg(\$splitview_mode, 'split-view', 'auto',
+ $splitview_modes_re);
+ $do_split_brain = 1 if $splitview_mode eq 'always';
+ }
+
+ printdebug "format $format, quilt mode $quilt_mode\n";
+
+ if (format_quiltmode_splitting $format) {
+ $splitview_mode ne 'never' or
+ fail f_ "dgit: quilt mode \`%s' (for format \`%s')".
+ " implies split view, but split-view set to \`%s'",
+ $quilt_mode, $format, $splitview_mode;
+ $do_split_brain = 1;
+ }
+ $do_split_brain //= 0;
+
+ return ($format);
+}
+
sub supplementary_message ($) {
my ($msg) = @_;
if (!$we_are_responder) {
$supplementary_message = $msg;
return;
- } elsif ($protovsn >= 3) {
+ } else {
responder_send_command "supplementary-message ".length($msg)
- or confess $!;
- print PO $msg or confess $!;
+ or confess "$!";
+ print PO $msg or confess "$!";
}
}
}
sub parse_dscdata () {
- my $dscfh = new IO::File \$dscdata, '<' or confess $!;
+ 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;
cfg_apply_map(\$aptsuites, 'suite map',
access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
- open SRCS, ">", "$aptget_base/$sourceslist" or confess $!;
+ open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
printf SRCS "deb-src %s %s %s\n",
access_cfg('mirror'),
$aptsuites,
access_cfg('aptget-components')
- or confess $!;
+ or confess "$!";
ensuredir "$aptget_base/cache";
ensuredir "$aptget_base/lists";
- open CONF, ">", $aptget_configpath or confess $!;
+ open CONF, ">", $aptget_configpath or confess "$!";
print CONF <<END;
Debug::NoLocking "true";
APT::Get::List-Cleanup "false";
Dir::Etc::preferencesparts
)) {
ensuredir "$aptget_base/$key";
- print CONF "$key \"$quoted_base/$key\";\n" or confess $!;
+ print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
};
- my $oldatime = (time // confess $!) - 1;
+ my $oldatime = (time // confess "$!") - 1;
foreach my $oldlist (<$aptget_base/lists/*Release>) {
next unless stat_exists $oldlist;
my ($mtime) = (stat _)[9];
my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
qw(x), $mirror, @$argl);
debugcmd "-|", @cmd;
- open FIA, "-|", @cmd or confess $!;
+ open FIA, "-|", @cmd or confess "$!";
my $r = $fn->();
close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
return $r;
" export LC_MESSAGES=C; export LC_CTYPE=C;".
" ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
debugcmd "|",@cmd;
- open P, "-|", @cmd or confess $!;
+ open P, "-|", @cmd or confess "$!";
while (<P>) {
chomp or die;
printdebug(">|$_|\n");
sub file_in_archive_dummycat () { return undef; }
sub package_not_wholly_new_dummycat () { return undef; }
-#---------- tag format handling ----------
-# (untranslated, because everything should be new tag format by now)
-
-sub access_cfg_tagformats () {
- split /\,/, access_cfg('dgit-tag-format');
-}
-
-sub access_cfg_tagformats_can_splitbrain () {
- my %y = map { $_ => 1 } access_cfg_tagformats;
- foreach my $needtf (qw(new maint)) {
- next if $y{$needtf};
- return 0;
- }
- return 1;
-}
-
-sub need_tagformat ($$) {
- my ($fmt, $why) = @_;
- fail "need to use tag format $fmt ($why) but also need".
- " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
- " - no way to proceed"
- if $tagformat_want && $tagformat_want->[0] ne $fmt;
- $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
-}
-
-sub select_tagformat () {
- # sets $tagformatfn
- return if $tagformatfn && !$tagformat_want;
- die 'bug' if $tagformatfn && $tagformat_want;
- # ... $tagformat_want assigned after previous select_tagformat
-
- my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
- printdebug "select_tagformat supported @supported\n";
-
- $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
- printdebug "select_tagformat specified @$tagformat_want\n";
-
- my ($fmt,$why,$override) = @$tagformat_want;
-
- fail "target distro supports tag formats @supported".
- " but have to use $fmt ($why)"
- unless $override
- or grep { $_ eq $fmt } @supported;
-
- $tagformat_want = undef;
- $tagformat = $fmt;
- $tagformatfn = ${*::}{"debiantag_$fmt"};
-
- fail "trying to use unknown tag format \`$fmt' ($why) !"
- unless $tagformatfn;
-}
-
#---------- archive query entrypoints and rest of program ----------
sub canonicalise_suite () {
my ($what) = @_;
my @gitscmd = qw(find -name .git -prune -print0);
debugcmd "|",@gitscmd;
- open GITS, "-|", @gitscmd or confess $!;
+ open GITS, "-|", @gitscmd or confess "$!";
{
local $/="\0";
while (<GITS>) {
}
}
-sub make_commit ($) {
- my ($file) = @_;
- return cmdoutput @git, qw(hash-object -w -t commit), $file;
-}
-
sub clogp_authline ($) {
my ($clogp) = @_;
my $author = getfield $clogp, 'Maintainer';
__ "(nominal) distro being accessed");
}
-sub generate_commits_from_dsc () {
- # See big comment in fetch_from_archive, below.
- # See also README.dsc-import.
- prep_ud();
- changedir $playground;
+sub check_bpd_exists () {
+ stat $buildproductsdir
+ or fail f_ "build-products-dir %s is not accessible: %s\n",
+ $buildproductsdir, $!;
+}
- my @dfi = dsc_files_info();
- foreach my $fi (@dfi) {
- my $f = $fi->{Filename};
- die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
- my $upper_f = (bpd_abs()."/$f");
+sub dotdot_bpd_transfer_origs ($$$) {
+ my ($bpd_abs, $upstreamversion, $wanted) = @_;
+ # checks is_orig_file_of_vsn and if
+ # calls $wanted->{$leaf} and expects boolish
- printdebug "considering reusing $f: ";
+ return if $buildproductsdir eq '..';
- if (link_ltarget "$upper_f,fetch", $f) {
- printdebug "linked (using ...,fetch).\n";
- } elsif ((printdebug "($!) "),
- $! != ENOENT) {
- fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
- } elsif (link_ltarget $upper_f, $f) {
- printdebug "linked.\n";
- } elsif ((printdebug "($!) "),
- $! != ENOENT) {
- fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
- } else {
- printdebug "absent.\n";
+ my $warned;
+ my $dotdot = $maindir;
+ $dotdot =~ s{/[^/]+$}{};
+ opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
+ while ($!=0, defined(my $leaf = readdir DD)) {
+ {
+ local ($debuglevel) = $debuglevel-1;
+ printdebug "DD_BPD $leaf ?\n";
}
-
- my $refetched;
- complete_file_from_dsc('.', $fi, \$refetched)
- or next;
-
- printdebug "considering saving $f: ";
-
- if (link $f, $upper_f) {
- printdebug "linked.\n";
- } elsif ((printdebug "($!) "),
- $! != EEXIST) {
- 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 f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $!;
+ next unless is_orig_file_of_vsn $leaf, $upstreamversion;
+ next unless $wanted->($leaf);
+ next if lstat "$bpd_abs/$leaf";
+
+ print STDERR f_
+ "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
+ $us
+ unless $warned++;
+ $! == &ENOENT or fail f_
+ "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
+ lstat "$dotdot/$leaf" or fail f_
+ "check orig file %s in ..: %s", $leaf, $!;
+ if (-l _) {
+ stat "$dotdot/$leaf" or fail f_
+ "check target of orig symlink %s in ..: %s", $leaf, $!;
+ my $ltarget = readlink "$dotdot/$leaf" or
+ die "readlink $dotdot/$leaf: $!";
+ if ($ltarget !~ m{^/}) {
+ $ltarget = "$dotdot/$ltarget";
+ }
+ symlink $ltarget, "$bpd_abs/$leaf"
+ or die "$ltarget $bpd_abs $leaf: $!";
+ print STDERR f_
+ "%s: cloned orig symlink from ..: %s\n",
+ $us, $leaf;
+ } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
+ print STDERR f_
+ "%s: hardlinked orig from ..: %s\n",
+ $us, $leaf;
+ } elsif ($! != EXDEV) {
+ fail f_ "failed to make %s a hardlink to %s: %s",
+ "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
} else {
- printdebug "cannot.\n";
+ symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
+ or die "$bpd_abs $dotdot $leaf $!";
+ print STDERR f_
+ "%s: symmlinked orig from .. on other filesystem: %s\n",
+ $us, $leaf;
}
}
+ die "$dotdot; $!" if $!;
+ closedir DD;
+}
+
+sub import_tarball_tartrees ($$) {
+ my ($upstreamv, $dfi) = @_;
+ # cwd should be the playground
# We unpack and record the orig tarballs first, so that we only
# need disk space for one private copy of the unpacked source.
# from the debian/changelog, so we record the tree objects now and
# make them into commits later.
my @tartrees;
- my $upstreamv = upstreamversion $dsc->{version};
my $orig_f_base = srcfn $upstreamv, '';
- foreach my $fi (@dfi) {
+ foreach my $fi (@$dfi) {
# We actually import, and record as a commit, every tarball
# (unless there is only one file, in which case there seems
# little point.
my $f = $fi->{Filename};
printdebug "import considering $f ";
- (printdebug "only one dfi\n"), next if @dfi == 1;
(printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
(printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
my $compr_ext = $1;
$compr_ext, $orig_f_part
), "\n";
+ my $path = $fi->{Path} // $f;
my $input = new IO::File $f, '<' or die "$f $!";
my $compr_pid;
my @compr_cmd;
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, "-|" // confess $!;
+ my $compr_pid = open $compr_fh, "-|" // confess "$!";
if (!$compr_pid) {
- open STDIN, "<&", $input or confess $!;
+ open STDIN, "<&", $input or confess "$!";
exec @compr_cmd;
die "dgit (child): exec $compr_cmd[0]: $!\n";
}
}
rmtree "_unpack-tar";
- mkdir "_unpack-tar" or confess $!;
+ 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 // confess $!;
+ my $tar_pid = fork // confess "$!";
if (!$tar_pid) {
- chdir "_unpack-tar" or confess $!;
- open STDIN, "<&", $input or confess $!;
+ chdir "_unpack-tar" or confess "$!";
+ open STDIN, "<&", $input or confess "$!";
exec @tarcmd;
die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
}
- $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess $!;
+ $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
!$? or failedcmd @tarcmd;
close $input or
(@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
- : confess $!);
+ : confess "$!");
# finally, we have the results in "tarball", but maybe
# with the wrong permissions
Sort => (!$orig_f_part ? 2 :
$orig_f_part =~ m/-/g ? 1 :
0),
+ OrigPart => $orig_f_part, # 'orig', 'orig-XXX', or undef
F => $f,
Tree => $tree,
};
$a->{F} cmp $b->{F}
} @tartrees;
- my $any_orig = grep { $_->{Orig} } @tartrees;
-
- my $dscfn = "$package.dsc";
-
- my $treeimporthow = 'package';
-
- open D, ">", $dscfn or die "$dscfn: $!";
- print D $dscdata or die "$dscfn: $!";
- close D or die "$dscfn: $!";
- my @cmd = qw(dpkg-source);
- push @cmd, '--no-check' if $dsc_checked;
- if (madformat $dsc->{format}) {
- push @cmd, '--skip-patches';
- $treeimporthow = 'unpatched';
- }
- push @cmd, qw(-x --), $dscfn;
- runcmd @cmd;
+ @tartrees;
+}
- my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
- if (madformat $dsc->{format}) {
- check_for_vendor_patches();
- }
+sub import_tarball_commits ($$) {
+ my ($tartrees, $upstreamv) = @_;
+ # cwd should be a playtree which has a relevant debian/changelog
+ # fills in $tt->{Commit} for each one
- my $dappliedtree;
- if (madformat $dsc->{format}) {
- my @pcmd = qw(dpkg-source --before-build .);
- runcmd shell_cmd 'exec >/dev/null', @pcmd;
- rmtree '.pc';
- $dappliedtree = git_add_write_tree();
- }
+ my $any_orig = grep { $_->{Orig} } @$tartrees;
my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
my $clogp;
$changes =~ s/^\n//; # Changes: \n
my $cversion = getfield $clogp, 'Version';
- if (@tartrees) {
+ my $r1authline;
+ if (@$tartrees) {
$r1clogp //= $clogp; # maybe there's only one entry;
- my $r1authline = clogp_authline $r1clogp;
+ $r1authline = clogp_authline $r1clogp;
# Strictly, r1authline might now be wrong if it's going to be
# unused because !$any_orig. Whatever.
printdebug "import tartrees authline $authline\n";
printdebug "import tartrees r1authline $r1authline\n";
- foreach my $tt (@tartrees) {
+ foreach my $tt (@$tartrees) {
printdebug "import tartree $tt->{F} $tt->{Tree}\n";
- my $mbody = f_ "Import %s", $tt->{F};
- $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
+ # untranslated so that different people's imports are identical
+ my $mbody = sprintf "Import %s", $tt->{F};
+ $tt->{Commit} = hash_commit_text($tt->{Orig} ? <<END_O : <<END_T);
tree $tt->{Tree}
author $r1authline
committer $r1authline
}
}
+ return ($authline, $r1authline, $clogp, $changes);
+}
+
+sub generate_commits_from_dsc () {
+ # See big comment in fetch_from_archive, below.
+ # See also README.dsc-import.
+ prep_ud();
+ changedir $playground;
+
+ my $bpd_abs = bpd_abs();
+ my $upstreamv = upstreamversion $dsc->{version};
+ my @dfi = dsc_files_info();
+
+ dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
+ sub { grep { $_->{Filename} eq $_[0] } @dfi };
+
+ foreach my $fi (@dfi) {
+ my $f = $fi->{Filename};
+ die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
+ my $upper_f = "$bpd_abs/$f";
+
+ printdebug "considering reusing $f: ";
+
+ if (link_ltarget "$upper_f,fetch", $f) {
+ printdebug "linked (using ...,fetch).\n";
+ } elsif ((printdebug "($!) "),
+ $! != ENOENT) {
+ fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
+ } elsif (link_ltarget $upper_f, $f) {
+ printdebug "linked.\n";
+ } elsif ((printdebug "($!) "),
+ $! != ENOENT) {
+ fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
+ } else {
+ printdebug "absent.\n";
+ }
+
+ my $refetched;
+ complete_file_from_dsc('.', $fi, \$refetched)
+ or next;
+
+ printdebug "considering saving $f: ";
+
+ if (rename_link_xf 1, $f, $upper_f) {
+ printdebug "linked.\n";
+ } elsif ((printdebug "($@) "),
+ $! != EEXIST) {
+ fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
+ } elsif (!$refetched) {
+ printdebug "no need.\n";
+ } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
+ printdebug "linked (using ...,fetch).\n";
+ } elsif ((printdebug "($@) "),
+ $! != EEXIST) {
+ fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
+ } else {
+ printdebug "cannot.\n";
+ }
+ }
+
+ my @tartrees;
+ @tartrees = import_tarball_tartrees($upstreamv, \@dfi)
+ unless @dfi == 1; # only one file in .dsc
+
+ my $dscfn = "$package.dsc";
+
+ my $treeimporthow = 'package';
+
+ open D, ">", $dscfn or die "$dscfn: $!";
+ print D $dscdata or die "$dscfn: $!";
+ close D or die "$dscfn: $!";
+ my @cmd = qw(dpkg-source);
+ push @cmd, '--no-check' if $dsc_checked;
+ if (madformat $dsc->{format}) {
+ push @cmd, '--skip-patches';
+ $treeimporthow = 'unpatched';
+ }
+ push @cmd, qw(-x --), $dscfn;
+ runcmd @cmd;
+
+ my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
+ if (madformat $dsc->{format}) {
+ check_for_vendor_patches();
+ }
+
+ my $dappliedtree;
+ if (madformat $dsc->{format}) {
+ my @pcmd = qw(dpkg-source --before-build .);
+ runcmd shell_cmd 'exec >/dev/null', @pcmd;
+ rmtree '.pc';
+ $dappliedtree = git_add_write_tree();
+ }
+
+ my ($authline, $r1authline, $clogp, $changes) =
+ import_tarball_commits(\@tartrees, $upstreamv);
+
+ my $cversion = getfield $clogp, 'Version';
+
printdebug "import main commit\n";
- open C, ">../commit.tmp" or confess $!;
- print C <<END or confess $!;
+ open C, ">../commit.tmp" or confess "$!";
+ print C <<END or confess "$!";
tree $tree
END
- print C <<END or confess $! foreach @tartrees;
+ print C <<END or confess "$!" foreach @tartrees;
parent $_->{Commit}
END
- print C <<END or confess $!;
+ print C <<END or confess "$!";
author $authline
committer $authline
[dgit import $treeimporthow $package $cversion]
END
- close C or confess $!;
- my $rawimport_hash = make_commit qw(../commit.tmp);
+ close C or confess "$!";
+ my $rawimport_hash = hash_commit qw(../commit.tmp);
if (madformat $dsc->{format}) {
printdebug "import apply patches...\n";
# regularise the state of the working tree so that
# the checkout of $rawimport_hash works nicely.
- my $dappliedcommit = make_commit_text(<<END);
+ my $dappliedcommit = hash_commit_text(<<END);
tree $dappliedtree
author $authline
committer $authline
progress f_ "%s: trying slow absurd-git-apply...", $us;
rename "../../gbp-pq-output","../../gbp-pq-output.0"
or $!==ENOENT
- or confess $!;
+ or confess "$!";
}
eval {
die "forbid absurd git-apply\n" if $use_absurd
if ($vcmp < 0) {
@output = ($rawimport_mergeinput, $lastpush_mergeinput,
{ ReverseParents => 1,
- Message => (f_ <<END, $package, $cversion, $csuite) });
+ # untranslated so that different people's pseudomerges
+ # are not needlessly different (although they will
+ # still differ if the series of pulls is different)
+ Message => (sprintf <<END, $package, $cversion, $csuite) });
Record %s (%s) in archive suite %s
END
} elsif ($vcmp > 0) {
Last version pushed with dgit: %s (newer or same)
%s
END
- __ $later_warning_msg or confess $!;
+ __ $later_warning_msg or confess "$!";
@output = $lastpush_mergeinput;
} else {
# Same version. Use what's in the server git branch,
open F, "<", "$tf" or die "$tf: $!";
$fi->{Digester}->reset();
$fi->{Digester}->addfile(*F);
- F->error and confess $!;
+ F->error and confess "$!";
$got = $fi->{Digester}->hexdigest();
return $got eq $fi->{Hash};
};
debugcmd "|",@lcmd;
my %wantr;
- open GITLS, "-|", @lcmd or confess $!;
+ open GITLS, "-|", @lcmd or confess "$!";
while (<GITLS>) {
printdebug "=> ", $_;
m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
# deliberately-not-ff, in which case we must fetch everything.
my @specs = deliberately_not_fast_forward ? qw(tags/*) :
- map { "tags/$_" }
- (quiltmode_splitbrain
- ? (map { $_->('*',access_nomdistro) }
- \&debiantag_new, \&debiantag_maintview)
- : debiantags('*',access_nomdistro));
+ map { "tags/$_" } debiantags('*',access_nomdistro);
push @specs, server_branch($csuite);
push @specs, $rewritemap;
push @specs, qw(heads/*) if deliberately_not_fast_forward;
}
sub fetch_from_archive () {
+ check_bpd_exists();
ensure_setup_existing_tree();
# Ensures that lrref() is what is actually in the archive, one way
printdebug "del_lrfetchrefs: $objid $fullrefname\n";
if (!$gur) {
$gur ||= new IO::Handle;
- open $gur, "|-", qw(git update-ref --stdin) or confess $!;
+ open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
}
printf $gur "delete %s %s\n", $fullrefname, $objid;
}
Last version pushed with dgit: %s
%s
END
- __ $later_warning_msg or confess $!;
+ __ $later_warning_msg or confess "$!";
@mergeinputs = ($lastpush_mergeinput);
} else {
# Archive has .dsc which is not a descendant of the last dgit
Package not found in the archive, but has allegedly been pushed using dgit.
%s
END
- __ $later_warning_msg or confess $!;
+ __ $later_warning_msg or confess "$!";
} else {
printdebug "nothing found!\n";
if (defined $skew_warning_vsn) {
- print STDERR f_ <<END, $skew_warning_vsn or confess $!;
+ print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
Warning: relevant archive skew detected.
Archive allegedly contains %s
my $mcf = dgit_privdir()."/mergecommit";
open MC, ">", $mcf or die "$mcf $!";
- print MC <<END or confess $!;
+ print MC <<END or confess "$!";
tree $tree
END
my @parents = grep { $_->{Commit} } @mergeinputs;
@parents = reverse @parents if $compat_info->{ReverseParents};
- print MC <<END or confess $! foreach @parents;
+ print MC <<END or confess "$!" foreach @parents;
parent $_->{Commit}
END
- print MC <<END or confess $!;
+ print MC <<END or confess "$!";
author $author
committer $author
END
if (defined $compat_info->{Message}) {
- print MC $compat_info->{Message} or confess $!;
+ print MC $compat_info->{Message} or confess "$!";
} else {
- print MC f_ <<END, $package, $cversion, $csuite or confess $!;
+ print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
Record %s (%s) in archive suite %s
Record that
my ($mi) = (@_);
my $mversion = mergeinfo_version $mi;
printf MC " %-20s %s\n", $mversion, $mi->{Info}
- or confess $!;
+ or confess "$!";
};
$message_add_info->($mergeinputs[0]);
- print MC __ <<END or confess $!;
+ print MC __ <<END or confess "$!";
should be treated as descended from
END
$message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
}
- close MC or confess $!;
- $hash = make_commit $mcf;
+ close MC or confess "$!";
+ $hash = hash_commit $mcf;
} else {
$hash = $mergeinputs[0]{Commit};
}
my $got_vsn = getfield $gotclogp, 'Version';
printdebug "SKEW CHECK GOT $got_vsn\n";
if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
- print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess $!;
+ print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
Warning: archive skew detected. Using the available version:
Archive allegedly contains %s
while (<ATTRS>) {
chomp;
next if m{^debian/changelog\s};
- print NATTRS $_, "\n" or confess $!;
+ print NATTRS $_, "\n" or confess "$!";
}
- ATTRS->error and confess $!;
+ ATTRS->error and confess "$!";
close ATTRS;
}
- print NATTRS "debian/changelog merge=$driver\n" or confess $!;
+ print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
close NATTRS;
set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
printdebug "is_gitattrs_setup: found old macro\n";
return 0;
}
- $gai->error and confess $!;
+ $gai->error and confess "$!";
printdebug "is_gitattrs_setup: found nothing\n";
return undef;
}
my $af = "$maindir_gitcommon/info/attributes";
ensuredir "$maindir_gitcommon/info";
- open GAO, "> $af.new" or confess $!;
- print GAO <<END, __ <<ENDT or confess $! unless defined $already;
+ open GAO, "> $af.new" or confess "$!";
+ print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
* dgit-defuse-attrs
$new
END
$_ = $new;
}
chomp;
- print GAO $_, "\n" or confess $!;
+ print GAO $_, "\n" or confess "$!";
}
- $gai->error and confess $!;
+ $gai->error and confess "$!";
}
- close GAO or confess $!;
+ close GAO or confess "$!";
rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
}
my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
debugcmd "|",@cmd;
my $gafl = new IO::File;
- open $gafl, "-|", @cmd or confess $!;
+ open $gafl, "-|", @cmd or confess "$!";
while (<$gafl>) {
chomp or die;
s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
# in child, sets things up, calls $fn->(), and returns undef
# in parent, returns canonical suite name for $tsuite
my $canonsuitefh = IO::File::new_tmpfile;
- my $pid = fork // confess $!;
+ my $pid = fork // confess "$!";
if (!$pid) {
forkcheck_setup();
$isuite = $tsuite;
$debugprefix .= " ";
progress f_ "fetching %s...", $tsuite;
canonicalise_suite();
- print $canonsuitefh $csuite, "\n" or confess $!;
- close $canonsuitefh or confess $!;
+ print $canonsuitefh $csuite, "\n" or confess "$!";
+ close $canonsuitefh or confess "$!";
$fn->();
return undef;
}
- waitpid $pid,0 == $pid or confess $!;
+ waitpid $pid,0 == $pid or confess "$!";
fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
if $? && $?!=256*4;
- seek $canonsuitefh,0,0 or confess $!;
+ seek $canonsuitefh,0,0 or confess "$!";
local $csuite = <$canonsuitefh>;
- confess $! unless defined $csuite && chomp $csuite;
+ confess "$!" unless defined $csuite && chomp $csuite;
if ($? == 256*4) {
printdebug "multisuite $tsuite missing\n";
return $csuite;
$commit .=
"author $authline\n".
"committer $authline\n\n";
- $output = make_commit_text $commit.$msg;
+ $output = hash_commit_text $commit.$msg;
printdebug "multisuite merge generated $output\n";
}
}
sub clone_set_head () {
- open H, "> .git/HEAD" or confess $!;
- print H "ref: ".lref()."\n" or confess $!;
- close H or confess $!;
+ open H, "> .git/HEAD" or confess "$!";
+ print H "ref: ".lref()."\n" or confess "$!";
+ close H or confess "$!";
}
sub clone_finish ($) {
my ($dstdir) = @_;
}
printdebug "clone main body\n";
- canonicalise_suite();
- my $hasgit = check_for_git();
mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
changedir $dstdir;
+ check_bpd_exists();
+
+ canonicalise_suite();
+ my $hasgit = check_for_git();
+
runcmd @git, qw(init -q);
record_maindir();
setup_new_tree();
}
sub check_not_dirty () {
- foreach my $f (qw(local-options local-patch-header)) {
- if (stat_exists "debian/source/$f") {
- fail f_ "git tree contains debian/source/%s", $f;
+ my @forbid = qw(local-options local-patch-header);
+ @forbid = map { "debian/source/$_" } @forbid;
+ foreach my $f (@forbid) {
+ if (stat_exists $f) {
+ fail f_ "git tree contains %s", $f;
}
}
+ my @cmd = (@git, qw(status -uall --ignored --porcelain));
+ push @cmd, qw(debian/source/format debian/source/options);
+ push @cmd, @forbid;
+
+ my $bad = cmdoutput @cmd;
+ if (length $bad) {
+ fail +(__
+ "you have uncommitted changes to critical files, cannot continue:\n").
+ $bad;
+ }
+
return if $includedirty;
git_check_unmodified();
$options{$_} = 1;
}
}
- F->error and confess $!;
+ F->error and confess "$!";
close F;
} else {
- confess $! unless $!==&ENOENT;
+ confess "$!" unless $!==&ENOENT;
}
if (!open F, "debian/source/format") {
- confess $! unless $!==&ENOENT;
+ confess "$!" unless $!==&ENOENT;
return '';
}
$_ = <F>;
- F->error and confess $!;
+ F->error and confess "$!";
chomp;
return ($_, \%options);
}
$cd = $gf->('Distribution');
};
if ($@) {
+ $@ =~ s/^\n//s;
$@ =~ s/^dgit: //gm;
fail "$@".
f_ "Perhaps debian/changelog does not mention %s ?", $v;
return $i_arch_v;
}
-sub pseudomerge_make_commit ($$$$ $$) {
+sub pseudomerge_hash_commit ($$$$ $$) {
my ($clogp, $dgitview, $archive_hash, $i_arch_v,
$msg_cmd, $msg_msg) = @_;
- progress f_ "Declaring that HEAD inciudes all changes in %s...",
+ progress f_ "Declaring that HEAD includes all changes in %s...",
$i_arch_v->[0];
my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
# git rev-list --first-parent DTRT.
my $pmf = dgit_privdir()."/pseudomerge";
open MC, ">", $pmf or die "$pmf $!";
- print MC <<END or confess $!;
+ print MC <<END or confess "$!";
tree $tree
parent $dgitview
parent $archive_hash
[$msg_cmd]
END
- close MC or confess $!;
+ close MC or confess "$!";
- return make_commit($pmf);
+ return hash_commit($pmf);
}
sub splitbrain_pseudomerge ($$$$) {
my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
if (!defined $overwrite_version) {
- progress __ "Checking that HEAD inciudes all changes in archive...";
+ progress __ "Checking that HEAD includes all changes in archive...";
}
return $dgitview if is_fast_fwd $archive_hash, $dgitview;
}
my $arch_v = $i_arch_v->[0];
- my $r = pseudomerge_make_commit
+ my $r = pseudomerge_hash_commit
$clogp, $dgitview, $archive_hash, $i_arch_v,
"dgit --quilt=$quilt_mode",
(defined $overwrite_version
my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
- my $r = pseudomerge_make_commit
+ my $r = pseudomerge_hash_commit
$clogp, $head, $archive_hash, $i_arch_v,
"dgit", $m;
if (!$we_are_initiator) {
# rpush initiator can't do this because it doesn't have $isuite yet
- my $tag = debiantag($cversion, access_nomdistro);
+ my $tag = debiantag_new($cversion, access_nomdistro);
runcmd @git, qw(check-ref-format), $tag;
}
my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
my @tagwants;
push @tagwants, {
- TagFn => \&debiantag,
+ TagFn => \&debiantag_new,
Objid => $dgithead,
TfSuffix => '',
View => 'dgit',
TfSuffix => '-maintview',
View => 'maint',
};
- } elsif ($dodep14tag eq 'no' ? 0
- : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
- : $dodep14tag eq 'always'
- ? (access_cfg_tagformats_can_splitbrain or fail <<END)
---dep14tag-always (or equivalent in config) means server must support
- both "new" and "maint" tag formats, but config says it doesn't.
-END
- : die "$dodep14tag ?") {
+ } elsif ($dodep14tag ne 'no') {
push @tagwants, {
TagFn => \&debiantag_maintview,
Objid => $dgithead,
$dsc->{$ourdscfield[0]} = join " ",
$tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
$reader_giturl;
- $dsc->save("$dscfn.tmp") or confess $!;
+ $dsc->save("$dscfn.tmp") or confess "$!";
my $changes = parsecontrol($changesfile,$changesfilewhat);
foreach my $field (qw(Source Distribution Version)) {
# We make the git tag by hand because (a) that makes it easier
# to control the "tagger" (b) we can do remote signing
my $authline = clogp_authline $clogp;
- my $delibs = join(" ", "",@deliberatelies);
+ my @dtxinfo = @deliberatelies;
my $mktag = sub {
my ($tw) = @_;
my $head = $tw->{Objid};
my $tag = $tw->{Tag};
- open TO, '>', $tfn->('.tmp') or confess $!;
- print TO <<END or confess $!;
+ open TO, '>', $tfn->('.tmp') or confess "$!";
+ print TO <<END or confess "$!";
object $head
type commit
tag $tag
print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
%s release %s for %s (%s) [dgit]
ENDT
- or confess $!;
- print TO <<END or confess $!;
-[dgit distro=$declaredistro$delibs]
+ or confess "$!";
+ my $dtxinfo = join(" ", "",@dtxinfo);
+ print TO <<END or confess "$!";
+[dgit distro=$declaredistro$dtxinfo]
END
foreach my $ref (sort keys %previously) {
- print TO <<END or confess $!;
+ print TO <<END or confess "$!";
[dgit previously:$ref=$previously{$ref}]
END
}
(maintainer view tag generated by dgit --quilt=%s)
END
$quilt_mode
- or confess $!;
+ or confess "$!";
} else {
confess Dumper($tw)."?";
}
- close TO or confess $!;
+ close TO or confess "$!";
my $tagobjfn = $tfn->('.tmp');
if ($sign) {
if (!defined $keyid) {
$keyid = getfield $clogp, 'Maintainer';
}
- unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess $!;
+ 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');
You can retry the push, after fixing the problem, if you like.
END
- need_tagformat 'new', "quilt mode $quilt_mode"
- if quiltmode_splitbrain;
-
prep_ud();
access_giturl(); # check that success is vaguely likely
rpush_handle_protovsn_bothends() if $we_are_initiator;
- select_tagformat();
my $clogpfn = dgit_privdir()."/changelog.822.tmp";
runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
push_parse_dsc($dscpath, $dscfn, $cversion);
my $format = getfield $dsc, 'Format';
- printdebug "format $format\n";
my $symref = git_get_symref();
my $actualhead = git_rev_parse('HEAD');
if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
- if (quiltmode_splitbrain()) {
+ if (quiltmode_splitting()) {
my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
fail f_ <<END, $ffq_prev, $quilt_mode;
Branch is managed by git-debrebase (%s
if (madformat_wantfixup($format)) {
# user might have not used dgit build, so maybe do this now:
- if (quiltmode_splitbrain()) {
+ if (do_split_brain()) {
changedir $playground;
- quilt_make_fake_dsc($upstreamversion);
my $cachekey;
($dgithead, $cachekey) =
quilt_check_splitbrain_cache($actualhead, $upstreamversion);
"--quilt=%s but no cached dgit view:
perhaps HEAD changed since dgit build[-source] ?",
$quilt_mode;
- $split_brain = 1;
- $dgithead = splitbrain_pseudomerge($clogp,
- $actualhead, $dgithead,
- $archive_hash);
- $maintviewhead = $actualhead;
- changedir $maindir;
- prep_ud(); # so _only_subdir() works, below
- } else {
+ }
+ if (!do_split_brain()) {
+ # In split brain mode, do not attempt to incorporate dirty
+ # stuff from the user's working tree. That would be mad.
commit_quilty_patch();
}
}
+ if (do_split_brain()) {
+ $made_split_brain = 1;
+ $dgithead = splitbrain_pseudomerge($clogp,
+ $actualhead, $dgithead,
+ $archive_hash);
+ $maintviewhead = $actualhead;
+ changedir $maindir;
+ prep_ud(); # so _only_subdir() works, below
+ }
if (defined $overwrite_version && !defined $maintviewhead
&& $archive_hash) {
}
}
+ confess unless !!$made_split_brain == do_split_brain();
+
changedir $playground;
progress f_ "checking that %s corresponds to HEAD", $dscfn;
runcmd qw(dpkg-source -x --),
my $r = system @diffcmd;
if ($r) {
if ($r==256) {
- my $referent = $split_brain ? $dgithead : 'HEAD';
+ my $referent = $made_split_brain ? $dgithead : 'HEAD';
my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
my @mode_changes;
if ($sourceonlypolicy eq 'ok') {
} elsif ($sourceonlypolicy eq 'always') {
forceable_fail [qw(uploading-binaries)],
- __ "uploading binaries, although distroy policy is source only"
+ __ "uploading binaries, although distro policy is source only"
if $hasdebs;
} elsif ($sourceonlypolicy eq 'never') {
forceable_fail [qw(uploading-source-only)],
- __ "source-only upload, although distroy policy requires .debs"
+ __ "source-only upload, although distro policy requires .debs"
if !$hasdebs;
} elsif ($sourceonlypolicy eq 'not-wholly-new') {
forceable_fail [qw(uploading-source-only)],
responder_send_command("param head $dgithead");
responder_send_command("param csuite $csuite");
responder_send_command("param isuite $isuite");
- responder_send_command("param tagformat $tagformat");
+ responder_send_command("param tagformat new"); # needed in $protovsn==4
if (defined $maintviewhead) {
- confess "internal error (protovsn=$protovsn)"
- if defined $protovsn and $protovsn < 4;
responder_send_command("param maint-view $maintviewhead");
}
sub cmd_pull {
parseopts();
fetchpullargs();
- if (quiltmode_splitbrain()) {
+ determine_whether_split_brain();
+ if (do_split_brain()) {
my ($format, $fopts) = get_source_format();
madformat($format) and fail f_ <<END, $quilt_mode
-dgit pull not yet supported in split view mode (--quilt=%s)
+dgit pull not yet supported in split view mode (including with view-splitting quilt modes)
END
}
pull();
parseopts();
build_or_push_prep_early();
pushing();
+ build_or_push_prep_modes();
check_not_dirty();
my $specsuite;
if (@ARGV==0) {
$we_are_responder = 1;
$us .= " (build host)";
- open PI, "<&STDIN" or confess $!;
- open STDIN, "/dev/null" or confess $!;
- open PO, ">&STDOUT" or confess $!;
+ open PI, "<&STDIN" or confess "$!";
+ open STDIN, "/dev/null" or confess "$!";
+ open PO, ">&STDOUT" or confess "$!";
autoflush PO 1;
- open STDOUT, ">&STDERR" or confess $!;
+ open STDOUT, ">&STDERR" or confess "$!";
autoflush STDOUT 1;
$vsnwant //= 1;
# a good error message)
sub rpush_handle_protovsn_bothends () {
- if ($protovsn < 4) {
- need_tagformat 'old', "rpush negotiated protocol $protovsn";
- }
- select_tagformat();
}
our $i_tmp;
changedir $i_tmp;
($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
- $supplementary_message = '' unless $protovsn >= 3;
for (;;) {
my ($icmd,$iargs) = initiator_expect {
$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;
- confess $! unless $got == $pid;
+ confess "$!" unless $got == $pid;
fail f_ "build host child failed: %s", waitstatusmsg() if $?;
i_cleanup();
pushing();
rpush_handle_protovsn_bothends();
- 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;
printdebug "[[ $keyword @localpaths\n";
foreach my $localpath (@localpaths) {
protocol_send_file \*RI, $localpath;
}
- print RI "files-end\n" or confess $!;
+ print RI "files-end\n" or confess "$!";
}
our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
my $maintview = $i_param{'maint-view'};
die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
- select_tagformat();
- if ($protovsn >= 4) {
+ if ($protovsn == 4) {
my $p = $i_param{'tagformat'} // '<undef>';
- $p eq $tagformat
- or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
+ $p eq 'new'
+ or badproto \*RO, "tag format mismatch: $p vs. new";
}
die unless $i_param{'csuite'} =~ m/^$suite_re$/;
my $descfn = ".git/dgit/quilt-description.tmp";
open O, '>', $descfn or confess "$descfn: $!";
$msg =~ s/\n+/\n\n/;
- print O <<END or confess $!;
+ print O <<END or confess "$!";
From: $author
${xinfo}Subject: $msg
---
END
- close O or confess $!;
+ close O or confess "$!";
{
local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
return $r;
}
-sub quiltify_splitbrain_needed () {
- if (!$split_brain) {
- progress __ "dgit view: changes are required...";
- runcmd @git, qw(checkout -q -b dgit-view);
- $split_brain = 1;
- }
-}
-
-sub quiltify_splitbrain ($$$$$$$) {
+sub quiltify_splitting ($$$$$$$) {
my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
$editedignores, $cachekey) = @_;
my $gitignore_special = 1;
- if ($quilt_mode !~ m/gbp|dpm/) {
+ if ($quilt_mode !~ m/gbp|dpm|baredebian/) {
# treat .gitignore just like any other upstream file
$diffbits = { %$diffbits };
$_ = !!$_ foreach values %$diffbits;
local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
local $ENV{GIT_AUTHOR_DATE} = $authline[2];
+ confess unless do_split_brain();
+
my $fulldiffhint = sub {
my ($x,$y) = @_;
my $cmd = "git diff $x $y -- :/ ':!debian'";
$cmd;
};
- if ($quilt_mode =~ m/gbp|unapplied/ &&
+ if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
($diffbits->{O2H} & 01)) {
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") {
+ if (!stat_exists "debian/patches" and $quilt_mode !~ m/baredebian/) {
$msg .= __
"\n ... debian/patches is missing; perhaps this is a patch queue branch?";
}
but git tree differs from result of applying debian/patches to upstream
END
}
- if ($quilt_mode =~ m/gbp|unapplied/ &&
+ if ($quilt_mode =~ m/baredebian/) {
+ # We need to construct a merge which has upstream files from
+ # upstream and debian/ files from HEAD.
+
+ read_tree_upstream $quilt_upstream_commitish, 1, $headref;
+ my $version = getfield $clogp, 'Version';
+ my $upsversion = upstreamversion $version;
+ my $merge = make_commit
+ [ $headref, $quilt_upstream_commitish ],
+ [ +(f_ <<ENDT, $upsversion), $quilt_upstream_commitish_message, <<ENDU ];
+Combine debian/ with upstream source for %s
+ENDT
+[dgit ($our_version) baredebian-merge $version $quilt_upstream_commitish_used]
+ENDU
+ runcmd @git, qw(reset -q --hard), $merge;
+ }
+ if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
($diffbits->{O2A} & 01)) { # some patches
- quiltify_splitbrain_needed();
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
}
if (($diffbits->{O2H} & 02) && # user has modified .gitignore
!($diffbits->{O2A} & 02)) { # patches do not change .gitignore
- quiltify_splitbrain_needed();
progress __
"dgit view: creating patch to represent .gitignore changes";
ensuredir "debian/patches";
close GIPATCH or die "$gipatch: $!";
runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
$unapplied, $headref, "--", sort keys %$editedignores;
- open SERIES, "+>>", "debian/patches/series" or confess $!;
- defined seek SERIES, -1, 2 or $!==EINVAL or confess $!;
+ open SERIES, "+>>", "debian/patches/series" or confess "$!";
+ defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
my $newline;
- defined read SERIES, $newline, 1 or confess $!;
- print SERIES "\n" or confess $! unless $newline eq "\n";
- print SERIES "auto-gitignore\n" or confess $!;
+ 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 +(__ <<END).<<ENDU
[dgit ($our_version) update-gitignore-quilt-fixup]
ENDU
}
-
- my $dgitview = git_rev_parse 'HEAD';
-
- changedir $maindir;
- reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
-
- changedir "$playground/work";
-
- my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
- progress f_ "dgit view: created (%s)", $saved;
}
sub quiltify ($$$$) {
printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
my @cmd= (@git, qw(diff-tree -r --name-only),
- $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
+ $p->{Commit},$c->{Commit},
+ qw(-- debian/patches .pc debian/source/format));
my $patchstackchange = cmdoutput @cmd;
if (length $patchstackchange) {
$patchstackchange =~ s/\n/,/g;
runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
}
-
- runcmd @git, qw(checkout -q master);
}
sub build_maybe_quilt_fixup () {
check_for_vendor_patches();
- if (quiltmode_splitbrain) {
- fail <<END unless access_cfg_tagformats_can_splitbrain;
-quilt mode $quilt_mode requires split view so server needs to support
- both "new" and "maint" tag formats, but config says it doesn't.
-END
- }
-
my $clogp = parsechangelog();
my $headref = git_rev_parse('HEAD');
my $symref = git_get_symref();
-
- if ($quilt_mode eq 'linear'
- && !$fopts->{'single-debian-patch'}
- && branch_is_gdr($headref)) {
- # This is much faster. It also makes patches that gdr
- # likes better for future updates without laundering.
- #
- # However, it can fail in some casses where we would
- # succeed: if there are existing patches, which correspond
- # to a prefix of the branch, but are not in gbp/gdr
- # format, gdr will fail (exiting status 7), but we might
- # be able to figure out where to start linearising. That
- # will be slower so hopefully there's not much to do.
- my @cmd = (@git_debrebase,
- qw(--noop-ok -funclean-mixed -funclean-ordering
- make-patches --quiet-would-amend));
- # We tolerate soe snags that gdr wouldn't, by default.
- if (act_local()) {
- debugcmd "+",@cmd;
- $!=0; $?=-1;
- failedcmd @cmd if system @cmd and $?!=7*256;
- } else {
- dryrun_report @cmd;
- }
- $headref = git_rev_parse('HEAD');
- }
+ my $upstreamversion = upstreamversion $version;
prep_ud();
changedir $playground;
- my $upstreamversion = upstreamversion $version;
+ my $splitbrain_cachekey;
+
+ if (do_split_brain()) {
+ my $cachehit;
+ ($cachehit, $splitbrain_cachekey) =
+ quilt_check_splitbrain_cache($headref, $upstreamversion);
+ if ($cachehit) {
+ changedir $maindir;
+ return;
+ }
+ }
+
+ unpack_playtree_need_cd_work($headref);
+ if (do_split_brain()) {
+ runcmd @git, qw(checkout -q -b dgit-view);
+ # so long as work is not deleted, its current branch will
+ # remain dgit-view, rather than master, so subsequent calls to
+ # unpack_playtree_need_cd_work
+ # will DTRT, resetting dgit-view.
+ confess if $made_split_brain;
+ $made_split_brain = 1;
+ }
+ chdir '..';
if ($fopts->{'single-debian-patch'}) {
+ fail f_
+ "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
+ $quilt_mode
+ if quiltmode_splitting();
quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
} else {
- quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
+ quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
+ $splitbrain_cachekey);
+ }
+
+ if (do_split_brain()) {
+ my $dgitview = git_rev_parse 'HEAD';
+
+ changedir $maindir;
+ reflog_cache_insert "refs/$splitbraincache",
+ $splitbrain_cachekey, $dgitview;
+
+ changedir "$playground/work";
+
+ my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
+ progress f_ "dgit view: created (%s)", $saved;
}
changedir $maindir;
@git, qw(pull --ff-only -q), "$playground/work", qw(master);
}
-sub unpack_playtree_mkwork ($) {
+sub build_check_quilt_splitbrain () {
+ build_maybe_quilt_fixup();
+}
+
+sub unpack_playtree_need_cd_work ($) {
my ($headref) = @_;
- mkdir "work" or confess $!;
- changedir "work";
- mktree_in_ud_here();
+ # prep_ud() must have been called already.
+ if (!chdir "work") {
+ # Check in the filesystem because sometimes we run prep_ud
+ # in between multiple calls to unpack_playtree_need_cd_work.
+ confess "$!" unless $!==ENOENT;
+ mkdir "work" or confess "$!";
+ changedir "work";
+ mktree_in_ud_here();
+ }
runcmd @git, qw(reset -q --hard), $headref;
}
# calls $fn->($leafname);
my $bpd_abs = bpd_abs();
+
+ dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
+
opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
- while ($!=0, defined(my $b = readdir QFD)) {
- my $f = bpd_abs()."/".$b;
+ while ($!=0, defined(my $leaf = readdir QFD)) {
+ my $f = bpd_abs()."/".$leaf;
{
local ($debuglevel) = $debuglevel-1;
- printdebug "QF linkorigs $b, $f ?\n";
+ printdebug "QF linkorigs bpd $leaf, $f ?\n";
}
- next unless is_orig_file_of_vsn $b, $upstreamversion;
- printdebug "QF linkorigs $b, $f Y\n";
- link_ltarget $f, $b or die "$b $!";
- $fn->($b);
+ next unless is_orig_file_of_vsn $leaf, $upstreamversion;
+ printdebug "QF linkorigs $leaf, $f Y\n";
+ link_ltarget $f, $leaf or die "$leaf $!";
+ $fn->($leaf);
}
die "$buildproductsdir: $!" if $!;
closedir QFD;
# necessary to build the source package.
unpack_playtree_linkorigs($upstreamversion, sub { });
- unpack_playtree_mkwork($headref);
+ unpack_playtree_need_cd_work($headref);
rmtree("debian/patches");
changedir "..";
runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
rename srcfn("$upstreamversion", "/debian/patches"),
- "work/debian/patches";
+ "work/debian/patches"
+ or $!==ENOENT
+ or confess "install d/patches: $!";
changedir "work";
commit_quilty_patch();
}
-sub quilt_make_fake_dsc ($) {
+sub quilt_need_fake_dsc ($) {
+ # cwd should be playground
my ($upstreamversion) = @_;
+ return if stat_exists "fake.dsc";
+ # ^ OK to test this as a sentinel because if we created it
+ # we must either have done the rest too, or crashed.
+
my $fakeversion="$upstreamversion-~~DGITFAKE";
- my $fakedsc=new IO::File 'fake.dsc', '>' or confess $!;
- print $fakedsc <<END or confess $!;
+ my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
+ print $fakedsc <<END or confess "$!";
Format: 3.0 (quilt)
Source: $package
Version: $fakeversion
END
my $dscaddfile=sub {
- my ($b) = @_;
+ my ($leaf) = @_;
my $md = new Digest::MD5;
- my $fh = new IO::File $b, '<' or die "$b $!";
- stat $fh or confess $!;
+ my $fh = new IO::File $leaf, '<' or die "$leaf $!";
+ stat $fh or confess "$!";
my $size = -s _;
$md->addfile($fh);
- print $fakedsc " ".$md->hexdigest." $size $b\n" or confess $!;
+ print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
};
unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
$dscaddfile->($debtar);
- close $fakedsc or confess $!;
+ close $fakedsc or confess "$!";
}
sub quilt_fakedsc2unapplied ($$) {
my ($headref, $upstreamversion) = @_;
# must be run in the playground
- # quilt_make_fake_dsc must have been called
+ # quilt_need_fake_dsc must have been called
+ quilt_need_fake_dsc($upstreamversion);
runcmd qw(sh -ec),
'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
# Computes the cache key and looks in the cache.
# Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
+ quilt_need_fake_dsc($upstreamversion);
+
my $splitbrain_cachekey;
progress f_
push @cachekey, $upstreamversion;
push @cachekey, $quilt_mode;
push @cachekey, $headref;
+ push @cachekey, $quilt_upstream_commitish // '-';
push @cachekey, hashfile('fake.dsc');
"refs/$splitbraincache", $splitbrain_cachekey;
if ($cachehit) {
- unpack_playtree_mkwork($headref);
+ unpack_playtree_need_cd_work($headref);
my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
if ($cachehit ne $headref) {
progress f_ "dgit view: found cached (%s)", $saved;
runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
- $split_brain = 1;
+ $made_split_brain = 1;
return ($cachehit, $splitbrain_cachekey);
}
progress __ "dgit view: found cached, no changes required";
return (undef, $splitbrain_cachekey);
}
+sub baredebian_origtarballs_scan ($$$) {
+ my ($fakedfi, $upstreamversion, $dir) = @_;
+ if (!opendir OD, $dir) {
+ return if $! == ENOENT;
+ fail "opendir $dir (origs): $!";
+ }
+
+ while ($!=0, defined(my $leaf = readdir OD)) {
+ {
+ local ($debuglevel) = $debuglevel-1;
+ printdebug "BDOS $dir $leaf ?\n";
+ }
+ next unless is_orig_file_of_vsn $leaf, $upstreamversion;
+ next if grep { $_->{Filename} eq $leaf } @$fakedfi;
+ push @$fakedfi, {
+ Filename => $leaf,
+ Path => "$dir/$leaf",
+ };
+ }
+
+ die "$dir; $!" if $!;
+ closedir OD;
+}
+
sub quilt_fixup_multipatch ($$$) {
- my ($clogp, $headref, $upstreamversion) = @_;
+ my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
progress f_ "examining quilt state (multiple patches, %s mode)",
$quilt_mode;
# afterwards with dpkg-source --before-build. That lets us save a
# tree object corresponding to .origs.
- my $splitbrain_cachekey;
+ if ($quilt_mode eq 'linear'
+ && branch_is_gdr($headref)) {
+ # This is much faster. It also makes patches that gdr
+ # likes better for future updates without laundering.
+ #
+ # However, it can fail in some casses where we would
+ # succeed: if there are existing patches, which correspond
+ # to a prefix of the branch, but are not in gbp/gdr
+ # format, gdr will fail (exiting status 7), but we might
+ # be able to figure out where to start linearising. That
+ # will be slower so hopefully there's not much to do.
- quilt_make_fake_dsc($upstreamversion);
+ unpack_playtree_need_cd_work $headref;
- if (quiltmode_splitbrain()) {
- my $cachehit;
- ($cachehit, $splitbrain_cachekey) =
- quilt_check_splitbrain_cache($headref, $upstreamversion);
- return if $cachehit;
+ my @cmd = (@git_debrebase,
+ qw(--noop-ok -funclean-mixed -funclean-ordering
+ make-patches --quiet-would-amend));
+ # We tolerate soe snags that gdr wouldn't, by default.
+ if (act_local()) {
+ debugcmd "+",@cmd;
+ $!=0; $?=-1;
+ failedcmd @cmd
+ if system @cmd
+ and not ($? == 7*256 or
+ $? == -1 && $!==ENOENT);
+ } else {
+ dryrun_report @cmd;
+ }
+ $headref = git_rev_parse('HEAD');
+
+ chdir '..';
}
+
my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
ensuredir '.pc';
changedir '..';
- unpack_playtree_mkwork($headref);
+ unpack_playtree_need_cd_work($headref);
my $mustdeletepc=0;
if (stat_exists ".pc") {
progress __ "Tree already contains .pc - will use it then delete it.";
$mustdeletepc=1;
} else {
- rename '../fake/.pc','.pc' or confess $!;
+ rename '../fake/.pc','.pc' or confess "$!";
}
changedir '../fake';
# We calculate some guesswork now about what kind of tree this might
# be. This is mostly for error reporting.
+ my $tentries = cmdoutput @git, qw(ls-tree --name-only -z), $headref;
+ my $onlydebian = $tentries eq "debian\0";
+
+ my $uheadref = $headref;
+ my $uhead_whatshort = 'HEAD';
+
+ if ($quilt_mode =~ m/baredebian\+tarball/) {
+ # We need to make a tarball import. Yuk.
+ # We want to do this here so that we have a $uheadref value
+
+ my @fakedfi;
+ baredebian_origtarballs_scan \@fakedfi, $upstreamversion, bpd_abs();
+ baredebian_origtarballs_scan \@fakedfi, $upstreamversion,
+ "$maindir/.." unless $buildproductsdir eq '..';
+ changedir '..';
+
+ my @tartrees = import_tarball_tartrees $upstreamversion, \@fakedfi;
+
+ fail __ "baredebian quilt fixup: could not find any origs"
+ unless @tartrees;
+
+ changedir 'work';
+ my ($authline, $r1authline, $clogp,) =
+ import_tarball_commits \@tartrees, $upstreamversion;
+
+ if (@tartrees == 1) {
+ $uheadref = $tartrees[0]{Commit};
+ # TRANSLATORS: this translation must fit in the ASCII art
+ # quilt differences display. The untranslated display
+ # says %9.9s, so with that display it must be at most 9
+ # characters.
+ $uhead_whatshort = __ 'tarball';
+ } else {
+ # on .dsc import we do not make a separate commit, but
+ # here we need to do so
+ rm_subdir_cached '.';
+ my $parents;
+ foreach my $ti (@tartrees) {
+ my $c = $ti->{Commit};
+ if ($ti->{OrigPart} eq 'orig') {
+ runcmd qw(git read-tree), $c;
+ } elsif ($ti->{OrigPart} =~ m/orig-/) {
+ read_tree_subdir $', $c;
+ } else {
+ confess "$ti->OrigPart} ?"
+ }
+ $parents .= "parent $c\n";
+ }
+ my $tree = git_write_tree();
+ my $mbody = f_ 'Combine orig tarballs for %s %s',
+ $package, $upstreamversion;
+ $uheadref = hash_commit_text <<END;
+tree $tree
+${parents}author $r1authline
+committer $r1authline
+
+$mbody
+
+[dgit import tarballs combine $package $upstreamversion]
+END
+ # TRANSLATORS: this translation must fit in the ASCII art
+ # quilt differences display. The untranslated display
+ # says %9.9s, so with that display it must be at most 9
+ # characters. This fragmentt is referring to multiple
+ # orig tarballs in a source package.
+ $uhead_whatshort = __ 'tarballs';
+
+ runcmd @git, qw(reset -q);
+ }
+ $quilt_upstream_commitish = $uheadref;
+ $quilt_upstream_commitish_used = '*orig*';
+ $quilt_upstream_commitish_message = '';
+ }
+ if ($quilt_mode =~ m/baredebian$/) {
+ $uheadref = $quilt_upstream_commitish;
+ # TRANSLATORS: this translation must fit in the ASCII art
+ # quilt differences display. The untranslated display
+ # says %9.9s, so with that display it must be at most 9
+ # characters.
+ $uhead_whatshort = __ 'upstream';
+ }
+
my %editedignores;
my @unrepres;
my $diffbits = {
# H = user's HEAD
# O = orig, without patches applied
# A = "applied", ie orig with H's debian/patches applied
- O2H => quiltify_trees_differ($unapplied,$headref, 1,
+ O2H => quiltify_trees_differ($unapplied,$uheadref, 1,
\%editedignores, \@unrepres),
- H2A => quiltify_trees_differ($headref, $oldtiptree,1),
+ H2A => quiltify_trees_differ($uheadref, $oldtiptree,1),
O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
};
my @dl;
- foreach my $b (qw(01 02)) {
+ foreach my $bits (qw(01 02)) {
foreach my $v (qw(O2H O2A H2A)) {
- push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
+ push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
}
}
printdebug "differences \@dl @dl.\n";
progress f_
"%s: base trees orig=%.20s o+d/p=%.20s",
$us, $unapplied, $oldtiptree;
+ # TRANSLATORS: Try to keep this ascii-art layout right. The 0s in
+ # %9.00009s will be ignored and are there to make the format the
+ # same length (9 characters) as the output it generates. If you
+ # change the value 9, your translations of "upstream" and
+ # 'tarball' must fit into the new length, and you should change
+ # the number of 0s. Do not reduce it below 4 as HEAD has to fit
+ # too.
progress f_
"%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
-"%s: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
+"%s: quilt differences: %9.00009s %s o+d/p %9.00009s %s o+d/p",
$us, $dl[0], $dl[1], $dl[3], $dl[4],
- $us, $dl[2], $dl[5];
+ $us, $uhead_whatshort, $dl[2], $uhead_whatshort, $dl[5];
- if (@unrepres) {
+ if (@unrepres && $quilt_mode !~ m/baredebian/) {
+ # With baredebian, even if the upstream commitish has this
+ # problem, we don't want to print this message, as nothing
+ # is going to try to make a patch out of it anyway.
print STDERR f_ "dgit: cannot represent change: %s: %s\n",
$_->[1], $_->[0]
foreach @unrepres;
}
my @failsuggestion;
- if (!($diffbits->{O2H} & $diffbits->{O2A})) {
+ if ($onlydebian) {
+ push @failsuggestion, [ 'onlydebian', __
+ "This has only a debian/ directory; you probably want --quilt=bare debian." ]
+ unless $quilt_mode =~ m/baredebian/;
+ } elsif (!($diffbits->{O2H} & $diffbits->{O2A})) {
push @failsuggestion, [ 'unapplied', __
"This might be a patches-unapplied branch." ];
} elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
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,
- $diffbits, \%editedignores,
- $splitbrain_cachekey);
+ "Maybe orig tarball(s) are not identical to git representation?" ]
+ unless $onlydebian && $quilt_mode !~ m/baredebian/;
+ # ^ in that case, we didn't really look properly
+
+ if (quiltmode_splitting()) {
+ quiltify_splitting($clogp, $unapplied, $headref, $oldtiptree,
+ $diffbits, \%editedignores,
+ $splitbrain_cachekey);
return;
}
progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
+ runcmd @git, qw(checkout -q), (qw(master dgit-view)[do_split_brain()]);
if (!open P, '>>', ".pc/applied-patches") {
- $!==&ENOENT or confess $!;
+ $!==&ENOENT or confess "$!";
} else {
close P;
}
open I2, '<', $editing or confess "$editing: $!";
unlink $editing or confess "$editing: $!";
open O, '>', $editing or confess "$editing: $!";
- while (<I1>) { print O or confess $!; } I1->error and confess $!;
+ while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
my $copying = 0;
while (<I2>) {
$copying ||= m/^\-\-\- /;
next unless $copying;
- print O or confess $!;
+ print O or confess "$!";
}
- I2->error and confess $!;
+ 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 <<END or confess $!;
+ return unless $quilt_mode =~ m/gbp|unapplied|baredebian/;
+ print STDERR __ <<END or confess "$!";
dgit: Building, or cleaning with rules target, in patches-unapplied tree.
dgit: Have to apply the patches - making the tree dirty.
}
sub maybe_unapply_patches_again () {
- progress "dgit: Unapplying patches again to tidy up the tree."
+ progress __ "dgit: Unapplying patches again to tidy up the tree."
if $patches_applied_dirtily;
runcmd qw(dpkg-source --after-build .)
if $patches_applied_dirtily & 01;
#----- other building -----
-our $clean_using_builder;
-# ^ tree is to be cleaned by dpkg-source's builtin idea that it should
-# clean the tree before building (perhaps invoked indirectly by
-# whatever we are using to run the build), rather than separately
-# and explicitly by us.
+sub clean_tree_check_git ($$$) {
+ my ($honour_ignores, $message, $ignmessage) = @_;
+ my @cmd = (@git, qw(clean -dn));
+ push @cmd, qw(-x) unless $honour_ignores;
+ my $leftovers = cmdoutput @cmd;
+ if (length $leftovers) {
+ print STDERR $leftovers, "\n" or confess "$!";
+ $message .= $ignmessage if $honour_ignores;
+ fail $message;
+ }
+}
+
+sub clean_tree_check_git_wd ($) {
+ my ($message) = @_;
+ return if $cleanmode =~ m{no-check};
+ return if $patches_applied_dirtily; # yuk
+ clean_tree_check_git +($cleanmode !~ m{all-check}),
+ $message, "\n".__ <<END;
+If this is just missing .gitignore entries, use a different clean
+mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
+or --clean=git (-wg/-wgf) to use \`git clean' instead.
+END
+}
+
+sub clean_tree_check () {
+ # This function needs to not care about modified but tracked files.
+ # That was done by check_not_dirty, and by now we may have run
+ # the rules clean target which might modify tracked files (!)
+ if ($cleanmode =~ m{^check}) {
+ clean_tree_check_git +($cleanmode =~ m{ignores}), __
+ "tree contains uncommitted files and --clean=check specified", '';
+ } elsif ($cleanmode =~ m{^dpkg-source}) {
+ clean_tree_check_git_wd __
+ "tree contains uncommitted files (NB dgit didn't run rules clean)";
+ } elsif ($cleanmode =~ m{^git}) {
+ clean_tree_check_git 1, __
+ "tree contains uncommited, untracked, unignored files\n".
+ "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
+ } elsif ($cleanmode eq 'none') {
+ } else {
+ confess "$cleanmode ?";
+ }
+}
sub clean_tree () {
- return if $clean_using_builder;
- if ($cleanmode eq 'dpkg-source') {
- maybe_apply_patches_dirtily();
- runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
- } elsif ($cleanmode eq 'dpkg-source-d') {
+ # We always clean the tree ourselves, rather than leave it to the
+ # builder (dpkg-source, or soemthing which calls dpkg-source).
+ if ($quilt_mode =~ m/baredebian/ and $cleanmode =~ m/git/) {
+ fail f_ <<END, $quilt_mode, $cleanmode;
+quilt mode %s (generally needs untracked upstream files)
+contradicts clean mode %s (which would delete them)
+END
+ # This is not 100% true: dgit build-source and push-source
+ # (for example) could operate just fine with no upstream
+ # source in the working tree. But it doesn't seem likely that
+ # the user wants dgit to proactively delete such things.
+ # -wn, for example, would produce identical output without
+ # deleting anything from the working tree.
+ }
+ if ($cleanmode =~ m{^dpkg-source}) {
+ my @cmd = @dpkgbuildpackage;
+ push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
+ push @cmd, qw(-T clean);
maybe_apply_patches_dirtily();
- runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
- } elsif ($cleanmode eq 'git') {
+ runcmd_ordryrun_local @cmd;
+ clean_tree_check_git_wd __
+ "tree contains uncommitted files (after running rules clean)";
+ } elsif ($cleanmode =~ m{^git(?!-)}) {
runcmd_ordryrun_local @git, qw(clean -xdf);
- } elsif ($cleanmode eq 'git-ff') {
+ } elsif ($cleanmode =~ m{^git-ff}) {
runcmd_ordryrun_local @git, qw(clean -xdff);
- } elsif ($cleanmode eq 'check') {
- my $leftovers = cmdoutput @git, qw(clean -xdn);
- if (length $leftovers) {
- print STDERR $leftovers, "\n" or confess $!;
- fail "tree contains uncommitted files and --clean=check specified";
- }
+ } elsif ($cleanmode =~ m{^check}) {
+ clean_tree_check();
} elsif ($cleanmode eq 'none') {
} else {
- die "$cleanmode ?";
+ confess "$cleanmode ?";
}
}
sub cmd_clean () {
- badusage "clean takes no additional arguments" if @ARGV;
+ badusage __ "clean takes no additional arguments" if @ARGV;
notpushing();
clean_tree();
maybe_unapply_patches_again();
sub build_or_push_prep_early () {
our $build_or_push_prep_early_done //= 0;
return if $build_or_push_prep_early_done++;
- badusage "-p is not allowed with dgit $subcommand" if defined $package;
+ badusage f_ "-p is not allowed with dgit %s", $subcommand
+ if defined $package;
my $clogp = parsechangelog();
$isuite = getfield $clogp, 'Distribution';
$package = getfield $clogp, 'Source';
$dscfn = dscfn($version);
}
+sub build_or_push_prep_modes () {
+ my ($format,) = determine_whether_split_brain();
+
+ fail __ "dgit: --include-dirty is not supported with split view".
+ " (including with view-splitting quilt modes)"
+ if do_split_brain() && $includedirty;
+
+ if (madformat_wantfixup $format and $quilt_mode =~ m/baredebian$/) {
+ ($quilt_upstream_commitish, $quilt_upstream_commitish_used,
+ $quilt_upstream_commitish_message)
+ = resolve_upstream_version
+ $quilt_upstream_commitish, upstreamversion $version;
+ progress f_ "dgit: --quilt=%s, %s", $quilt_mode,
+ $quilt_upstream_commitish_message;
+ } elsif (defined $quilt_upstream_commitish) {
+ fail __
+ "dgit: --upstream-commitish only makes sense with --quilt=baredebian"
+ }
+}
+
sub build_prep_early () {
build_or_push_prep_early();
notpushing();
+ build_or_push_prep_modes();
check_not_dirty();
}
sub build_prep ($) {
my ($wantsrc) = @_;
build_prep_early();
- # clean the tree if we're trying to include dirty changes in the
- # source package, or we are running the builder in $maindir
- clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
- build_maybe_quilt_fixup();
+ check_bpd_exists();
+ if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
+ # Clean the tree because we're going to use the contents of
+ # $maindir. (We trying to include dirty changes in the source
+ # package, or we are running the builder in $maindir.)
+ || $cleanmode =~ m{always}) {
+ # Or because the user asked us to.
+ clean_tree();
+ } else {
+ # We don't actually need to do anything in $maindir, but we
+ # should do some kind of cleanliness check because (i) the
+ # user may have forgotten a `git add', and (ii) if the user
+ # said -wc we should still do the check.
+ clean_tree_check();
+ }
+ build_check_quilt_splitbrain();
if ($rmchanges) {
my $pat = changespat $version;
foreach my $f (glob "$buildproductsdir/$pat") {
if (act_local()) {
- unlink $f or fail "remove old changes file $f: $!";
+ unlink $f or
+ fail f_ "remove old changes file %s: %s", $f, $!;
} else {
- progress "would remove $f";
+ progress f_ "would remove %s", $f;
}
}
}
1;
}) {
print STDERR $@;
- fail
+ fail __
"archive query failed (queried because --since-version not specified)";
}
if (@vsns) {
@vsns = map { $_->[0] } @vsns;
@vsns = sort { -version_compare($a, $b) } @vsns;
$changes_since_version = $vsns[0];
- progress "changelog will contain changes since $vsns[0]";
+ progress f_ "changelog will contain changes since %s", $vsns[0];
} else {
$changes_since_version = '_';
- progress "package seems new, not specifying -v<version>";
+ progress __ "package seems new, not specifying -v<version>";
}
}
if ($changes_since_version ne '_') {
$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;
+ fail __ "Wanted to build nothing!" unless $r;
$dmode = '--build='. join ',', grep m/./, @d;
} else {
$r =
$dmode =~ m/[S]/ ? WANTSRC_SOURCE :
$dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
$dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
- die "$dmode ?";
+ confess "$dmode ?";
}
printdebug "massage done $r $dmode.\n";
push @$cmd, $dmode;
} @changesfiles;
my $result;
if (@changesfiles==1) {
- fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
-only one changes file from build (@changesfiles)
+ fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
+only one changes file from build (%s)
END
+ if defined $msg_if_onlyone;
$result = $changesfiles[0];
} elsif (@changesfiles==2) {
my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
foreach my $l (split /\n/, getfield $binchanges, 'Files') {
- fail "$l found in binaries changes file $binchanges"
+ fail f_ "%s found in binaries changes file %s", $l, $binchanges
if $l =~ m/\.dsc$/;
}
runcmd_ordryrun_local @mergechanges, @changesfiles;
my $multichanges = changespat $version,'multi';
if (act_local()) {
- stat_exists $multichanges or fail "$multichanges: $!";
+ stat_exists $multichanges or fail f_
+ "%s unexpectedly not created by build", $multichanges;
foreach my $cf (glob $pat) {
next if $cf eq $multichanges;
- rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
+ rename "$cf", "$cf.inmulti" or fail f_
+ "install new changes %s\{,.inmulti}: %s", $cf, $!;
}
}
$result = $multichanges;
} else {
- fail "wrong number of different changes files (@changesfiles)";
+ fail f_ "wrong number of different changes files (%s)",
+ "@changesfiles";
}
- printdone "build successful, results in $result\n" or confess $!;
+ printdone f_ "build successful, results in %s\n", $result
+ or confess "$!";
}
sub midbuild_checkchanges () {
$_ ne changespat $version,'source' and
$_ ne changespat $version,'multi'
} @unwanted;
- fail <<END
-changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
-Suggest you delete @unwanted.
+ fail +(f_ <<END, $pat, "@unwanted")
+changes files other than source matching %s already present; building would result in ambiguity about the intended results.
+Suggest you delete %s.
END
if @unwanted;
}
postbuild_mergechanges(undef);
};
} else {
- printdone "build successful\n";
+ printdone __ "build successful\n";
}
}
sub cmd_build {
build_prep_early();
- $buildproductsdir eq '..' or print STDERR <<END;
-$us: warning: build-products-dir set, but not supported by dpkg-buildpackage
-$us: warning: build-products-dir will be ignored; files will go to ..
+ $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
+%s: warning: build-products-dir set, but not supported by dpkg-buildpackage
+%s: warning: build-products-dir will be ignored; files will go to ..
END
$buildproductsdir = '..';
my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
if ($gbp_make_orig) {
my $priv = dgit_privdir();
my $ok = "$priv/origs-gen-ok";
- unlink $ok or $!==&ENOENT or confess $!;
+ unlink $ok or $!==&ENOENT or confess "$!";
my @origs_cmd = @cmd;
push @origs_cmd, qw(--git-cleaner=true);
push @origs_cmd, "--git-prebuild=".
build_source();
midbuild_checkchanges_vanilla $wantsrc;
} else {
- if (!$clean_using_builder) {
- push @cmd, '--git-cleaner=true';
- }
+ push @cmd, '--git-cleaner=true';
}
maybe_unapply_patches_again();
if ($wantsrc & WANTSRC_BUILDER) {
#
# 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
+ # that makes quilt fixup too hard. I.e. ($made_split_brain && (dgit is
# building a source package)) => !$includedirty
return !$includedirty;
}
$sourcechanges = changespat $version,'source';
if (act_local()) {
unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
- or fail "remove $sourcechanges: $!";
+ or fail f_ "remove %s: %s", $sourcechanges, $!;
}
+# confess unless !!$made_split_brain == do_split_brain();
+
my @cmd = (@dpkgsource, qw(-b --));
my $leafdir;
if (building_source_in_playtree()) {
# 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;
+ prep_ud() unless $made_split_brain;
changedir $playground;
- unless ($split_brain) {
+ unless ($made_split_brain) {
my $upstreamversion = upstreamversion $version;
unpack_playtree_linkorigs($upstreamversion, sub { });
- unpack_playtree_mkwork($headref);
+ unpack_playtree_need_cd_work($headref);
changedir '..';
}
} else {
$leafdir = basename $maindir;
+
+ if ($buildproductsdir ne '..') {
+ # Well, we are going to run dpkg-source -b which consumes
+ # origs from .. and generates output there. To make this
+ # work when the bpd is not .. , we would have to (i) link
+ # origs from bpd to .. , (ii) check for files that
+ # dpkg-source -b would/might overwrite, and afterwards
+ # (iii) move all the outputs back to the bpd (iv) except
+ # for the origs which should be deleted from .. if they
+ # weren't there beforehand. And if there is an error and
+ # we don't run to completion we would necessarily leave a
+ # mess. This is too much. The real way to fix this
+ # is for dpkg-source to have bpd support.
+ confess unless $includedirty;
+ fail __
+ "--include-dirty not supported with --build-products-dir, sorry";
+ }
+
changedir '..';
}
runcmd_ordryrun_local @cmd, $leafdir;
my $mv = sub {
my ($why, $l) = @_;
printdebug " renaming ($why) $l\n";
- rename "$l", bpd_abs()."/$l"
- or fail "put in place new built file ($l): $!";
+ rename_link_xf 0, "$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;
}
sub cmd_build_source {
- 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_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();
+ fail __
+ "dgit push-source: --include-dirty/--ignore-dirty does not make".
+ "sense with push-source!"
+ if $includedirty;
+ build_check_quilt_splitbrain();
if ($changesfile) {
my $changes = parsecontrol("$buildproductsdir/$changesfile",
- "source changes file");
+ __ "source changes file");
unless (test_source_only_changes($changes)) {
- fail "user-specified changes file is not source-only";
+ fail __ "user-specified changes file is not source-only";
}
} else {
# Building a source package is very fast, so just do it
build_source();
- die "er, patches are applied dirtily but shouldn't be.."
+ confess "er, patches are applied dirtily but shouldn't be.."
if $patches_applied_dirtily;
$changesfile = $sourcechanges;
}
midbuild_checkchanges();
in_bpd {
if (act_local()) {
- stat_exists $dscfn or fail "$dscfn (in build products dir): $!";
- stat_exists $sourcechanges
- or fail "$sourcechanges (in build products dir): $!";
+ 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 @$bbuilder, @args;
};
sub cmd_sbuild {
build_prep_early();
- binary_builder(\@sbuild, <<END, qw(-d), $isuite, @ARGV, $dscfn);
+ binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
perhaps you need to pass -A ? (sbuild's default is to build only
arch-specific binaries; dgit 1.4 used to override that.)
END
# @ARGV is allowed to contain only things that should be passed to
# pbuilder under debbuildopts; just massage those
my $wantsrc = massage_dbp_args \@ARGV;
- fail "you asked for a builder but your debbuildopts didn't ask for".
- " any binaries -- is this really what you meant?"
- unless $wantsrc & WANTSRC_BUILDER;
- fail "we must build a .dsc to pass to the builder but your debbuiltopts".
- " forbids the building of a source package; cannot continue"
+ fail __
+ "you asked for a builder but your debbuildopts didn't ask for".
+ " any binaries -- is this really what you meant?"
+ unless $wantsrc & WANTSRC_BUILDER;
+ fail __
+ "we must build a .dsc to pass to the builder but your debbuiltopts".
+ " forbids the building of a source package; cannot continue"
unless $wantsrc & WANTSRC_SOURCE;
# We do not want to include the verb "build" in @pbuilder because
# the user can customise @pbuilder and they shouldn't be required
}
sub cmd_print_unapplied_treeish {
- badusage "incorrect arguments to dgit print-unapplied-treeish" if @ARGV;
+ badusage __ "incorrect arguments to dgit print-unapplied-treeish"
+ if @ARGV;
my $headref = git_rev_parse('HEAD');
my $clogp = commit_getclogp $headref;
$package = getfield $clogp, 'Source';
prep_ud();
changedir $playground;
my $uv = upstreamversion $version;
- quilt_make_fake_dsc($uv);
my $u = quilt_fakedsc2unapplied($headref, $uv);
- print $u, "\n" or confess $!;
+ print $u, "\n" or confess "$!";
}
sub import_dsc_result {
my ($dstref, $newhash, $what_log, $what_msg) = @_;
my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
runcmd @cmd;
- check_gitattrs($newhash, "source tree");
+ check_gitattrs($newhash, __ "source tree");
- progress "dgit: import-dsc: $what_msg";
+ progress f_ "dgit: import-dsc: %s", $what_msg;
}
sub cmd_import_dsc {
if (m/^--require-valid-signature$/) {
$needsig = 1;
} else {
- badusage "unknown dgit import-dsc sub-option \`$_'";
+ badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
}
}
- badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
+ badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
+ unless @ARGV==2;
my ($dscfn, $dstbranch) = @ARGV;
- badusage "dry run makes no sense with import-dsc" unless act_local();
+ badusage __ "dry run makes no sense with import-dsc"
+ unless act_local();
my $force = $dstbranch =~ s/^\+// ? +1 :
$dstbranch =~ s/^\.\.// ? -1 :
my $chead = cmdoutput_errok @symcmd;
defined $chead or $?==256 or failedcmd @symcmd;
- fail "$dstbranch is checked out - will not update it"
+ fail f_ "%s is checked out - will not update it", $dstbranch
if defined $chead and $chead eq $dstbranch;
my $oldhash = git_get_ref $dstbranch;
- open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
+ open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
$dscdata = do { local $/ = undef; <D>; };
- D->error and fail "read $dscfn: $!";
+ D->error and fail f_ "read %s: %s", $dscfn, $!;
close C;
# we don't normally need this so import it here
local $SIG{__WARN__} = sub {
print STDERR $_[0];
return unless $needsig;
- fail "import-dsc signature check failed";
+ fail __ "import-dsc signature check failed";
};
if (!$dp->is_signed()) {
- warn "$us: warning: importing unsigned .dsc\n";
+ warn f_ "%s: warning: importing unsigned .dsc\n", $us;
} else {
my $r = $dp->check_signature();
- die "->check_signature => $r" if $needsig && $r;
+ confess "->check_signature => $r" if $needsig && $r;
}
}
$package = getfield $dsc, 'Source';
- parse_dsc_field($dsc, "Dgit metadata in .dsc")
+ parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
unless forceing [qw(import-dsc-with-dgit-field)];
parse_dsc_field_def_dsc_distro();
notpushing();
if (defined $dsc_hash) {
- progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
+ progress __
+ "dgit: import-dsc of .dsc with Dgit field, using git hash";
resolve_dsc_field_commit undef, undef;
}
if (defined $dsc_hash) {
"echo $dsc_hash | git cat-file --batch-check");
my $objgot = cmdoutput @cmd;
if ($objgot =~ m#^\w+ missing\b#) {
- fail <<END
-.dsc contains Dgit field referring to object $dsc_hash
+ fail f_ <<END, $dsc_hash
+.dsc contains Dgit field referring to object %s
Your git tree does not have that object. Try `git fetch' from a
-plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
+plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
END
}
if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
if ($force > 0) {
- progress "Not fast forward, forced update.";
+ progress __ "Not fast forward, forced update.";
} else {
- fail "Not fast forward to $dsc_hash";
+ fail f_ "Not fast forward to %s", $dsc_hash;
}
}
import_dsc_result $dstbranch, $dsc_hash,
"dgit import-dsc (Dgit): $info",
- "updated git ref $dstbranch";
+ f_ "updated git ref %s", $dstbranch;
return 0;
}
- fail <<END
-Branch $dstbranch already exists
-Specify ..$specbranch for a pseudo-merge, binding in existing history
-Specify +$specbranch to overwrite, discarding existing history
+ fail f_ <<END, $dstbranch, $specbranch, $specbranch
+Branch %s already exists
+Specify ..%s for a pseudo-merge, binding in existing history
+Specify +%s to overwrite, discarding existing history
END
if $oldhash && !$force;
my @dfi = dsc_files_info();
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
+ # We transfer all the pieces of the dsc to the bpd, not just
+ # origs. This is by analogy with dgit fetch, which wants to
+ # keep them somewhere to avoid downloading them again.
+ # We make symlinks, though. If the user wants copies, then
+ # they can copy the parts of the dsc to the bpd using dcmd,
+ # or something.
my $here = "$buildproductsdir/$f";
if (lstat $here) {
- next if stat $here;
- fail "lstat $here works but stat gives $! !";
+ if (stat $here) {
+ next;
+ }
+ fail f_ "lstat %s works but stat gives %s !", $here, $!;
}
- fail "stat $here: $!" unless $! == ENOENT;
+ fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
+ printdebug "not in bpd, $f ...\n";
+ # $f does not exist in bpd, we need to transfer it
my $there = $dscfn;
- if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
- $there = $';
- } elsif ($dscfn =~ m#^/#) {
- $there = $dscfn;
+ $there =~ s{[^/]+$}{$f} or confess "$there ?";
+ # $there is file we want, relative to user's cwd, or abs
+ printdebug "not in bpd, $f, test $there ...\n";
+ stat $there or fail f_
+ "import %s requires %s, but: %s", $dscfn, $there, $!;
+ if ($there =~ m#^(?:\./+)?\.\./+#) {
+ # $there is relative to user's cwd
+ my $there_from_parent = $';
+ if ($buildproductsdir !~ m{^/}) {
+ # abs2rel, despite its name, can take two relative paths
+ $there = File::Spec->abs2rel($there,$buildproductsdir);
+ # now $there is relative to bpd, great
+ printdebug "not in bpd, $f, abs2rel, $there ...\n";
+ } else {
+ $there = (dirname $maindir)."/$there_from_parent";
+ # now $there is absoute
+ printdebug "not in bpd, $f, rel2rel, $there ...\n";
+ }
+ } elsif ($there =~ m#^/#) {
+ # $there is absolute already
+ printdebug "not in bpd, $f, abs, $there ...\n";
} 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 .= "/$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";
+ symlink $there, $here or fail f_
+ "symlink %s to %s: %s", $there, $here, $!;
+ progress f_ "made symlink %s -> %s", $here, $there;
# print STDERR Dumper($fi);
}
my @mergeinputs = generate_commits_from_dsc();
if ($oldhash) {
if ($force > 0) {
- progress "Import, forced update - synthetic orphan git history.";
+ progress __
+ "Import, forced update - synthetic orphan git history.";
} elsif ($force < 0) {
- progress "Import, merging.";
+ progress __ "Import, merging.";
my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
my $version = getfield $dsc, 'Version';
my $clogp = commit_getclogp $newhash;
my $authline = clogp_authline $clogp;
- $newhash = make_commit_text <<END;
+ $newhash = hash_commit_text <<ENDU
tree $tree
parent $newhash
parent $oldhash
author $authline
committer $authline
-Merge $package ($version) import into $dstbranch
+ENDU
+ .(f_ <<END, $package, $version, $dstbranch);
+Merge %s (%s) import into %s
END
} else {
die; # caught earlier
import_dsc_result $dstbranch, $newhash,
"dgit import-dsc: $info",
- "results are in in git ref $dstbranch";
+ f_ "results are in git ref %s", $dstbranch;
}
sub pre_archive_api_query () {
not_necessarily_a_tree();
}
sub cmd_archive_api_query {
- badusage "need only 1 subpath argument" unless @ARGV==1;
+ badusage __ "need only 1 subpath argument" unless @ARGV==1;
my ($subpath) = @ARGV;
local $isuite = 'DGIT-API-QUERY-CMD';
my @cmd = archive_api_query_cmd($subpath);
push @cmd, qw(-f);
debugcmd ">",@cmd;
- exec @cmd or fail "exec curl: $!\n";
+ exec @cmd or fail f_ "exec curl: %s\n", $!;
}
sub repos_server_url () {
not_necessarily_a_tree();
}
sub cmd_clone_dgit_repos_server {
- badusage "need destination argument" unless @ARGV==1;
+ badusage __ "need destination argument" unless @ARGV==1;
my ($destdir) = @ARGV;
my $url = repos_server_url();
my @cmd = (@git, qw(clone), $url, $destdir);
debugcmd ">",@cmd;
- exec @cmd or fail "exec git clone: $!\n";
+ exec @cmd or fail f_ "exec git clone: %s\n", $!;
}
sub pre_print_dgit_repos_server_source_url () {
not_necessarily_a_tree();
}
sub cmd_print_dgit_repos_server_source_url {
- badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
+ badusage __
+ "no arguments allowed to dgit print-dgit-repos-server-source-url"
if @ARGV;
my $url = repos_server_url();
- print $url, "\n" or confess $!;
+ 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 confess $!;
+ print "@dpkg_source_ignores\n" or confess "$!";
}
sub cmd_setup_mergechangelogs {
- badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
+ badusage __ "no arguments allowed to dgit setup-mergechangelogs"
+ if @ARGV;
local $isuite = 'DGIT-SETUP-TREE';
setup_mergechangelogs(1);
}
sub cmd_setup_useremail {
- badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
+ badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
local $isuite = 'DGIT-SETUP-TREE';
setup_useremail(1);
}
sub cmd_setup_gitattributes {
- badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
+ badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
local $isuite = 'DGIT-SETUP-TREE';
setup_gitattrs(1);
}
sub cmd_setup_new_tree {
- badusage "no arguments allowed to dgit setup-tree" if @ARGV;
+ badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
local $isuite = 'DGIT-SETUP-TREE';
setup_new_tree();
}
#---------- argument parsing and main program ----------
sub cmd_version {
- print "dgit version $our_version\n" or confess $!;
+ print "dgit version $our_version\n" or confess "$!";
finish 0;
}
defvalopt '--initiator-tempdir','','.*', sub {
($initiator_tempdir) = (@_);
$initiator_tempdir =~ m#^/# or
- badusage "--initiator-tempdir must be used specify an".
- " absolute, not relative, directory."
+ badusage __ "--initiator-tempdir must be used specify an".
+ " absolute, not relative, directory."
};
sub defoptmodes ($@) {
my ($what) = @_;
@rvalopts = ($_);
if (!defined $val) {
- badusage "$what needs a value" unless @ARGV;
+ badusage f_ "%s needs a value", $what unless @ARGV;
$val = shift @ARGV;
push @rvalopts, $val;
}
- badusage "bad value \`$val' for $what" unless
+ badusage f_ "bad value \`%s' for %s", $val, $what unless
$val =~ m/^$oi->{Re}$(?!\n)/s;
my $how = $oi->{How};
if (ref($how) eq 'SCALAR') {
($om = $opts_opt_map{$1})) {
push @ropts, $_;
push @$om, $2;
- } elsif (m/^--(gbp|dpm)$/s) {
+ } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
+ !$opts_opt_cmdonly{$1} &&
+ ($om = $opts_opt_map{$1})) {
+ push @ropts, $_;
+ my $cmd = shift @$om;
+ @$om = ($cmd, grep { $_ ne $2 } @$om);
+ } elsif (m/^--($quilt_options_re)$/s) {
push @ropts, "--quilt=$1";
$quilt_mode = $1;
} elsif (m/^--(?:ignore|include)-dirty$/s) {
} elsif (m/^--overwrite$/s) {
push @ropts, $_;
$overwrite_version = '';
+ } elsif (m/^--split-(?:view|brain)$/s) {
+ push @ropts, $_;
+ $splitview_mode = 'always';
+ } elsif (m/^--split-(?:view|brain)=($splitview_modes_re)$/s) {
+ push @ropts, $_;
+ $splitview_mode = $1;
} elsif (m/^--overwrite=(.+)$/s) {
push @ropts, $_;
$overwrite_version = $1;
} elsif (m/^--delayed=(\d+)$/s) {
push @ropts, $_;
push @dput, $_;
- } elsif (my ($k,$v) =
- m/^--save-(dgit-view)=(.+)$/s ||
+ } elsif (m/^--upstream-commitish=(.+)$/s) {
+ push @ropts, $_;
+ $quilt_upstream_commitish = $1;
+ } elsif (m/^--save-(dgit-view)=(.+)$/s ||
m/^--(dgit-view)-save=(.+)$/s
) {
+ my ($k,$v) = ($1,$2);
push @ropts, $_;
$v =~ s#^(?!refs/)#refs/heads/#;
$internal_object_save{$k} = $v;
$_='';
} 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/^--config-lookup-explode=(.+)$/s) {
# undocumented, for testing
push @ropts, $_;
push @ropts, $_;
$funcopts_long{$_}();
} else {
- badusage "unknown long option \`$_'";
+ badusage f_ "unknown long option \`%s'", $_;
}
} else {
while (m/^-./s) {
} elsif (s/^-wn$//s) {
push @ropts, $&;
$cleanmode = 'none';
- } elsif (s/^-wg$//s) {
+ } elsif (s/^-wg(f?)(a?)$//s) {
push @ropts, $&;
$cleanmode = 'git';
- } elsif (s/^-wgf$//s) {
- push @ropts, $&;
- $cleanmode = 'git-ff';
- } elsif (s/^-wd$//s) {
+ $cleanmode .= '-ff' if $1;
+ $cleanmode .= ',always' if $2;
+ } elsif (s/^-wd(d?)([na]?)$//s) {
push @ropts, $&;
$cleanmode = 'dpkg-source';
- } elsif (s/^-wdd$//s) {
- push @ropts, $&;
- $cleanmode = 'dpkg-source-d';
+ $cleanmode .= '-d' if $1;
+ $cleanmode .= ',no-check' if $2 eq 'n';
+ $cleanmode .= ',all-check' if $2 eq 'a';
} elsif (s/^-wc$//s) {
push @ropts, $&;
$cleanmode = 'check';
+ } elsif (s/^-wci$//s) {
+ push @ropts, $&;
+ $cleanmode = 'check,ignores';
} elsif (s/^-c([^=]*)\=(.*)$//s) {
push @git, '-c', $&;
$gitcfgs{cmdline}{$1} = [ $2 ];
$valopt->($oi->{Short});
$_ = '';
} else {
- badusage "unknown short option \`$_'";
+ badusage f_ "unknown short option \`%s'", $_;
}
}
}
sub check_env_sanity () {
my $blocked = new POSIX::SigSet;
- sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess $!;
+ sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
eval {
foreach my $name (qw(PIPE CHLD)) {
my $signame = "SIG$name";
my $signum = eval "POSIX::$signame" // die;
- die "$signame is set to something other than SIG_DFL\n"
+ die f_ "%s is set to something other than SIG_DFL\n",
+ $signame
if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
$blocked->ismember($signum) and
- die "$signame is blocked\n";
+ die f_ "%s is blocked\n", $signame;
}
};
return unless $@;
chomp $@;
- fail <<END;
-On entry to dgit, $@
-This is a bug produced by something in in your execution environment.
+ fail f_ <<END, $@;
+On entry to dgit, %s
+This is a bug produced by something in your execution environment.
Giving up.
END
}
my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
if (defined $v) {
- badcfg "cannot set command for $k"
+ badcfg f_ "cannot set command for %s", $k
unless length $om->[0];
$om->[0] = $v;
}
printdebug "CL $c ", (join " ", map { shellquote } @vl),
"\n" if $debuglevel >= 4;
next unless @vl;
- badcfg "cannot configure options for $k"
+ badcfg f_ "cannot configure options for %s", $k
if $opts_opt_cmdonly{$k};
my $insertpos = $opts_cfg_insertpos{$k};
@$om = ( @$om[0..$insertpos-1],
// access_cfg('quilt-mode', 'RETURN-UNDEF')
// 'linear';
$quilt_mode =~ m/^($quilt_modes_re)$/
- or badcfg "unknown quilt-mode \`$quilt_mode'";
+ or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
$quilt_mode = $1;
}
+ $quilt_mode =~ s/^(baredebian)\+git$/$1/;
foreach my $moc (@modeopt_cfgs) {
local $access_forpush;
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;
}
- 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
- $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
+ default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
+ $cleanmode_re);
}
$buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
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 confess $!;
+ print STDERR __ $helpmsg or confess "$!";
finish 8;
}
$cmd = $subcommand = shift @ARGV;
my $pre_fn = ${*::}{"pre_$cmd"};
$pre_fn->() if $pre_fn;
-record_maindir if $invoked_in_git_tree;
+if ($invoked_in_git_tree) {
+ changedir_git_toplevel();
+ record_maindir();
+}
git_slurp_config();
my $fn = ${*::}{"cmd_$cmd"};
-$fn or badusage "unknown operation $cmd";
+$fn or badusage f_ "unknown operation %s", $cmd;
$fn->();
finish 0;