# 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 Debian::Dgit;
our $our_version = 'UNRELEASED'; ###substituted###
+our $absurdity = undef; ###substituted###
our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
our $protovsn;
our $cleanmode;
our $changes_since_version;
our $rmchanges;
-our $overwrite_version;
+our $overwrite_version; # undef: not specified; '': check changelog
our $quilt_mode;
our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
our $we_are_responder;
our $tagformat;
our $tagformatfn;
+our %forceopts = map { $_=>0 }
+ qw(unrepresentable unsupported-source-format
+ dsc-changes-mismatch
+ import-gitapply-absurd
+ import-gitapply-no-absurd);
+
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' => \@gbp,
+ '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);
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 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;
$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:
'dgit.default.ssh' => 'ssh',
'dgit.default.archive-query' => 'madison:',
'dgit.default.sshpsql-dbname' => 'service=projectb',
- 'dgit.default.dgit-tag-format' => 'old,new,maint',
+ '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"
'dgit-distro.debian.git-check' => 'url',
'dgit-distro.debian.git-check-suffix' => '/info/refs',
'dgit-distro.debian.new-private-pushers' => 't',
- 'dgit-distro.debian.dgit-tag-format' => 'new',
'dgit-distro.debian/push.git-url' => '',
'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
'dgit-distro.debian/push.git-user-force' => 'dgit',
'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 die $!;
- 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 $!;
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;
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 = $&;
+ fail "fetch of $url gave HTTP code $code"
+ unless $url =~ m#^file://# or $code =~ m/^2/;
return decode_json($json);
}
$dsc = parsecontrolfh($dscfh,$dscurl,1);
printdebug Dumper($dsc) if $debuglevel>1;
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;
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
$!=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 "@dirs ?" 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)'],
+ ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
+ ['Files', 'Digest::MD5', 'new()']);
+
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 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';
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$#;
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 $rawimport_hash = make_commit qw(../commit.tmp);
- my $cversion = getfield $clogp, 'Version';
+
+ 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";
+
my $rawimport_mergeinput = {
Commit => $rawimport_hash,
Info => "Import of source package",
};
my @output = ($rawimport_mergeinput);
- progress "synthesised git commit from .dsc $cversion";
+
if ($lastpush_mergeinput) {
my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
my $oversion = getfield $oldclogp, 'Version';
$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;
}
push @specs, qw(heads/*) if deliberately_not_fast_forward;
# This is rather miserable:
- # When git-fetch --prune is passed a fetchspec ending with a *,
+ # 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
# 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
+ # 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
+ # 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
+ # 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 ($objid,$rrefname) = ($1,$2);
if (!$wanted_rref->($rrefname)) {
print STDERR <<END;
-warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
+warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
END
next;
}
if (!exists $wantr{$rrefname}) {
if ($wanted_rref->($rrefname)) {
printdebug <<END;
-git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
+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.
+warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
END
}
runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
next if $got eq $want;
if (!defined $objgot{$want}) {
print STDERR <<END;
-warning: git-ls-remote suggests we want $lrefname
+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: 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
+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;
+ "dgit fetch git fetch fixup", $lrefname, $want;
$lrfetchrefs_f{$lrefname} = $want;
}
last;
}
- printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
+ printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
Dumper(\%lrfetchrefs_f);
my %here;
}
sub fetch_from_archive () {
+ 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.
} else {
$hash = $mergeinputs[0]{Commit};
}
- progress "fetch hash=$hash\n";
+ printdebug "fetch hash=$hash\n";
my $chkff = sub {
my ($lasth, $what) = @_;
$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();
}
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;
my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
'version currently in archive' ];
if (defined $overwrite_version) {
- infopair_cond_equal([ $overwrite_version, '--overwrite= version' ],
- $i_arch_v);
+ 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) = @_;
+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, $msg or die $!;
+ 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 $dgitview if is_fast_fwd $archive_hash, $dgitview;
- 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);
- $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
+ 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 $overwrite_version
-
-[dgit --quilt=$quilt_mode --overwrite=$overwrite_version]
+Declare fast forward from $i_arch_v->[0]
END_OVERWR
Make fast forward from $i_arch_v->[0]
-
-[dgit --quilt=$quilt_mode]
END_MAKEFF
progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
- my @tagformats = access_cfg_tagformats();
- my @t_overwr =
- map { $_->($overwrite_version, access_basedistro) }
- (grep { m/^(?:old|hist)$/ } @tagformats)
- ? \&debiantags : \&debiantag_new;
- my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
- my $i_archive = [ $archive_hash, "current archive contents" ];
-
- infopair_cond_equal($i_overwr, $i_archive);
-
return $head if is_fast_fwd $archive_hash, $head;
- my $m = "Declare fast forward from $overwrite_version";
+ my $m = "Declare fast forward from $i_arch_v->[0]";
my $r = pseudomerge_make_commit
- $clogp, $head, $archive_hash, $i_arch_v, <<END;
-$m
-
-[dgit --overwrite=$overwrite_version]
-END
+ $clogp, $head, $archive_hash, $i_arch_v,
+ "dgit", $m;
runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
my $dgithead = $actualhead;
my $maintviewhead = undef;
- if (madformat($format)) {
+ if (madformat_wantfixup($format)) {
# user might have not used dgit build, so maybe do this now:
if (quiltmode_splitbrain()) {
my $upstreamversion = $clogp->{Version};
$upstreamversion =~ s/-[^-]*$//;
changedir $ud;
quilt_make_fake_dsc($upstreamversion);
- my ($dgitview, $cachekey) =
+ my $cachekey;
+ ($dgithead, $cachekey) =
quilt_check_splitbrain_cache($actualhead, $upstreamversion);
- $dgitview or fail
+ $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, $dgitview,
+ $actualhead, $dgithead,
$archive_hash);
$maintviewhead = $actualhead;
changedir '../../../..';
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, $dgithead);
+ my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
debugcmd "+",@diffcmd;
$!=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;
}
$changesfile = "$buildproductsdir/$changesfile";
}
+ # Check that changes and .dsc agree enough
+ $changesfile =~ m{[^/]*$};
+ files_compare_inputs($dsc, parsecontrol($changesfile,$&))
+ unless forceing [qw(dsc-changes-mismatch)];
+
# Checks complete, we're going to try and go ahead:
responder_send_file('changes',$changesfile);
push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
}
- runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
+ 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');
}
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";
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;
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.";
($diffbits->{O2A} & 01)) { # some patches
quiltify_splitbrain_needed();
progress "dgit view: creating patches-applied version using gbp pq";
- runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
+ 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);
.gitignores: but, such patches exist in debian/patches.
END
}
- if (($diffbits->{H2O} & 02) && # user has modified .gitignore
+ if (($diffbits->{O2H} & 02) && # user has modified .gitignore
!($diffbits->{O2A} & 02)) { # patches do not change .gitignore
quiltify_splitbrain_needed();
progress "dgit view: creating patch to represent .gitignore changes";
.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;
$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();
}
my $srcshash = Digest::SHA->new(256);
my %sfs = ( %INC, '$0(dgit)' => $0 );
foreach my $sfk (sort keys %sfs) {
- next unless m/^\$0\b/ || m{^Debian/Dgit\b};
+ 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(reflog), '--pretty=format:%H %gs',
+ my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
$splitbraincache);
printdebug "splitbrain cachekey $splitbrain_cachekey\n";
debugcmd "|(probably)",@cmd;
# 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
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 $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';
}
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();
runcmd_ordryrun_local @cmd, @ARGV;
}
- printdone "build successful\n";
+ postbuild_mergechanges_vanilla $wantsrc;
}
sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
sub 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;
- }
- my $wasdir = must_getcwd();
- 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): $!";
}
- }
- changedir $wasdir;
+ 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 {
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) {
+ } elsif (m/^--overwrite$/s) {
+ push @ropts, $_;
+ $overwrite_version = '';
+ } elsif (m/^--overwrite=(.+)$/s) {
push @ropts, $_;
$overwrite_version = $1;
} elsif (m/^--(no-)?rm-old-changes$/s) {
} 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, $_;
} 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');
~ianmdlvl / dgit.git / blobdiff