# dgit
# Integration between git and Debian-style archives
#
-# Copyright (C)2013-2015 Ian Jackson
+# Copyright (C)2013-2016 Ian Jackson
#
# 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
use IPC::Open2;
use Digest::SHA;
use Digest::MD5;
+use List::Util qw(any);
+use List::MoreUtils qw(pairwise);
+use Text::Glob qw(match_glob);
+use Fcntl qw(:DEFAULT :flock);
+use Carp;
use Debian::Dgit;
our $our_version = 'UNRELEASED'; ###substituted###
+our $absurdity = undef; ###substituted###
-our @rpushprotovsn_support = qw(3 2);
+our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
our $protovsn;
our $isuite = 'unstable';
our $existing_package = 'dpkg';
our $cleanmode;
our $changes_since_version;
+our $rmchanges;
+our $overwrite_version; # undef: not specified; '': check changelog
our $quilt_mode;
-our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck';
+our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
+our $split_brain_save;
our $we_are_responder;
our $initiator_tempdir;
+our $patches_applied_dirtily = 00;
+our $tagformat_want;
+our $tagformat;
+our $tagformatfn;
+
+our %forceopts = map { $_=>0 }
+ qw(unrepresentable unsupported-source-format
+ dsc-changes-mismatch changes-origs-exactly
+ import-gitapply-absurd
+ import-gitapply-no-absurd
+ import-dsc-with-dgit-field);
our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
our $suite_re = '[-+.0-9a-z]+';
our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
+our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
+our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
+our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
+
+our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
+our $splitbraincache = 'dgit-intern/quilt-cache';
our (@git) = qw(git);
our (@dget) = qw(dget);
-our (@curl) = qw(curl -f);
+our (@curl) = qw(curl);
our (@dput) = qw(dput);
our (@debsign) = qw(debsign);
our (@gpg) = qw(gpg);
-our (@sbuild) = qw(sbuild -A);
+our (@sbuild) = qw(sbuild);
our (@ssh) = 'ssh';
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 (@dpkggenchanges) = qw(dpkg-genchanges);
our (@mergechanges) = qw(mergechanges -f);
+our (@gbp_build) = ('');
+our (@gbp_pq) = ('gbp pq');
our (@changesopts) = ('');
our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
'ssh' => \@ssh,
'dgit' => \@dgit,
'git' => \@git,
+ 'apt-get' => \@aptget,
+ 'apt-cache' => \@aptcache,
'dpkg-source' => \@dpkgsource,
'dpkg-buildpackage' => \@dpkgbuildpackage,
'dpkg-genchanges' => \@dpkggenchanges,
+ 'gbp-build' => \@gbp_build,
+ 'gbp-pq' => \@gbp_pq,
'ch' => \@changesopts,
'mergechanges' => \@mergechanges);
autoflush STDOUT 1;
our $supplementary_message = '';
+our $need_split_build_invocation = 0;
+our $split_brain = 0;
END {
local ($@, $?);
our $csuite;
our $instead_distro;
+if (!defined $absurdity) {
+ $absurdity = $0;
+ $absurdity =~ s{/[^/]+$}{/absurd} or die;
+}
+
+sub debiantag ($$) {
+ my ($v,$distro) = @_;
+ return $tagformatfn->($v, $distro);
+}
+
+sub debiantag_maintview ($$) {
+ my ($v,$distro) = @_;
+ $v =~ y/~:/_%/;
+ return "$distro/$v";
+}
+
+sub madformat ($) { $_[0] eq '3.0 (quilt)' }
+
sub lbranch () { return "$branchprefix/$csuite"; }
my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
sub lref () { return "refs/heads/".lbranch(); }
sub rrref () { return server_ref($csuite); }
sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
+sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
+
+# We fetch some parts of lrfetchrefs/*. Ideally we delete these
+# locally fetched refs because they have unhelpful names and clutter
+# up gitk etc. So we track whether we have "used up" head ref (ie,
+# whether we have made another local ref which refers to this object).
+#
+# (If we deleted them unconditionally, then we might end up
+# re-fetching the same git objects each time dgit fetch was run.)
+#
+# So, leach use of lrfetchrefs needs to be accompanied by arrangements
+# in git_fetch_us to fetch the refs in question, and possibly a call
+# to lrfetchref_used.
+
+our (%lrfetchrefs_f, %lrfetchrefs_d);
+# $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
+
+sub lrfetchref_used ($) {
+ my ($fullrefname) = @_;
+ my $objid = $lrfetchrefs_f{$fullrefname};
+ $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
+}
sub stripepoch ($) {
my ($vsn) = @_;
return srcfn($vsn,".dsc");
}
+sub changespat ($;$) {
+ my ($vsn, $arch) = @_;
+ return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
+}
+
+sub upstreamversion ($) {
+ my ($vsn) = @_;
+ $vsn =~ s/-[^-]+$//;
+ return $vsn;
+}
+
our $us = 'dgit';
initdebug('');
local ($?);
foreach my $f (@end) {
eval { $f->(); };
- warn "$us: cleanup: $@" if length $@;
+ print STDERR "$us: cleanup: $@" if length $@;
}
};
sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
+sub forceable_fail ($$) {
+ my ($forceoptsl, $msg) = @_;
+ fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
+ print STDERR "warning: overriding problem due to --force:\n". $msg;
+}
+
+sub forceing ($) {
+ my ($forceoptsl) = @_;
+ my @got = grep { $forceopts{$_} } @$forceoptsl;
+ return 0 unless @got;
+ print STDERR
+ "warning: skipping checks or functionality due to --force-$got[0]\n";
+}
+
sub no_such_package () {
print STDERR "$us: package $package does not exist in suite $isuite\n";
exit 4;
}
-sub fetchspec () {
- local $csuite = '*';
- return "+".rrref().":".lrref();
-}
-
sub changedir ($) {
my ($newdir) = @_;
printdebug "CD $newdir\n";
- chdir $newdir or die "chdir: $newdir: $!";
+ chdir $newdir or confess "chdir: $newdir: $!";
}
sub deliberately ($) {
}
}
+sub quiltmode_splitbrain () {
+ $quilt_mode =~ m/gbp|dpm|unapplied/;
+}
+
+sub opts_opt_multi_cmd {
+ my @cmd;
+ push @cmd, split /\s+/, shift @_;
+ push @cmd, @_;
+ @cmd;
+}
+
+sub gbp_pq {
+ return opts_opt_multi_cmd @gbp_pq;
+}
+
#---------- remote protocol support, common ----------
# remote push initiator/responder protocol:
# where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
# < dgit-remote-push-ready <actual-proto-vsn>
#
+# occasionally:
+#
+# > progress NBYTES
+# [NBYTES message]
+#
+# > supplementary-message NBYTES # $protovsn >= 3
+# [NBYTES message]
+#
+# main sequence:
+#
# > file parsed-changelog
# [indicates that output of dpkg-parsechangelog follows]
# > data-block NBYTES
# > file changes
# [etc]
#
-# > param head HEAD
+# > param head DGIT-VIEW-HEAD
+# > param csuite SUITE
+# > param tagformat old|new
+# > param maint-view MAINT-VIEW-HEAD
+#
+# > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
+# # goes into tag, for replay prevention
#
# > want signed-tag
# [indicates that signed tag is wanted]
sub runcmd {
debugcmd "+",@_;
- $!=0; $?=0;
+ $!=0; $?=-1;
failedcmd @_ if system @_;
}
sub printdone {
if (!$dryrun_level) {
- progress "dgit ok: @_";
+ progress "$us ok: @_";
} else {
progress "would be ok: @_ (but dry run only)";
}
our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
our %defcfg = ('dgit.default.distro' => 'debian',
+ 'dgit-suite.*-security.distro' => 'debian-security',
'dgit.default.username' => '',
'dgit.default.archive-query-default-component' => 'main',
'dgit.default.ssh' => 'ssh',
'dgit.default.archive-query' => 'madison:',
'dgit.default.sshpsql-dbname' => 'service=projectb',
+ 'dgit.default.aptget-components' => 'main',
+ 'dgit.default.dgit-tag-format' => 'new,old,maint',
+ # old means "repo server accepts pushes with old dgit tags"
+ # new means "repo server accepts pushes with new dgit tags"
+ # maint means "repo server accepts split brain pushes"
+ # hist means "repo server may have old pushes without new tag"
+ # ("hist" is implied by "old")
'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
'dgit-distro.debian.git-check' => 'url',
'dgit-distro.debian.git-check-suffix' => '/info/refs',
'dgit-distro.debian.git-url-suffix' => '',
'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
+ 'dgit-distro.debian-security.archive-query' => 'aptget:',
+ 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
+ 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
+ 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
+ 'dgit-distro.debian-security.nominal-distro' => 'debian',
'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
'dgit-distro.ubuntu.git-check' => 'false',
'dgit-distro.test-dummy.git-url' => "$td/git",
'dgit-distro.test-dummy.git-host' => "git",
'dgit-distro.test-dummy.git-path' => "$td/git",
- 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
+ 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
'dgit-distro.test-dummy.upload-host' => 'test-dummy',
);
-our %gitcfg;
+our %gitcfgs;
+our @gitcfgsources = qw(cmdline local global system);
sub git_slurp_config () {
local ($debuglevel) = $debuglevel-2;
local $/="\0";
- my @cmd = (@git, qw(config -z --get-regexp .*));
- debugcmd "|",@cmd;
-
- open GITS, "-|", @cmd or failedcmd @cmd;
- while (<GITS>) {
- chomp or die;
- printdebug "=> ", (messagequote $_), "\n";
- m/\n/ or die "$_ ?";
- push @{ $gitcfg{$`} }, $'; #';
+ # 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;
}
- $!=0; $?=0;
- close GITS
- or ($!==0 && $?==256)
- or failedcmd @cmd;
}
sub git_get_config ($) {
my ($c) = @_;
- my $l = $gitcfg{$c};
- printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
- if $debuglevel >= 4;
- $l or return undef;
- @$l==1 or badcfg "multiple values for $c" if @$l > 1;
- return $l->[0];
+ foreach my $src (@gitcfgsources) {
+ my $l = $gitcfgs{$src}{$c};
+ printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
+ if $debuglevel >= 4;
+ $l or next;
+ @$l==1 or badcfg "multiple values for $c".
+ " (in $src git config)" if @$l > 1;
+ return $l->[0];
+ }
+ return undef;
}
sub cfg {
if (defined $idistro) {
return $idistro;
} else {
- return cfg("dgit-suite.$isuite.distro",
- "dgit.default.distro");
+ my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
+ return $def if defined $def;
+ foreach my $src (@gitcfgsources, 'internal') {
+ my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
+ next unless $kl;
+ foreach my $k (keys %$kl) {
+ next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
+ my $dpat = $1;
+ next unless match_glob $dpat, $isuite;
+ return $kl->{$k};
+ }
+ }
+ return cfg("dgit.default.distro");
}
}
+sub access_nomdistro () {
+ my $base = access_basedistro();
+ return cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
+}
+
sub access_quirk () {
# returns (quirk name, distro to use instead or undef, quirk-specific info)
my $basedistro = access_basedistro();
unshift @l, $instead_distro;
@l = grep { defined } @l;
+ push @l, access_nomdistro();
+
if (access_forpush()) {
@l = map { ("$_/push", $_) } @l;
}
}
sub parsecontrol {
- my ($file, $desc) = @_;
+ my ($file, $desc, $allowsigned) = @_;
my $fh = new IO::Handle;
open $fh, '<', $file or die "$file: $!";
- my $c = parsecontrolfh($fh,$desc);
+ my $c = parsecontrolfh($fh,$desc,$allowsigned);
$fh->error and die $!;
close $fh;
return $c;
my ($dctrl,$field) = @_;
my $v = $dctrl->{$field};
return $v if defined $v;
- fail "missing field $field in ".$v->get_option('name');
+ fail "missing field $field in ".$dctrl->get_option('name');
}
sub parsechangelog {
- my $c = Dpkg::Control::Hash->new();
+ my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
my $p = new IO::Handle;
my @cmd = (qw(dpkg-parsechangelog), @_);
open $p, '-|', @cmd or die $!;
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";
+ 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;
+ $dsc = parsecontrolfh($dscfh,$dscurl,1);
+ printdebug Dumper($dsc) if $debuglevel>1;
+}
+
our %rmad;
-sub archive_query ($) {
- my ($method) = @_;
+sub archive_query ($;@) {
+ my ($method) = shift @_;
+ fail "this operation does not support multiple comma-separated suites"
+ if $isuite =~ m/,/;
my $query = access_cfg('archive-query','RETURN-UNDEF');
$query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
my $proto = $1;
my $data = $'; #';
- { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
+ { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
+}
+
+sub archive_query_prepend_mirror {
+ my $m = access_cfg('mirror');
+ return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
}
sub pool_dsc_subpath ($$) {
return "/pool/$component/$prefix/$package/".dscfn($vsn);
}
+sub cfg_apply_map ($$$) {
+ my ($varref, $what, $mapspec) = @_;
+ return unless $mapspec;
+
+ printdebug "config $what EVAL{ $mapspec; }\n";
+ $_ = $$varref;
+ eval "package Dgit::Config; $mapspec;";
+ die $@ if $@;
+ $$varref = $_;
+}
+
#---------- `ftpmasterapi' archive query method (nascent) ----------
sub archive_api_query_cmd ($) {
my ($subpath) = @_;
- my @cmd = qw(curl -sS);
+ my @cmd = (@curl, qw(-sS));
my $url = access_cfg('archive-query-url');
if ($url =~ m#^https://([-.0-9a-z]+)/#) {
my $host = $1;
return @cmd;
}
-sub api_query ($$) {
+sub api_query ($$;$) {
use JSON;
- my ($data, $subpath) = @_;
+ my ($data, $subpath, $ok404) = @_;
badcfg "ftpmasterapi archive query method takes no data part"
if length $data;
my @cmd = archive_api_query_cmd($subpath);
+ my $url = $cmd[$#cmd];
+ push @cmd, qw(-w %{http_code});
my $json = cmdoutput @cmd;
+ unless ($json =~ s/\d+\d+\d$//) {
+ failedcmd_report_cmd undef, @cmd;
+ fail "curl failed to print 3-digit HTTP code";
+ }
+ my $code = $&;
+ return undef if $code eq '404' && $ok404;
+ fail "fetch of $url gave HTTP code $code"
+ unless $url =~ m#^file://# or $code =~ m/^2/;
return decode_json($json);
}
-sub canonicalise_suite_ftpmasterapi () {
+sub canonicalise_suite_ftpmasterapi {
my ($proto,$data) = @_;
my $suites = api_query($data, 'suites');
my @matched;
return $cn;
}
-sub archive_query_ftpmasterapi () {
+sub archive_query_ftpmasterapi {
my ($proto,$data) = @_;
my $info = api_query($data, "dsc_in_suite/$isuite/$package");
my @rows;
if length $@;
}
@rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
- return @rows;
+ return archive_query_prepend_mirror @rows;
+}
+
+sub file_in_archive_ftpmasterapi {
+ my ($proto,$data,$filename) = @_;
+ my $pat = $filename;
+ $pat =~ s/_/\\_/g;
+ $pat = "%/$pat";
+ $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
+ my $info = api_query($data, "file_in_archive/$pat", 1);
+}
+
+#---------- `aptget' archive query method ----------
+
+our $aptget_base;
+our $aptget_releasefile;
+our $aptget_configpath;
+
+sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
+sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
+
+sub aptget_cache_clean {
+ runcmd_ordryrun_local qw(sh -ec),
+ 'cd "$1"; pwd; find -atime +30 -type f -print0 | xargs -0r echo rm --',
+ 'x', $aptget_base;
+}
+
+sub aptget_lock_acquire () {
+ my $lockfile = "$aptget_base/lock";
+ open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
+ flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
+}
+
+sub aptget_prep ($) {
+ my ($data) = @_;
+ return if defined $aptget_base;
+
+ badcfg "aptget archive query method takes no data part"
+ if length $data;
+
+ my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
+
+ ensuredir $cache;
+ ensuredir "$cache/dgit";
+ my $cachekey =
+ access_cfg('aptget-cachekey','RETURN-UNDEF')
+ // access_nomdistro();
+
+ $aptget_base = "$cache/dgit/aptget";
+ ensuredir $aptget_base;
+
+ my $quoted_base = $aptget_base;
+ die "$quoted_base contains bad chars, cannot continue"
+ if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
+
+ ensuredir $aptget_base;
+
+ aptget_lock_acquire();
+
+ aptget_cache_clean();
+
+ $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
+ my $sourceslist = "source.list#$cachekey";
+
+ my $aptsuites = $isuite;
+ cfg_apply_map(\$aptsuites, 'suite map',
+ access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
+
+ open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
+ printf SRCS "deb-src %s %s %s\n",
+ access_cfg('mirror'),
+ $aptsuites,
+ access_cfg('aptget-components')
+ or die $!;
+
+ ensuredir "$aptget_base/cache";
+ ensuredir "$aptget_base/lists";
+
+ open CONF, ">", $aptget_configpath or die $!;
+ print CONF <<END;
+Debug::NoLocking "true";
+APT::Get::List-Cleanup "false";
+#clear APT::Update::Post-Invoke-Success;
+Dir::Etc::SourceList "$quoted_base/$sourceslist";
+Dir::State::Lists "$quoted_base/lists";
+Dir::Etc::preferences "$quoted_base/preferences";
+Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
+Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
+END
+
+ foreach my $key (qw(
+ Dir::Cache
+ Dir::State
+ Dir::Cache::Archives
+ Dir::Etc::SourceParts
+ Dir::Etc::preferencesparts
+ )) {
+ ensuredir "$aptget_base/$key";
+ print CONF "$key \"$quoted_base/$key\";\n" or die $!;
+ };
+
+ my $oldatime = (time // die $!) - 1;
+ foreach my $oldlist (<$aptget_base/lists/*Release>) {
+ next unless stat_exists $oldlist;
+ my ($mtime) = (stat _)[9];
+ utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
+ }
+
+ runcmd_ordryrun_local aptget_aptget(), qw(update);
+
+ my @releasefiles;
+ foreach my $oldlist (<$aptget_base/lists/*Release>) {
+ next unless stat_exists $oldlist;
+ my ($atime) = (stat _)[8];
+ next if $atime == $oldatime;
+ push @releasefiles, $oldlist;
+ }
+ my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
+ @releasefiles = @inreleasefiles if @inreleasefiles;
+ die "apt updated wrong number of Release files (@releasefiles), erk"
+ unless @releasefiles == 1;
+
+ ($aptget_releasefile) = @releasefiles;
+}
+
+sub canonicalise_suite_aptget {
+ my ($proto,$data) = @_;
+ aptget_prep($data);
+
+ my $release = parsecontrol $aptget_releasefile, "Release file", 1;
+
+ foreach my $name (qw(Codename Suite)) {
+ my $val = $release->{$name};
+ if (defined $val) {
+ printdebug "release file $name: $val\n";
+ $val =~ m/^$suite_re$/o or fail
+ "Release file ($aptget_releasefile) specifies intolerable $name";
+ cfg_apply_map(\$val, 'suite rmap',
+ access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
+ return $val
+ }
+ }
+ return $isuite;
+}
+
+sub archive_query_aptget {
+ my ($proto,$data) = @_;
+ aptget_prep($data);
+
+ ensuredir "$aptget_base/source";
+ foreach my $old (<$aptget_base/source/*.dsc>) {
+ unlink $old or die "$old: $!";
+ }
+
+ my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
+ return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
+ # avoids apt-get source failing with ambiguous error code
+
+ runcmd_ordryrun_local
+ shell_cmd 'cd "$1"/source; shift', $aptget_base,
+ aptget_aptget(), qw(--download-only --only-source source), $package;
+
+ my @dscs = <$aptget_base/source/*.dsc>;
+ fail "apt-get source did not produce a .dsc" unless @dscs;
+ fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
+
+ my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
+
+ use URI::Escape;
+ my $uri = "file://". uri_escape $dscs[0];
+ $uri =~ s{\%2f}{/}gi;
+ return [ (getfield $pre_dsc, 'Version'), $uri ];
+}
+
+#---------- `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) = @_;
+ 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);
+ 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;
+ return \@out;
}
#---------- `madison' archive query method ----------
sub archive_query_madison {
- return map { [ @$_[0..1] ] } madison_get_parse(@_);
+ return archive_query_prepend_mirror
+ map { [ @$_[0..1] ] } madison_get_parse(@_);
}
sub madison_get_parse {
return $r[0][2];
}
+sub file_in_archive_madison { return undef; }
+
#---------- `sshpsql' archive query method ----------
sub sshpsql ($$$) {
my ($vsn,$component,$filename,$sha256sum) = @$_;
[ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
} @rows;
- return @rows;
+ return archive_query_prepend_mirror @rows;
}
sub canonicalise_suite_sshpsql ($$) {
return $rows[0];
}
+sub file_in_archive_sshpsql ($$$) { return undef; }
+
#---------- `dummycat' archive query method ----------
sub canonicalise_suite_dummycat ($$) {
}
C->error and die "$dpath: $!";
close C;
- return sort { -version_compare($a->[0],$b->[0]); } @rows;
+ return archive_query_prepend_mirror
+ sort { -version_compare($a->[0],$b->[0]); } @rows;
+}
+
+sub file_in_archive_dummycat () { return undef; }
+
+#---------- tag format handling ----------
+
+sub access_cfg_tagformats () {
+ split /\,/, access_cfg('dgit-tag-format');
+}
+
+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 ----------
$csuite = archive_query('canonicalise_suite');
if ($isuite ne $csuite) {
progress "canonical suite name for $isuite is $csuite";
+ } else {
+ progress "canonical suite name is $csuite";
}
}
canonicalise_suite();
my @vsns = archive_query('archive_query');
foreach my $vinfo (@vsns) {
- my ($vsn,$subpath,$digester,$digest) = @$vinfo;
- $dscurl = access_cfg('mirror').$subpath;
+ my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
+ $dscurl = $vsn_dscurl;
$dscdata = url_get($dscurl);
if (!$dscdata) {
$skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
fail "$dscurl has hash $got but".
" archive told us to expect $digest";
}
- my $dscfh = new IO::File \$dscdata, '<' or die $!;
- printdebug Dumper($dscdata) if $debuglevel>1;
- $dsc = parsecontrolfh($dscfh,$dscurl,1);
- printdebug Dumper($dsc) if $debuglevel>1;
+ parse_dscdata();
my $fmt = getfield $dsc, 'Format';
- fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
+ $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
+ "unsupported source format $fmt, sorry";
+
$dsc_checked = !!$digester;
+ printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
return;
}
$dsc = undef;
+ printdebug "get_archive_dsc: nothing in archive, returning undef\n";
}
sub check_for_git ();
" set -e; cd ".access_cfg('git-path').";".
" if test -d $package.git; then echo 1; else echo 0; fi");
my $r= cmdoutput @cmd;
- if ($r =~ m/^divert (\w+)$/) {
+ if (defined $r and $r =~ m/^divert (\w+)$/) {
my $divert=$1;
my ($usedistro,) = access_distros();
# NB that if we are pushing, $usedistro will be $distro/push
progress "diverting to $divert (using config for $instead_distro)";
return check_for_git();
}
- failedcmd @cmd unless $r =~ m/^[01]$/;
+ failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
return $r+0;
} elsif ($how eq 'url') {
my $prefix = access_cfg('git-check-url','git-url');
my $suffix = access_cfg('git-check-suffix','git-suffix',
'RETURN-UNDEF') // '.git';
my $url = "$prefix/$package$suffix";
- my @cmd = (qw(curl -sS -I), $url);
+ my @cmd = (@curl, qw(-sS -I), $url);
my $result = cmdoutput @cmd;
$result =~ s/^\S+ 200 .*\n\r?\n//;
# curl -sS -I with https_proxy prints
}
}
-our ($dsc_hash,$lastpush_hash);
+our ($dsc_hash,$lastpush_mergeinput);
our $ud = '.git/dgit/unpack';
-sub prep_ud () {
- rmtree($ud);
+sub prep_ud (;$) {
+ my ($d) = @_;
+ $d //= $ud;
+ rmtree($d);
mkpath '.git/dgit';
- mkdir $ud or die $!;
+ mkdir $d or die $!;
}
sub mktree_in_ud_here () {
runcmd qw(git init -q);
+ runcmd qw(git config gc.auto 0);
rmtree('.git/objects');
symlink '../../../../objects','.git/objects' or die $!;
}
sub remove_stray_gits () {
my @gitscmd = qw(find -name .git -prune -print0);
debugcmd "|",@gitscmd;
- open GITS, "-|", @gitscmd or failedcmd @gitscmd;
+ open GITS, "-|", @gitscmd or die $!;
{
local $/="\0";
while (<GITS>) {
$!=0; $?=0; close GITS or failedcmd @gitscmd;
}
-sub mktree_in_ud_from_only_subdir () {
+sub mktree_in_ud_from_only_subdir (;$) {
+ my ($raw) = @_;
+
# changes into the subdir
my (@dirs) = <*/.>;
- die unless @dirs==1;
+ die "expected one subdir but found @dirs ?" unless @dirs==1;
$dirs[0] =~ m#^([^/]+)/\.$# or die;
my $dir = $1;
changedir $dir;
remove_stray_gits();
mktree_in_ud_here();
- my $format=get_source_format();
- if (madformat($format)) {
- rmtree '.pc';
+ if (!$raw) {
+ my ($format, $fopts) = get_source_format();
+ if (madformat($format)) {
+ rmtree '.pc';
+ }
}
+
runcmd @git, qw(add -Af);
my $tree=git_write_tree();
return ($tree,$dir);
}
+our @files_csum_info_fields =
+ (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
+ ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
+ ['Files', 'Digest::MD5', 'new()', 'md5sum']);
+
sub dsc_files_info () {
- foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
- ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
- ['Files', 'Digest::MD5', 'new()']) {
+ foreach my $csumi (@files_csum_info_fields) {
my ($fname, $module, $method) = @$csumi;
my $field = $dsc->{$fname};
next unless defined $field;
map { $_->{Filename} } dsc_files_info();
}
-sub is_orig_file ($;$) {
- local ($_) = $_[0];
- my $base = $_[1];
- m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
- defined $base or return 1;
- return $` eq $base;
+sub files_compare_inputs (@) {
+ my $inputs = \@_;
+ my %record;
+ my %fchecked;
+
+ my $showinputs = sub {
+ return join "; ", map { $_->get_option('name') } @$inputs;
+ };
+
+ foreach my $in (@$inputs) {
+ my $expected_files;
+ my $in_name = $in->get_option('name');
+
+ printdebug "files_compare_inputs $in_name\n";
+
+ foreach my $csumi (@files_csum_info_fields) {
+ my ($fname) = @$csumi;
+ printdebug "files_compare_inputs $in_name $fname\n";
+
+ my $field = $in->{$fname};
+ next unless defined $field;
+
+ my @files;
+ foreach (split /\n/, $field) {
+ next unless m/\S/;
+
+ my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
+ fail "could not parse $in_name $fname line \`$_'";
+
+ printdebug "files_compare_inputs $in_name $fname $f\n";
+
+ push @files, $f;
+
+ my $re = \ $record{$f}{$fname};
+ if (defined $$re) {
+ $fchecked{$f}{$in_name} = 1;
+ $$re eq $info or
+ fail "hash or size of $f varies in $fname fields".
+ " (between: ".$showinputs->().")";
+ } else {
+ $$re = $info;
+ }
+ }
+ @files = sort @files;
+ $expected_files //= \@files;
+ "@$expected_files" eq "@files" or
+ fail "file list in $in_name varies between hash fields!";
+ }
+ $expected_files or
+ fail "$in_name has no files list field(s)";
+ }
+ printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
+ if $debuglevel>=2;
+
+ grep { keys %$_ == @$inputs-1 } values %fchecked
+ or fail "no file appears in all file lists".
+ " (looked in: ".$showinputs->().")";
+}
+
+sub is_orig_file_in_dsc ($$) {
+ my ($f, $dsc_files_info) = @_;
+ return 0 if @$dsc_files_info <= 1;
+ # One file means no origs, and the filename doesn't have a "what
+ # part of dsc" component. (Consider versions ending `.orig'.)
+ return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
+ return 1;
+}
+
+sub is_orig_file_of_vsn ($$) {
+ my ($f, $upstreamvsn) = @_;
+ my $base = srcfn $upstreamvsn, '';
+ return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
+ return 1;
+}
+
+sub changes_update_origs_from_dsc ($$$$) {
+ my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
+ my %changes_f;
+ printdebug "checking origs needed ($upstreamvsn)...\n";
+ $_ = getfield $changes, 'Files';
+ m/^\w+ \d+ (\S+ \S+) \S+$/m or
+ fail "cannot find section/priority from .changes Files field";
+ my $placementinfo = $1;
+ my %changed;
+ printdebug "checking origs needed placement '$placementinfo'...\n";
+ foreach my $l (split /\n/, getfield $dsc, 'Files') {
+ $l =~ m/\S+$/ or next;
+ my $file = $&;
+ printdebug "origs $file | $l\n";
+ next unless is_orig_file_of_vsn $file, $upstreamvsn;
+ printdebug "origs $file is_orig\n";
+ my $have = archive_query('file_in_archive', $file);
+ if (!defined $have) {
+ print STDERR <<END;
+archive does not support .orig check; hope you used --ch:--sa/-sd if needed
+END
+ return;
+ }
+ my $found_same = 0;
+ my @found_differ;
+ printdebug "origs $file \$#\$have=$#$have\n";
+ foreach my $h (@$have) {
+ my $same = 0;
+ my @differ;
+ foreach my $csumi (@files_csum_info_fields) {
+ my ($fname, $module, $method, $archivefield) = @$csumi;
+ next unless defined $h->{$archivefield};
+ $_ = $dsc->{$fname};
+ next unless defined;
+ m/^(\w+) .* \Q$file\E$/m or
+ fail ".dsc $fname missing entry for $file";
+ if ($h->{$archivefield} eq $1) {
+ $same++;
+ } else {
+ push @differ,
+ "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
+ }
+ }
+ die "$file ".Dumper($h)." ?!" if $same && @differ;
+ $found_same++
+ if $same;
+ push @found_differ, "archive $h->{filename}: ".join "; ", @differ
+ if @differ;
+ }
+ print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
+ if (@found_differ && !$found_same) {
+ fail join "\n",
+ "archive contains $file with different checksum",
+ @found_differ;
+ }
+ # Now we edit the changes file to add or remove it
+ foreach my $csumi (@files_csum_info_fields) {
+ my ($fname, $module, $method, $archivefield) = @$csumi;
+ next unless defined $changes->{$fname};
+ 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) {
+ # 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 ?";
+ my $extra = $1;
+ $extra =~ s/ \d+ /$&$placementinfo /
+ or die "$fname $extra >$dsc_data< ?"
+ if $fname eq 'Files';
+ $changes->{$fname} .= "\n". $extra;
+ $changed{$file} = "added";
+ }
+ }
+ }
+ if (%changed) {
+ foreach my $file (keys %changed) {
+ progress sprintf
+ "edited .changes for archive .orig contents: %s %s",
+ $changed{$file}, $file;
+ }
+ my $chtmp = "$changesfile.tmp";
+ $changes->save($chtmp);
+ if (act_local()) {
+ rename $chtmp,$changesfile or die "$changesfile $!";
+ } else {
+ progress "[new .changes left in $changesfile]";
+ }
+ } else {
+ progress "$changesfile already has appropriate .orig(s) (if any)";
+ }
}
sub make_commit ($) {
return cmdoutput @git, qw(hash-object -w -t commit), $file;
}
+sub make_commit_text ($) {
+ my ($text) = @_;
+ my ($out, $in);
+ my @cmd = (@git, qw(hash-object -w -t commit --stdin));
+ debugcmd "|",@cmd;
+ print Dumper($text) if $debuglevel > 1;
+ my $child = open2($out, $in, @cmd) or die $!;
+ my $h;
+ eval {
+ print $in $text or die $!;
+ close $in or die $!;
+ $h = <$out>;
+ $h =~ m/^\w+$/ or die;
+ $h = $&;
+ printdebug "=> $h\n";
+ };
+ close $out;
+ waitpid $child, 0 == $child or die "$child $!";
+ $? and failedcmd @cmd;
+ return $h;
+}
+
sub clogp_authline ($) {
my ($clogp) = @_;
my $author = getfield $clogp, 'Maintainer';
$author =~ s#,.*##ms;
my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
my $authline = "$author $date";
- $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
+ $authline =~ m/$git_authline_re/o or
fail "unexpected commit author line format \`$authline'".
" (was generated from changelog Maintainer field)";
+ return ($1,$2,$3) if wantarray;
return $authline;
}
vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
"Dpkg::Vendor \`current vendor'");
vendor_patches_distro(access_basedistro(),
- "distro being accessed");
+ "(base) distro being accessed");
+ vendor_patches_distro(access_nomdistro(),
+ "(nominal) distro being accessed");
}
-sub generate_commit_from_dsc () {
+sub generate_commits_from_dsc () {
+ # See big comment in fetch_from_archive, below.
+ # See also README.dsc-import.
prep_ud();
changedir $ud;
- foreach my $fi (dsc_files_info()) {
+ my @dfi = dsc_files_info();
+ foreach my $fi (@dfi) {
my $f = $fi->{Filename};
die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
- link_ltarget "../../../$f", $f
+ printdebug "considering linking $f: ";
+
+ link_ltarget "../../../../$f", $f
+ or ((printdebug "($!) "), 0)
or $!==&ENOENT
or die "$f $!";
+ printdebug "linked.\n";
+
complete_file_from_dsc('.', $fi)
or next;
- if (is_orig_file($f)) {
+ if (is_orig_file_in_dsc($f, \@dfi)) {
link $f, "../../../../$f"
or $!==&EEXIST
or die "$f $!";
}
}
+ # We unpack and record the orig tarballs first, so that we only
+ # need disk space for one private copy of the unpacked source.
+ # But we can't make them into commits until we have the metadata
+ # 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) {
+ # 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;
+
+ my ($orig_f_part) =
+ $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
+
+ printdebug "Y ", (join ' ', map { $_//"(none)" }
+ $compr_ext, $orig_f_part
+ ), "\n";
+
+ my $input = new IO::File $f, '<' or die "$f $!";
+ my $compr_pid;
+ my @compr_cmd;
+
+ if (defined $compr_ext) {
+ my $cname =
+ Dpkg::Compression::compression_guess_from_filename $f;
+ fail "Dpkg::Compression cannot handle file $f in source package"
+ if defined $compr_ext && !defined $cname;
+ my $compr_proc =
+ new Dpkg::Compression::Process compression => $cname;
+ my @compr_cmd = $compr_proc->get_uncompress_cmdline();
+ my $compr_fh = new IO::Handle;
+ my $compr_pid = open $compr_fh, "-|" // die $!;
+ if (!$compr_pid) {
+ open STDIN, "<&", $input or die $!;
+ exec @compr_cmd;
+ die "dgit (child): exec $compr_cmd[0]: $!\n";
+ }
+ $input = $compr_fh;
+ }
+
+ rmtree "../unpack-tar";
+ mkdir "../unpack-tar" or die $!;
+ my @tarcmd = qw(tar -x -f -
+ --no-same-owner --no-same-permissions
+ --no-acls --no-xattrs --no-selinux);
+ my $tar_pid = fork // die $!;
+ if (!$tar_pid) {
+ chdir "../unpack-tar" or die $!;
+ open STDIN, "<&", $input or die $!;
+ exec @tarcmd;
+ die "dgit (child): exec $tarcmd[0]: $!";
+ }
+ $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
+ !$? or failedcmd @tarcmd;
+
+ close $input or
+ (@compr_cmd ? failedcmd @compr_cmd
+ : die $!);
+ # finally, we have the results in "tarball", but maybe
+ # with the wrong permissions
+
+ runcmd qw(chmod -R +rwX ../unpack-tar);
+ changedir "../unpack-tar";
+ my ($tree) = mktree_in_ud_from_only_subdir(1);
+ changedir "../../unpack";
+ rmtree "../unpack-tar";
+
+ my $ent = [ $f, $tree ];
+ push @tartrees, {
+ Orig => !!$orig_f_part,
+ Sort => (!$orig_f_part ? 2 :
+ $orig_f_part =~ m/-/g ? 1 :
+ 0),
+ F => $f,
+ Tree => $tree,
+ };
+ }
+
+ @tartrees = sort {
+ # put any without "_" first (spec is not clear whether files
+ # are always in the usual order). Tarballs without "_" are
+ # the main orig or the debian tarball.
+ $a->{Sort} <=> $b->{Sort} or
+ $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;
my ($tree,$dir) = mktree_in_ud_from_only_subdir();
- check_for_vendor_patches() if madformat($dsc->{format});
- runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
- my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
+ 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';
+ runcmd @git, qw(add -Af);
+ $dappliedtree = git_write_tree();
+ }
+
+ my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
+ debugcmd "|",@clogcmd;
+ open CLOGS, "-|", @clogcmd or die $!;
+
+ my $clogp;
+ my $r1clogp;
+
+ printdebug "import clog search...\n";
+
+ 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";
+
+ last if !$any_orig; # we don't need $r1clogp
+
+ # We look for the first (most recent) changelog entry whose
+ # version number is lower than the upstream version of this
+ # package. Then the last (least recent) previous changelog
+ # entry is treated as the one which introduced this upstream
+ # version and used for the synthetic commits for the upstream
+ # tarballs.
+
+ # One might think that a more sophisticated algorithm would be
+ # necessary. But: we do not want to scan the whole changelog
+ # file. Stopping when we see an earlier version, which
+ # necessarily then is an earlier upstream version, is the only
+ # realistic way to do that. Then, either the earliest
+ # changelog entry we have seen so far is indeed the earliest
+ # upload of this upstream version; or there are only changelog
+ # entries relating to later upstream versions (which is not
+ # possible unless the changelog and .dsc disagree about the
+ # 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
+ # that the changelog entries have been misordered.
+
+ printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
+
+ last if version_compare($thisstanza->{version}, $upstreamv) < 0;
+ $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 $authline = clogp_authline $clogp;
my $changes = getfield $clogp, 'Changes';
+ my $cversion = getfield $clogp, 'Version';
+
+ if (@tartrees) {
+ $r1clogp //= $clogp; # maybe there's only one entry;
+ my $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) {
+ printdebug "import tartree $tt->{F} $tt->{Tree}\n";
+
+ $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
+tree $tt->{Tree}
+author $r1authline
+committer $r1authline
+
+Import $tt->{F}
+
+[dgit import orig $tt->{F}]
+END_O
+tree $tt->{Tree}
+author $authline
+committer $authline
+
+Import $tt->{F}
+
+[dgit import tarball $package $cversion $tt->{F}]
+END_T
+ }
+ }
+
+ printdebug "import main commit\n";
+
open C, ">../commit.tmp" or die $!;
print C <<END or die $!;
tree $tree
+END
+ print C <<END or die $! foreach @tartrees;
+parent $_->{Commit}
+END
+ print C <<END or die $!;
author $authline
committer $authline
$changes
-# imported from the archive
+[dgit import $treeimporthow $package $cversion]
END
+
close C or die $!;
- my $outputhash = make_commit qw(../commit.tmp);
- my $cversion = getfield $clogp, 'Version';
- progress "synthesised git commit from .dsc $cversion";
- if ($lastpush_hash) {
- runcmd @git, qw(reset --hard), $lastpush_hash;
- runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
- my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
- my $oversion = getfield $oldclogp, 'Version';
- my $vcmp =
- version_compare($oversion, $cversion);
- if ($vcmp < 0) {
- # git upload/ is earlier vsn than archive, use archive
- open C, ">../commit2.tmp" or die $!;
- print C <<END or die $!;
-tree $tree
-parent $lastpush_hash
-parent $outputhash
+ my $rawimport_hash = make_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);
+tree $dappliedtree
author $authline
committer $authline
-Record $package ($cversion) in archive suite $csuite
+[dgit dummy commit]
END
- $outputhash = make_commit qw(../commit2.tmp);
- } elsif ($vcmp > 0) {
- print STDERR <<END or die $!;
+ runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
+
+ runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
+
+ # We need the answers to be reproducible
+ my @authline = clogp_authline($clogp);
+ local $ENV{GIT_COMMITTER_NAME} = $authline[0];
+ local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
+ local $ENV{GIT_COMMITTER_DATE} = $authline[2];
+ local $ENV{GIT_AUTHOR_NAME} = $authline[0];
+ local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
+ local $ENV{GIT_AUTHOR_DATE} = $authline[2];
+
+ my $path = $ENV{PATH} or die;
+
+ foreach my $use_absurd (qw(0 1)) {
+ local $ENV{PATH} = $path;
+ if ($use_absurd) {
+ chomp $@;
+ progress "warning: $@";
+ $path = "$absurdity:$path";
+ progress "$us: trying slow absurd-git-apply...";
+ rename "../../gbp-pq-output","../../gbp-pq-output.0"
+ or $!==ENOENT
+ or die $!;
+ }
+ eval {
+ die "forbid absurd git-apply\n" if $use_absurd
+ && forceing [qw(import-gitapply-no-absurd)];
+ die "only absurd git-apply!\n" if !$use_absurd
+ && forceing [qw(import-gitapply-absurd)];
+
+ local $ENV{PATH} = $path if $use_absurd;
+
+ my @showcmd = (gbp_pq, qw(import));
+ my @realcmd = shell_cmd
+ 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
+ debugcmd "+",@realcmd;
+ if (system @realcmd) {
+ die +(shellquote @showcmd).
+ " failed: ".
+ failedcmd_waitstatus()."\n";
+ }
-Version actually in archive: $cversion (older)
-Last allegedly pushed/uploaded: $oversion (newer or same)
-$later_warning_msg
+ my $gapplied = git_rev_parse('HEAD');
+ my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
+ $gappliedtree eq $dappliedtree or
+ fail <<END;
+gbp-pq import and dpkg-source disagree!
+ gbp-pq import gave commit $gapplied
+ gbp-pq import gave tree $gappliedtree
+ dpkg-source --before-build gave tree $dappliedtree
END
- $outputhash = $lastpush_hash;
- } else {
- $outputhash = $lastpush_hash;
+ $rawimport_hash = $gapplied;
+ };
+ last unless $@;
+ }
+ if ($@) {
+ { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
+ die $@;
}
}
- changedir '../../../..';
- runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
- 'DGIT_ARCHIVE', $outputhash;
- cmdoutput @git, qw(log -n2), $outputhash;
- # ... gives git a chance to complain if our commit is malformed
+
+ progress "synthesised git commit from .dsc $cversion";
+
+ my $rawimport_mergeinput = {
+ Commit => $rawimport_hash,
+ Info => "Import of source package",
+ };
+ my @output = ($rawimport_mergeinput);
+
+ if ($lastpush_mergeinput) {
+ my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
+ my $oversion = getfield $oldclogp, 'Version';
+ my $vcmp =
+ version_compare($oversion, $cversion);
+ if ($vcmp < 0) {
+ @output = ($rawimport_mergeinput, $lastpush_mergeinput,
+ { Message => <<END, ReverseParents => 1 });
+Record $package ($cversion) in archive suite $csuite
+END
+ } elsif ($vcmp > 0) {
+ print STDERR <<END or die $!;
+
+Version actually in archive: $cversion (older)
+Last version pushed with dgit: $oversion (newer or same)
+$later_warning_msg
+END
+ @output = $lastpush_mergeinput;
+ } else {
+ # Same version. Use what's in the server git branch,
+ # discarding our own import. (This could happen if the
+ # server automatically imports all packages into git.)
+ @output = $lastpush_mergeinput;
+ }
+ }
+ changedir '../../../..';
rmtree($ud);
- return $outputhash;
+ return @output;
}
sub complete_file_from_dsc ($$) {
if (stat_exists $tf) {
progress "using existing $f";
} else {
+ printdebug "$tf does not exist, need to fetch\n";
my $furl = $dscurl;
$furl =~ s{/[^/]+$}{};
$furl .= "/$f";
die "$f ?" unless $f =~ m/^\Q${package}\E_/;
die "$f ?" if $f =~ m#/#;
- runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
+ runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
return 0 if !act_local();
$downloaded = 1;
}
}
sub ensure_we_have_orig () {
- foreach my $fi (dsc_files_info()) {
+ my @dfi = dsc_files_info();
+ foreach my $fi (@dfi) {
my $f = $fi->{Filename};
- next unless is_orig_file($f);
+ next unless is_orig_file_in_dsc($f, \@dfi);
complete_file_from_dsc('..', $fi)
or next;
}
}
sub git_fetch_us () {
- my @specs = (fetchspec());
- push @specs,
- map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
- qw(tags heads);
- runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
+ # Want to fetch only what we are going to use, unless
+ # 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));
+ push @specs, server_branch($csuite);
+ push @specs, qw(heads/*) if deliberately_not_fast_forward;
+
+ # This is rather miserable:
+ # When git fetch --prune is passed a fetchspec ending with a *,
+ # it does a plausible thing. If there is no * then:
+ # - it matches subpaths too, even if the supplied refspec
+ # starts refs, and behaves completely madly if the source
+ # has refs/refs/something. (See, for example, Debian #NNNN.)
+ # - if there is no matching remote ref, it bombs out the whole
+ # fetch.
+ # We want to fetch a fixed ref, and we don't know in advance
+ # if it exists, so this is not suitable.
+ #
+ # Our workaround is to use git ls-remote. git ls-remote has its
+ # own qairks. Notably, it has the absurd multi-tail-matching
+ # behaviour: git ls-remote R refs/foo can report refs/foo AND
+ # refs/refs/foo etc.
+ #
+ # Also, we want an idempotent snapshot, but we have to make two
+ # calls to the remote: one to git ls-remote and to git fetch. The
+ # solution is use git ls-remote to obtain a target state, and
+ # git fetch to try to generate it. If we don't manage to generate
+ # the target state, we try again.
+
+ printdebug "git_fetch_us specs @specs\n";
+
+ my $specre = join '|', map {
+ my $x = $_;
+ $x =~ s/\W/\\$&/g;
+ $x =~ s/\\\*$/.*/;
+ "(?:refs/$x)";
+ } @specs;
+ printdebug "git_fetch_us specre=$specre\n";
+ my $wanted_rref = sub {
+ local ($_) = @_;
+ return m/^(?:$specre)$/o;
+ };
+
+ my $fetch_iteration = 0;
+ FETCH_ITERATION:
+ for (;;) {
+ printdebug "git_fetch_us iteration $fetch_iteration\n";
+ if (++$fetch_iteration > 10) {
+ fail "too many iterations trying to get sane fetch!";
+ }
+
+ my @look = map { "refs/$_" } @specs;
+ my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
+ debugcmd "|",@lcmd;
+
+ my %wantr;
+ open GITLS, "-|", @lcmd or die $!;
+ while (<GITLS>) {
+ printdebug "=> ", $_;
+ m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
+ my ($objid,$rrefname) = ($1,$2);
+ if (!$wanted_rref->($rrefname)) {
+ print STDERR <<END;
+warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
+END
+ next;
+ }
+ $wantr{$rrefname} = $objid;
+ }
+ $!=0; $?=0;
+ close GITLS or failedcmd @lcmd;
+
+ # OK, now %want is exactly what we want for refs in @specs
+ my @fspecs = map {
+ !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
+ "+refs/$_:".lrfetchrefs."/$_";
+ } @specs;
+
+ printdebug "git_fetch_us fspecs @fspecs\n";
+
+ my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
+ runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
+ @fspecs;
+
+ %lrfetchrefs_f = ();
+ my %objgot;
+
+ git_for_each_ref(lrfetchrefs, sub {
+ my ($objid,$objtype,$lrefname,$reftail) = @_;
+ $lrfetchrefs_f{$lrefname} = $objid;
+ $objgot{$objid} = 1;
+ });
+
+ foreach my $lrefname (sort keys %lrfetchrefs_f) {
+ my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
+ if (!exists $wantr{$rrefname}) {
+ if ($wanted_rref->($rrefname)) {
+ printdebug <<END;
+git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
+END
+ } else {
+ print STDERR <<END
+warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
+END
+ }
+ runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
+ delete $lrfetchrefs_f{$lrefname};
+ next;
+ }
+ }
+ foreach my $rrefname (sort keys %wantr) {
+ my $lrefname = lrfetchrefs.substr($rrefname, 4);
+ my $got = $lrfetchrefs_f{$lrefname} // '<none>';
+ my $want = $wantr{$rrefname};
+ next if $got eq $want;
+ if (!defined $objgot{$want}) {
+ print STDERR <<END;
+warning: git ls-remote suggests we want $lrefname
+warning: and it should refer to $want
+warning: but git fetch didn't fetch that object to any relevant ref.
+warning: This may be due to a race with someone updating the server.
+warning: Will try again...
+END
+ next FETCH_ITERATION;
+ }
+ printdebug <<END;
+git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
+END
+ runcmd_ordryrun_local @git, qw(update-ref -m),
+ "dgit fetch git fetch fixup", $lrefname, $want;
+ $lrfetchrefs_f{$lrefname} = $want;
+ }
+ last;
+ }
+ printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
+ Dumper(\%lrfetchrefs_f);
my %here;
- my $tagpat = debiantag('*',access_basedistro);
+ my @tagpats = debiantags('*',access_nomdistro);
- git_for_each_ref("refs/tags/".$tagpat, sub {
+ git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
my ($objid,$objtype,$fullrefname,$reftail) = @_;
printdebug "currently $fullrefname=$objid\n";
$here{$fullrefname} = $objid;
});
- git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
+ git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
my ($objid,$objtype,$fullrefname,$reftail) = @_;
- my $lref = "refs".substr($fullrefname, length lrfetchrefs);
+ my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
printdebug "offered $lref=$objid\n";
if (!defined $here{$lref}) {
my @upd = (@git, qw(update-ref), $lref, $objid, '');
runcmd_ordryrun_local @upd;
+ lrfetchref_used $fullrefname;
} elsif ($here{$lref} eq $objid) {
+ lrfetchref_used $fullrefname;
} else {
print STDERR \
"Not updateting $lref from $here{$lref} to $objid.\n";
});
}
+sub mergeinfo_getclogp ($) {
+ # Ensures thit $mi->{Clogp} exists and returns it
+ my ($mi) = @_;
+ $mi->{Clogp} = commit_getclogp($mi->{Commit});
+}
+
+sub mergeinfo_version ($) {
+ return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
+}
+
+sub fetch_from_archive_record_1 ($) {
+ my ($hash) = @_;
+ runcmd @git, qw(update-ref -m), "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);
+ if (act_local()) {
+ cmdoutput @upd_cmd;
+ } else {
+ dryrun_report @upd_cmd;
+ }
+}
+
sub fetch_from_archive () {
- # ensures that lrref() is what is actually in the archive,
- # one way or another
+ ensure_setup_existing_tree();
+
+ # Ensures that lrref() is what is actually in the archive, one way
+ # or another, according to us - ie this client's
+ # appropritaely-updated archive view. Also returns the commit id.
+ # If there is nothing in the archive, leaves lrref alone and
+ # returns undef. git_fetch_us must have already been called.
get_archive_dsc();
if ($dsc) {
progress "no version available from the archive";
}
- $lastpush_hash = git_get_ref(lrref());
+ # If the archive's .dsc has a Dgit field, there are three
+ # relevant git commitids we need to choose between and/or merge
+ # together:
+ # 1. $dsc_hash: the Dgit field from the archive
+ # 2. $lastpush_hash: the suite branch on the dgit git server
+ # 3. $lastfetch_hash: our local tracking brach for the suite
+ #
+ # These may all be distinct and need not be in any fast forward
+ # relationship:
+ #
+ # If the dsc was pushed to this suite, then the server suite
+ # branch will have been updated; but it might have been pushed to
+ # a different suite and copied by the archive. Conversely a more
+ # recent version may have been pushed with dgit but not appeared
+ # in the archive (yet).
+ #
+ # $lastfetch_hash may be awkward because archive imports
+ # (particularly, imports of Dgit-less .dscs) are performed only as
+ # needed on individual clients, so different clients may perform a
+ # different subset of them - and these imports are only made
+ # public during push. So $lastfetch_hash may represent a set of
+ # imports different to a subsequent upload by a different dgit
+ # client.
+ #
+ # Our approach is as follows:
+ #
+ # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
+ # descendant of $dsc_hash, then it was pushed by a dgit user who
+ # had based their work on $dsc_hash, so we should prefer it.
+ # Otherwise, $dsc_hash was installed into this suite in the
+ # archive other than by a dgit push, and (necessarily) after the
+ # last dgit push into that suite (since a dgit push would have
+ # been descended from the dgit server git branch); thus, in that
+ # case, we prefer the archive's version (and produce a
+ # pseudo-merge to overwrite the dgit server git branch).
+ #
+ # (If there is no Dgit field in the archive's .dsc then
+ # generate_commit_from_dsc uses the version numbers to decide
+ # whether the suite branch or the archive is newer. If the suite
+ # branch is newer it ignores the archive's .dsc; otherwise it
+ # generates an import of the .dsc, and produces a pseudo-merge to
+ # overwrite the suite branch with the archive contents.)
+ #
+ # The outcome of that part of the algorithm is the `public view',
+ # and is same for all dgit clients: it does not depend on any
+ # unpublished history in the local tracking branch.
+ #
+ # As between the public view and the local tracking branch: The
+ # local tracking branch is only updated by dgit fetch, and
+ # whenever dgit fetch runs it includes the public view in the
+ # local tracking branch. Therefore if the public view is not
+ # descended from the local tracking branch, the local tracking
+ # branch must contain history which was imported from the archive
+ # but never pushed; and, its tip is now out of date. So, we make
+ # a pseudo-merge to overwrite the old imports and stitch the old
+ # history in.
+ #
+ # Finally: we do not necessarily reify the public view (as
+ # described above). This is so that we do not end up stacking two
+ # pseudo-merges. So what we actually do is figure out the inputs
+ # to any public view pseudo-merge and put them in @mergeinputs.
+
+ my @mergeinputs;
+ # $mergeinputs[]{Commit}
+ # $mergeinputs[]{Info}
+ # $mergeinputs[0] is the one whose tree we use
+ # @mergeinputs is in the order we use in the actual commit)
+ #
+ # Also:
+ # $mergeinputs[]{Message} is a commit message to use
+ # $mergeinputs[]{ReverseParents} if def specifies that parent
+ # list should be in opposite order
+ # Such an entry has no Commit or Info. It applies only when found
+ # in the last entry. (This ugliness is to support making
+ # identical imports to previous dgit versions.)
+
+ my $lastpush_hash = git_get_ref(lrfetchref());
printdebug "previous reference hash=$lastpush_hash\n";
- my $hash;
+ $lastpush_mergeinput = $lastpush_hash && {
+ Commit => $lastpush_hash,
+ Info => "dgit suite branch on dgit git server",
+ };
+
+ my $lastfetch_hash = git_get_ref(lrref());
+ printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
+ my $lastfetch_mergeinput = $lastfetch_hash && {
+ Commit => $lastfetch_hash,
+ Info => "dgit client's archive history view",
+ };
+
+ my $dsc_mergeinput = $dsc_hash && {
+ Commit => $dsc_hash,
+ Info => "Dgit field in .dsc from archive",
+ };
+
+ my $cwd = getcwd();
+ my $del_lrfetchrefs = sub {
+ changedir $cwd;
+ my $gur;
+ printdebug "del_lrfetchrefs...\n";
+ foreach my $fullrefname (sort keys %lrfetchrefs_d) {
+ my $objid = $lrfetchrefs_d{$fullrefname};
+ printdebug "del_lrfetchrefs: $objid $fullrefname\n";
+ if (!$gur) {
+ $gur ||= new IO::Handle;
+ open $gur, "|-", qw(git update-ref --stdin) or die $!;
+ }
+ printf $gur "delete %s %s\n", $fullrefname, $objid;
+ }
+ if ($gur) {
+ close $gur or failedcmd "git update-ref delete lrfetchrefs";
+ }
+ };
+
if (defined $dsc_hash) {
- fail "missing remote git history even though dsc has hash -".
- " could not find ref ".lrref().
- " (should have been fetched from ".access_giturl()."#".rrref().")"
- unless $lastpush_hash;
- $hash = $dsc_hash;
ensure_we_have_orig();
- if ($dsc_hash eq $lastpush_hash) {
+ if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
+ @mergeinputs = $dsc_mergeinput
} elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
print STDERR <<END or die $!;
Git commit in archive is behind the last version allegedly pushed/uploaded.
-Commit referred to by archive: $dsc_hash
-Last allegedly pushed/uploaded: $lastpush_hash
+Commit referred to by archive: $dsc_hash
+Last version pushed with dgit: $lastpush_hash
$later_warning_msg
END
- $hash = $lastpush_hash;
+ @mergeinputs = ($lastpush_mergeinput);
} else {
- fail "git head (".lrref()."=$lastpush_hash) is not a ".
- "descendant of archive's .dsc hash ($dsc_hash)";
+ # Archive has .dsc which is not a descendant of the last dgit
+ # push. This can happen if the archive moves .dscs about.
+ # Just follow its lead.
+ if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
+ progress "archive .dsc names newer git commit";
+ @mergeinputs = ($dsc_mergeinput);
+ } else {
+ progress "archive .dsc names other git commit, fixing up";
+ @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
+ }
}
} elsif ($dsc) {
- $hash = generate_commit_from_dsc();
+ @mergeinputs = generate_commits_from_dsc();
+ # We have just done an import. Now, our import algorithm might
+ # have been improved. But even so we do not want to generate
+ # a new different import of the same package. So if the
+ # version numbers are the same, just use our existing version.
+ # If the version numbers are different, the archive has changed
+ # (perhaps, rewound).
+ if ($lastfetch_mergeinput &&
+ !version_compare( (mergeinfo_version $lastfetch_mergeinput),
+ (mergeinfo_version $mergeinputs[0]) )) {
+ @mergeinputs = ($lastfetch_mergeinput);
+ }
} elsif ($lastpush_hash) {
# only in git, not in the archive yet
- $hash = $lastpush_hash;
+ @mergeinputs = ($lastpush_mergeinput);
print STDERR <<END or die $!;
Package not found in the archive, but has allegedly been pushed using dgit.
END
}
- return 0;
+ unshift @end, $del_lrfetchrefs;
+ return undef;
}
- printdebug "current hash=$hash\n";
- if ($lastpush_hash) {
- fail "not fast forward on last upload branch!".
- " (archive's version left in DGIT_ARCHIVE)"
- unless is_fast_fwd($lastpush_hash, $hash);
+
+ if ($lastfetch_hash &&
+ !grep {
+ my $h = $_->{Commit};
+ $h and is_fast_fwd($lastfetch_hash, $h);
+ # If true, one of the existing parents of this commit
+ # is a descendant of the $lastfetch_hash, so we'll
+ # be ff from that automatically.
+ } @mergeinputs
+ ) {
+ # Otherwise:
+ push @mergeinputs, $lastfetch_mergeinput;
}
+
+ printdebug "fetch mergeinfos:\n";
+ foreach my $mi (@mergeinputs) {
+ if ($mi->{Info}) {
+ printdebug " commit $mi->{Commit} $mi->{Info}\n";
+ } else {
+ printdebug sprintf " ReverseParents=%d Message=%s",
+ $mi->{ReverseParents}, $mi->{Message};
+ }
+ }
+
+ my $compat_info= pop @mergeinputs
+ if $mergeinputs[$#mergeinputs]{Message};
+
+ @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
+
+ my $hash;
+ if (@mergeinputs > 1) {
+ # here we go, then:
+ my $tree_commit = $mergeinputs[0]{Commit};
+
+ my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
+ $tree =~ m/\n\n/; $tree = $`;
+ $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
+ $tree = $1;
+
+ # We use the changelog author of the package in question the
+ # author of this pseudo-merge. This is (roughly) correct if
+ # this commit is simply representing aa non-dgit upload.
+ # (Roughly because it does not record sponsorship - but we
+ # don't have sponsorship info because that's in the .changes,
+ # which isn't in the archivw.)
+ #
+ # But, it might be that we are representing archive history
+ # updates (including in-archive copies). These are not really
+ # the responsibility of the person who created the .dsc, but
+ # there is no-one whose name we should better use. (The
+ # author of the .dsc-named commit is clearly worse.)
+
+ my $useclogp = mergeinfo_getclogp $mergeinputs[0];
+ my $author = clogp_authline $useclogp;
+ my $cversion = getfield $useclogp, 'Version';
+
+ my $mcf = ".git/dgit/mergecommit";
+ open MC, ">", $mcf or die "$mcf $!";
+ print MC <<END or die $!;
+tree $tree
+END
+
+ my @parents = grep { $_->{Commit} } @mergeinputs;
+ @parents = reverse @parents if $compat_info->{ReverseParents};
+ print MC <<END or die $! foreach @parents;
+parent $_->{Commit}
+END
+
+ print MC <<END or die $!;
+author $author
+committer $author
+
+END
+
+ if (defined $compat_info->{Message}) {
+ print MC $compat_info->{Message} or die $!;
+ } else {
+ print MC <<END or die $!;
+Record $package ($cversion) in archive suite $csuite
+
+Record that
+END
+ my $message_add_info = sub {
+ my ($mi) = (@_);
+ my $mversion = mergeinfo_version $mi;
+ printf MC " %-20s %s\n", $mversion, $mi->{Info}
+ or die $!;
+ };
+
+ $message_add_info->($mergeinputs[0]);
+ print MC <<END or die $!;
+should be treated as descended from
+END
+ $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
+ }
+
+ close MC or die $!;
+ $hash = make_commit $mcf;
+ } else {
+ $hash = $mergeinputs[0]{Commit};
+ }
+ printdebug "fetch hash=$hash\n";
+
+ my $chkff = sub {
+ my ($lasth, $what) = @_;
+ return unless $lasth;
+ die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
+ };
+
+ $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
+ if $lastpush_hash;
+ $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
+
+ fetch_from_archive_record_1($hash);
+
if (defined $skew_warning_vsn) {
mkpath '.git/dgit';
printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
- my $clogf = ".git/dgit/changelog.tmp";
- runcmd shell_cmd "exec >$clogf",
- @git, qw(cat-file blob), "$hash:debian/changelog";
- my $gotclogp = parsechangelog("-l$clogf");
+ my $gotclogp = commit_getclogp($hash);
my $got_vsn = getfield $gotclogp, 'Version';
printdebug "SKEW CHECK GOT $got_vsn\n";
if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
END
}
}
- if ($lastpush_hash ne $hash) {
- my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
- if (act_local()) {
- cmdoutput @upd_cmd;
- } else {
- dryrun_report @upd_cmd;
- }
+
+ if ($lastfetch_hash ne $hash) {
+ fetch_from_archive_record_2($hash);
}
- return 1;
+
+ lrfetchref_used lrfetchref();
+
+ unshift @end, $del_lrfetchrefs;
+ return $hash;
}
sub set_local_git_config ($$) {
$setup->('name', 'DEBFULLNAME');
}
+sub ensure_setup_existing_tree () {
+ my $k = "remote.$remotename.skipdefaultupdate";
+ my $c = git_get_config $k;
+ return if defined $c;
+ set_local_git_config $k, 'true';
+}
+
sub setup_new_tree () {
setup_mergechangelogs();
setup_useremail();
}
+sub multisuite_suite_child ($$$) {
+ my ($tsuite, $merginputs, $fn) = @_;
+ # in child, sets things up, calls $fn->(), and returns undef
+ # in parent, returns canonical suite name for $tsuite
+ my $canonsuitefh = IO::File::new_tmpfile;
+ my $pid = fork // die $!;
+ if (!$pid) {
+ $isuite = $tsuite;
+ $us .= " [$isuite]";
+ $debugprefix .= " ";
+ progress "fetching $tsuite...";
+ canonicalise_suite();
+ print $canonsuitefh $csuite, "\n" or die $!;
+ close $canonsuitefh or die $!;
+ $fn->();
+ return undef;
+ }
+ waitpid $pid,0 == $pid or die $!;
+ fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
+ seek $canonsuitefh,0,0 or die $!;
+ local $csuite = <$canonsuitefh>;
+ die $! unless defined $csuite && chomp $csuite;
+ if ($? == 256*4) {
+ printdebug "multisuite $tsuite missing\n";
+ return $csuite;
+ }
+ printdebug "multisuite $tsuite ok (canon=$csuite)\n";
+ push @$merginputs, {
+ Ref => lrref,
+ Info => $csuite,
+ };
+ return $csuite;
+}
+
+sub fork_for_multisuite ($) {
+ my ($before_fetch_merge) = @_;
+ # if nothing unusual, just returns ''
+ #
+ # if multisuite:
+ # returns 0 to caller in child, to do first of the specified suites
+ # in child, $csuite is not yet set
+ #
+ # returns 1 to caller in parent, to finish up anything needed after
+ # in parent, $csuite is set to canonicalised portmanteau
+
+ my $org_isuite = $isuite;
+ my @suites = split /\,/, $isuite;
+ return '' unless @suites > 1;
+ printdebug "fork_for_multisuite: @suites\n";
+
+ my @mergeinputs;
+
+ my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
+ sub { });
+ return 0 unless defined $cbasesuite;
+
+ fail "package $package missing in (base suite) $cbasesuite"
+ unless @mergeinputs;
+
+ my @csuites = ($cbasesuite);
+
+ $before_fetch_merge->();
+
+ foreach my $tsuite (@suites[1..$#suites]) {
+ my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
+ sub {
+ @end = ();
+ fetch();
+ exit 0;
+ });
+ # xxx collecte the ref here
+
+ $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
+ push @csuites, $csubsuite;
+ }
+
+ foreach my $mi (@mergeinputs) {
+ my $ref = git_get_ref $mi->{Ref};
+ die "$mi->{Ref} ?" unless length $ref;
+ $mi->{Commit} = $ref;
+ }
+
+ $csuite = join ",", @csuites;
+
+ my $previous = git_get_ref lrref;
+ if ($previous) {
+ unshift @mergeinputs, {
+ Commit => $previous,
+ Info => "local combined tracking branch",
+ Warning =>
+ "archive seems to have rewound: local tracking branch is ahead!",
+ };
+ }
+
+ foreach my $ix (0..$#mergeinputs) {
+ $mergeinputs[$ix]{Index} = $ix;
+ }
+
+ @mergeinputs = sort {
+ -version_compare(mergeinfo_version $a,
+ mergeinfo_version $b) # highest version first
+ or
+ $a->{Index} <=> $b->{Index}; # earliest in spec first
+ } @mergeinputs;
+
+ my @needed;
+
+ NEEDED:
+ foreach my $mi (@mergeinputs) {
+ printdebug "multisuite merge check $mi->{Info}\n";
+ foreach my $previous (@needed) {
+ next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
+ printdebug "multisuite merge un-needed $previous->{Info}\n";
+ next NEEDED;
+ }
+ push @needed, $mi;
+ printdebug "multisuite merge this-needed\n";
+ $mi->{Character} = '+';
+ }
+
+ $needed[0]{Character} = '*';
+
+ my $output = $needed[0]{Commit};
+
+ if (@needed > 1) {
+ printdebug "multisuite merge nontrivial\n";
+ my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
+
+ my $commit = "tree $tree\n";
+ my $msg = "Combine archive branches $csuite [dgit]\n\n".
+ "Input branches:\n";
+
+ foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
+ printdebug "multisuite merge include $mi->{Info}\n";
+ $mi->{Character} //= ' ';
+ $commit .= "parent $mi->{Commit}\n";
+ $msg .= sprintf " %s %-25s %s\n",
+ $mi->{Character},
+ (mergeinfo_version $mi),
+ $mi->{Info};
+ }
+ my $authline = clogp_authline mergeinfo_getclogp $needed[0];
+ $msg .= "\nKey\n".
+ " * marks the highest version branch, which choose to use\n".
+ " + marks each branch which was not already an ancestor\n\n".
+ "[dgit multi-suite $csuite]\n";
+ $commit .=
+ "author $authline\n".
+ "committer $authline\n\n";
+ $output = make_commit_text $commit.$msg;
+ printdebug "multisuite merge generated $output\n";
+ }
+
+ fetch_from_archive_record_1($output);
+ fetch_from_archive_record_2($output);
+
+ progress "calculated combined tracking suite $csuite";
+
+ return 1;
+}
+
+sub clone_set_head () {
+ open H, "> .git/HEAD" or die $!;
+ print H "ref: ".lref()."\n" or die $!;
+ close H or die $!;
+}
+sub clone_finish ($) {
+ my ($dstdir) = @_;
+ runcmd @git, qw(reset --hard), lrref();
+ runcmd qw(bash -ec), <<'END';
+ set -o pipefail
+ git ls-tree -r --name-only -z HEAD | \
+ xargs -0r touch -r . --
+END
+ printdone "ready for work in $dstdir";
+}
+
sub clone ($) {
my ($dstdir) = @_;
- canonicalise_suite();
badusage "dry run makes no sense with clone" unless act_local();
+
+ my $multi_fetched = fork_for_multisuite(sub {
+ printdebug "multi clone before fetch merge\n";
+ changedir $dstdir;
+ });
+ if ($multi_fetched) {
+ printdebug "multi clone after fetch merge\n";
+ clone_set_head();
+ clone_finish($dstdir);
+ exit 0;
+ }
+ printdebug "clone main body\n";
+
+ canonicalise_suite();
my $hasgit = check_for_git();
- mkdir $dstdir or die "$dstdir $!";
+ mkdir $dstdir or fail "create \`$dstdir': $!";
changedir $dstdir;
runcmd @git, qw(init -q);
+ clone_set_head();
my $giturl = access_giturl(1);
if (defined $giturl) {
- set_local_git_config "remote.$remotename.fetch", fetchspec();
- open H, "> .git/HEAD" or die $!;
- print H "ref: ".lref()."\n" or die $!;
- close H or die $!;
runcmd @git, qw(remote add), 'origin', $giturl;
}
if ($hasgit) {
runcmd @git, qw(remote add vcs-git), $vcsgiturl;
}
setup_new_tree();
- runcmd @git, qw(reset --hard), lrref();
- printdone "ready for work in $dstdir";
+ clone_finish($dstdir);
}
sub fetch () {
+ canonicalise_suite();
if (check_for_git()) {
git_fetch_us();
}
}
sub pull () {
- fetch();
+ my $multi_fetched = fork_for_multisuite(sub { });
+ fetch() unless $multi_fetched; # parent
+ return if $multi_fetched eq '0'; # child
runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
lrref();
printdone "fetched to ".lrref()." and merged into HEAD";
}
sub check_not_dirty () {
+ foreach my $f (qw(local-options local-patch-header)) {
+ if (stat_exists "debian/source/$f") {
+ fail "git tree contains debian/source/$f";
+ }
+ }
+
return if $ignoredirty;
+
my @cmd = (@git, qw(diff --quiet HEAD));
debugcmd "+",@cmd;
- $!=0; $?=0; system @cmd;
- return if !$! && !$?;
- if (!$! && $?==256) {
+ $!=0; $?=-1; system @cmd;
+ return if !$?;
+ if ($?==256) {
fail "working tree is dirty (does not match HEAD)";
} else {
failedcmd @cmd;
}
-
- if (stat_exists "debian/source/local-options") {
- fail "git tree contains debian/source/local-options";
- }
}
sub commit_admin ($) {
}
my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
runcmd_ordryrun_local @git, qw(add -f), @adds;
- commit_admin "Commit Debian 3.0 (quilt) metadata";
+ commit_admin <<END
+Commit Debian 3.0 (quilt) metadata
+
+[dgit ($our_version) quilt-fixup]
+END
}
sub get_source_format () {
+ my %options;
+ if (open F, "debian/source/options") {
+ while (<F>) {
+ next if m/^\s*\#/;
+ next unless m/\S/;
+ s/\s+$//; # ignore missing final newline
+ if (m/\s*\#\s*/) {
+ my ($k, $v) = ($`, $'); #');
+ $v =~ s/^"(.*)"$/$1/;
+ $options{$k} = $v;
+ } else {
+ $options{$_} = 1;
+ }
+ }
+ F->error and die $!;
+ close F;
+ } else {
+ die $! unless $!==&ENOENT;
+ }
+
if (!open F, "debian/source/format") {
die $! unless $!==&ENOENT;
return '';
$_ = <F>;
F->error and die $!;
chomp;
- return $_;
+ return ($_, \%options);
}
-sub madformat ($) {
+sub madformat_wantfixup ($) {
my ($format) = @_;
return 0 unless $format eq '3.0 (quilt)';
+ our $quilt_mode_warned;
if ($quilt_mode eq 'nocheck') {
- progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
+ progress "Not doing any fixup of \`$format' due to".
+ " ----no-quilt-fixup or --quilt=nocheck"
+ unless $quilt_mode_warned++;
return 0;
}
- progress "Format \`$format', checking/updating patch stack";
+ progress "Format \`$format', need to check/update patch stack"
+ unless $quilt_mode_warned++;
return 1;
}
+sub maybe_split_brain_save ($$$) {
+ my ($headref, $dgitview, $msg) = @_;
+ # => message fragment "$saved" describing disposition of $dgitview
+ return "commit id $dgitview" unless defined $split_brain_save;
+ my @cmd = (shell_cmd "cd ../../../..",
+ @git, qw(update-ref -m),
+ "dgit --dgit-view-save $msg HEAD=$headref",
+ $split_brain_save, $dgitview);
+ runcmd @cmd;
+ return "and left in $split_brain_save";
+}
+
+# An "infopair" is a tuple [ $thing, $what ]
+# (often $thing is a commit hash; $what is a description)
+
+sub infopair_cond_equal ($$) {
+ my ($x,$y) = @_;
+ $x->[0] eq $y->[0] or fail <<END;
+$x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
+END
+};
+
+sub infopair_lrf_tag_lookup ($$) {
+ my ($tagnames, $what) = @_;
+ # $tagname may be an array ref
+ my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
+ printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
+ foreach my $tagname (@tagnames) {
+ my $lrefname = lrfetchrefs."/tags/$tagname";
+ my $tagobj = $lrfetchrefs_f{$lrefname};
+ next unless defined $tagobj;
+ printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
+ return [ git_rev_parse($tagobj), $what ];
+ }
+ fail @tagnames==1 ? <<END : <<END;
+Wanted tag $what (@tagnames) on dgit server, but not found
+END
+Wanted tag $what (one of: @tagnames) on dgit server, but not found
+END
+}
+
+sub infopair_cond_ff ($$) {
+ my ($anc,$desc) = @_;
+ is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
+$anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
+END
+};
+
+sub pseudomerge_version_check ($$) {
+ my ($clogp, $archive_hash) = @_;
+
+ my $arch_clogp = commit_getclogp $archive_hash;
+ my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
+ 'version currently in archive' ];
+ if (defined $overwrite_version) {
+ if (length $overwrite_version) {
+ infopair_cond_equal([ $overwrite_version,
+ '--overwrite= version' ],
+ $i_arch_v);
+ } else {
+ my $v = $i_arch_v->[0];
+ progress "Checking package changelog for archive version $v ...";
+ eval {
+ my @xa = ("-f$v", "-t$v");
+ my $vclogp = parsechangelog @xa;
+ my $cv = [ (getfield $vclogp, 'Version'),
+ "Version field from dpkg-parsechangelog @xa" ];
+ infopair_cond_equal($i_arch_v, $cv);
+ };
+ if ($@) {
+ $@ =~ s/^dgit: //gm;
+ fail "$@".
+ "Perhaps debian/changelog does not mention $v ?";
+ }
+ }
+ }
+
+ printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
+ return $i_arch_v;
+}
+
+sub pseudomerge_make_commit ($$$$ $$) {
+ my ($clogp, $dgitview, $archive_hash, $i_arch_v,
+ $msg_cmd, $msg_msg) = @_;
+ progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
+
+ my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
+ my $authline = clogp_authline $clogp;
+
+ chomp $msg_msg;
+ $msg_cmd .=
+ !defined $overwrite_version ? ""
+ : !length $overwrite_version ? " --overwrite"
+ : " --overwrite=".$overwrite_version;
+
+ mkpath '.git/dgit';
+ my $pmf = ".git/dgit/pseudomerge";
+ open MC, ">", $pmf or die "$pmf $!";
+ print MC <<END or die $!;
+tree $tree
+parent $dgitview
+parent $archive_hash
+author $authline
+commiter $authline
+
+$msg_msg
+
+[$msg_cmd]
+END
+ close MC or die $!;
+
+ return make_commit($pmf);
+}
+
+sub splitbrain_pseudomerge ($$$$) {
+ my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
+ # => $merged_dgitview
+ printdebug "splitbrain_pseudomerge...\n";
+ #
+ # We: debian/PREVIOUS HEAD($maintview)
+ # expect: o ----------------- o
+ # \ \
+ # o o
+ # a/d/PREVIOUS $dgitview
+ # $archive_hash \
+ # If so, \ \
+ # we do: `------------------ o
+ # this: $dgitview'
+ #
+
+ return $dgitview unless defined $archive_hash;
+
+ printdebug "splitbrain_pseudomerge...\n";
+
+ my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
+
+ if (!defined $overwrite_version) {
+ progress "Checking that HEAD inciudes all changes in archive...";
+ }
+
+ return $dgitview if is_fast_fwd $archive_hash, $dgitview;
+
+ if (defined $overwrite_version) {
+ } elsif (!eval {
+ my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
+ my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
+ my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
+ my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
+ my $i_archive = [ $archive_hash, "current archive contents" ];
+
+ printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
+
+ infopair_cond_equal($i_dgit, $i_archive);
+ infopair_cond_ff($i_dep14, $i_dgit);
+ infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
+ 1;
+ }) {
+ print STDERR <<END;
+$us: check failed (maybe --overwrite is needed, consult documentation)
+END
+ die "$@";
+ }
+
+ my $r = pseudomerge_make_commit
+ $clogp, $dgitview, $archive_hash, $i_arch_v,
+ "dgit --quilt=$quilt_mode",
+ (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
+Declare fast forward from $i_arch_v->[0]
+END_OVERWR
+Make fast forward from $i_arch_v->[0]
+END_MAKEFF
+
+ maybe_split_brain_save $maintview, $r, "pseudomerge";
+
+ progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
+ return $r;
+}
+
+sub plain_overwrite_pseudomerge ($$$) {
+ my ($clogp, $head, $archive_hash) = @_;
+
+ printdebug "plain_overwrite_pseudomerge...";
+
+ my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
+
+ return $head if is_fast_fwd $archive_hash, $head;
+
+ my $m = "Declare fast forward from $i_arch_v->[0]";
+
+ my $r = pseudomerge_make_commit
+ $clogp, $head, $archive_hash, $i_arch_v,
+ "dgit", $m;
+
+ runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
+
+ progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
+ return $r;
+}
+
sub push_parse_changelog ($) {
my ($clogpfn) = @_;
my $clogp = Dpkg::Control::Hash->new();
$clogp->load($clogpfn) or die;
- $package = getfield $clogp, 'Source';
+ my $clogpackage = getfield $clogp, 'Source';
+ $package //= $clogpackage;
+ fail "-p specified $package but changelog specified $clogpackage"
+ unless $package eq $clogpackage;
my $cversion = getfield $clogp, 'Version';
- my $tag = debiantag($cversion, access_basedistro);
+ my $tag = debiantag($cversion, access_nomdistro);
runcmd @git, qw(check-ref-format), $tag;
my $dscfn = dscfn($cversion);
- return ($clogp, $cversion, $tag, $dscfn);
+ return ($clogp, $cversion, $dscfn);
}
sub push_parse_dsc ($$$) {
" but debian/changelog is for $package $cversion";
}
-sub push_mktag ($$$$$$$) {
- my ($head,$clogp,$tag,
- $dscfn,
+sub push_tagwants ($$$$) {
+ my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
+ my @tagwants;
+ push @tagwants, {
+ TagFn => \&debiantag,
+ Objid => $dgithead,
+ TfSuffix => '',
+ View => 'dgit',
+ };
+ if (defined $maintviewhead) {
+ push @tagwants, {
+ TagFn => \&debiantag_maintview,
+ Objid => $maintviewhead,
+ TfSuffix => '-maintview',
+ View => 'maint',
+ };
+ }
+ foreach my $tw (@tagwants) {
+ $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
+ $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
+ }
+ printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
+ return @tagwants;
+}
+
+sub push_mktags ($$ $$ $) {
+ my ($clogp,$dscfn,
$changesfile,$changesfilewhat,
- $tfn) = @_;
+ $tagwants) = @_;
- $dsc->{$ourdscfield[0]} = $head;
+ die unless $tagwants->[0]{View} eq 'dgit';
+
+ $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
$dsc->save("$dscfn.tmp") or die $!;
my $changes = parsecontrol($changesfile,$changesfilewhat);
# to control the "tagger" (b) we can do remote signing
my $authline = clogp_authline $clogp;
my $delibs = join(" ", "",@deliberatelies);
- my $declaredistro = access_basedistro();
- open TO, '>', $tfn->('.tmp') or die $!;
- print TO <<END or die $!;
+ my $declaredistro = access_nomdistro();
+
+ my $mktag = sub {
+ my ($tw) = @_;
+ my $tfn = $tw->{Tfn};
+ my $head = $tw->{Objid};
+ my $tag = $tw->{Tag};
+
+ open TO, '>', $tfn->('.tmp') or die $!;
+ print TO <<END or die $!;
object $head
type commit
tag $tag
tagger $authline
+END
+ if ($tw->{View} eq 'dgit') {
+ print TO <<END or die $!;
$package release $cversion for $clogsuite ($csuite) [dgit]
[dgit distro=$declaredistro$delibs]
END
- foreach my $ref (sort keys %previously) {
- print TO <<END or die $!;
+ foreach my $ref (sort keys %previously) {
+ print TO <<END or die $!;
[dgit previously:$ref=$previously{$ref}]
END
- }
+ }
+ } elsif ($tw->{View} eq 'maint') {
+ print TO <<END or die $!;
+$package release $cversion for $clogsuite ($csuite)
+(maintainer view tag generated by dgit --quilt=$quilt_mode)
+END
+ } else {
+ die Dumper($tw)."?";
+ }
- close TO or die $!;
+ close TO or die $!;
- my $tagobjfn = $tfn->('.tmp');
- if ($sign) {
- if (!defined $keyid) {
- $keyid = access_cfg('keyid','RETURN-UNDEF');
- }
- if (!defined $keyid) {
- $keyid = getfield $clogp, 'Maintainer';
- }
- unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
- my @sign_cmd = (@gpg, qw(--detach-sign --armor));
- push @sign_cmd, qw(-u),$keyid if defined $keyid;
- push @sign_cmd, $tfn->('.tmp');
- runcmd_ordryrun @sign_cmd;
- if (act_scary()) {
- $tagobjfn = $tfn->('.signed.tmp');
- runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
- $tfn->('.tmp'), $tfn->('.tmp.asc');
+ my $tagobjfn = $tfn->('.tmp');
+ if ($sign) {
+ if (!defined $keyid) {
+ $keyid = access_cfg('keyid','RETURN-UNDEF');
+ }
+ if (!defined $keyid) {
+ $keyid = getfield $clogp, 'Maintainer';
+ }
+ unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
+ my @sign_cmd = (@gpg, qw(--detach-sign --armor));
+ push @sign_cmd, qw(-u),$keyid if defined $keyid;
+ push @sign_cmd, $tfn->('.tmp');
+ runcmd_ordryrun @sign_cmd;
+ if (act_scary()) {
+ $tagobjfn = $tfn->('.signed.tmp');
+ runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
+ $tfn->('.tmp'), $tfn->('.tmp.asc');
+ }
}
- }
+ return $tagobjfn;
+ };
- return ($tagobjfn);
+ my @r = map { $mktag->($_); } @$tagwants;
+ return @r;
}
sub sign_changes ($) {
}
}
-sub dopush ($) {
- my ($forceflag) = @_;
+sub dopush () {
printdebug "actually entering push\n";
+
+ supplementary_message(<<'END');
+Push failed, while checking state of the archive.
+You can retry the push, after fixing the problem, if you like.
+END
+ if (check_for_git()) {
+ git_fetch_us();
+ }
+ my $archive_hash = fetch_from_archive();
+ if (!$archive_hash) {
+ $new_package or
+ fail "package appears to be new in this suite;".
+ " if this is intentional, use --new";
+ }
+
supplementary_message(<<'END');
Push failed, while preparing your push.
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
+ select_tagformat();
my $clogpfn = ".git/dgit/changelog.822.tmp";
runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
responder_send_file('parsed-changelog', $clogpfn);
- my ($clogp, $cversion, $tag, $dscfn) =
+ my ($clogp, $cversion, $dscfn) =
push_parse_changelog("$clogpfn");
my $dscpath = "$buildproductsdir/$dscfn";
my $format = getfield $dsc, 'Format';
printdebug "format $format\n";
- if (madformat($format)) {
- commit_quilty_patch();
+
+ my $actualhead = git_rev_parse('HEAD');
+ my $dgithead = $actualhead;
+ my $maintviewhead = undef;
+
+ my $upstreamversion = upstreamversion $clogp->{Version};
+
+ if (madformat_wantfixup($format)) {
+ # user might have not used dgit build, so maybe do this now:
+ if (quiltmode_splitbrain()) {
+ changedir $ud;
+ 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] ?";
+ $split_brain = 1;
+ $dgithead = splitbrain_pseudomerge($clogp,
+ $actualhead, $dgithead,
+ $archive_hash);
+ $maintviewhead = $actualhead;
+ changedir '../../../..';
+ prep_ud(); # so _only_subdir() works, below
+ } else {
+ commit_quilty_patch();
+ }
+ }
+
+ if (defined $overwrite_version && !defined $maintviewhead) {
+ $dgithead = plain_overwrite_pseudomerge($clogp,
+ $dgithead,
+ $archive_hash);
}
+
check_not_dirty();
+
+ my $forceflag = '';
+ if ($archive_hash) {
+ if (is_fast_fwd($archive_hash, $dgithead)) {
+ # ok
+ } elsif (deliberately_not_fast_forward) {
+ $forceflag = '+';
+ } else {
+ fail "dgit push: HEAD is not a descendant".
+ " of the archive's version.\n".
+ "To overwrite the archive's contents,".
+ " pass --overwrite[=VERSION].\n".
+ "To rewind history, if permitted by the archive,".
+ " use --deliberately-not-fast-forward.";
+ }
+ }
+
changedir $ud;
progress "checking that $dscfn corresponds to HEAD";
runcmd qw(dpkg-source -x --),
my ($tree,$dir) = mktree_in_ud_from_only_subdir();
check_for_vendor_patches() if madformat($dsc->{format});
changedir '../../../..';
- my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
- my @diffcmd = (@git, qw(diff), $diffopt, $tree);
+ my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
debugcmd "+",@diffcmd;
- $!=0; $?=0;
+ $!=0; $?=-1;
my $r = system @diffcmd;
if ($r) {
if ($r==256) {
- fail "$dscfn specifies a different tree to your HEAD commit;".
- " perhaps you forgot to build".
- ($diffopt eq '--exit-code' ? "" :
- " (run with -D to see full diff output)");
+ my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
+ 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
+END
} else {
failedcmd @diffcmd;
}
}
- my $head = git_rev_parse('HEAD');
if (!$changesfile) {
- my $multi = "$buildproductsdir/".
- "${package}_".(stripepoch $cversion)."_multi.changes";
- if (stat_exists "$multi") {
- $changesfile = $multi;
- } else {
- my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
- my @cs = glob "$buildproductsdir/$pat";
- fail "failed to find unique changes file".
- " (looked for $pat in $buildproductsdir, or $multi);".
- " perhaps you need to use dgit -C"
- unless @cs==1;
- ($changesfile) = @cs;
- }
+ my $pat = changespat $cversion;
+ my @cs = glob "$buildproductsdir/$pat";
+ fail "failed to find unique changes file".
+ " (looked for $pat in $buildproductsdir);".
+ " perhaps you need to use dgit -C"
+ unless @cs==1;
+ ($changesfile) = @cs;
} else {
$changesfile = "$buildproductsdir/$changesfile";
}
+ # Check that changes and .dsc agree enough
+ $changesfile =~ m{[^/]*$};
+ my $changes = parsecontrol($changesfile,$&);
+ files_compare_inputs($dsc, $changes)
+ unless forceing [qw(dsc-changes-mismatch)];
+
+ # Perhaps adjust .dsc to contain right set of origs
+ changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
+ $changesfile)
+ unless forceing [qw(changes-origs-exactly)];
+
+ # Checks complete, we're going to try and go ahead:
+
responder_send_file('changes',$changesfile);
- responder_send_command("param head $head");
+ responder_send_command("param head $dgithead");
responder_send_command("param csuite $csuite");
+ responder_send_command("param tagformat $tagformat");
+ if (defined $maintviewhead) {
+ die unless ($protovsn//4) >= 4;
+ responder_send_command("param maint-view $maintviewhead");
+ }
if (deliberately_not_fast_forward) {
git_for_each_ref(lrfetchrefs, sub {
});
}
- my $tfn = sub { ".git/dgit/tag$_[0]"; };
- my $tagobjfn;
+ my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
+ ".git/dgit/tag");
+ my @tagobjfns;
supplementary_message(<<'END');
Push failed, while signing the tag.
END
# If we manage to sign but fail to record it anywhere, it's fine.
if ($we_are_responder) {
- $tagobjfn = $tfn->('.signed.tmp');
- responder_receive_files('signed-tag', $tagobjfn);
+ @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
+ responder_receive_files('signed-tag', @tagobjfns);
} else {
- $tagobjfn =
- push_mktag($head,$clogp,$tag,
- $dscpath,
- $changesfile,$changesfile,
- $tfn);
+ @tagobjfns = push_mktags($clogp,$dscpath,
+ $changesfile,$changesfile,
+ \@tagwants);
}
supplementary_message(<<'END');
Push failed, *after* signing the tag.
If you want to try again, you should use a new version number.
END
- my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
- runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
- runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
+ pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
+
+ foreach my $tw (@tagwants) {
+ my $tag = $tw->{Tag};
+ my $tagobjfn = $tw->{TagObjFn};
+ my $tag_obj_hash =
+ cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
+ runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
+ runcmd_ordryrun_local
+ @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
+ }
supplementary_message(<<'END');
Push failed, while updating the remote git repository - see messages above.
if (!check_for_git()) {
create_remote_git_repo();
}
- runcmd_ordryrun @git, qw(push),access_giturl(),
- $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
- runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
+
+ my @pushrefs = $forceflag.$dgithead.":".rrref();
+ foreach my $tw (@tagwants) {
+ push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
+ }
+
+ runcmd_ordryrun @git,
+ qw(-c push.followTags=false push), access_giturl(), @pushrefs;
+ runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
supplementary_message(<<'END');
Push failed, after updating the remote git repository.
sign_changes $changesfile;
}
- supplementary_message(<<'END');
+ supplementary_message(<<END);
Push failed, while uploading package(s) to the archive server.
You can retry the upload of exactly these same files with dput of:
$changesfile
return if $!==&ENOENT;
die "chdir $cwd_remove: $!";
}
- rmtree($dstdir) or die "remove $dstdir: $!\n";
+ printdebug "clone rmonerror removing $dstdir\n";
+ if (stat $dstdir) {
+ rmtree($dstdir) or die "remove $dstdir: $!\n";
+ } elsif (grep { $! == $_ }
+ (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
+ } else {
+ print STDERR "check whether to remove $dstdir: $!\n";
+ }
};
}
$package = getfield $sourcep, 'Source';
}
if (@ARGV==0) {
-# $isuite = branchsuite(); # this doesn't work because dak hates canons
+ $isuite = branchsuite();
if (!$isuite) {
my $clogp = parsechangelog();
$isuite = getfield $clogp, 'Distribution';
}
- canonicalise_suite();
- progress "fetching from suite $csuite";
} elsif (@ARGV==1) {
($isuite) = @ARGV;
- canonicalise_suite();
} else {
badusage "incorrect arguments to dgit fetch or dgit pull";
}
sub cmd_fetch {
parseopts();
fetchpullargs();
+ my $multi_fetched = fork_for_multisuite(sub { });
+ exit 0 if $multi_fetched;
fetch();
}
sub cmd_pull {
parseopts();
fetchpullargs();
+ if (quiltmode_splitbrain()) {
+ my ($format, $fopts) = get_source_format();
+ madformat($format) and fail <<END
+dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
+END
+ }
pull();
}
fail "dgit push: changelog specifies $isuite ($csuite)".
" but command line specifies $specsuite";
}
- supplementary_message(<<'END');
-Push failed, while checking state of the archive.
-You can retry the push, after fixing the problem, if you like.
-END
- if (check_for_git()) {
- git_fetch_us();
- }
- my $forceflag = '';
- if (fetch_from_archive()) {
- if (is_fast_fwd(lrref(), 'HEAD')) {
- # ok
- } elsif (deliberately_not_fast_forward) {
- $forceflag = '+';
- } else {
- fail "dgit push: HEAD is not a descendant".
- " of the archive's version.\n".
- "dgit: To overwrite its contents,".
- " use git merge -s ours ".lrref().".\n".
- "dgit: To rewind history, if permitted by the archive,".
- " use --deliberately-not-fast-forward";
- }
- } else {
- $new_package or
- fail "package appears to be new in this suite;".
- " if this is intentional, use --new";
- }
- dopush($forceflag);
+ dopush();
}
#---------- remote commands' implementation ----------
unless defined $protovsn;
responder_send_command("dgit-remote-push-ready $protovsn");
-
+ rpush_handle_protovsn_bothends();
changedir $dir;
&cmd_push;
}
# ... for compatibility with proto vsn.1 dgit (just so that user gets
# a good error message)
+sub rpush_handle_protovsn_bothends () {
+ if ($protovsn < 4) {
+ need_tagformat 'old', "rpush negotiated protocol $protovsn";
+ }
+ select_tagformat();
+}
+
our $i_tmp;
sub i_cleanup {
($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
$supplementary_message = '' unless $protovsn >= 3;
+
+ fail "rpush negotiated protocol version $protovsn".
+ " which does not support quilt mode $quilt_mode"
+ if quiltmode_splitbrain;
+
+ rpush_handle_protovsn_bothends();
for (;;) {
my ($icmd,$iargs) = initiator_expect {
m/^(\S+)(?: (.*))?$/;
print RI "files-end\n" or die $!;
}
-our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
+our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
sub i_localname_parsed_changelog {
return "remote-changelog.822";
}
sub i_file_parsed_changelog {
- ($i_clogp, $i_version, $i_tag, $i_dscfn) =
+ ($i_clogp, $i_version, $i_dscfn) =
push_parse_changelog "$i_tmp/remote-changelog.822";
die if $i_dscfn =~ m#/|^\W#;
}
my $head = $i_param{'head'};
die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
+ my $maintview = $i_param{'maint-view'};
+ die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
+
+ select_tagformat();
+ if ($protovsn >= 4) {
+ my $p = $i_param{'tagformat'} // '<undef>';
+ $p eq $tagformat
+ or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
+ }
+
die unless $i_param{'csuite'} =~ m/^$suite_re$/;
$csuite = $&;
push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
- my $tagobjfn =
- push_mktag $head, $i_clogp, $i_tag,
- $i_dscfn,
- $i_changesfn, 'remote changes',
- sub { "tag$_[0]"; };
+ my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
- return $tagobjfn;
+ return
+ push_mktags $i_clogp, $i_dscfn,
+ $i_changesfn, 'remote changes',
+ \@tagwants;
}
sub i_want_signed_dsc_changes {
mkpath '.git/dgit';
my $descfn = ".git/dgit/quilt-description.tmp";
open O, '>', $descfn or die "$descfn: $!";
- $msg =~ s/\s+$//g;
- $msg =~ s/\n/\n /g;
- $msg =~ s/^\s+$/ ./mg;
+ $msg =~ s/\n+/\n\n/;
print O <<END or die $!;
-Description: $msg
-Author: $author
-$xinfo
+From: $author
+${xinfo}Subject: $msg
---
END
local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
local $ENV{'VISUAL'} = $ENV{'EDITOR'};
local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
- runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
+ runcmd @dpkgsource, qw(--commit .), $patchname;
}
}
-sub quiltify_trees_differ ($$) {
- my ($x,$y) = @_;
- # returns 1 iff the two tree objects differ other than in debian/
+sub quiltify_trees_differ ($$;$$$) {
+ my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
+ # returns true iff the two tree objects differ other than in debian/
+ # with $finegrained,
+ # returns bitmask 01 - differ in upstream files except .gitignore
+ # 02 - differ in .gitignore
+ # if $ignorenamesr is defined, $ingorenamesr->{$fn}
+ # is set for each modified .gitignore filename $fn
+ # if $unrepres is defined, array ref to which is appeneded
+ # a list of unrepresentable changes (removals of upstream files
+ # (as messages)
local $/=undef;
- my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
+ my @cmd = (@git, qw(diff-tree -z));
+ push @cmd, qw(--name-only) unless $unrepres;
+ push @cmd, qw(-r) if $finegrained || $unrepres;
+ push @cmd, $x, $y;
my $diffs= cmdoutput @cmd;
+ my $r = 0;
+ my @lmodes;
foreach my $f (split /\0/, $diffs) {
- next if $f eq 'debian';
- return 1;
+ if ($unrepres && !@lmodes) {
+ @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
+ next;
+ }
+ my ($oldmode,$newmode) = @lmodes;
+ @lmodes = ();
+
+ next if $f =~ m#^debian(?:/.*)?$#s;
+
+ if ($unrepres) {
+ eval {
+ die "deleted\n" unless $newmode =~ m/[^0]/;
+ die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
+ if ($oldmode =~ m/[^0]/) {
+ die "mode changed\n" if $oldmode ne $newmode;
+ } else {
+ die "non-default mode\n" unless $newmode =~ m/^100644$/;
+ }
+ };
+ if ($@) {
+ local $/="\n"; chomp $@;
+ push @$unrepres, [ $f, $@ ];
+ }
+ }
+
+ my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
+ $r |= $isignore ? 02 : 01;
+ $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
}
- return 0;
+ printdebug "quiltify_trees_differ $x $y => $r\n";
+ return $r;
}
sub quiltify_tree_sentinelfiles ($) {
return $r;
}
-sub quiltify ($$) {
- my ($clogp,$target) = @_;
+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 ($$$$$$) {
+ my ($clogp, $unapplied, $headref, $diffbits,
+ $editedignores, $cachekey) = @_;
+ if ($quilt_mode !~ m/gbp|dpm/) {
+ # treat .gitignore just like any other upstream file
+ $diffbits = { %$diffbits };
+ $_ = !!$_ foreach values %$diffbits;
+ }
+ # We would like any commits we generate to be reproducible
+ my @authline = clogp_authline($clogp);
+ local $ENV{GIT_COMMITTER_NAME} = $authline[0];
+ local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
+ local $ENV{GIT_COMMITTER_DATE} = $authline[2];
+ local $ENV{GIT_AUTHOR_NAME} = $authline[0];
+ local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
+ local $ENV{GIT_AUTHOR_DATE} = $authline[2];
+
+ 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.";
+ if (!stat_exists "debian/patches") {
+ $msg .=
+ "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
+ }
+ fail $msg;
+ }
+ if ($quilt_mode =~ m/dpm/ &&
+ ($diffbits->{H2A} & 01)) {
+ fail <<END;
+--quilt=$quilt_mode specified, implying patches-applied git tree
+ but git tree differs from result of applying debian/patches to upstream
+END
+ }
+ if ($quilt_mode =~ m/gbp|unapplied/ &&
+ ($diffbits->{O2A} & 01)) { # some patches
+ quiltify_splitbrain_needed();
+ progress "dgit view: creating patches-applied version using gbp pq";
+ runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
+ # gbp pq import creates a fresh branch; push back to dgit-view
+ runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
+ runcmd @git, qw(checkout -q dgit-view);
+ }
+ if ($quilt_mode =~ m/gbp|dpm/ &&
+ ($diffbits->{O2A} & 02)) {
+ 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.
+END
+ }
+ if (($diffbits->{O2H} & 02) && # user has modified .gitignore
+ !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
+ quiltify_splitbrain_needed();
+ progress "dgit view: creating patch to represent .gitignore changes";
+ ensuredir "debian/patches";
+ my $gipatch = "debian/patches/auto-gitignore";
+ open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
+ stat GIPATCH or die "$gipatch: $!";
+ fail "$gipatch already exists; but want to create it".
+ " to record .gitignore changes" if (stat _)[7];
+ print GIPATCH <<END or die "$gipatch: $!";
+Subject: Update .gitignore from Debian packaging branch
+
+The Debian packaging git branch contains these updates to the upstream
+.gitignore file(s). This patch is autogenerated, to provide these
+updates to users of the official Debian archive view of the package.
+
+[dgit ($our_version) update-gitignore]
+---
+END
+ close GIPATCH or die "$gipatch: $!";
+ runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
+ $unapplied, $headref, "--", sort keys %$editedignores;
+ open SERIES, "+>>", "debian/patches/series" or die $!;
+ defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
+ my $newline;
+ defined read SERIES, $newline, 1 or die $!;
+ print SERIES "\n" or die $! unless $newline eq "\n";
+ print SERIES "auto-gitignore\n" or die $!;
+ close SERIES or die $!;
+ runcmd @git, qw(add -- debian/patches/series), $gipatch;
+ commit_admin <<END
+Commit patch to update .gitignore
+
+[dgit ($our_version) update-gitignore-quilt-fixup]
+END
+ }
+
+ my $dgitview = git_rev_parse 'HEAD';
+
+ changedir '../../../..';
+ # 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", '>>'
+ or die $!;
+
+ my $oldcache = git_get_ref "refs/$splitbraincache";
+ if ($oldcache eq $dgitview) {
+ my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
+ # git update-ref doesn't always update, in this case. *sigh*
+ my $dummy = make_commit_text <<END;
+tree $tree
+parent $dgitview
+author Dgit <dgit\@example.com> 1000000000 +0000
+committer Dgit <dgit\@example.com> 1000000000 +0000
+
+Dummy commit - do not use
+END
+ runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
+ "refs/$splitbraincache", $dummy;
+ }
+ runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
+ $dgitview;
+
+ changedir '.git/dgit/unpack/work';
+
+ my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
+ progress "dgit view: created ($saved)";
+}
+
+sub quiltify ($$$$) {
+ my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
# Quilt patchification algorithm
#
# After traversing PT, we git commit the changes which
# should be contained within debian/patches.
- changedir '../fake';
- remove_stray_gits();
- mktree_in_ud_here();
- rmtree '.pc';
- runcmd @git, qw(add -Af .);
- my $oldtiptree=git_write_tree();
- changedir '../work';
-
# The search for the path S..T is breadth-first. We maintain a
# todo list containing search nodes. A search node identifies a
# commit, and looks something like this:
foreach my $notp (@nots) {
print STDERR "$us: ", $reportnot->($notp), "\n";
}
+ print STDERR "$us: $_\n" foreach @$failsuggestion;
fail "quilt fixup naive history linearisation failed.\n".
"Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
} elsif ($quilt_mode eq 'smash') {
die "$quilt_mode ?";
}
- my $time = time;
+ my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
+ $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
my $ncommits = 3;
my $msg = cmdoutput @git, qw(log), "-n$ncommits";
$commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
my $author = $1;
+ my $commitdate = cmdoutput
+ @git, qw(log -n1 --pretty=format:%aD), $cc;
+
$msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
+ my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
+ $strip_nls->();
+
my $title = $1;
- my $patchname = $title;
- $patchname =~ s/[.:]$//;
- $patchname =~ y/ A-Z/-a-z/;
- $patchname =~ y/-a-z0-9_.+=~//cd;
- $patchname =~ s/^\W/x-$&/;
- $patchname = substr($patchname,0,40);
+ my $patchname;
+ my $patchdir;
+
+ my $gbp_check_suitable = sub {
+ $_ = shift;
+ my ($what) = @_;
+
+ eval {
+ die "contains unexpected slashes\n" if m{//} || m{/$};
+ die "contains leading punctuation\n" if m{^\W} || m{/\W};
+ die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
+ die "too long" if length > 200;
+ };
+ return $_ unless $@;
+ print STDERR "quiltifying commit $cc:".
+ " ignoring/dropping Gbp-Pq $what: $@";
+ return undef;
+ };
+
+ if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
+ gbp-pq-name: \s* )
+ (\S+) \s* \n //ixm) {
+ $patchname = $gbp_check_suitable->($1, 'Name');
+ }
+ if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
+ gbp-pq-topic: \s* )
+ (\S+) \s* \n //ixm) {
+ $patchdir = $gbp_check_suitable->($1, 'Topic');
+ }
+
+ $strip_nls->();
+
+ if (!defined $patchname) {
+ $patchname = $title;
+ $patchname =~ s/[.:]$//;
+ use Text::Iconv;
+ eval {
+ my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
+ my $translitname = $converter->convert($patchname);
+ die unless defined $translitname;
+ $patchname = $translitname;
+ };
+ print STDERR
+ "dgit: patch title transliteration error: $@"
+ if $@;
+ $patchname =~ y/ A-Z/-a-z/;
+ $patchname =~ y/-a-z0-9_.+=~//cd;
+ $patchname =~ s/^\W/x-$&/;
+ $patchname = substr($patchname,0,40);
+ }
+ if (!defined $patchdir) {
+ $patchdir = '';
+ }
+ if (length $patchdir) {
+ $patchname = "$patchdir/$patchname";
+ }
+ if ($patchname =~ m{^(.*)/}) {
+ mkpath "debian/patches/$1";
+ }
+
my $index;
for ($index='';
stat "debian/patches/$patchname$index";
runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
quiltify_dpkg_commit "$patchname$index", $author, $msg,
+ "Date: $commitdate\n".
"X-Dgit-Generated: $clogp->{Version} $cc\n";
- runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
+ runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
+ }
+
+ runcmd @git, qw(checkout -q master);
+}
+
+sub build_maybe_quilt_fixup () {
+ my ($format,$fopts) = get_source_format;
+ return unless madformat_wantfixup $format;
+ # sigh
+
+ check_for_vendor_patches();
+
+ if (quiltmode_splitbrain) {
+ foreach my $needtf (qw(new maint)) {
+ next if grep { $_ eq $needtf } access_cfg_tagformats;
+ fail <<END
+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');
+
+ prep_ud();
+ changedir $ud;
+
+ my $upstreamversion = upstreamversion $version;
+
+ if ($fopts->{'single-debian-patch'}) {
+ quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
+ } else {
+ quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
+ }
+
+ die 'bug' if $split_brain && !$need_split_build_invocation;
+
+ changedir '../../../..';
+ runcmd_ordryrun_local
+ @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
+}
+
+sub quilt_fixup_mkwork ($) {
+ my ($headref) = @_;
+
+ mkdir "work" or die $!;
+ changedir "work";
+ mktree_in_ud_here();
+ runcmd @git, qw(reset -q --hard), $headref;
+}
+
+sub quilt_fixup_linkorigs ($$) {
+ my ($upstreamversion, $fn) = @_;
+ # calls $fn->($leafname);
+
+ foreach my $f (<../../../../*>) { #/){
+ my $b=$f; $b =~ s{.*/}{};
+ {
+ local ($debuglevel) = $debuglevel-1;
+ printdebug "QF linkorigs $b, $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);
+ }
+}
+
+sub quilt_fixup_delete_pc () {
+ runcmd @git, qw(rm -rqf .pc);
+ commit_admin <<END
+Commit removal of .pc (quilt series tracking data)
+
+[dgit ($our_version) upgrade quilt-remove-pc]
+END
+}
+
+sub quilt_fixup_singlepatch ($$$) {
+ my ($clogp, $headref, $upstreamversion) = @_;
+
+ progress "starting quiltify (single-debian-patch)";
+
+ # dpkg-source --commit generates new patches even if
+ # single-debian-patch is in debian/source/options. In order to
+ # get it to generate debian/patches/debian-changes, it is
+ # necessary to build the source package.
+
+ quilt_fixup_linkorigs($upstreamversion, sub { });
+ quilt_fixup_mkwork($headref);
+
+ rmtree("debian/patches");
+
+ runcmd @dpkgsource, qw(-b .);
+ changedir "..";
+ runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
+ rename srcfn("$upstreamversion", "/debian/patches"),
+ "work/debian/patches";
+
+ changedir "work";
+ commit_quilty_patch();
+}
+
+sub quilt_make_fake_dsc ($) {
+ my ($upstreamversion) = @_;
+
+ my $fakeversion="$upstreamversion-~~DGITFAKE";
+
+ my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
+ print $fakedsc <<END or die $!;
+Format: 3.0 (quilt)
+Source: $package
+Version: $fakeversion
+Files:
+END
+
+ my $dscaddfile=sub {
+ my ($b) = @_;
+
+ my $md = new Digest::MD5;
+
+ my $fh = new IO::File $b, '<' or die "$b $!";
+ stat $fh or die $!;
+ my $size = -s _;
+
+ $md->addfile($fh);
+ print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
+ };
+
+ quilt_fixup_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";
+ push @files, $maybe;
+ }
+
+ my $debtar= srcfn $fakeversion,'.debian.tar.gz';
+ runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @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.
+ # Computes the cache key and looks in the cache.
+ # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
+
+ my $splitbrain_cachekey;
+
+ progress
+ "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
+ # we look in the reflog of dgit-intern/quilt-cache
+ # we look for an entry whose message is the key for the cache lookup
+ my @cachekey = (qw(dgit), $our_version);
+ push @cachekey, $upstreamversion;
+ push @cachekey, $quilt_mode;
+ push @cachekey, $headref;
+
+ push @cachekey, hashfile('fake.dsc');
+
+ my $srcshash = Digest::SHA->new(256);
+ my %sfs = ( %INC, '$0(dgit)' => $0 );
+ foreach my $sfk (sort keys %sfs) {
+ next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
+ $srcshash->add($sfk," ");
+ $srcshash->add(hashfile($sfs{$sfk}));
+ $srcshash->add("\n");
+ }
+ push @cachekey, $srcshash->hexdigest();
+ $splitbrain_cachekey = "@cachekey";
+
+ my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
+ $splitbraincache);
+ printdebug "splitbrain cachekey $splitbrain_cachekey\n";
+ debugcmd "|(probably)",@cmd;
+ my $child = open GC, "-|"; defined $child or die $!;
+ if (!$child) {
+ chdir '../../..' or die $!;
+ if (!stat ".git/logs/refs/$splitbraincache") {
+ $! == ENOENT or die $!;
+ printdebug ">(no reflog)\n";
+ exit 0;
+ }
+ exec @cmd; die $!;
}
+ while (<GC>) {
+ chomp;
+ printdebug ">| ", $_, "\n" if $debuglevel > 1;
+ next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
+
+ my $cachehit = $1;
+ quilt_fixup_mkwork($headref);
+ my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
+ if ($cachehit ne $headref) {
+ progress "dgit view: found cached ($saved)";
+ runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
+ $split_brain = 1;
+ return ($cachehit, $splitbrain_cachekey);
+ }
+ progress "dgit view: found cached, no changes required";
+ return ($headref, $splitbrain_cachekey);
+ }
+ die $! if GC->error;
+ failedcmd unless close GC;
- runcmd @git, qw(checkout -q master);
+ printdebug "splitbrain cache miss\n";
+ return (undef, $splitbrain_cachekey);
}
-sub build_maybe_quilt_fixup () {
- my $format=get_source_format;
- return unless madformat $format;
- # sigh
+sub quilt_fixup_multipatch ($$$) {
+ my ($clogp, $headref, $upstreamversion) = @_;
- check_for_vendor_patches();
+ progress "examining quilt state (multiple patches, $quilt_mode mode)";
# Our objective is:
# - honour any existing .pc in case it has any strangeness
# 2. Copy .pc from the fake's extraction, if necessary
# 3. Run dpkg-source --commit
# 4. If the result has changes to debian/, then
- # - git-add them them
- # - git-add .pc if we had a .pc in-tree
- # - git-commit
- # 5. If we had a .pc in-tree, delete it, and git-commit
+ # - git add them them
+ # - git add .pc if we had a .pc in-tree
+ # - git commit
+ # 5. If we had a .pc in-tree, delete it, and git commit
# 6. Back in the main tree, fast forward to the new HEAD
- my $clogp = parsechangelog();
- my $headref = git_rev_parse('HEAD');
+ # Another situation we may have to cope with is gbp-style
+ # patches-unapplied trees.
+ #
+ # We would want to detect these, so we know to escape into
+ # quilt_fixup_gbp. However, this is in general not possible.
+ # Consider a package with a one patch which the dgit user reverts
+ # (with git revert or the moral equivalent).
+ #
+ # That is indistinguishable in contents from a patches-unapplied
+ # tree. And looking at the history to distinguish them is not
+ # useful because the user might have made a confusing-looking git
+ # history structure (which ought to produce an error if dgit can't
+ # cope, not a silent reintroduction of an unwanted patch).
+ #
+ # So gbp users will have to pass an option. But we can usually
+ # detect their failure to do so: if the tree is not a clean
+ # patches-applied tree, quilt linearisation fails, but the tree
+ # _is_ a clean patches-unapplied tree, we can suggest that maybe
+ # they want --quilt=unapplied.
+ #
+ # To help detect this, when we are extracting the fake dsc, we
+ # first extract it with --skip-patches, and then apply the patches
+ # afterwards with dpkg-source --before-build. That lets us save a
+ # tree object corresponding to .origs.
- prep_ud();
- changedir $ud;
+ my $splitbrain_cachekey;
- my $upstreamversion=$version;
- $upstreamversion =~ s/-[^-]*$//;
+ quilt_make_fake_dsc($upstreamversion);
- my $fakeversion="$upstreamversion-~~DGITFAKE";
+ if (quiltmode_splitbrain()) {
+ my $cachehit;
+ ($cachehit, $splitbrain_cachekey) =
+ quilt_check_splitbrain_cache($headref, $upstreamversion);
+ return if $cachehit;
+ }
- my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
- print $fakedsc <<END or die $!;
-Format: 3.0 (quilt)
-Source: $package
-Version: $fakeversion
-Files:
-END
+ runcmd qw(sh -ec),
+ 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
- my $dscaddfile=sub {
- my ($b) = @_;
-
- my $md = new Digest::MD5;
+ my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
+ rename $fakexdir, "fake" or die "$fakexdir $!";
- my $fh = new IO::File $b, '<' or die "$b $!";
- stat $fh or die $!;
- my $size = -s _;
+ changedir 'fake';
- $md->addfile($fh);
- print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
- };
+ remove_stray_gits();
+ mktree_in_ud_here();
- foreach my $f (<../../../../*>) { #/){
- my $b=$f; $b =~ s{.*/}{};
- next unless is_orig_file $b, srcfn $upstreamversion,'';
- link_ltarget $f, $b or die "$b $!";
- $dscaddfile->($b);
- }
+ rmtree '.pc';
- my @files=qw(debian/source/format debian/rules);
- foreach my $maybe (qw(debian/patches debian/source/options)) {
- next unless stat_exists "../../../$maybe";
- push @files, $maybe;
+ runcmd @git, qw(add -Af .);
+ my $unapplied=git_write_tree();
+ printdebug "fake orig tree object $unapplied\n";
+
+ ensuredir '.pc';
+
+ my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
+ $!=0; $?=-1;
+ if (system @bbcmd) {
+ failedcmd @bbcmd if $? < 0;
+ fail <<END;
+failed to apply your git tree's patch stack (from debian/patches/) to
+ the corresponding upstream tarball(s). Your source tree and .orig
+ are probably too inconsistent. dgit can only fix up certain kinds of
+ anomaly (depending on the quilt mode). See --quilt= in dgit(1).
+END
}
- my $debtar= srcfn $fakeversion,'.debian.tar.gz';
- runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
-
- $dscaddfile->($debtar);
- close $fakedsc or die $!;
-
- runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
-
- my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
- rename $fakexdir, "fake" or die "$fakexdir $!";
+ changedir '..';
- mkdir "work" or die $!;
- changedir "work";
- mktree_in_ud_here();
- runcmd @git, qw(reset --hard), $headref;
+ quilt_fixup_mkwork($headref);
my $mustdeletepc=0;
if (stat_exists ".pc") {
rename '../fake/.pc','.pc' or die $!;
}
- quiltify($clogp,$headref);
+ changedir '../fake';
+ rmtree '.pc';
+ runcmd @git, qw(add -Af .);
+ my $oldtiptree=git_write_tree();
+ printdebug "fake o+d/p tree object $unapplied\n";
+ changedir '../work';
+
+
+ # We calculate some guesswork now about what kind of tree this might
+ # be. This is mostly for error reporting.
+
+ 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,
+ \%editedignores, \@unrepres),
+ H2A => quiltify_trees_differ($headref, $oldtiptree,1),
+ O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
+ };
+
+ my @dl;
+ foreach my $b (qw(01 02)) {
+ foreach my $v (qw(O2H O2A H2A)) {
+ push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
+ }
+ }
+ printdebug "differences \@dl @dl.\n";
+
+ progress sprintf
+"$us: base trees orig=%.20s o+d/p=%.20s",
+ $unapplied, $oldtiptree;
+ progress sprintf
+"$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
+"$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
+ $dl[0], $dl[1], $dl[3], $dl[4],
+ $dl[2], $dl[5];
+
+ if (@unrepres) {
+ print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
+ foreach @unrepres;
+ forceable_fail [qw(unrepresentable)], <<END;
+HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
+END
+ }
+
+ my @failsuggestion;
+ if (!($diffbits->{O2H} & $diffbits->{O2A})) {
+ push @failsuggestion, "This might be a patches-unapplied branch.";
+ } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
+ push @failsuggestion, "This might be a patches-applied branch.";
+ }
+ push @failsuggestion, "Maybe you need to specify one of".
+ " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
+
+ if (quiltmode_splitbrain()) {
+ quiltify_splitbrain($clogp, $unapplied, $headref,
+ $diffbits, \%editedignores,
+ $splitbrain_cachekey);
+ return;
+ }
+
+ progress "starting quiltify (multiple patches, $quilt_mode mode)";
+ quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
if (!open P, '>>', ".pc/applied-patches") {
$!==&ENOENT or die $!;
commit_quilty_patch();
if ($mustdeletepc) {
- runcmd @git, qw(rm -rqf .pc);
- commit_admin "Commit removal of .pc (quilt series tracking data)";
+ quilt_fixup_delete_pc();
}
-
- changedir '../../../..';
- runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
}
sub quilt_fixup_editor () {
exit 0;
}
+sub maybe_apply_patches_dirtily () {
+ return unless $quilt_mode =~ m/gbp|unapplied/;
+ print STDERR <<END or die $!;
+
+dgit: Building, or cleaning with rules target, in patches-unapplied tree.
+dgit: Have to apply the patches - making the tree dirty.
+dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
+
+END
+ $patches_applied_dirtily = 01;
+ $patches_applied_dirtily |= 02 unless stat_exists '.pc';
+ runcmd qw(dpkg-source --before-build .);
+}
+
+sub maybe_unapply_patches_again () {
+ 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;
+ rmtree '.pc'
+ if $patches_applied_dirtily & 02;
+ $patches_applied_dirtily = 0;
+}
+
#----- other building -----
-our $suppress_clean;
+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 () {
- return if $suppress_clean;
+ 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') {
+ maybe_apply_patches_dirtily();
runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
} elsif ($cleanmode eq 'git') {
runcmd_ordryrun_local @git, qw(clean -xdf);
badusage "clean takes no additional arguments" if @ARGV;
notpushing();
clean_tree();
+ maybe_unapply_patches_again();
}
-sub build_prep () {
+sub build_prep_early () {
+ our $build_prep_early_done //= 0;
+ return if $build_prep_early_done++;
notpushing();
badusage "-p is not allowed when building" if defined $package;
- check_not_dirty();
- clean_tree();
my $clogp = parsechangelog();
$isuite = getfield $clogp, 'Distribution';
$package = getfield $clogp, 'Source';
$version = getfield $clogp, 'Version';
+ check_not_dirty();
+}
+
+sub build_prep () {
+ build_prep_early();
+ clean_tree();
build_maybe_quilt_fixup();
+ if ($rmchanges) {
+ my $pat = changespat $version;
+ foreach my $f (glob "$buildproductsdir/$pat") {
+ if (act_local()) {
+ unlink $f or fail "remove old changes file $f: $!";
+ } else {
+ progress "would remove $f";
+ }
+ }
+ }
}
sub changesopts_initial () {
sub massage_dbp_args ($;$) {
my ($cmd,$xargs) = @_;
- if ($cleanmode eq 'dpkg-source') {
- $suppress_clean = 1;
- return;
- }
+ # We need to:
+ #
+ # - if we're going to split the source build out so we can
+ # do strange things to it, massage the arguments to dpkg-buildpackage
+ # so that the main build doessn't build source (or add an argument
+ # to stop it building source by default).
+ #
+ # - add -nc to stop dpkg-source cleaning the source tree,
+ # unless we're not doing a split build and want dpkg-source
+ # as cleanmode, in which case we can do nothing
+ #
+ # return values:
+ # 0 - source will NOT need to be built separately by caller
+ # +1 - source will need to be built separately by caller
+ # +2 - source will need to be built separately by caller AND
+ # dpkg-buildpackage should not in fact be run at all!
debugcmd '#massaging#', @$cmd if $debuglevel>1;
- my @newcmd = shift @$cmd;
+#print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
+ if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
+ $clean_using_builder = 1;
+ return 0;
+ }
# -nc has the side effect of specifying -b if nothing else specified
- push @newcmd, '-nc';
# and some combinations of -S, -b, et al, are errors, rather than
- # later simply overriding earlier
- push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } (@$cmd, @$xargs);
- push @newcmd, @$cmd;
- @$cmd = @newcmd;
+ # later simply overriding earlie. So we need to:
+ # - search the command line for these options
+ # - pick the last one
+ # - perhaps add our own as a default
+ # - perhaps adjust it to the corresponding non-source-building version
+ my $dmode = '-F';
+ foreach my $l ($cmd, $xargs) {
+ next unless $l;
+ @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
+ }
+ push @$cmd, '-nc';
+#print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
+ my $r = 0;
+ if ($need_split_build_invocation) {
+ printdebug "massage split $dmode.\n";
+ $r = $dmode =~ m/[S]/ ? +2 :
+ $dmode =~ y/gGF/ABb/ ? +1 :
+ $dmode =~ m/[ABb]/ ? 0 :
+ die "$dmode ?";
+ }
+ printdebug "massage done $r $dmode.\n";
+ push @$cmd, $dmode;
+#print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
+ return $r;
+}
+
+sub in_parent (&) {
+ my ($fn) = @_;
+ my $wasdir = must_getcwd();
+ changedir "..";
+ $fn->();
+ changedir $wasdir;
+}
+
+sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
+ 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;
+ @changesfiles = sort {
+ ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
+ or $a cmp $b
+ } @changesfiles;
+ my $result;
+ if (@changesfiles==1) {
+ fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
+only one changes file from build (@changesfiles)
+END
+ $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"
+ if $l =~ m/\.dsc$/;
+ }
+ runcmd_ordryrun_local @mergechanges, @changesfiles;
+ my $multichanges = changespat $version,'multi';
+ if (act_local()) {
+ stat_exists $multichanges or fail "$multichanges: $!";
+ foreach my $cf (glob $pat) {
+ next if $cf eq $multichanges;
+ rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
+ }
+ }
+ $result = $multichanges;
+ } else {
+ fail "wrong number of different changes files (@changesfiles)";
+ }
+ printdone "build successful, results in $result\n" or die $!;
+}
+
+sub midbuild_checkchanges () {
+ my $pat = changespat $version;
+ return if $rmchanges;
+ my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
+ @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
+ fail <<END
+changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
+Suggest you delete @unwanted.
+END
+ if @unwanted;
+}
+
+sub midbuild_checkchanges_vanilla ($) {
+ my ($wantsrc) = @_;
+ midbuild_checkchanges() if $wantsrc == 1;
+}
+
+sub postbuild_mergechanges_vanilla ($) {
+ my ($wantsrc) = @_;
+ if ($wantsrc == 1) {
+ in_parent {
+ postbuild_mergechanges(undef);
+ };
+ } else {
+ printdone "build successful\n";
+ }
}
sub cmd_build {
my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
- massage_dbp_args \@dbp;
- build_prep();
- push @dbp, changesopts_version();
- runcmd_ordryrun_local @dbp;
- printdone "build successful\n";
+ my $wantsrc = massage_dbp_args \@dbp;
+ if ($wantsrc > 0) {
+ build_source();
+ midbuild_checkchanges_vanilla $wantsrc;
+ } else {
+ build_prep();
+ }
+ if ($wantsrc < 2) {
+ push @dbp, changesopts_version();
+ maybe_apply_patches_dirtily();
+ runcmd_ordryrun_local @dbp;
+ }
+ maybe_unapply_patches_again();
+ postbuild_mergechanges_vanilla $wantsrc;
+}
+
+sub pre_gbp_build {
+ $quilt_mode //= 'gbp';
}
sub cmd_gbp_build {
+ build_prep_early();
+
+ # gbp can make .origs out of thin air. In my tests it does this
+ # even for a 1.0 format package, with no origs present. So I
+ # guess it keys off just the version number. We don't know
+ # exactly what .origs ought to exist, but let's assume that we
+ # should run gbp if: the version has an upstream part and the main
+ # orig is absent.
+ my $upstreamversion = upstreamversion $version;
+ my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
+ my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
+
+ if ($gbp_make_orig) {
+ clean_tree();
+ $cleanmode = 'none'; # don't do it again
+ $need_split_build_invocation = 1;
+ }
+
my @dbp = @dpkgbuildpackage;
- massage_dbp_args \@dbp, \@ARGV;
- my @cmd;
- if (length executable_on_path('git-buildpackage')) {
- @cmd = qw(git-buildpackage);
- } else {
- @cmd = qw(gbp buildpackage);
+ my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
+
+ if (!length $gbp_build[0]) {
+ if (length executable_on_path('git-buildpackage')) {
+ $gbp_build[0] = qw(git-buildpackage);
+ } else {
+ $gbp_build[0] = 'gbp buildpackage';
+ }
}
+ my @cmd = opts_opt_multi_cmd @gbp_build;
+
push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
- if ($cleanmode eq 'dpkg-source') {
- $suppress_clean = 1;
+ if ($gbp_make_orig) {
+ ensuredir '.git/dgit';
+ my $ok = '.git/dgit/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, @ARGV;
+ if (act_local()) {
+ debugcmd @origs_cmd;
+ system @origs_cmd;
+ do { local $!; stat_exists $ok; }
+ or failedcmd @origs_cmd;
+ } else {
+ dryrun_report @origs_cmd;
+ }
+ }
+
+ if ($wantsrc > 0) {
+ build_source();
+ midbuild_checkchanges_vanilla $wantsrc;
} else {
- push @cmd, '--git-cleaner=true';
+ if (!$clean_using_builder) {
+ push @cmd, '--git-cleaner=true';
+ }
+ build_prep();
}
- build_prep();
- unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
- canonicalise_suite();
- push @cmd, "--git-debian-branch=".lbranch();
+ maybe_unapply_patches_again();
+ if ($wantsrc < 2) {
+ push @cmd, changesopts();
+ runcmd_ordryrun_local @cmd, @ARGV;
}
- push @cmd, changesopts();
- runcmd_ordryrun_local @cmd, @ARGV;
- printdone "build successful\n";
+ postbuild_mergechanges_vanilla $wantsrc;
}
sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
sub build_source {
- if ($cleanmode =~ m/^dpkg-source/) {
- # dpkg-source will clean, so we shouldn't
- $suppress_clean = 1;
+ 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 = "${package}_".(stripepoch $version)."_source.changes";
+ $sourcechanges = changespat $version,'source';
+ if (act_local()) {
+ unlink "../$sourcechanges" or $!==ENOENT
+ or fail "remove $sourcechanges: $!";
+ }
$dscfn = dscfn($version);
- if ($cleanmode eq 'dpkg-source') {
- runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
+ if ($our_cleanmode eq 'dpkg-source') {
+ maybe_apply_patches_dirtily();
+ runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
changesopts();
- } elsif ($cleanmode eq 'dpkg-source-d') {
- runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
+ } elsif ($our_cleanmode eq 'dpkg-source-d') {
+ maybe_apply_patches_dirtily();
+ runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
changesopts();
} else {
- my $pwd = must_getcwd();
- my $leafdir = basename $pwd;
- changedir "..";
- runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
- changedir $pwd;
+ 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",
sub cmd_build_source {
badusage "build-source takes no additional arguments" if @ARGV;
build_source();
+ maybe_unapply_patches_again();
printdone "source built, results in $dscfn and $sourcechanges";
}
sub cmd_sbuild {
build_source();
- changedir "..";
- my $pat = "${package}_".(stripepoch $version)."_*.changes";
- if (act_local()) {
- stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
- stat_exists $sourcechanges
- or fail "$sourcechanges (in parent directory): $!";
- foreach my $cf (glob $pat) {
- next if $cf eq $sourcechanges;
- unlink $cf or fail "remove $cf: $!";
+ midbuild_checkchanges();
+ in_parent {
+ if (act_local()) {
+ stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
+ stat_exists $sourcechanges
+ or fail "$sourcechanges (in parent directory): $!";
}
- }
- runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
- my @changesfiles = glob $pat;
- @changesfiles = sort {
- ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
- or $a cmp $b
- } @changesfiles;
- fail "wrong number of different changes files (@changesfiles)"
- unless @changesfiles;
- runcmd_ordryrun_local @mergechanges, @changesfiles;
- my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
- if (act_local()) {
- stat_exists $multichanges or fail "$multichanges: $!";
- }
- printdone "build successful, results in $multichanges\n" or die $!;
+ runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
+ };
+ maybe_unapply_patches_again();
+ in_parent {
+ 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.)
+END
+ };
}
sub cmd_quilt_fixup {
my $clogp = parsechangelog();
$version = getfield $clogp, 'Version';
$package = getfield $clogp, 'Source';
+ check_not_dirty();
+ clean_tree();
build_maybe_quilt_fixup();
}
+sub cmd_import_dsc {
+ my $needsig = 0;
+
+ while (@ARGV) {
+ last unless $ARGV[0] =~ m/^-/;
+ $_ = shift @ARGV;
+ last if m/^--?$/;
+ if (m/^--require-valid-signature$/) {
+ $needsig = 1;
+ } else {
+ badusage "unknown dgit import-dsc sub-option \`$_'";
+ }
+ }
+
+ 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();
+
+ my $force = $dstbranch =~ s/^\+// ? +1 :
+ $dstbranch =~ s/^\.\.// ? -1 :
+ 0;
+ my $info = $force ? " $&" : '';
+ $info = "$dscfn$info";
+
+ my $specbranch = $dstbranch;
+ $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
+ $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
+
+ my @symcmd = (@git, qw(symbolic-ref -q HEAD));
+ my $chead = cmdoutput_errok @symcmd;
+ defined $chead or $?==256 or failedcmd @symcmd;
+
+ fail "$dstbranch is checked out - will not update it"
+ if defined $chead and $chead eq $dstbranch;
+
+ my $oldhash = git_get_ref $dstbranch;
+
+ open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
+ $dscdata = do { local $/ = undef; <D>; };
+ D->error and fail "read $dscfn: $!";
+ close C;
+
+ # we don't normally need this so import it here
+ use Dpkg::Source::Package;
+ my $dp = new Dpkg::Source::Package filename => $dscfn,
+ require_valid_signature => $needsig;
+ {
+ local $SIG{__WARN__} = sub {
+ print STDERR $_[0];
+ return unless $needsig;
+ fail "import-dsc signature check failed";
+ };
+ if (!$dp->is_signed()) {
+ warn "$us: warning: importing unsigned .dsc\n";
+ } else {
+ my $r = $dp->check_signature();
+ die "->check_signature => $r" if $needsig && $r;
+ }
+ }
+
+ parse_dscdata();
+
+ my $dgit_commit = $dsc->{$ourdscfield[0]};
+ if (defined $dgit_commit &&
+ !forceing [qw(import-dsc-with-dgit-field)]) {
+ $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc";
+ progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
+ my @cmd = (qw(sh -ec),
+ "echo $dgit_commit | git cat-file --batch-check");
+ my $objgot = cmdoutput @cmd;
+ if ($objgot =~ m#^\w+ missing\b#) {
+ fail <<END
+.dsc contains Dgit field referring to object $dgit_commit
+Your git tree does not have that object. Try `git fetch' from a
+plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
+END
+ }
+ if ($oldhash && !is_fast_fwd $oldhash, $dgit_commit) {
+ if ($force > 0) {
+ progress "Not fast forward, forced update.";
+ } else {
+ fail "Not fast forward to $dgit_commit";
+ }
+ }
+ @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
+ $dstbranch, $dgit_commit);
+ runcmd @cmd;
+ progress "dgit: import-dsc updated git ref $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
+END
+ if $oldhash && !$force;
+
+ $package = getfield $dsc, 'Source';
+ my @dfi = dsc_files_info();
+ foreach my $fi (@dfi) {
+ my $f = $fi->{Filename};
+ my $here = "../$f";
+ next if lstat $here;
+ fail "stat $here: $!" unless $! == ENOENT;
+ my $there = $dscfn;
+ if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
+ $there = $';
+ } elsif ($dscfn =~ m#^/#) {
+ $there = $dscfn;
+ } else {
+ fail "cannot import $dscfn which seems to be inside working tree!";
+ }
+ $there =~ s#/+[^/]+$## or
+ fail "cannot import $dscfn which seems to not have a basename";
+ $there .= "/$f";
+ symlink $there, $here or fail "symlink $there to $here: $!";
+ progress "made symlink $here -> $there";
+ print STDERR Dumper($fi);
+ }
+ my @mergeinputs = generate_commits_from_dsc();
+ die unless @mergeinputs == 1;
+
+ my $newhash = $mergeinputs[0]{Commit};
+
+ if ($oldhash) {
+ if ($force > 0) {
+ progress "Import, forced update - synthetic orphan git history.";
+ } elsif ($force < 0) {
+ progress "Import, merging.";
+ my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
+ my $version = getfield $dsc, 'Version';
+ $newhash = make_commit_text <<END;
+tree $tree
+parent $newhash
+parent $oldhash
+
+Merge $package ($version) import into $dstbranch
+END
+ } else {
+ die; # caught earlier
+ }
+ }
+
+ my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
+ $dstbranch, $newhash);
+ runcmd @cmd;
+ progress "dgit: import-dsc results are in in git ref $dstbranch";
+}
+
sub cmd_archive_api_query {
badusage "need only 1 subpath argument" unless @ARGV==1;
my ($subpath) = @ARGV;
my @cmd = archive_api_query_cmd($subpath);
+ push @cmd, qw(-f);
debugcmd ">",@cmd;
exec @cmd or fail "exec curl: $!\n";
}
defvalopt '--existing-package','', '.*', \$existing_package;
defvalopt '--build-products-dir','','.*', \$buildproductsdir;
defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
+defvalopt '--package', '-p', $package_re, \$package;
defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
-defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
-
defvalopt '', '-C', '.+', sub {
($changesfile) = (@_);
if ($changesfile =~ s#^(.*)/##) {
($om = $opts_opt_map{$1})) {
push @ropts, $_;
push @$om, $2;
+ } elsif (m/^--(gbp|dpm)$/s) {
+ push @ropts, "--quilt=$1";
+ $quilt_mode = $1;
} elsif (m/^--ignore-dirty$/s) {
push @ropts, $_;
$ignoredirty = 1;
} elsif (m/^--no-rm-on-error$/s) {
push @ropts, $_;
$rmonerror = 0;
+ } elsif (m/^--overwrite$/s) {
+ push @ropts, $_;
+ $overwrite_version = '';
+ } elsif (m/^--overwrite=(.+)$/s) {
+ push @ropts, $_;
+ $overwrite_version = $1;
+ } elsif (m/^--delayed=(\d+)$/s) {
+ push @ropts, $_;
+ push @dput, $_;
+ } elsif (m/^--dgit-view-save=(.+)$/s) {
+ push @ropts, $_;
+ $split_brain_save = $1;
+ $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
+ } elsif (m/^--(no-)?rm-old-changes$/s) {
+ push @ropts, $_;
+ $rmchanges = !$1;
} elsif (m/^--deliberately-($deliberately_re)$/s) {
push @ropts, $_;
push @deliberatelies, $&;
+ } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
+ push @ropts, $&;
+ $forceopts{$1} = 1;
+ $_='';
+ } elsif (m/^--force-/) {
+ print STDERR
+ "$us: warning: ignoring unknown force option $_\n";
+ $_='';
+ } elsif (m/^--dgit-tag-format=(old|new)$/s) {
+ # undocumented, for testing
+ push @ropts, $_;
+ $tagformat_want = [ $1, 'command line', 1 ];
+ # 1 menas overrides distro configuration
+ } elsif (m/^--always-split-source-build$/s) {
+ # undocumented, for testing
+ push @ropts, $_;
+ $need_split_build_invocation = 1;
} elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
$val = $2 ? $' : undef; #';
$valopt->($oi->{Long});
} elsif (s/^-wc$//s) {
push @ropts, $&;
$cleanmode = 'check';
+ } elsif (s/^-c([^=]*)\=(.*)$//s) {
+ push @git, '-c', $&;
+ $gitcfgs{cmdline}{$1} = [ $2 ];
+ } elsif (s/^-c([^=]+)$//s) {
+ push @git, '-c', $&;
+ $gitcfgs{cmdline}{$1} = [ 'true' ];
} elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
$val = $'; #';
$val = undef unless length $val;
}
}
+sub check_env_sanity () {
+ my $blocked = new POSIX::SigSet;
+ sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
+
+ eval {
+ foreach my $name (qw(PIPE CHLD)) {
+ my $signame = "SIG$name";
+ my $signum = eval "POSIX::$signame" // die;
+ ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
+ die "$signame is set to something other than SIG_DFL\n";
+ $blocked->ismember($signum) and
+ die "$signame is blocked\n";
+ }
+ };
+ return unless $@;
+ chomp $@;
+ fail <<END;
+On entry to dgit, $@
+This is a bug produced by something in in your execution environment.
+Giving up.
+END
+}
+
+
sub finalise_opts_opts () {
foreach my $k (keys %opts_opt_map) {
my $om = $opts_opt_map{$k};
}
foreach my $c (access_cfg_cfgs("opts-$k")) {
- my $vl = $gitcfg{$c};
- printdebug "CL $c ",
- ($vl ? join " ", map { shellquote } @$vl : ""),
+ my @vl =
+ map { $_ ? @$_ : () }
+ map { $gitcfgs{$_}{$c} }
+ reverse @gitcfgsources;
+ printdebug "CL $c ", (join " ", map { shellquote } @vl),
"\n" if $debuglevel >= 4;
- next unless $vl;
+ next unless @vl;
badcfg "cannot configure options for $k"
if $opts_opt_cmdonly{$k};
my $insertpos = $opts_cfg_insertpos{$k};
@$om = ( @$om[0..$insertpos-1],
- @$vl,
+ @vl,
@$om[$insertpos..$#$om] );
}
}
}
parseopts();
+check_env_sanity();
git_slurp_config();
print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
my $cmd = shift @ARGV;
$cmd =~ y/-/_/;
+my $pre_fn = ${*::}{"pre_$cmd"};
+$pre_fn->() if $pre_fn;
+
+if (!defined $rmchanges) {
+ local $access_forpush;
+ $rmchanges = access_cfg_bool(0, 'rm-old-changes');
+}
+
if (!defined $quilt_mode) {
local $access_forpush;
$quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
$quilt_mode = $1;
}
+$need_split_build_invocation ||= quiltmode_splitbrain();
+
if (!defined $cleanmode) {
local $access_forpush;
$cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');