# 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 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 $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|gbp|unapplied';
+our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
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 (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
our (@dpkggenchanges) = qw(dpkg-genchanges);
our (@mergechanges) = qw(mergechanges -f);
-our (@gbp) = qw(gbp);
+our (@gbp_build) = ('');
+our (@gbp_pq) = ('gbp pq');
our (@changesopts) = ('');
our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
'dpkg-source' => \@dpkgsource,
'dpkg-buildpackage' => \@dpkgbuildpackage,
'dpkg-genchanges' => \@dpkggenchanges,
+ 'gbp-build' => \@gbp_build,
+ 'gbp-pq' => \@gbp_pq,
'ch' => \@changesopts,
'mergechanges' => \@mergechanges);
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) = @_;
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 ($) {
$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 @_;
}
'dgit.default.ssh' => 'ssh',
'dgit.default.archive-query' => 'madison:',
'dgit.default.sshpsql-dbname' => 'service=projectb',
+ '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.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;
+ # 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 failedcmd @cmd;
- while (<GITS>) {
- chomp or die;
- printdebug "=> ", (messagequote $_), "\n";
- m/\n/ or die "$_ ?";
- push @{ $gitcfg{$`} }, $'; #';
+ 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 {
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 @_;
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 pool_dsc_subpath ($$) {
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;
return @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);
+}
+
+#---------- `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 $r[0][2];
}
+sub file_in_archive_madison { return undef; }
+
#---------- `sshpsql' archive query method ----------
sub sshpsql ($$$) {
return $rows[0];
}
+sub file_in_archive_sshpsql ($$$) { return undef; }
+
#---------- `dummycat' archive query method ----------
sub canonicalise_suite_dummycat ($$) {
return 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 ----------
sub canonicalise_suite () {
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 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, $fopts) = 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';
"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 = $dsc->{version};
+ $upstreamv =~ s/-[^-]+$//;
+ 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';
+ 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
+
+[dgit dummy commit]
+END
+ 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";
+ }
+
+ 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
+ $rawimport_hash = $gapplied;
+ };
+ last unless $@;
+ }
+ if ($@) {
+ { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
+ die $@;
+ }
+ }
+
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 $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) {
- # 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
-author $authline
-committer $authline
-
+ @output = ($rawimport_mergeinput, $lastpush_mergeinput,
+ { Message => <<END, ReverseParents => 1 });
Record $package ($cversion) in archive suite $csuite
END
- $outputhash = make_commit qw(../commit2.tmp);
} elsif ($vcmp > 0) {
print STDERR <<END or die $!;
-Version actually in archive: $cversion (older)
-Last allegedly pushed/uploaded: $oversion (newer or same)
+Version actually in archive: $cversion (older)
+Last version pushed with dgit: $oversion (newer or same)
$later_warning_msg
END
- $outputhash = $lastpush_hash;
+ @output = $lastpush_mergeinput;
} else {
- $outputhash = $lastpush_hash;
+ # 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 '../../../..';
- 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
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_basedistro) }
+ \&debiantag_new, \&debiantag_maintview)
+ : debiantags('*',access_basedistro));
+ 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.
+
+ 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 (;;) {
+ 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 {
+ return () if !m/\*$/ && !exists $wantr{"refs/$_"};
+ "+refs/$_:".lrfetchrefs."/$_";
+ } @specs;
+
+ 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_basedistro);
- 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 () {
- # 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().")"
+ " could not find ref ".rref()." at ".access_giturl()
unless $lastpush_hash;
- $hash = $dsc_hash;
ensure_we_have_orig();
if ($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;
+ }
+
+ 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};
+ }
}
- 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);
+
+ 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)');
+ $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
+
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) {
+
+ if ($lastfetch_hash ne $hash) {
my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
if (act_local()) {
cmdoutput @upd_cmd;
dryrun_report @upd_cmd;
}
}
- 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();
runcmd @git, qw(init -q);
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 $!;
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;
}
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 () {
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;
}
+# 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_basedistro;
+ my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
+ my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
+ 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
+
+ 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 $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_basedistro);
+ $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);
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 $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)) {
+ my $actualhead = git_rev_parse('HEAD');
+ my $dgithead = $actualhead;
+ my $maintviewhead = undef;
+
+ my $upstreamversion = $clogp->{Version};
+ $upstreamversion =~ s/-[^-]*$//;
+
+ if (madformat_wantfixup($format)) {
# user might have not used dgit build, so maybe do this now:
- commit_quilty_patch();
+ 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();
+ }
}
- die 'xxx fast forward (should not depend on quilt mode, but will always be needed if we did $split_brain)' if $split_brain;
+ 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 $pat = changespat $cversion;
my @cs = glob "$buildproductsdir/$pat";
$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.
}
if (stat $dstdir) {
rmtree($dstdir) or die "remove $dstdir: $!\n";
- } elsif (!grep { $! == $_ }
+ } elsif (grep { $! == $_ }
(ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
} else {
print STDERR "check whether to remove $dstdir: $!\n";
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
}
}
-sub quiltify_trees_differ ($$;$$) {
- my ($x,$y,$finegrained,$ignorenamesr) = @_;
+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));
- push @cmd, qw(-r) if $finegrained;
+ 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) {
+ 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;
qw(-- debian/rules debian/control);
$r =~ s/\n/,/g;
return $r;
- }
+}
sub quiltify_splitbrain_needed () {
if (!$split_brain) {
- progress "creating dgit view";
+ progress "dgit view: changes are required...";
runcmd @git, qw(checkout -q -b dgit-view);
$split_brain = 1;
}
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->{H2O} & 01)) {
+ ($diffbits->{O2H} & 01)) {
my $msg =
"--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
" but git tree differs from orig in upstream files.";
}
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 "creating patches-applied version using gbp pq";
- runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
+ 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 (($diffbits->{H2O} & 02) && # user has modified .gitignore
+ 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 "creating patch to represent .gitignore changes";
+ progress "dgit view: creating patch to represent .gitignore changes";
ensuredir "debian/patches";
my $gipatch = "debian/patches/auto-gitignore";
open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
.gitignore file(s). This patch is autogenerated, to provide these
updates to users of the official Debian archive view of the package.
-[dgit version $our_version]
+[dgit ($our_version) update-gitignore]
---
END
close GIPATCH or die "$gipatch: $!";
print SERIES "auto-gitignore\n" or die $!;
close SERIES or die $!;
runcmd @git, qw(add -- debian/patches/series), $gipatch;
- commit_admin "Commit patch to update .gitignore";
+ commit_admin <<END
+Commit patch to update .gitignore
+
+[dgit ($our_version) update-gitignore-quilt-fixup]
+END
}
- my $dgitview = git_rev_parse 'refs/heads/dgit-view';
+ 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;
- progress "created dgit view (commit id $dgitview)";
+ progress "dgit view: created (commit id $dgitview)";
changedir '.git/dgit/unpack/work';
}
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);
sub build_maybe_quilt_fixup () {
my ($format,$fopts) = get_source_format;
- return unless madformat $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');
local ($debuglevel) = $debuglevel-1;
printdebug "QF linkorigs $b, $f ?\n";
}
- next unless is_orig_file $b, srcfn $upstreamversion,'';
+ 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 "Commit removal of .pc (quilt series tracking data)";
+ commit_admin <<END
+Commit removal of .pc (quilt series tracking data)
+
+[dgit ($our_version) upgrade quilt-remove-pc]
+END
}
sub quilt_fixup_singlepatch ($$$) {
rmtree("debian/patches");
runcmd @dpkgsource, qw(-b .);
- chdir "..";
+ changedir "..";
runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
rename srcfn("$upstreamversion", "/debian/patches"),
"work/debian/patches";
- chdir "work";
+ 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);
+ if ($cachehit ne $headref) {
+ progress "dgit view: found cached (commit id $cachehit)";
+ 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;
+
+ printdebug "splitbrain cache miss\n";
+ return (undef, $splitbrain_cachekey);
}
sub quilt_fixup_multipatch ($$$) {
my ($clogp, $headref, $upstreamversion) = @_;
- progress "starting quiltify (multiple patches, $quilt_mode mode)";
+ 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
# Another situation we may have to cope with is gbp-style
# 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).
+ # (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
# afterwards with dpkg-source --before-build. That lets us save a
# tree object corresponding to .origs.
- 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=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
+ my $splitbrain_cachekey;
- $dscaddfile->($debtar);
- close $fakedsc or die $!;
+ quilt_make_fake_dsc($upstreamversion);
- my $splitbrain_cachekey;
if (quiltmode_splitbrain()) {
- # 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) {
- $srcshash->add($sfk," ");
- $srcshash->add(hashfile($sfs{$sfk}));
- $srcshash->add("\n");
- }
- push @cachekey, $srcshash->hexdigest();
- $splitbrain_cachekey = "@cachekey";
-
- my @cmd = (@git, qw(reflog), '--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);
- if ($cachehit ne $headref) {
- progress "quilt fixup ($quilt_mode mode) found cached tree";
- runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
- $split_brain = 1;
- return;
- }
- progress "quilt fixup ($quilt_mode mode)".
- " found cached indication that no changes needed";
- return;
- }
- die $! if GC->error;
- failedcmd unless close GC;
-
- printdebug "splitbrain cache miss\n";
+ my $cachehit;
+ ($cachehit, $splitbrain_cachekey) =
+ quilt_check_splitbrain_cache($headref, $upstreamversion);
+ return if $cachehit;
}
runcmd qw(sh -ec),
ensuredir '.pc';
- runcmd qw(sh -ec),
- 'exec dpkg-source --before-build . >/dev/null';
+ 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
+ }
changedir '..';
# 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
- H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
+ 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(H2O O2A H2A)) {
+ 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->{H2O} & $diffbits->{O2A})) {
+ 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 ?";
+ " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
if (quiltmode_splitbrain()) {
quiltify_splitbrain($clogp, $unapplied, $headref,
return;
}
+ progress "starting quiltify (multiple patches, $quilt_mode mode)";
quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
if (!open P, '>>', ".pc/applied-patches") {
if $patches_applied_dirtily & 01;
rmtree '.pc'
if $patches_applied_dirtily & 02;
+ $patches_applied_dirtily = 0;
}
#----- other building -----
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);
my $wantsrc = massage_dbp_args \@dbp;
if ($wantsrc > 0) {
build_source();
+ midbuild_checkchanges_vanilla $wantsrc;
} else {
build_prep();
}
runcmd_ordryrun_local @dbp;
}
maybe_unapply_patches_again();
- printdone "build successful\n";
+ postbuild_mergechanges_vanilla $wantsrc;
+}
+
+sub pre_gbp_build {
+ $quilt_mode //= 'gbp';
}
sub cmd_gbp_build {
my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
- my @cmd;
- if (length executable_on_path('git-buildpackage')) {
- @cmd = qw(git-buildpackage);
- } else {
- @cmd = qw(gbp buildpackage);
+ 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 ($wantsrc > 0) {
build_source();
+ midbuild_checkchanges_vanilla $wantsrc;
} else {
if (!$clean_using_builder) {
push @cmd, '--git-cleaner=true';
}
build_prep();
}
+ maybe_unapply_patches_again();
if ($wantsrc < 2) {
- unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
- canonicalise_suite();
- push @cmd, "--git-debian-branch=".lbranch();
- }
push @cmd, changesopts();
- maybe_apply_patches_dirtily();
runcmd_ordryrun_local @cmd, @ARGV;
}
- maybe_unapply_patches_again();
- printdone "build successful\n";
+ postbuild_mergechanges_vanilla $wantsrc;
}
sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
sub cmd_sbuild {
build_source();
- my $pat = changespat $version;
- if (!$rmchanges) {
- my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
- @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
- fail "changes files other than source matching $pat".
- " already present (@unwanted);".
- " building would result in ambiguity about the intended results"
- if @unwanted;
- }
- changedir "..";
- 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, qw(-d), $isuite, @ARGV, $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==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}: $!";
+ 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, qw(-d), $isuite, @ARGV, $dscfn;
+ };
maybe_unapply_patches_again();
- printdone "build successful, results in $multichanges\n" or die $!;
+ 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 {
build_maybe_quilt_fixup();
}
+sub cmd_import_dsc {
+ 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();
+
+ $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;
+
+ open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
+ $dscdata = do { local $/ = undef; <D>; };
+ D->error and fail "read $dscfn: $!";
+ close C;
+ 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
+ }
+ @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $dscfn",
+ $dstbranch, $dgit_commit);
+ runcmd @cmd;
+ progress "dgit: import-dsc updated git ref $dstbranch";
+ return 0;
+ }
+
+ $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 @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $dscfn",
+ $dstbranch, $mergeinputs[0]{Commit});
+ 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 '--clean', '', $cleanmode_re, \$cleanmode;
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/^--(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, $_;
} 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');