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 $overwrite_version; # undef: not specified; '': check changelog
our $quilt_mode;
our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
+our $dodep14tag;
+our $dodep14tag_re = 'want|no|always';
our $split_brain_save;
our $we_are_responder;
our $initiator_tempdir;
our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
our $splitbraincache = 'dgit-intern/quilt-cache';
+our $rewritemap = 'dgit-rewrite/map';
our (@git) = qw(git);
our (@dget) = qw(dget);
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);
'ssh' => \@ssh,
'dgit' => \@dgit,
'git' => \@git,
+ 'apt-get' => \@aptget,
+ 'apt-cache' => \@aptcache,
'dpkg-source' => \@dpkgsource,
'dpkg-buildpackage' => \@dpkgbuildpackage,
'dpkg-genchanges' => \@dpkggenchanges,
scalar @{ $opts_opt_map{$_} }
} keys %opts_opt_map;
-sub finalise_opts_opts();
+sub parseopts_late_defaults();
our $keyid;
sub debiantag_maintview ($$) {
my ($v,$distro) = @_;
- $v =~ y/~:/_%/;
- return "$distro/$v";
+ return "$distro/".dep14_version_mangle $v;
}
sub madformat ($) { $_[0] eq '3.0 (quilt)' }
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"
'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',
sub access_nomdistro () {
my $base = access_basedistro();
- return cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
+ my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
+ $r =~ m/^$distro_re$/ or badcfg
+ "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
+ return $r;
}
sub access_quirk () {
Push failed, before we got started.
You can retry the push, after fixing the problem, if you like.
END
- finalise_opts_opts();
+ parseopts_late_defaults();
}
sub notpushing () {
- finalise_opts_opts();
+ parseopts_late_defaults();
}
sub supplementary_message ($) {
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;
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 $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"; find -atime +30 -type f -print0 | xargs -0r 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 @_; }
split /\,/, access_cfg('dgit-tag-format');
}
+sub access_cfg_tagformats_can_splitbrain () {
+ my %y = map { $_ => 1 } access_cfg_tagformats;
+ foreach my $needtf (qw(new maint)) {
+ next if $y{$needtf};
+ return 0;
+ }
+ return 1;
+}
+
sub need_tagformat ($$) {
my ($fmt, $why) = @_;
fail "need to use tag format $fmt ($why) but also need".
$csuite = archive_query('canonicalise_suite');
if ($isuite ne $csuite) {
progress "canonical suite name for $isuite is $csuite";
+ } else {
+ progress "canonical suite name is $csuite";
}
}
return $tree;
}
-sub remove_stray_gits () {
+sub git_add_write_tree () {
+ runcmd @git, qw(add -Af .);
+ return git_write_tree();
+}
+
+sub remove_stray_gits ($) {
+ my ($what) = @_;
my @gitscmd = qw(find -name .git -prune -print0);
debugcmd "|",@gitscmd;
open GITS, "-|", @gitscmd or die $!;
local $/="\0";
while (<GITS>) {
chomp or die;
- print STDERR "$us: warning: removing from source package: ",
+ print STDERR "$us: warning: removing from $what: ",
(messagequote $_), "\n";
rmtree $_;
}
$!=0; $?=0; close GITS or failedcmd @gitscmd;
}
-sub mktree_in_ud_from_only_subdir (;$) {
- my ($raw) = @_;
+sub mktree_in_ud_from_only_subdir ($;$) {
+ my ($what,$raw) = @_;
# changes into the subdir
my (@dirs) = <*/.>;
my $dir = $1;
changedir $dir;
- remove_stray_gits();
+ remove_stray_gits($what);
mktree_in_ud_here();
if (!$raw) {
my ($format, $fopts) = get_source_format();
}
}
- runcmd @git, qw(add -Af);
- my $tree=git_write_tree();
+ my $tree=git_add_write_tree();
return ($tree,$dir);
}
push @found_differ, "archive $h->{filename}: ".join "; ", @differ
if @differ;
}
- print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
+ printdebug "origs $file f.same=$found_same".
+ " #f._differ=$#found_differ\n";
if (@found_differ && !$found_same) {
fail join "\n",
"archive contains $file with different checksum",
$input = $compr_fh;
}
- rmtree "../unpack-tar";
- mkdir "../unpack-tar" or die $!;
+ 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 $!;
+ chdir "_unpack-tar" or die $!;
open STDIN, "<&", $input or die $!;
exec @tarcmd;
die "dgit (child): exec $tarcmd[0]: $!";
# 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";
+ runcmd qw(chmod -R +rwX _unpack-tar);
+ changedir "_unpack-tar";
+ remove_stray_gits($f);
+ mktree_in_ud_here();
+
+ my ($tree) = git_add_write_tree();
+ my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
+ if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
+ $tree = $1;
+ printdebug "one subtree $1\n";
+ } else {
+ printdebug "multiple subtrees\n";
+ }
+ changedir "..";
+ rmtree "_unpack-tar";
my $ent = [ $f, $tree ];
push @tartrees, {
push @cmd, qw(-x --), $dscfn;
runcmd @cmd;
- my ($tree,$dir) = mktree_in_ud_from_only_subdir();
+ my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
if (madformat $dsc->{format}) {
check_for_vendor_patches();
}
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();
+ $dappliedtree = git_add_write_tree();
}
my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
my $path = $ENV{PATH} or die;
foreach my $use_absurd (qw(0 1)) {
+ runcmd @git, qw(checkout -q unpa);
+ runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
local $ENV{PATH} = $path;
if ($use_absurd) {
chomp $@;
die "only absurd git-apply!\n" if !$use_absurd
&& forceing [qw(import-gitapply-absurd)];
- local $ENV{PATH} = $path if $use_absurd;
+ local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_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;
+ 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
debugcmd "+",@realcmd;
if (system @realcmd) {
die +(shellquote @showcmd).
\&debiantag_new, \&debiantag_maintview)
: debiantags('*',access_nomdistro));
push @specs, server_branch($csuite);
+ push @specs, $rewritemap;
push @specs, qw(heads/*) if deliberately_not_fast_forward;
# This is rather miserable:
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 parse_dsc_field ($$) {
+ my ($f, $what) = @_;
+ if (!defined $f) {
+ progress "$what: NO git hash";
+ } elsif ($f =~ m/^\w+/) {
+ $dsc_hash = $&;
+ progress "$what: specified git hash";
+ } else {
+ fail "$what: invalid Dgit info";
+ }
+}
+
sub fetch_from_archive () {
ensure_setup_existing_tree();
get_archive_dsc();
if ($dsc) {
+ my $f;
foreach my $field (@ourdscfield) {
- $dsc_hash = $dsc->{$field};
- last if defined $dsc_hash;
+ $f = $dsc->{$field};
+ last if defined $f;
}
+ parse_dsc_field($f, 'last upload to archive');
+ } else {
+ progress "no version available from the archive";
+ }
+
+ my $rewritemapdata = git_cat_file lrfetchrefs."/".$rewritemap.':map';
+ if (defined $rewritemapdata
+ && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
+ progress "server's git history rewrite map contains a relevant entry!";
+ $dsc_hash = $1;
if (defined $dsc_hash) {
- $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
- $dsc_hash = $&;
- progress "last upload to archive specified git hash";
+ progress "using rewritten git hash in place of .dsc value";
} else {
- progress "last upload to archive has NO git hash";
+ progress "server data says .dsc hash is to be disregarded";
}
- } else {
- progress "no version available from the archive";
}
# If the archive's .dsc has a Dgit field, there are three
if $lastpush_hash;
$chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
- 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
+ fetch_from_archive_record_1($hash);
if (defined $skew_warning_vsn) {
mkpath '.git/dgit';
}
if ($lastfetch_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;
- }
+ fetch_from_archive_record_2($hash);
}
lrfetchref_used lrfetchref();
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 -h -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 fail "create \`$dstdir': $!";
changedir $dstdir;
runcmd @git, qw(init -q);
+ clone_set_head();
my $giturl = access_giturl(1);
if (defined $giturl) {
- 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();
- 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";
+ 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";
parent $dgitview
parent $archive_hash
author $authline
-commiter $authline
+committer $authline
$msg_msg
TfSuffix => '-maintview',
View => 'maint',
};
- }
+ } elsif ($dodep14tag eq 'no' ? 0
+ : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
+ : $dodep14tag eq 'always'
+ ? (access_cfg_tagformats_can_splitbrain or fail <<END)
+--dep14tag-always (or equivalent in config) means server must support
+ both "new" and "maint" tag formats, but config says it doesn't.
+END
+ : die "$dodep14tag ?") {
+ push @tagwants, {
+ TagFn => \&debiantag_maintview,
+ Objid => $dgithead,
+ TfSuffix => '-dgit',
+ View => 'dgit',
+ };
+ };
foreach my $tw (@tagwants) {
$tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
$tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
die unless $tagwants->[0]{View} eq 'dgit';
- $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
+ my $declaredistro = access_nomdistro();
+ my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
+ $dsc->{$ourdscfield[0]} = join " ",
+ $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
+ $reader_giturl;
$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_nomdistro();
my $mktag = sub {
my ($tw) = @_;
my $dscpath = "$buildproductsdir/$dscfn";
stat_exists $dscpath or
- fail "looked for .dsc $dscfn, but $!;".
+ fail "looked for .dsc $dscpath, but $!;".
" maybe you forgot to build";
responder_send_file('dsc', $dscpath);
progress "checking that $dscfn corresponds to HEAD";
runcmd qw(dpkg-source -x --),
$dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
- my ($tree,$dir) = mktree_in_ud_from_only_subdir();
+ my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
check_for_vendor_patches() if madformat($dsc->{format});
changedir '../../../..';
my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
supplementary_message(<<'END');
-Push failed, after updating the remote git repository.
-If you want to try again, you must use a new version number.
+Push failed, while obtaining signatures on the .changes and .dsc.
+If it was just that the signature failed, you may try again by using
+debsign by hand to sign the changes
+ $changesfile
+and then dput to complete the upload.
+If you need to change the package, you must use a new version number.
END
if ($we_are_responder) {
my $dryrunsuffix = act_local() ? "" : ".tmp";
sub cmd_clone {
parseopts();
- notpushing();
my $dstdir;
badusage "-p is not allowed with clone; specify as argument instead"
if defined $package;
} else {
badusage "incorrect arguments to dgit clone";
}
- $dstdir ||= "$package";
+ notpushing();
+ $dstdir ||= "$package";
if (stat_exists $dstdir) {
fail "$dstdir already exists";
}
return if $!==&ENOENT;
die "chdir $cwd_remove: $!";
}
+ printdebug "clone rmonerror removing $dstdir\n";
if (stat $dstdir) {
rmtree($dstdir) or die "remove $dstdir: $!\n";
} elsif (grep { $! == $_ }
}
sub fetchpullargs () {
- notpushing();
if (!defined $package) {
my $sourcep = parsecontrol('debian/control','debian/control');
$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";
}
+ notpushing();
}
sub cmd_fetch {
parseopts();
fetchpullargs();
+ my $multi_fetched = fork_for_multisuite(sub { });
+ exit 0 if $multi_fetched;
fetch();
}
local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
local $ENV{'VISUAL'} = $ENV{'EDITOR'};
local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
- runcmd @dpkgsource, qw(--commit .), $patchname;
+ runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
}
}
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 "not a plain file\n"
+ unless $newmode =~ m/^10\d{4}$/ ||
+ $oldmode =~ m/^10\d{4}$/;
+ if ($oldmode =~ m/[^0]/ &&
+ $newmode =~ m/[^0]/) {
die "mode changed\n" if $oldmode ne $newmode;
} else {
- die "non-default mode\n" unless $newmode =~ m/^100644$/;
+ die "non-default mode\n"
+ unless $newmode =~ m/^100644$/ ||
+ $oldmode =~ m/^100644$/;
}
};
if ($@) {
local $/="\n"; chomp $@;
- push @$unrepres, [ $f, $@ ];
+ push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
}
}
check_for_vendor_patches();
if (quiltmode_splitbrain) {
- foreach my $needtf (qw(new maint)) {
- next if grep { $_ eq $needtf } access_cfg_tagformats;
- fail <<END
+ fail <<END unless access_cfg_tagformats_can_splitbrain;
quilt mode $quilt_mode requires split view so server needs to support
both "new" and "maint" tag formats, but config says it doesn't.
END
- }
}
my $clogp = parsechangelog();
changedir 'fake';
- remove_stray_gits();
+ remove_stray_gits("source package");
mktree_in_ud_here();
rmtree '.pc';
- runcmd @git, qw(add -Af .);
- my $unapplied=git_write_tree();
+ my $unapplied=git_add_write_tree();
printdebug "fake orig tree object $unapplied\n";
ensuredir '.pc';
changedir '../fake';
rmtree '.pc';
- runcmd @git, qw(add -Af .);
- my $oldtiptree=git_write_tree();
+ my $oldtiptree=git_add_write_tree();
printdebug "fake o+d/p tree object $unapplied\n";
changedir '../work';
}
sub cmd_build {
+ build_prep_early();
my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
my $wantsrc = massage_dbp_args \@dbp;
if ($wantsrc > 0) {
sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
sub build_source {
+ build_prep_early();
my $our_cleanmode = $cleanmode;
if ($need_split_build_invocation) {
# Pretend that clean is being done some other way. This
}
sub cmd_build_source {
+ build_prep_early();
badusage "build-source takes no additional arguments" if @ARGV;
build_source();
maybe_unapply_patches_again();
sub cmd_quilt_fixup {
badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
- my $clogp = parsechangelog();
- $version = getfield $clogp, 'Version';
- $package = getfield $clogp, 'Source';
- check_not_dirty();
+ build_prep_early();
clean_tree();
build_maybe_quilt_fixup();
}
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";
+ my $dgit_field = $dsc->{$ourdscfield[0]};
+ parse_dsc_field($dgit_field, "$ourdscfield[0] field in .dsc");
+
+ if (defined $dsc_hash
+ && !forceing [qw(import-dsc-with-dgit-field)]) {
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");
+ "echo $dsc_hash | git cat-file --batch-check");
my $objgot = cmdoutput @cmd;
if ($objgot =~ m#^\w+ missing\b#) {
fail <<END
-.dsc contains Dgit field referring to object $dgit_commit
+.dsc contains Dgit field referring to object $dsc_hash
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 ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
if ($force > 0) {
progress "Not fast forward, forced update.";
} else {
- fail "Not fast forward to $dgit_commit";
+ fail "Not fast forward to $dsc_hash";
}
}
@cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
- $dstbranch, $dgit_commit);
+ $dstbranch, $dsc_hash);
runcmd @cmd;
progress "dgit: import-dsc updated git ref $dstbranch";
return 0;
$there .= "/$f";
symlink $there, $here or fail "symlink $there to $here: $!";
progress "made symlink $here -> $there";
- print STDERR Dumper($fi);
+# print STDERR Dumper($fi);
}
my @mergeinputs = generate_commits_from_dsc();
die unless @mergeinputs == 1;
progress "Import, merging.";
my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
my $version = getfield $dsc, 'Version';
+ my $clogp = commit_getclogp $newhash;
+ my $authline = clogp_authline $clogp;
$newhash = make_commit_text <<END;
tree $tree
parent $newhash
parent $oldhash
+author $authline
+committer $authline
Merge $package ($version) import into $dstbranch
END
} elsif (m/^--overwrite=(.+)$/s) {
push @ropts, $_;
$overwrite_version = $1;
+ } elsif (m/^--dep14tag$/s) {
+ push @ropts, $_;
+ $dodep14tag= 'want';
+ } elsif (m/^--no-dep14tag$/s) {
+ push @ropts, $_;
+ $dodep14tag= 'no';
+ } elsif (m/^--always-dep14tag$/s) {
+ push @ropts, $_;
+ $dodep14tag= 'always';
} elsif (m/^--delayed=(\d+)$/s) {
push @ropts, $_;
push @dput, $_;
}
-sub finalise_opts_opts () {
+sub parseopts_late_defaults () {
foreach my $k (keys %opts_opt_map) {
my $om = $opts_opt_map{$k};
@$om[$insertpos..$#$om] );
}
}
+
+ 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')
+ // access_cfg('quilt-mode', 'RETURN-UNDEF')
+ // 'linear';
+ $quilt_mode =~ m/^($quilt_modes_re)$/
+ or badcfg "unknown quilt-mode \`$quilt_mode'";
+ $quilt_mode = $1;
+ }
+
+ if (!defined $dodep14tag) {
+ local $access_forpush;
+ $dodep14tag = access_cfg('dep14tag', 'RETURN-UNDEF') // 'want';
+ $dodep14tag =~ m/^($dodep14tag_re)$/
+ or badcfg "unknown dep14tag setting \`$dodep14tag'";
+ $dodep14tag = $1;
+ }
+
+ $need_split_build_invocation ||= quiltmode_splitbrain();
+
+ if (!defined $cleanmode) {
+ local $access_forpush;
+ $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
+ $cleanmode //= 'dpkg-source';
+
+ badcfg "unknown clean-mode \`$cleanmode'" unless
+ $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
+ }
}
if ($ENV{$fakeeditorenv}) {
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')
- // access_cfg('quilt-mode', 'RETURN-UNDEF')
- // 'linear';
- $quilt_mode =~ m/^($quilt_modes_re)$/
- or badcfg "unknown quilt-mode \`$quilt_mode'";
- $quilt_mode = $1;
-}
-
-$need_split_build_invocation ||= quiltmode_splitbrain();
-
-if (!defined $cleanmode) {
- local $access_forpush;
- $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
- $cleanmode //= 'dpkg-source';
-
- badcfg "unknown clean-mode \`$cleanmode'" unless
- $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
-}
-
my $fn = ${*::}{"cmd_$cmd"};
$fn or badusage "unknown operation $cmd";
$fn->();
~ianmdlvl / dgit.git / blobdiff