# dgit
# Integration between git and Debian-style archives
#
-# Copyright (C)2013-2016 Ian Jackson
+# Copyright (C)2013-2017 Ian Jackson
+# Copyright (C)2017 Sean Whitton
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
+END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
+use Debian::Dgit::ExitStatus;
+
use 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 @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
our $protovsn;
+our $cmd;
+our $subcommand;
our $isuite;
our $idistro;
our $package;
our $sign = 1;
our $dryrun_level = 0;
our $changesfile;
-our $buildproductsdir = '..';
+our $buildproductsdir;
+our $bpd_glob;
our $new_package = 0;
-our $ignoredirty = 0;
+our $includedirty = 0;
our $rmonerror = 1;
our @deliberatelies;
our %previously;
our %forceopts = map { $_=>0 }
qw(unrepresentable unsupported-source-format
dsc-changes-mismatch changes-origs-exactly
+ uploading-binaries uploading-source-only
import-gitapply-absurd
import-gitapply-no-absurd
import-dsc-with-dgit-field);
our $suite_re = '[-+.0-9a-z]+';
our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
-our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
+our $orig_f_comp_re = qr{orig(?:-$extra_orig_namepart_re)?};
our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
our $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 (@sbuild) = qw(sbuild);
our (@ssh) = 'ssh';
our (@dgit) = qw(dgit);
+our (@git_debrebase) = qw(git-debrebase);
our (@aptget) = qw(apt-get);
our (@aptcache) = qw(apt-cache);
-our (@dpkgbuildpackage) = qw(dpkg-buildpackage -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) = ('');
'ssh' => \@ssh,
'dgit' => \@dgit,
'git' => \@git,
+ 'git-debrebase' => \@git_debrebase,
'apt-get' => \@aptget,
'apt-cache' => \@aptcache,
'dpkg-source' => \@dpkgsource,
sub setup_gitattrs(;$);
sub check_gitattrs($$);
+our $playground;
our $keyid;
autoflush STDOUT 1;
our $supplementary_message = '';
-our $need_split_build_invocation = 0;
+our $need_split_build_invocation = 1;
our $split_brain = 0;
END {
return $tagformatfn->($v, $distro);
}
-sub debiantag_maintview ($$) {
- my ($v,$distro) = @_;
- return "$distro/".dep14_version_mangle $v;
-}
-
sub madformat ($) { $_[0] eq '3.0 (quilt)' }
sub lbranch () { return "$branchprefix/$csuite"; }
}
};
-sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
+sub badcfg { print STDERR "$us: invalid configuration: @_\n"; finish 12; }
sub forceable_fail ($$) {
my ($forceoptsl, $msg) = @_;
sub no_such_package () {
print STDERR "$us: package $package does not exist in suite $isuite\n";
- exit 4;
-}
-
-sub changedir ($) {
- my ($newdir) = @_;
- printdebug "CD $newdir\n";
- chdir $newdir or confess "chdir: $newdir: $!";
+ finish 4;
}
sub deliberately ($) {
return opts_opt_multi_cmd @gbp_pq;
}
+sub dgit_privdir () {
+ our $dgit_privdir_made //= ensure_a_playground 'dgit';
+}
+
+sub bpd_abs () {
+ my $r = $buildproductsdir;
+ $r = "$maindir/$r" unless $r =~ m{^/};
+ return $r;
+}
+
+sub branch_gdr_info ($$) {
+ my ($symref, $head) = @_;
+ my ($status, $msg, $current, $ffq_prev, $gdrlast) =
+ gdr_ffq_prev_branchinfo($symref);
+ return () unless $status eq 'branch';
+ $ffq_prev = git_get_ref $ffq_prev;
+ $gdrlast = git_get_ref $gdrlast;
+ $gdrlast &&= is_fast_fwd $gdrlast, $head;
+ return ($ffq_prev, $gdrlast);
+}
+
+sub branch_is_gdr ($$) {
+ my ($symref, $head) = @_;
+ my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
+ return 0 unless $ffq_prev || $gdrlast;
+ return 1;
+}
+
+sub branch_is_gdr_unstitched_ff ($$$) {
+ my ($symref, $head, $ancestor) = @_;
+ my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
+ return 0 unless $ffq_prev;
+ return 0 unless is_fast_fwd $ancestor, $ffq_prev;
+ return 1;
+}
+
#---------- remote protocol support, common ----------
# remote push initiator/responder protocol:
}
}
-sub shell_cmd {
- my ($first_shell, @cmd) = @_;
- return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
-}
-
our $helpmsg = <<END;
main usages:
dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
dgit [dgit-opts] build [dpkg-buildpackage-opts]
dgit [dgit-opts] sbuild [sbuild-opts]
dgit [dgit-opts] push [dgit-opts] [suite]
+ dgit [dgit-opts] push-source [dgit-opts] [suite]
dgit [dgit-opts] rpush build-host:build-dir ...
important dgit options:
-k<keyid> sign tag and package with <keyid> instead of default
sub badusage {
print STDERR "$us: @_\n", $helpmsg or die $!;
- exit 8;
+ finish 8;
}
sub nextarg {
}
sub pre_help () {
- no_local_git_cfg();
+ not_necessarily_a_tree();
}
sub cmd_help () {
print $helpmsg or die $!;
- exit 0;
+ finish 0;
}
our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
'dgit.default.sshpsql-dbname' => 'service=projectb',
'dgit.default.aptget-components' => 'main',
'dgit.default.dgit-tag-format' => 'new,old,maint',
+ 'dgit.default.source-only-uploads' => 'ok',
'dgit.dsc-url-proto-ok.http' => 'true',
'dgit.dsc-url-proto-ok.https' => 'true',
'dgit.dsc-url-proto-ok.git' => 'true',
+ 'dgit.vcs-git.suites', => 'sid', # ;-separated
'dgit.default.dsc-url-proto-ok' => 'false',
# old means "repo server accepts pushes with old dgit tags"
# new means "repo server accepts pushes with new dgit tags"
'dgit-distro.debian.git-check' => 'url',
'dgit-distro.debian.git-check-suffix' => '/info/refs',
'dgit-distro.debian.new-private-pushers' => 't',
+ 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
'dgit-distro.debian/push.git-url' => '',
'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
'dgit-distro.debian/push.git-user-force' => 'dgit',
our %gitcfgs;
our @gitcfgsources = qw(cmdline local global system);
+our $invoked_in_git_tree = 1;
sub git_slurp_config () {
- local ($debuglevel) = $debuglevel-2;
- local $/="\0";
-
# This algoritm is a bit subtle, but this is needed so that for
# options which we want to be single-valued, we allow the
# different config sources to override properly. See #835858.
foreach my $src (@gitcfgsources) {
next if $src eq 'cmdline';
# we do this ourselves since git doesn't handle it
-
- my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
- debugcmd "|",@cmd;
- open GITS, "-|", @cmd or die $!;
- while (<GITS>) {
- chomp or die;
- printdebug "=> ", (messagequote $_), "\n";
- m/\n/ or die "$_ ?";
- push @{ $gitcfgs{$src}{$`} }, $'; #';
- }
- $!=0; $?=0;
- close GITS
- or ($!==0 && $?==256)
- or failedcmd @cmd;
+ $gitcfgs{$src} = git_slurp_config_src $src;
}
}
"$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 () {
return "$url/$package$suffix";
}
-sub parsecontrolfh ($$;$) {
- my ($fh, $desc, $allowsigned) = @_;
- our $dpkgcontrolhash_noissigned;
- my $c;
- for (;;) {
- my %opts = ('name' => $desc);
- $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
- $c = Dpkg::Control::Hash->new(%opts);
- $c->parse($fh,$desc) or die "parsing of $desc failed";
- last if $allowsigned;
- last if $dpkgcontrolhash_noissigned;
- my $issigned= $c->get_option('is_pgp_signed');
- if (!defined $issigned) {
- $dpkgcontrolhash_noissigned= 1;
- seek $fh, 0,0 or die "seek $desc: $!";
- } elsif ($issigned) {
- fail "control file $desc is (already) PGP-signed. ".
- " Note that dgit push needs to modify the .dsc and then".
- " do the signature itself";
- } else {
- last;
- }
- }
- return $c;
-}
-
-sub parsecontrol {
- my ($file, $desc, $allowsigned) = @_;
- my $fh = new IO::Handle;
- open $fh, '<', $file or die "$file: $!";
- my $c = parsecontrolfh($fh,$desc,$allowsigned);
- $fh->error and die $!;
- close $fh;
- return $c;
-}
-
-sub getfield ($$) {
- my ($dctrl,$field) = @_;
- my $v = $dctrl->{$field};
- return $v if defined $v;
- fail "missing field $field in ".$dctrl->get_option('name');
-}
-
-sub parsechangelog {
- my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
- my $p = new IO::Handle;
- my @cmd = (qw(dpkg-parsechangelog), @_);
- open $p, '-|', @cmd or die $!;
- $c->parse($p);
- $?=0; $!=0; close $p or failedcmd @cmd;
- return $c;
-}
-
sub commit_getclogp ($) {
# Returns the parsed changelog hashref for a particular commit
my ($objid) = @_;
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;
my $info = api_query($data, "file_in_archive/$pat", 1);
}
+sub package_not_wholly_new_ftpmasterapi {
+ my ($proto,$data,$pkg) = @_;
+ my $info = api_query($data,"madison?package=${pkg}&f=json");
+ return !!@$info;
+}
+
#---------- `aptget' archive query method ----------
our $aptget_base;
}
my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
@releasefiles = @inreleasefiles if @inreleasefiles;
- die "apt updated wrong number of Release files (@releasefiles), erk"
+ if (!@releasefiles) {
+ fail <<END;
+apt seemed to not to update dgit's cached Release files for $isuite.
+(Perhaps $cache
+ is on a filesystem mounted `noatime'; if so, please use `relatime'.)
+END
+ }
+ die "apt updated too many Release files (@releasefiles), erk"
unless @releasefiles == 1;
($aptget_releasefile) = @releasefiles;
}
sub file_in_archive_aptget () { return undef; }
+sub package_not_wholly_new_aptget () { return undef; }
#---------- `dummyapicat' archive query method ----------
sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
-sub file_in_archive_dummycatapi ($$$) {
- my ($proto,$data,$filename) = @_;
+sub dummycatapi_run_in_mirror ($@) {
+ # runs $fn with FIA open onto rune
+ my ($rune, $argl, $fn) = @_;
+
my $mirror = access_cfg('mirror');
$mirror =~ s#^file://#/# or die "$mirror ?";
- my @out;
- my @cmd = (qw(sh -ec), '
- cd "$1"
- find -name "$2" -print0 |
- xargs -0r sha256sum
- ', qw(x), $mirror, $filename);
+ my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
+ qw(x), $mirror, @$argl);
debugcmd "-|", @cmd;
open FIA, "-|", @cmd or die $!;
- while (<FIA>) {
- chomp or die;
- printdebug "| $_\n";
- m/^(\w+) (\S+)$/ or die "$_ ?";
- push @out, { sha256sum => $1, filename => $2 };
- }
- close FIA or die failedcmd @cmd;
+ my $r = $fn->();
+ close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
+ return $r;
+}
+
+sub file_in_archive_dummycatapi ($$$) {
+ my ($proto,$data,$filename) = @_;
+ my @out;
+ dummycatapi_run_in_mirror '
+ find -name "$1" -print0 |
+ xargs -0r sha256sum
+ ', [$filename], sub {
+ while (<FIA>) {
+ chomp or die;
+ printdebug "| $_\n";
+ m/^(\w+) (\S+)$/ or die "$_ ?";
+ push @out, { sha256sum => $1, filename => $2 };
+ }
+ };
return \@out;
}
+sub package_not_wholly_new_dummycatapi {
+ my ($proto,$data,$pkg) = @_;
+ dummycatapi_run_in_mirror "
+ find -name ${pkg}_*.dsc
+ ", [], sub {
+ local $/ = undef;
+ !!<FIA>;
+ };
+}
+
#---------- `madison' archive query method ----------
sub archive_query_madison {
}
sub file_in_archive_madison { return undef; }
+sub package_not_wholly_new_madison { return undef; }
#---------- `sshpsql' archive query method ----------
}
sub file_in_archive_sshpsql ($$$) { return undef; }
+sub package_not_wholly_new_sshpsql ($$$) { return undef; }
#---------- `dummycat' archive query method ----------
}
sub file_in_archive_dummycat () { return undef; }
+sub package_not_wholly_new_dummycat () { return undef; }
#---------- tag format handling ----------
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
+ $playground = fresh_playground 'dgit/unpack';
}
sub mktree_in_ud_here () {
- runcmd qw(git init -q);
- runcmd qw(git config gc.auto 0);
- foreach my $copy (qw(user.email user.name user.useConfigOnly
- core.sharedRepository
- core.compression core.looseCompression
- core.bigFileThreshold core.fsyncObjectFiles)) {
- my $v = $gitcfgs{local}{$copy};
- next unless $v;
- runcmd qw(git config), $copy, $_ foreach @$v;
- }
- rmtree('.git/objects');
- symlink '../../../../objects','.git/objects' or die $!;
- ensuredir '.git/info';
- open GA, "> .git/info/attributes" or die $!;
- print GA "* $negate_harmful_gitattrs\n" or die $!;
- close GA or die $!;
+ 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;
return 1;
}
+# This function determines whether a .changes file is source-only from
+# the point of view of dak. Thus, it permits *_source.buildinfo
+# files.
+#
+# It does not, however, permit any other buildinfo files. After a
+# source-only upload, the buildds will try to upload files like
+# foo_1.2.3_amd64.buildinfo. If the package maintainer included files
+# named like this in their (otherwise) source-only upload, the uploads
+# of the buildd can be rejected by dak. Fixing the resultant
+# situation can require manual intervention. So we block such
+# .buildinfo files when the user tells us to perform a source-only
+# upload (such as when using the push-source subcommand with the -C
+# option, which calls this function).
+#
+# Note, though, that when dgit is told to prepare a source-only
+# upload, such as when subcommands like build-source and push-source
+# without -C are used, dgit has a more restrictive notion of
+# source-only .changes than dak: such uploads will never include
+# *_source.buildinfo files. This is because there is no use for such
+# files when using a tool like dgit to produce the source package, as
+# dgit ensures the source is identical to git HEAD.
+sub test_source_only_changes ($) {
+ my ($changes) = @_;
+ foreach my $l (split /\n/, getfield $changes, 'Files') {
+ $l =~ m/\S+$/ or next;
+ # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
+ unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
+ print "purportedly source-only changes polluted by $&\n";
+ return 0;
+ }
+ }
+ return 1;
+}
+
sub changes_update_origs_from_dsc ($$$$) {
my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
my %changes_f;
if ($found_same) {
# in archive, delete from .changes if it's there
$changed{$file} = "removed" if
- $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
- } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
+ $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
+ } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
# not in archive, but it's here in the .changes
} else {
my $dsc_data = getfield $dsc, $fname;
- $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
+ $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
my $extra = $1;
$extra =~ s/ \d+ /$&$placementinfo /
or die "$fname $extra >$dsc_data< ?"
# 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 = (bpd_abs()."/$f");
printdebug "considering reusing $f: ";
printdebug "linked (using ...,fetch).\n";
} elsif ((printdebug "($!) "),
$! != ENOENT) {
- fail "accessing ../$f,fetch: $!";
+ fail "accessing $buildproductsdir/$f,fetch: $!";
} elsif (link_ltarget $upper_f, $f) {
printdebug "linked.\n";
} elsif ((printdebug "($!) "),
$! != ENOENT) {
- fail "accessing ../$f: $!";
+ fail "accessing $buildproductsdir/$f: $!";
} else {
printdebug "absent.\n";
}
printdebug "linked.\n";
} elsif ((printdebug "($!) "),
$! != EEXIST) {
- fail "saving ../$f: $!";
+ fail "saving $buildproductsdir/$f: $!";
} elsif (!$refetched) {
printdebug "no need.\n";
} elsif (link $f, "$upper_f,fetch") {
printdebug "linked (using ...,fetch).\n";
} elsif ((printdebug "($!) "),
$! != EEXIST) {
- fail "saving ../$f,fetch: $!";
+ fail "saving $buildproductsdir/$f,fetch: $!";
} else {
printdebug "cannot.\n";
}
}
my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
- debugcmd "|",@clogcmd;
- open CLOGS, "-|", @clogcmd or die $!;
-
my $clogp;
my $r1clogp;
printdebug "import clog search...\n";
+ parsechangelog_loop \@clogcmd, "package changelog", sub {
+ my ($thisstanza, $desc) = @_;
+ no warnings qw(exiting);
- for (;;) {
- my $stanzatext = do { local $/=""; <CLOGS>; };
- printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
- last if !defined $stanzatext;
-
- my $desc = "package changelog, entry no.$.";
- open my $stanzafh, "<", \$stanzatext or die;
- my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
$clogp //= $thisstanza;
printdebug "import clog $thisstanza->{version} $desc...\n";
# version). Then it remains to choose between the physically
# last entry in the file, and the one with the lowest version
# number. If these are not the same, we guess that the
- # versions were created in a non-monotic order rather than
+ # versions were created in a non-monotonic order rather than
# that the changelog entries have been misordered.
printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
$r1clogp = $thisstanza;
printdebug "import clog $r1clogp->{version} becomes r1\n";
- }
- die $! if CLOGS->error;
- close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
+ };
$clogp or fail "package changelog has no entries!";
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;
}
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
next unless is_orig_file_in_dsc($f, \@dfi);
- complete_file_from_dsc('..', $fi)
+ complete_file_from_dsc($buildproductsdir, $fi)
or next;
}
}
my $want = $wantr{$rrefname};
next if $got eq $want;
if (!defined $objgot{$want}) {
+ fail <<END unless act_local();
+--dry-run specified but we actually wanted the results of git fetch,
+so this is not going to work. Try running dgit fetch first,
+or using --damp-run instead of --dry-run.
+END
print STDERR <<END;
warning: git ls-remote suggests we want $lrefname
warning: and it should refer to $want
sub fetch_from_archive_record_1 ($) {
my ($hash) = @_;
- runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
- 'DGIT_ARCHIVE', $hash;
+ runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
cmdoutput @git, qw(log -n2), $hash;
# ... gives git a chance to complain if our commit is malformed
}
sub fetch_from_archive_record_2 ($) {
my ($hash) = @_;
- my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
+ my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
if (act_local()) {
cmdoutput @upd_cmd;
} else {
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;
}
+our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
+
sub is_gitattrs_setup () {
- my $gai = open_gitattrs();
+ # return values:
+ # trueish
+ # 1: gitattributes set up and should be left alone
+ # falseish
+ # 0: there is a dgit-defuse-attrs but it needs fixing
+ # undef: there is none
+ my $gai = open_main_gitattrs();
return 0 unless $gai;
while (<$gai>) {
- return 1 if m{^\[attr\]dgit-defuse-attrs\s};
+ next unless m{$gitattrs_ourmacro_re};
+ return 1 if m{\s-working-tree-encoding\s};
+ printdebug "is_gitattrs_setup: found old macro\n";
+ return 0;
}
$gai->error and die $!;
- return 0;
+ printdebug "is_gitattrs_setup: found nothing\n";
+ return undef;
}
sub setup_gitattrs (;$) {
my ($always) = @_;
return unless $always || access_cfg_bool(1, 'setup-gitattributes');
- if (is_gitattrs_setup()) {
+ my $already = is_gitattrs_setup();
+ if ($already) {
progress <<END;
-[attr]dgit-defuse-attrs already found in .git/info/attributes
+[attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
not doing further gitattributes setup
END
return;
}
- my $af = ".git/info/attributes";
- ensuredir '.git/info';
+ my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
+ my $af = "$maindir_gitcommon/info/attributes";
+ ensuredir "$maindir_gitcommon/info";
+
open GAO, "> $af.new" or die $!;
- print GAO <<END or die $!;
+ print GAO <<END or die $! unless defined $already;
* dgit-defuse-attrs
-[attr]dgit-defuse-attrs $negate_harmful_gitattrs
+$new
# ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
END
- my $gai = open_gitattrs();
+ my $gai = open_main_gitattrs();
if ($gai) {
while (<$gai>) {
+ if (m{$gitattrs_ourmacro_re}) {
+ die unless defined $already;
+ $_ = $new;
+ }
chomp;
print GAO $_, "\n" or die $!;
}
# oh dear, found one
print STDERR <<END;
dgit: warning: $what contains .gitattributes
-dgit: .gitattributes have not been defused. Recommended: dgit setup-new-tree.
+dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
END
close $gafl;
return;
my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
sub {
@end = ();
- fetch();
- exit 0;
+ fetch_one();
+ finish 0;
});
# xxx collecte the ref here
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);
clone_finish($dstdir);
}
-sub fetch () {
+sub fetch_one () {
canonicalise_suite();
if (check_for_git()) {
git_fetch_us();
}
fetch_from_archive() or no_such_package();
+
+ my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
+ if (length $vcsgiturl and
+ (grep { $csuite eq $_ }
+ split /\;/,
+ cfg 'dgit.vcs-git.suites')) {
+ my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
+ if (defined $current && $current ne $vcsgiturl) {
+ print STDERR <<END;
+FYI: Vcs-Git in $csuite has different url to your vcs-git remote.
+ Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
+END
+ }
+ }
printdone "fetched into ".lrref();
}
-sub pull () {
+sub dofetch () {
my $multi_fetched = fork_for_multisuite(sub { });
- fetch() unless $multi_fetched; # parent
- return if $multi_fetched eq '0'; # child
+ fetch_one() unless $multi_fetched; # parent
+ finish 0 if $multi_fetched eq '0'; # child
+}
+
+sub pull () {
+ dofetch();
runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
lrref();
printdone "fetched to ".lrref()." and merged into HEAD";
}
}
- return if $ignoredirty;
+ return if $includedirty;
- my @cmd = (@git, qw(diff --quiet HEAD));
- debugcmd "+",@cmd;
- $!=0; $?=-1; system @cmd;
- return if !$?;
- if ($?==256) {
- fail "working tree is dirty (does not match HEAD)";
- } else {
- failedcmd @cmd;
- }
+ git_check_unmodified();
}
sub commit_admin ($) {
runcmd_ordryrun_local @git, qw(commit -m), $m;
}
+sub quiltify_nofix_bail ($$) {
+ my ($headinfo, $xinfo) = @_;
+ if ($quilt_mode eq 'nofix') {
+ fail "quilt fixup required but quilt mode is \`nofix'\n".
+ "HEAD commit".$headinfo." differs from tree implied by ".
+ " debian/patches".$xinfo;
+ }
+}
+
sub commit_quilty_patch () {
- my $output = cmdoutput @git, qw(status --porcelain);
+ my $output = cmdoutput @git, qw(status --ignored --porcelain);
my %adds;
foreach my $l (split /\n/, $output) {
next unless $l =~ m/\S/;
- if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
+ if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
$adds{$1}++;
}
}
progress "nothing quilty to commit, ok.";
return;
}
+ quiltify_nofix_bail "", " (wanted to commit patch update)";
my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
runcmd_ordryrun_local @git, qw(add -f), @adds;
commit_admin <<END
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 ../../../..",
- @git, qw(update-ref -m),
+ my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
+ git_update_ref_cmd
"dgit --dgit-view-save $msg HEAD=$headref",
$split_brain_save, $dgitview);
runcmd @cmd;
: !length $overwrite_version ? " --overwrite"
: " --overwrite=".$overwrite_version;
- mkpath '.git/dgit';
- my $pmf = ".git/dgit/pseudomerge";
+ # Contributing parent is the first parent - that makes
+ # git rev-list --first-parent DTRT.
+ my $pmf = dgit_privdir()."/pseudomerge";
open MC, ">", $pmf or die "$pmf $!";
print MC <<END or die $!;
tree $tree
infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
1;
}) {
+ $@ =~ s/^\n//; chomp $@;
print STDERR <<END;
-$us: check failed (maybe --overwrite is needed, consult documentation)
+$@
+| Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
END
- die "$@";
+ finish -1;
}
my $r = pseudomerge_make_commit
$clogp, $head, $archive_hash, $i_arch_v,
"dgit", $m;
- runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
+ runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
return $r;
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);
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)) {
+ runcmd_ordryrun_local @git_debrebase, 'stitch';
+ $actualhead = git_rev_parse('HEAD');
+ }
+
my $dgithead = $actualhead;
my $maintviewhead = undef;
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();
}
}
- if (defined $overwrite_version && !defined $maintviewhead) {
+ if (defined $overwrite_version && !defined $maintviewhead
+ && $archive_hash) {
$dgithead = plain_overwrite_pseudomerge($clogp,
$dgithead,
$archive_hash);
}
}
- 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;
files_compare_inputs($dsc, $changes)
unless forceing [qw(dsc-changes-mismatch)];
+ # Check whether this is a source only upload
+ my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
+ my $sourceonlypolicy = access_cfg 'source-only-uploads';
+ if ($sourceonlypolicy eq 'ok') {
+ } elsif ($sourceonlypolicy eq 'always') {
+ forceable_fail [qw(uploading-binaries)],
+ "uploading binaries, although distroy policy is source only"
+ if $hasdebs;
+ } elsif ($sourceonlypolicy eq 'never') {
+ forceable_fail [qw(uploading-source-only)],
+ "source-only upload, although distroy policy requires .debs"
+ if !$hasdebs;
+ } elsif ($sourceonlypolicy eq 'not-wholly-new') {
+ forceable_fail [qw(uploading-source-only)],
+ "source-only upload, even though package is entirely NEW\n".
+ "(this is contrary to policy in ".(access_nomdistro()).")"
+ if !$hasdebs
+ && $new_package
+ && !(archive_query('package_not_wholly_new', $package) // 1);
+ } else {
+ badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'";
+ }
+
# Perhaps adjust .dsc to contain right set of origs
changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
$changesfile)
}
my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
- ".git/dgit/tag");
+ dgit_privdir()."/tag");
my @tagobjfns;
supplementary_message(<<'END');
runcmd_ordryrun @git,
qw(-c push.followTags=false push), access_giturl(), @pushrefs;
- runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
+ runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
supplementary_message(<<'END');
Push failed, while obtaining signatures on the .changes and .dsc.
}
sub pre_clone () {
- no_local_git_cfg();
+ not_necessarily_a_tree();
}
sub cmd_clone {
parseopts();
}
sub branchsuite () {
- my @cmd = (@git, qw(symbolic-ref -q HEAD));
- my $branch = cmdoutput_errok @cmd;
- if (!defined $branch) {
- $?==256 or failedcmd @cmd;
- return undef;
- }
- if ($branch =~ m#$lbranch_re#o) {
+ my $branch = git_get_symref();
+ if (defined $branch && $branch =~ m#$lbranch_re#o) {
return $1;
} else {
return undef;
}
}
-sub fetchpullargs () {
+sub package_from_d_control () {
if (!defined $package) {
my $sourcep = parsecontrol('debian/control','debian/control');
$package = getfield $sourcep, 'Source';
}
+}
+
+sub fetchpullargs () {
+ package_from_d_control();
if (@ARGV==0) {
$isuite = branchsuite();
if (!$isuite) {
sub cmd_fetch {
parseopts();
fetchpullargs();
- my $multi_fetched = fork_for_multisuite(sub { });
- exit 0 if $multi_fetched;
- fetch();
+ dofetch();
}
sub cmd_pull {
pull();
}
-sub cmd_push {
+sub cmd_checkout {
+ parseopts();
+ package_from_d_control();
+ @ARGV==1 or badusage "dgit checkout needs a suite argument";
+ ($isuite) = @ARGV;
+ notpushing();
+
+ foreach my $canon (qw(0 1)) {
+ if (!$canon) {
+ $csuite= $isuite;
+ } else {
+ undef $csuite;
+ canonicalise_suite();
+ }
+ if (length git_get_ref lref()) {
+ # local branch already exists, yay
+ last;
+ }
+ if (!length git_get_ref lrref()) {
+ if (!$canon) {
+ # nope
+ next;
+ }
+ dofetch();
+ }
+ # now lrref exists
+ runcmd (@git, qw(update-ref), lref(), lrref(), '');
+ last;
+ }
+ local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
+ "dgit checkout $isuite";
+ runcmd (@git, qw(checkout), lbranch());
+}
+
+sub cmd_update_vcs_git () {
+ my $specsuite;
+ if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
+ ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
+ } else {
+ ($specsuite) = (@ARGV);
+ shift @ARGV;
+ }
+ my $dofetch=1;
+ if (@ARGV) {
+ if ($ARGV[0] eq '-') {
+ $dofetch = 0;
+ } elsif ($ARGV[0] eq '-') {
+ shift;
+ }
+ }
+
+ package_from_d_control();
+ my $ctrl;
+ if ($specsuite eq '.') {
+ $ctrl = parsecontrol 'debian/control', 'debian/control';
+ } else {
+ $isuite = $specsuite;
+ get_archive_dsc();
+ $ctrl = $dsc;
+ }
+ my $url = getfield $ctrl, 'Vcs-Git';
+
+ my @cmd;
+ my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
+ if (!defined $orgurl) {
+ print STDERR "setting up vcs-git: $url\n";
+ @cmd = (@git, qw(remote add vcs-git), $url);
+ } elsif ($orgurl eq $url) {
+ print STDERR "vcs git already configured: $url\n";
+ } else {
+ print STDERR "changing vcs-git url to: $url\n";
+ @cmd = (@git, qw(remote set-url vcs-git), $url);
+ }
+ runcmd_ordryrun_local @cmd;
+ if ($dofetch) {
+ print "fetching (@ARGV)\n";
+ runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
+ }
+}
+
+sub prep_push () {
parseopts();
- 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();
+}
+
+our $sourcechanges;
+
+sub cmd_push_source {
+ prep_push();
+ fail "dgit push-source: --include-dirty/--ignore-dirty does not make".
+ "sense with push-source!" if $includedirty;
+ if ($changesfile) {
+ my $changes = parsecontrol("$buildproductsdir/$changesfile",
+ "source changes file");
+ unless (test_source_only_changes($changes)) {
+ fail "user-specified changes file is not source-only";
+ }
+ } else {
+ # Building a source package is very fast, so just do it
+ build_source_for_push();
+ }
dopush();
}
}
sub pre_rpush () {
- no_local_git_cfg();
+ not_necessarily_a_tree();
}
sub cmd_rpush {
my $host = nextarg;
i_cleanup();
printdebug "all done\n";
- exit 0;
+ finish 0;
}
sub i_resp_file ($) {
#---------- building etc. ----------
our $version;
-our $sourcechanges;
our $dscfn;
#----- `3.0 (quilt)' handling -----
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/;
}
}
-sub quiltify_splitbrain ($$$$$$) {
- my ($clogp, $unapplied, $headref, $diffbits,
+sub quiltify_splitbrain ($$$$$$$) {
+ my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
$editedignores, $cachekey) = @_;
+ my $gitignore_special = 1;
if ($quilt_mode !~ m/gbp|dpm/) {
# treat .gitignore just like any other upstream file
$diffbits = { %$diffbits };
$_ = !!$_ foreach values %$diffbits;
+ $gitignore_special = 0;
}
# We would like any commits we generate to be reproducible
my @authline = clogp_authline($clogp);
local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
local $ENV{GIT_AUTHOR_DATE} = $authline[2];
+ my $fulldiffhint = sub {
+ my ($x,$y) = @_;
+ my $cmd = "git diff $x $y -- :/ ':!debian'";
+ $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
+ return "\nFor full diff showing the problem(s), type:\n $cmd\n";
+ };
+
if ($quilt_mode =~ m/gbp|unapplied/ &&
($diffbits->{O2H} & 01)) {
my $msg =
"--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
" but git tree differs from orig in upstream files.";
+ $msg .= $fulldiffhint->($unapplied, 'HEAD');
if (!stat_exists "debian/patches") {
$msg .=
"\n ... debian/patches is missing; perhaps this is a patch queue branch?";
}
if ($quilt_mode =~ m/dpm/ &&
($diffbits->{H2A} & 01)) {
- fail <<END;
+ fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
--quilt=$quilt_mode specified, implying patches-applied git tree
but git tree differs from result of applying debian/patches to upstream
END
}
if ($quilt_mode =~ m/gbp|dpm/ &&
($diffbits->{O2A} & 02)) {
- fail <<END
+ fail <<END;
--quilt=$quilt_mode specified, implying that HEAD is for use with a
tool which does not create patches for changes to upstream
.gitignores: but, such patches exist in debian/patches.
print SERIES "\n" or die $! unless $newline eq "\n";
print SERIES "auto-gitignore\n" or die $!;
close SERIES or die $!;
- runcmd @git, qw(add -- debian/patches/series), $gipatch;
+ runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
commit_admin <<END
Commit patch to update .gitignore
my $dgitview = git_rev_parse 'HEAD';
- changedir '../../../..';
+ 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)";
last;
}
- if ($quilt_mode eq 'nofix') {
- fail "quilt fixup required but quilt mode is \`nofix'\n".
- "HEAD commit $c->{Commit} differs from tree implied by ".
- " debian/patches (tree object $oldtiptree)";
- }
+ quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
if ($quilt_mode eq 'smash') {
printdebug " search quitting smash\n";
last;
return $s;
};
if ($quilt_mode eq 'linear') {
- print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
+ print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
foreach my $notp (@nots) {
print STDERR "$us: ", $reportnot->($notp), "\n";
}
print STDERR "$us: $_\n" foreach @$failsuggestion;
- fail "quilt fixup naive history linearisation failed.\n".
+ fail
+ "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n".
"Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
} elsif ($quilt_mode eq 'smash') {
} elsif ($quilt_mode eq 'auto') {
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($symref, $headref)) {
+ # This is much faster. It also makes patches that gdr
+ # likes better for future updates without laundering.
+ #
+ # However, it can fail in some casses where we would
+ # succeed: if there are existing patches, which correspond
+ # to a prefix of the branch, but are not in gbp/gdr
+ # format, gdr will fail (exiting status 7), but we might
+ # be able to figure out where to start linearising. That
+ # will be slower so hopefully there's not much to do.
+ my @cmd = (@git_debrebase,
+ qw(--noop-ok -funclean-mixed -funclean-ordering
+ make-patches --quiet-would-amend));
+ # We tolerate soe snags that gdr wouldn't, by default.
+ if (act_local()) {
+ debugcmd "+",@cmd;
+ $!=0; $?=-1;
+ failedcmd @cmd if system @cmd and $?!=7*256;
+ } else {
+ dryrun_report @cmd;
+ }
+ $headref = git_rev_parse('HEAD');
+ }
prep_ud();
- changedir $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 ($) {
+sub unpack_playtree_mkwork ($) {
my ($headref) = @_;
mkdir "work" or die $!;
runcmd @git, qw(reset -q --hard), $headref;
}
-sub quilt_fixup_linkorigs ($$) {
+sub unpack_playtree_linkorigs ($$) {
my ($upstreamversion, $fn) = @_;
# calls $fn->($leafname);
- foreach my $f (<../../../../*>) { #/){
- my $b=$f; $b =~ s{.*/}{};
+ my $bpd_abs = bpd_abs();
+ opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
+ while ($!=0, defined(my $b = readdir QFD)) {
+ my $f = bpd_abs()."/".$b;
{
local ($debuglevel) = $debuglevel-1;
printdebug "QF linkorigs $b, $f ?\n";
link_ltarget $f, $b or die "$b $!";
$fn->($b);
}
+ die "$buildproductsdir: $!" if $!;
+ closedir QFD;
}
sub quilt_fixup_delete_pc () {
# get it to generate debian/patches/debian-changes, it is
# necessary to build the source package.
- quilt_fixup_linkorigs($upstreamversion, sub { });
- quilt_fixup_mkwork($headref);
+ unpack_playtree_linkorigs($upstreamversion, sub { });
+ unpack_playtree_mkwork($headref);
rmtree("debian/patches");
print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
};
- quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
+ unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
my @files=qw(debian/source/format debian/rules
debian/control debian/changelog);
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;
+ finish 0;
}
exec @cmd; die $!;
}
next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
my $cachehit = $1;
- quilt_fixup_mkwork($headref);
+ unpack_playtree_mkwork($headref);
my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
if ($cachehit ne $headref) {
progress "dgit view: found cached ($saved)";
rmtree '.pc';
+ rmtree 'debian'; # git checkout commitish paths does not delete!
runcmd @git, qw(checkout -f), $headref, qw(-- debian);
my $unapplied=git_add_write_tree();
printdebug "fake orig tree object $unapplied\n";
failed to apply your git tree's patch stack (from debian/patches/) to
the corresponding upstream tarball(s). Your source tree and .orig
are probably too inconsistent. dgit can only fix up certain kinds of
- anomaly (depending on the quilt mode). See --quilt= in dgit(1).
+ anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
END
}
changedir '..';
- quilt_fixup_mkwork($headref);
+ unpack_playtree_mkwork($headref);
my $mustdeletepc=0;
if (stat_exists ".pc") {
" --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
if (quiltmode_splitbrain()) {
- quiltify_splitbrain($clogp, $unapplied, $headref,
+ quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
$diffbits, \%editedignores,
$splitbrain_cachekey);
return;
}
I2->error and die $!;
close O or die $1;
- exit 0;
+ finish 0;
}
sub maybe_apply_patches_dirtily () {
maybe_unapply_patches_again();
}
-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;
+# return values from massage_dbp_args are one or both of these flags
+sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
+sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
+
+sub build_or_push_prep_early () {
+ our $build_or_push_prep_early_done //= 0;
+ return if $build_or_push_prep_early_done++;
+ badusage "-p is not allowed with dgit $subcommand" if defined $package;
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();
}
sub changesopts_version () {
if (!defined $changes_since_version) {
- my @vsns = archive_query('archive_query');
- my @quirk = access_quirk();
- if ($quirk[0] eq 'backports') {
- local $isuite = $quirk[2];
- local $csuite;
- canonicalise_suite();
- push @vsns, archive_query('archive_query');
+ my @vsns;
+ unless (eval {
+ @vsns = archive_query('archive_query');
+ my @quirk = access_quirk();
+ if ($quirk[0] eq 'backports') {
+ local $isuite = $quirk[2];
+ local $csuite;
+ canonicalise_suite();
+ push @vsns, archive_query('archive_query');
+ }
+ 1;
+ }) {
+ print STDERR $@;
+ fail
+ "archive query failed (queried because --since-version not specified)";
}
if (@vsns) {
@vsns = map { $_->[0] } @vsns;
# unless we're not doing a split build and want dpkg-source
# as cleanmode, in which case we can do nothing
#
- # return values:
- # 0 - source will NOT need to be built separately by caller
- # +1 - source will need to be built separately by caller
- # +2 - source will need to be built separately by caller AND
- # dpkg-buildpackage should not in fact be run at all!
debugcmd '#massaging#', @$cmd if $debuglevel>1;
#print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
$clean_using_builder = 1;
- return 0;
+ return WANTSRC_BUILDER;
}
# -nc has the side effect of specifying -b if nothing else specified
# and some combinations of -S, -b, et al, are errors, rather than
}
push @$cmd, '-nc';
#print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
- my $r = 0;
+ my $r = WANTSRC_BUILDER;
if ($need_split_build_invocation) {
printdebug "massage split $dmode.\n";
- $r = $dmode =~ m/[S]/ ? +2 :
- $dmode =~ y/gGF/ABb/ ? +1 :
- $dmode =~ m/[ABb]/ ? 0 :
+ $r = $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
+ $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
+ $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
die "$dmode ?";
}
printdebug "massage done $r $dmode.\n";
return $r;
}
-sub in_parent (&) {
+sub in_bpd (&) {
my ($fn) = @_;
my $wasdir = must_getcwd();
- changedir "..";
+ changedir $buildproductsdir;
$fn->();
changedir $wasdir;
}
-sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
+# this sub must run with CWD=$buildproductsdir (eg in in_bpd)
+sub postbuild_mergechanges ($) {
my ($msg_if_onlyone) = @_;
# If there is only one .changes file, fail with $msg_if_onlyone,
# or if that is undef, be a no-op.
# Returns the changes file to report to the user.
my $pat = changespat $version;
- my @changesfiles = glob $pat;
+ my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
@changesfiles = sort {
($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
or $a cmp $b
sub midbuild_checkchanges () {
my $pat = changespat $version;
return if $rmchanges;
- my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
- @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
+ my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
+ @unwanted = grep {
+ $_ ne changespat $version,'source' and
+ $_ ne changespat $version,'multi'
+ } @unwanted;
fail <<END
changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
Suggest you delete @unwanted.
sub midbuild_checkchanges_vanilla ($) {
my ($wantsrc) = @_;
- midbuild_checkchanges() if $wantsrc == 1;
+ midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
}
sub postbuild_mergechanges_vanilla ($) {
my ($wantsrc) = @_;
- if ($wantsrc == 1) {
- in_parent {
+ if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
+ in_bpd {
postbuild_mergechanges(undef);
};
} else {
build_prep_early();
my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
my $wantsrc = massage_dbp_args \@dbp;
- if ($wantsrc > 0) {
+ if ($wantsrc & WANTSRC_SOURCE) {
build_source();
midbuild_checkchanges_vanilla $wantsrc;
} else {
build_prep();
}
- if ($wantsrc < 2) {
+ if ($wantsrc & WANTSRC_BUILDER) {
push @dbp, changesopts_version();
maybe_apply_patches_dirtily();
runcmd_ordryrun_local @dbp;
# orig is absent.
my $upstreamversion = upstreamversion $version;
my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
- my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
+ my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
if ($gbp_make_orig) {
clean_tree();
}
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;
}
}
- if ($wantsrc > 0) {
+ if ($wantsrc & WANTSRC_SOURCE) {
build_source();
midbuild_checkchanges_vanilla $wantsrc;
} else {
build_prep();
}
maybe_unapply_patches_again();
- if ($wantsrc < 2) {
+ if ($wantsrc & WANTSRC_BUILDER) {
push @cmd, changesopts();
runcmd_ordryrun_local @cmd, @ARGV;
}
}
sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
+sub build_source_for_push {
+ build_source();
+ die "er, patches are applied dirtily but shouldn't be.."
+ if $patches_applied_dirtily;
+ $changesfile = $sourcechanges;
+}
+
sub build_source {
build_prep_early();
- my $our_cleanmode = $cleanmode;
- if ($need_split_build_invocation) {
- # Pretend that clean is being done some other way. This
- # forces us not to try to use dpkg-buildpackage to clean and
- # build source all in one go; and instead we run dpkg-source
- # (and build_prep() will do the clean since $clean_using_builder
- # is false).
- $our_cleanmode = 'ELSEWHERE';
- }
- if ($our_cleanmode =~ m/^dpkg-source/) {
- # dpkg-source invocation (below) will clean, so build_prep shouldn't
- $clean_using_builder = 1;
- }
build_prep();
$sourcechanges = changespat $version,'source';
if (act_local()) {
- unlink "../$sourcechanges" or $!==ENOENT
+ unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
or fail "remove $sourcechanges: $!";
}
$dscfn = dscfn($version);
- if ($our_cleanmode eq 'dpkg-source') {
- maybe_apply_patches_dirtily();
- runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
- changesopts();
- } elsif ($our_cleanmode eq 'dpkg-source-d') {
- maybe_apply_patches_dirtily();
- runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
- changesopts();
+ my @cmd = (@dpkgsource, qw(-b --));
+ if ($split_brain) {
+ changedir $playground;
+ runcmd_ordryrun_local @cmd, "work";
+ my @udfiles = <${package}_*>;
+ changedir $maindir;
+ foreach my $f (@udfiles) {
+ printdebug "source copy, found $f\n";
+ next unless
+ $f eq $dscfn or
+ ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
+ $f eq srcfn($version, $&));
+ printdebug "source copy, found $f - renaming\n";
+ rename "$playground/$f", "$buildproductsdir/$f" or $!==ENOENT
+ or fail "put in place new source file ($f): $!";
+ }
} else {
- my @cmd = (@dpkgsource, qw(-b --));
- if ($split_brain) {
- changedir $ud;
- runcmd_ordryrun_local @cmd, "work";
- my @udfiles = <${package}_*>;
- changedir "../../..";
- foreach my $f (@udfiles) {
- printdebug "source copy, found $f\n";
- next unless
- $f eq $dscfn or
- ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
- $f eq srcfn($version, $&));
- printdebug "source copy, found $f - renaming\n";
- rename "$ud/$f", "../$f" or $!==ENOENT
- or fail "put in place new source file ($f): $!";
- }
- } else {
- my $pwd = must_getcwd();
- my $leafdir = basename $pwd;
- changedir "..";
- runcmd_ordryrun_local @cmd, $leafdir;
- changedir $pwd;
- }
- runcmd_ordryrun_local qw(sh -ec),
- 'exec >$1; shift; exec "$@"','x',
- "../$sourcechanges",
- @dpkggenchanges, qw(-S), changesopts();
+ my $pwd = must_getcwd();
+ my $leafdir = basename $pwd;
+ changedir "..";
+ runcmd_ordryrun_local @cmd, $leafdir;
+ changedir $pwd;
}
+ runcmd_ordryrun_local qw(sh -ec),
+ 'exec >$1; shift; exec "$@"','x',
+ "$buildproductsdir/$sourcechanges",
+ @dpkggenchanges, qw(-S), changesopts();
}
sub cmd_build_source {
sub cmd_sbuild {
build_source();
midbuild_checkchanges();
- in_parent {
+ in_bpd {
if (act_local()) {
stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
stat_exists $sourcechanges
runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
};
maybe_unapply_patches_again();
- in_parent {
+ in_bpd {
postbuild_mergechanges(<<END);
perhaps you need to pass -A ? (sbuild's default is to build only
arch-specific binaries; dgit 1.4 used to override that.)
sub import_dsc_result {
my ($dstref, $newhash, $what_log, $what_msg) = @_;
- my @cmd = (@git, qw(update-ref -m), $what_log, $dstref, $newhash);
+ my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
runcmd @cmd;
check_gitattrs($newhash, "source tree");
my @dfi = dsc_files_info();
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
- my $here = "../$f";
+ my $here = "$buildproductsdir/$f";
if (lstat $here) {
next if stat $here;
fail "lstat $here works but stat gives $! !";
}
sub 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;
my ($subpath) = @ARGV;
+ local $isuite = 'DGIT-API-QUERY-CMD';
my @cmd = archive_api_query_cmd($subpath);
push @cmd, qw(-f);
debugcmd ">",@cmd;
}
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';
sub cmd_version {
print "dgit version $our_version\n" or die $!;
- exit 0;
+ finish 0;
}
our (%valopts_long, %valopts_short);
} elsif (m/^--(gbp|dpm)$/s) {
push @ropts, "--quilt=$1";
$quilt_mode = $1;
- } elsif (m/^--ignore-dirty$/s) {
+ } elsif (m/^--(?:ignore|include)-dirty$/s) {
push @ropts, $_;
- $ignoredirty = 1;
+ $includedirty = 1;
} elsif (m/^--no-quilt-fixup$/s) {
push @ropts, $_;
$quilt_mode = 'nocheck';
$need_split_build_invocation ||= quiltmode_splitbrain();
+ fail "dgit: --include-dirty is not supported in split view quilt mode"
+ if $split_brain && $includedirty;
+
if (!defined $cleanmode) {
local $access_forpush;
$cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
badcfg "unknown clean-mode \`$cleanmode'" unless
$cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
}
+
+ $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
+ $buildproductsdir //= '..';
+ $bpd_glob = $buildproductsdir;
+ $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
}
if ($ENV{$fakeeditorenv}) {
if $dryrun_level == 1;
if (!@ARGV) {
print STDERR $helpmsg or die $!;
- exit 8;
+ finish 8;
}
-my $cmd = shift @ARGV;
+$cmd = $subcommand = shift @ARGV;
$cmd =~ y/-/_/;
my $pre_fn = ${*::}{"pre_$cmd"};
$pre_fn->() if $pre_fn;
+record_maindir if $invoked_in_git_tree;
git_slurp_config();
my $fn = ${*::}{"cmd_$cmd"};
$fn or badusage "unknown operation $cmd";
$fn->();
+
+finish 0;
~ianmdlvl / dgit.git / blobdiff