use strict;
-use Debian::Dgit;
+use Debian::Dgit qw(:DEFAULT :playground);
setup_sigwarn();
use IO::Handle;
use File::Temp qw(tempdir);
use File::Basename;
use Dpkg::Version;
+use Dpkg::Compression;
+use Dpkg::Compression::Process;
use POSIX;
use IPC::Open2;
use Digest::SHA;
our $splitbraincache = 'dgit-intern/quilt-cache';
our $rewritemap = 'dgit-rewrite/map';
+our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
+
our (@git) = qw(git);
our (@dget) = qw(dget);
our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
our (@dgit) = qw(dgit);
our (@aptget) = qw(apt-get);
our (@aptcache) = qw(apt-cache);
-our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
-our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
+our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
+our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
our (@dpkggenchanges) = qw(dpkg-genchanges);
our (@mergechanges) = qw(mergechanges -f);
our (@gbp_build) = ('');
return opts_opt_multi_cmd @gbp_pq;
}
+sub dgit_privdir () {
+ our $dgit_privdir_made //= ensure_a_playground 'dgit';
+}
+
#---------- remote protocol support, common ----------
# remote push initiator/responder protocol:
}
sub pre_help () {
- no_local_git_cfg();
+ not_necessarily_a_tree();
}
sub cmd_help () {
print $helpmsg or die $!;
our %gitcfgs;
our @gitcfgsources = qw(cmdline local global system);
+our $invoked_in_git_tree = 1;
sub git_slurp_config () {
# This algoritm is a bit subtle, but this is needed so that for
"$us: distro or suite appears not to be (properly) supported";
}
-sub no_local_git_cfg () {
+sub not_necessarily_a_tree () {
# needs to be called from pre_*
@gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
+ $invoked_in_git_tree = 0;
}
sub access_basedistro__noalias () {
our %commit_getclogp_memo;
my $memo = $commit_getclogp_memo{$objid};
return $memo if $memo;
- mkpath '.git/dgit';
- my $mclog = ".git/dgit/clog-$objid";
+
+ my $mclog = dgit_privdir()."clog";
runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
"$objid:debian/changelog";
$commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
}
-sub must_getcwd () {
- my $d = getcwd();
- defined $d or fail "getcwd failed: $!";
- return $d;
-}
-
sub parse_dscdata () {
my $dscfh = new IO::File \$dscdata, '<' or die $!;
printdebug Dumper($dscdata) if $debuglevel>1;
our ($dsc_hash,$lastpush_mergeinput);
our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
-our $ud = '.git/dgit/unpack';
-sub prep_ud (;$) {
- my ($d) = @_;
- $d //= $ud;
- rmtree($d);
- mkpath '.git/dgit';
- mkdir $d or die $!;
+sub prep_ud () {
+ dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
+ fresh_playground 'dgit/unpack';
}
sub mktree_in_ud_here () {
- workarea_setup $gitcfgs{local};
+ playtree_setup $gitcfgs{local};
}
sub git_write_tree () {
sub mktree_in_ud_from_only_subdir ($;$) {
my ($what,$raw) = @_;
-
# changes into the subdir
+
my (@dirs) = <*/.>;
die "expected one subdir but found @dirs ?" unless @dirs==1;
$dirs[0] =~ m#^([^/]+)/\.$# or die;
# See big comment in fetch_from_archive, below.
# See also README.dsc-import.
prep_ud();
- changedir $ud;
+ changedir $playground;
my @dfi = dsc_files_info();
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
- my $upper_f = "../../../../$f";
+ my $upper_f = "$maindir/../$f";
printdebug "considering reusing $f: ";
my $path = $ENV{PATH} or die;
+ # we use ../../gbp-pq-output, which (given that we are in
+ # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
+ # is .git/dgit.
+
foreach my $use_absurd (qw(0 1)) {
runcmd @git, qw(checkout -q unpa);
runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
@output = $lastpush_mergeinput;
}
}
- changedir '../../../..';
- rmtree($ud);
+ changedir $maindir;
+ rmtree $playground;
return @output;
}
my $author = clogp_authline $useclogp;
my $cversion = getfield $useclogp, 'Version';
- my $mcf = ".git/dgit/mergecommit";
+ my $mcf = dgit_privdir()."/mergecommit";
open MC, ">", $mcf or die "$mcf $!";
print MC <<END or die $!;
tree $tree
fetch_from_archive_record_1($hash);
if (defined $skew_warning_vsn) {
- mkpath '.git/dgit';
printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
my $gotclogp = commit_getclogp($hash);
my $got_vsn = getfield $gotclogp, 'Version';
my $driver = 'dpkg-mergechangelogs';
my $cb = "merge.$driver";
- my $attrs = '.git/info/attributes';
- ensuredir '.git/info';
+ confess unless defined $maindir;
+ my $attrs = "$maindir_gitcommon/info/attributes";
+ ensuredir "$maindir_gitcommon/info";
open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
if (!open ATTRS, "<", $attrs) {
set_local_git_config $k, 'true';
}
-sub open_gitattrs () {
- my $gai = new IO::File ".git/info/attributes"
+sub open_main_gitattrs () {
+ confess 'internal error no maindir' unless defined $maindir;
+ my $gai = new IO::File "$maindir_gitcommon/info/attributes"
or $!==ENOENT
- or die "open .git/info/attributes: $!";
+ or die "open $maindir_gitcommon/info/attributes: $!";
return $gai;
}
sub is_gitattrs_setup () {
- my $gai = open_gitattrs();
+ my $gai = open_main_gitattrs();
return 0 unless $gai;
while (<$gai>) {
return 1 if m{^\[attr\]dgit-defuse-attrs\s};
END
return;
}
- my $af = ".git/info/attributes";
- ensuredir '.git/info';
+ my $af = "$maindir_gitcommon/info/attributes";
+ ensuredir "$maindir_gitcommon/info";
open GAO, "> $af.new" or die $!;
print GAO <<END or die $!;
* dgit-defuse-attrs
[attr]dgit-defuse-attrs $negate_harmful_gitattrs
# ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
END
- my $gai = open_gitattrs();
+ my $gai = open_main_gitattrs();
if ($gai) {
while (<$gai>) {
chomp;
my $multi_fetched = fork_for_multisuite(sub {
printdebug "multi clone before fetch merge\n";
changedir $dstdir;
+ record_maindir();
});
if ($multi_fetched) {
printdebug "multi clone after fetch merge\n";
mkdir $dstdir or fail "create \`$dstdir': $!";
changedir $dstdir;
runcmd @git, qw(init -q);
+ record_maindir();
setup_new_tree();
clone_set_head();
my $giturl = access_giturl(1);
my ($headref, $dgitview, $msg) = @_;
# => message fragment "$saved" describing disposition of $dgitview
return "commit id $dgitview" unless defined $split_brain_save;
- my @cmd = (shell_cmd "cd ../../../..",
+ my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
@git, qw(update-ref -m),
"dgit --dgit-view-save $msg HEAD=$headref",
$split_brain_save, $dgitview);
: !length $overwrite_version ? " --overwrite"
: " --overwrite=".$overwrite_version;
- mkpath '.git/dgit';
- my $pmf = ".git/dgit/pseudomerge";
+ my $pmf = dgit_privdir()."/pseudomerge";
open MC, ">", $pmf or die "$pmf $!";
print MC <<END or die $!;
tree $tree
rpush_handle_protovsn_bothends() if $we_are_initiator;
select_tagformat();
- my $clogpfn = ".git/dgit/changelog.822.tmp";
+ my $clogpfn = dgit_privdir()."/changelog.822.tmp";
runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
responder_send_file('parsed-changelog', $clogpfn);
if (madformat_wantfixup($format)) {
# user might have not used dgit build, so maybe do this now:
if (quiltmode_splitbrain()) {
- changedir $ud;
+ changedir $playground;
quilt_make_fake_dsc($upstreamversion);
my $cachekey;
($dgithead, $cachekey) =
quilt_check_splitbrain_cache($actualhead, $upstreamversion);
$dgithead or fail
"--quilt=$quilt_mode but no cached dgit view:
- perhaps tree changed since dgit build[-source] ?";
+ perhaps HEAD changed since dgit build[-source] ?";
$split_brain = 1;
$dgithead = splitbrain_pseudomerge($clogp,
$actualhead, $dgithead,
$archive_hash);
$maintviewhead = $actualhead;
- changedir '../../../..';
+ changedir $maindir;
prep_ud(); # so _only_subdir() works, below
} else {
commit_quilty_patch();
}
}
- changedir $ud;
+ changedir $playground;
progress "checking that $dscfn corresponds to HEAD";
runcmd qw(dpkg-source -x --),
- $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
+ $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
check_for_vendor_patches() if madformat($dsc->{format});
- changedir '../../../..';
+ changedir $maindir;
my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
debugcmd "+",@diffcmd;
$!=0; $?=-1;
my $r = system @diffcmd;
if ($r) {
if ($r==256) {
+ my $referent = $split_brain ? $dgithead : 'HEAD';
my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
- fail <<END
+
+ my @mode_changes;
+ my $raw = cmdoutput @git,
+ qw(diff --no-renames -z -r --raw), $tree, $dgithead;
+ my $changed;
+ foreach (split /\0/, $raw) {
+ if (defined $changed) {
+ push @mode_changes, "$changed: $_\n" if $changed;
+ $changed = undef;
+ next;
+ } elsif (m/^:0+ 0+ /) {
+ $changed = '';
+ } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
+ $changed = "Mode change from $1 to $2"
+ } else {
+ die "$_ ?";
+ }
+ }
+ if (@mode_changes) {
+ fail <<END.(join '', @mode_changes).<<END;
+HEAD specifies a different tree to $dscfn:
+$diffs
+END
+There is a problem with your source tree (see dgit(7) for some hints).
+To see a full diff, run git diff $tree $referent
+END
+ }
+
+ fail <<END;
HEAD specifies a different tree to $dscfn:
$diffs
Perhaps you forgot to build. Or perhaps there is a problem with your
source tree (see dgit(7) for some hints). To see a full diff, run
- git diff $tree HEAD
+ git diff $tree $referent
END
} else {
failedcmd @diffcmd;
}
my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
- ".git/dgit/tag");
+ dgit_privdir()."/tag");
my @tagobjfns;
supplementary_message(<<'END');
}
sub pre_clone () {
- no_local_git_cfg();
+ not_necessarily_a_tree();
}
sub cmd_clone {
parseopts();
pull();
}
-sub cmd_push {
+sub prep_push () {
parseopts();
- badusage "-p is not allowed with dgit push" if defined $package;
+ build_or_push_prep_early();
+ pushing();
check_not_dirty();
- my $clogp = parsechangelog();
- $package = getfield $clogp, 'Source';
my $specsuite;
if (@ARGV==0) {
} elsif (@ARGV==1) {
($specsuite) = (@ARGV);
} else {
- badusage "incorrect arguments to dgit push";
+ badusage "incorrect arguments to dgit $subcommand";
}
- $isuite = getfield $clogp, 'Distribution';
- pushing();
if ($new_package) {
local ($package) = $existing_package; # this is a hack
canonicalise_suite();
if (defined $specsuite &&
$specsuite ne $isuite &&
$specsuite ne $csuite) {
- fail "dgit push: changelog specifies $isuite ($csuite)".
+ fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
" but command line specifies $specsuite";
}
+}
+
+sub cmd_push {
+ prep_push();
dopush();
}
}
sub pre_rpush () {
- no_local_git_cfg();
+ not_necessarily_a_tree();
}
sub cmd_rpush {
my $host = nextarg;
my ($patchname,$author,$msg, $xinfo) = @_;
$xinfo //= '';
- mkpath '.git/dgit';
+ mkpath '.git/dgit'; # we are in playtree
my $descfn = ".git/dgit/quilt-description.tmp";
open O, '>', $descfn or die "$descfn: $!";
$msg =~ s/\n+/\n\n/;
my $dgitview = git_rev_parse 'HEAD';
- changedir '../../../..';
+ changedir $maindir;
# When we no longer need to support squeeze, use --create-reflog
# instead of this:
- ensuredir ".git/logs/refs/dgit-intern";
- my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
+ ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
+ my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>'
or die $!;
my $oldcache = git_get_ref "refs/$splitbraincache";
runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
$dgitview;
- changedir '.git/dgit/unpack/work';
+ changedir "$playground/work";
my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
progress "dgit view: created ($saved)";
my $headref = git_rev_parse('HEAD');
prep_ud();
- changedir $ud;
+ changedir $playground;
my $upstreamversion = upstreamversion $version;
die 'bug' if $split_brain && !$need_split_build_invocation;
- changedir '../../../..';
+ changedir $maindir;
runcmd_ordryrun_local
- @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
+ @git, qw(pull --ff-only -q), "$playground/work", qw(master);
}
sub quilt_fixup_mkwork ($) {
my ($upstreamversion, $fn) = @_;
# calls $fn->($leafname);
- foreach my $f (<../../../../*>) { #/){
+ foreach my $f (<$maindir/../*>) { #/){
my $b=$f; $b =~ s{.*/}{};
{
local ($debuglevel) = $debuglevel-1;
debian/control debian/changelog);
foreach my $maybe (qw(debian/patches debian/source/options
debian/tests/control)) {
- next unless stat_exists "../../../$maybe";
+ next unless stat_exists "$maindir/$maybe";
push @files, $maybe;
}
my $debtar= srcfn $fakeversion,'.debian.tar.gz';
- runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
+ runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
$dscaddfile->($debtar);
close $fakedsc or die $!;
sub quilt_check_splitbrain_cache ($$) {
my ($headref, $upstreamversion) = @_;
# Called only if we are in (potentially) split brain mode.
- # Called in $ud.
+ # Called in playground.
# Computes the cache key and looks in the cache.
# Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
debugcmd "|(probably)",@cmd;
my $child = open GC, "-|"; defined $child or die $!;
if (!$child) {
- chdir '../../..' or die $!;
- if (!stat ".git/logs/refs/$splitbraincache") {
+ chdir $maindir or die $!;
+ if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
$! == ENOENT or die $!;
printdebug ">(no reflog)\n";
exit 0;
maybe_unapply_patches_again();
}
-sub build_prep_early () {
- our $build_prep_early_done //= 0;
- return if $build_prep_early_done++;
- badusage "-p is not allowed when building" if defined $package;
+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;
my $clogp = parsechangelog();
$isuite = getfield $clogp, 'Distribution';
$package = getfield $clogp, 'Source';
$version = getfield $clogp, 'Version';
+}
+
+sub build_prep_early () {
+ build_or_push_prep_early();
notpushing();
check_not_dirty();
}
}
my @cmd = opts_opt_multi_cmd @gbp_build;
- push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
+ push @cmd, (qw(-us -uc --git-no-sign-tags),
+ "--git-builder=".(shellquote @dbp));
if ($gbp_make_orig) {
- ensuredir '.git/dgit';
- my $ok = '.git/dgit/origs-gen-ok';
+ my $priv = dgit_privdir();
+ my $ok = "$priv/origs-gen-ok";
unlink $ok or $!==&ENOENT or die $!;
my @origs_cmd = @cmd;
push @origs_cmd, qw(--git-cleaner=true);
- push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
+ push @origs_cmd, "--git-prebuild=".
+ "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
push @origs_cmd, @ARGV;
if (act_local()) {
debugcmd @origs_cmd;
} else {
my @cmd = (@dpkgsource, qw(-b --));
if ($split_brain) {
- changedir $ud;
+ changedir $playground;
runcmd_ordryrun_local @cmd, "work";
my @udfiles = <${package}_*>;
- changedir "../../..";
+ changedir $maindir;
foreach my $f (@udfiles) {
printdebug "source copy, found $f\n";
next unless
($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
$f eq srcfn($version, $&));
printdebug "source copy, found $f - renaming\n";
- rename "$ud/$f", "../$f" or $!==ENOENT
+ rename "$playground/$f", "../$f" or $!==ENOENT
or fail "put in place new source file ($f): $!";
}
} else {
}
sub pre_archive_api_query () {
- no_local_git_cfg();
+ not_necessarily_a_tree();
}
sub cmd_archive_api_query {
badusage "need only 1 subpath argument" unless @ARGV==1;
}
sub pre_clone_dgit_repos_server () {
- no_local_git_cfg();
+ not_necessarily_a_tree();
}
sub cmd_clone_dgit_repos_server {
badusage "need destination argument" unless @ARGV==1;
}
sub pre_print_dgit_repos_server_source_url () {
- no_local_git_cfg();
+ not_necessarily_a_tree();
}
sub cmd_print_dgit_repos_server_source_url {
badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
print $url, "\n" or die $!;
}
+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"
+ if @ARGV;
+ print "@dpkg_source_ignores\n" or die $!;
+}
+
sub cmd_setup_mergechangelogs {
badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
local $isuite = 'DGIT-SETUP-TREE';
my $pre_fn = ${*::}{"pre_$cmd"};
$pre_fn->() if $pre_fn;
+record_maindir if $invoked_in_git_tree;
git_slurp_config();
my $fn = ${*::}{"cmd_$cmd"};