# dgit
# Integration between git and Debian-style archives
#
-# Copyright (C)2013-2018 Ian Jackson
-# Copyright (C)2017-2018 Sean Whitton
+# Copyright (C)2013-2019 Ian Jackson
+# Copyright (C)2017-2019 Sean Whitton
+# Copyright (C)2019 Matthew Vernon / Genome Research Limited
#
# 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 IO::Handle;
use Data::Dumper;
-use LWP::UserAgent;
+use WWW::Curl::Easy;
use Dpkg::Control::Hash;
use File::Path;
use File::Spec;
our $our_version = 'UNRELEASED'; ###substituted###
our $absurdity = undef; ###substituted###
-our @rpushprotovsn_support = qw(4 5); # 5 drops tag format specification
+$SIG{INT} = 'DEFAULT'; # work around #932841
+
+our @rpushprotovsn_support = qw(6 5 4); # Reverse order!
our $protovsn;
our $cmd;
our $overwrite_version; # undef: not specified; '': check changelog
our $quilt_mode;
our $quilt_upstream_commitish;
-our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
+our $quilt_upstream_commitish_used;
+our $quilt_upstream_commitish_message;
+our $quilt_options_re = 'gbp|dpm|baredebian(?:\+tarball|\+git)?';
+our $quilt_modes_re = "linear|smash|auto|nofix|nocheck|unapplied|$quilt_options_re";
our $splitview_mode;
our $splitview_modes_re = qr{auto|always|never};
our $dodep14tag;
our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
-our $suite_re = '[-+.0-9a-z]+';
our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
| (?: git | git-ff ) (?: ,always )?
| check (?: ,ignores )?
our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
-our (@git) = qw(git);
our (@dget) = qw(dget);
our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
our (@dput) = qw(dput);
}
sub quiltmode_splitting () {
- $quilt_mode =~ m/gbp|dpm|unapplied/;
+ $quilt_mode =~ m/gbp|dpm|unapplied|baredebian/;
+}
+sub format_quiltmode_splitting ($) {
+ my ($format) = @_;
+ return madformat_wantfixup($format) && quiltmode_splitting();
}
sub do_split_brain () { !!($do_split_brain // confess) }
# > param head DGIT-VIEW-HEAD
# > param csuite SUITE
# > param tagformat new # $protovsn == 4
+# > param splitbrain 0|1 # $protovsn >= 6
# > param maint-view MAINT-VIEW-HEAD
#
# > param buildinfo-filename P_V_X.buildinfo # zero or more times
our $ua;
-sub url_get {
- if (!$ua) {
- $ua = LWP::UserAgent->new();
- $ua->env_proxy;
- }
- my $what = $_[$#_];
- progress "downloading $what...";
- my $r = $ua->get(@_) or confess "$!";
- return undef if $r->code == 404;
- $r->is_success or fail f_ "failed to fetch %s: %s",
- $what, $r->status_line;
- return $r->decoded_content(charset => 'none');
-}
-
our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
sub act_local () { return $dryrun_level <= 1; }
'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
'dgit-distro.ubuntu.git-check' => 'false',
'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
+ 'dgit-distro.ubuntucloud.git-check' => 'false',
+ 'dgit-distro.ubuntucloud.nominal-distro' => 'ubuntu',
+ 'dgit-distro.ubuntucloud.archive-query' => 'aptget:',
+ 'dgit-distro.ubuntucloud.mirror' => 'http://ubuntu-cloud.archive.canonical.com/ubuntu',
+ 'dgit-distro.ubuntucloud.aptget-suite-map' => 's#^([^-]+):([^:]+)$#${1}-updates/$2#; s#^(.+)-(.+):(.+)#$1-$2/$3#;',
+ 'dgit-distro.ubuntucloud.aptget-suite-rmap' => 's#/(.+)$#-$1#',
'dgit-distro.test-dummy.ssh' => "$td/ssh",
'dgit-distro.test-dummy.username' => "alice",
'dgit-distro.test-dummy.git-check' => "ssh-cmd",
parseopts_late_defaults();
}
-sub determine_whether_split_brain () {
- my ($format,) = get_source_format();
-
+sub determine_whether_split_brain ($) {
+ my ($format) = @_;
{
local $access_forpush;
default_from_access_cfg(\$splitview_mode, 'split-view', 'auto',
printdebug "format $format, quilt mode $quilt_mode\n";
- if (madformat_wantfixup($format) && quiltmode_splitting()) {
+ if (format_quiltmode_splitting $format) {
$splitview_mode ne 'never' or
fail f_ "dgit: quilt mode \`%s' (for format \`%s')".
" implies split view, but split-view set to \`%s'",
$do_split_brain = 1;
}
$do_split_brain //= 0;
-
- return ($format);
}
sub supplementary_message ($) {
$$varref = $_;
}
-#---------- `ftpmasterapi' archive query method (nascent) ----------
+sub url_fetch ($;@) {
+ my ($url, %xopts) = @_;
+ # Ok404 => 1 means give undef for 404
+ # AccessBase => 'archive-query' (eg)
+ # CurlOpts => { key => value }
-sub archive_api_query_cmd ($) {
- my ($subpath) = @_;
- my @cmd = (@curl, qw(-sS));
- my $url = access_cfg('archive-query-url');
- if ($url =~ m#^https://([-.0-9a-z]+)/#) {
- my $host = $1;
- my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
- foreach my $key (split /\:/, $keys) {
- $key =~ s/\%HOST\%/$host/g;
- if (!stat $key) {
- fail "for $url: stat $key: $!" unless $!==ENOENT;
- next;
- }
- fail f_ "config requested specific TLS key but do not know".
- " how to get curl to use exactly that EE key (%s)",
- $key;
-# push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
-# # Sadly the above line does not work because of changes
-# # to gnutls. The real fix for #790093 may involve
-# # new curl options.
- last;
+ my $curl = WWW::Curl::Easy->new;
+ my $setopt = sub {
+ my ($k,$v) = @_;
+ my $x = $curl->setopt($k, $v);
+ confess "$k $v ".$curl->strerror($x)." ?" if $x;
+ };
+
+ my $response_body = '';
+ $setopt->(CURLOPT_REDIR_PROTOCOLS, CURLPROTO_HTTPS|CURLPROTO_HTTP);
+ $setopt->(CURLOPT_URL, $url);
+ $setopt->(CURLOPT_NOSIGNAL, 1);
+ $setopt->(CURLOPT_WRITEDATA, \$response_body);
+
+ my $xcurlopts = $xopts{CurlOpts} // { };
+ keys %$xcurlopts;
+ while (my ($k,$v) = each %$xcurlopts) { $setopt->($k,$v); }
+
+ if ($xopts{AccessBase} && $url =~ m#^https://([-.0-9a-z]+)/#) {
+ foreach my $k ("$xopts{AccessBase}-tls-key",
+ "$xopts{AccessBase}-tls-curl-ca-args") {
+ fail "config option $k is obsolete and no longer supported"
+ if defined access_cfg($k, 'RETURN-UNDEF');
}
- # Fixing #790093 properly will involve providing a value
- # for this on clients.
- my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
- push @cmd, split / /, $kargs if defined $kargs;
}
- push @cmd, $url.$subpath;
- return @cmd;
+
+ printdebug "query: fetching $url...\n";
+
+ local $SIG{PIPE} = 'IGNORE';
+
+ my $x = $curl->perform();
+ fail f_ "fetch of %s failed (%s): %s",
+ $url, $curl->strerror($x), $curl->errbuf
+ if $x;
+
+ my $code = $curl->getinfo(CURLINFO_HTTP_CODE);
+ if ($code eq '404' && $xopts{Ok404}) { return undef; }
+
+ fail f_ "fetch of %s gave HTTP code %s", $url, $code
+ unless $url =~ m#^file://# or $code =~ m/^2/;
+
+ confess unless defined $response_body;
+ return $response_body;
+}
+
+#---------- `ftpmasterapi' archive query method (nascent) ----------
+
+sub api_query_raw ($;$) {
+ my ($subpath, $ok404) = @_;
+ my $url = access_cfg('archive-query-url');
+ $url .= $subpath;
+ return url_fetch $url,
+ Ok404 => $ok404,
+ AccessBase => 'archive-query';
}
sub api_query ($$;$) {
- use JSON;
my ($data, $subpath, $ok404) = @_;
+ use JSON;
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 f_ "fetch of %s gave HTTP code %s", $url, $code
- unless $url =~ m#^file://# or $code =~ m/^2/;
+ my $json = api_query_raw $subpath, $ok404;
+ return undef unless defined $json;
return decode_json($json);
}
my $val = $release->{$name};
if (defined $val) {
printdebug "release file $name: $val\n";
+ cfg_apply_map(\$val, 'suite rmap',
+ access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
$val =~ m/^$suite_re$/o or fail f_
"Release file (%s) specifies intolerable %s",
$aptget_releasefile, $name;
- cfg_apply_map(\$val, 'suite rmap',
- access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
return $val
}
}
foreach my $vinfo (@vsns) {
my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
$dscurl = $vsn_dscurl;
- $dscdata = url_get($dscurl);
+ $dscdata = url_fetch($dscurl);
if (!$dscdata) {
$skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
next;
my $suffix = access_cfg('git-check-suffix','git-suffix',
'RETURN-UNDEF') // '.git';
my $url = "$prefix/$package$suffix";
- 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
- # HTTP/1.0 200 Connection established
- $result =~ m/^\S+ (404|200) /s or
- fail +(__ "unexpected results from git check query - ").
- Dumper($prefix, $result);
- my $code = $1;
- if ($code eq '404') {
- return 0;
- } elsif ($code eq '200') {
- return 1;
- } else {
- die;
- }
+ my $result = url_fetch $url,
+ CurlOpts => { CURLOPT_NOBODY() => 1 },
+ Ok404 => 1,
+ AccessBase => 'git-check';
+ $result = defined $result;
+ printdebug "dgit-repos check_for_git => $result.\n";
+ return $result;
} elsif ($how eq 'true') {
return 1;
} elsif ($how eq 'false') {
}
sub mktree_in_ud_here () {
- playtree_setup $gitcfgs{local};
+ playtree_setup();
}
sub git_write_tree () {
closedir DD;
}
-sub generate_commits_from_dsc () {
- # See big comment in fetch_from_archive, below.
- # See also README.dsc-import.
- prep_ud();
- changedir $playground;
-
- my $bpd_abs = bpd_abs();
- my $upstreamv = upstreamversion $dsc->{version};
- my @dfi = dsc_files_info();
-
- dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
- sub { grep { $_->{Filename} eq $_[0] } @dfi };
-
- foreach my $fi (@dfi) {
- my $f = $fi->{Filename};
- die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
- my $upper_f = "$bpd_abs/$f";
-
- printdebug "considering reusing $f: ";
-
- if (link_ltarget "$upper_f,fetch", $f) {
- printdebug "linked (using ...,fetch).\n";
- } elsif ((printdebug "($!) "),
- $! != ENOENT) {
- fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
- } elsif (link_ltarget $upper_f, $f) {
- printdebug "linked.\n";
- } elsif ((printdebug "($!) "),
- $! != ENOENT) {
- fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
- } else {
- printdebug "absent.\n";
- }
-
- my $refetched;
- complete_file_from_dsc('.', $fi, \$refetched)
- or next;
-
- printdebug "considering saving $f: ";
-
- if (rename_link_xf 1, $f, $upper_f) {
- printdebug "linked.\n";
- } elsif ((printdebug "($@) "),
- $! != EEXIST) {
- fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
- } elsif (!$refetched) {
- printdebug "no need.\n";
- } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
- printdebug "linked (using ...,fetch).\n";
- } elsif ((printdebug "($@) "),
- $! != EEXIST) {
- fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
- } else {
- printdebug "cannot.\n";
- }
- }
+sub import_tarball_tartrees ($$) {
+ my ($upstreamv, $dfi) = @_;
+ # cwd should be the playground
# We unpack and record the orig tarballs first, so that we only
# need disk space for one private copy of the unpacked source.
my @tartrees;
my $orig_f_base = srcfn $upstreamv, '';
- foreach my $fi (@dfi) {
+ 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;
$compr_ext, $orig_f_part
), "\n";
+ my $path = $fi->{Path} // $f;
my $input = new IO::File $f, '<' or die "$f $!";
my $compr_pid;
my @compr_cmd;
Sort => (!$orig_f_part ? 2 :
$orig_f_part =~ m/-/g ? 1 :
0),
+ OrigPart => $orig_f_part, # 'orig', 'orig-XXX', or undef
F => $f,
Tree => $tree,
};
$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;
+ @tartrees;
+}
- my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
- if (madformat $dsc->{format}) {
- check_for_vendor_patches();
- }
+sub import_tarball_commits ($$) {
+ my ($tartrees, $upstreamv) = @_;
+ # cwd should be a playtree which has a relevant debian/changelog
+ # fills in $tt->{Commit} for each one
- my $dappliedtree;
- if (madformat $dsc->{format}) {
- my @pcmd = qw(dpkg-source --before-build .);
- runcmd shell_cmd 'exec >/dev/null', @pcmd;
- rmtree '.pc';
- $dappliedtree = git_add_write_tree();
- }
+ my $any_orig = grep { $_->{Orig} } @$tartrees;
my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
my $clogp;
$changes =~ s/^\n//; # Changes: \n
my $cversion = getfield $clogp, 'Version';
- if (@tartrees) {
+ my $r1authline;
+ if (@$tartrees) {
$r1clogp //= $clogp; # maybe there's only one entry;
- my $r1authline = clogp_authline $r1clogp;
+ $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) {
+ foreach my $tt (@$tartrees) {
printdebug "import tartree $tt->{F} $tt->{Tree}\n";
- my $mbody = f_ "Import %s", $tt->{F};
+ # untranslated so that different people's imports are identical
+ my $mbody = sprintf "Import %s", $tt->{F};
$tt->{Commit} = hash_commit_text($tt->{Orig} ? <<END_O : <<END_T);
tree $tt->{Tree}
author $r1authline
}
}
+ return ($authline, $r1authline, $clogp, $changes);
+}
+
+sub generate_commits_from_dsc () {
+ # See big comment in fetch_from_archive, below.
+ # See also README.dsc-import.
+ prep_ud();
+ changedir $playground;
+
+ my $bpd_abs = bpd_abs();
+ my $upstreamv = upstreamversion $dsc->{version};
+ my @dfi = dsc_files_info();
+
+ dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
+ sub { grep { $_->{Filename} eq $_[0] } @dfi };
+
+ foreach my $fi (@dfi) {
+ my $f = $fi->{Filename};
+ die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
+ my $upper_f = "$bpd_abs/$f";
+
+ printdebug "considering reusing $f: ";
+
+ if (link_ltarget "$upper_f,fetch", $f) {
+ printdebug "linked (using ...,fetch).\n";
+ } elsif ((printdebug "($!) "),
+ $! != ENOENT) {
+ fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
+ } elsif (link_ltarget $upper_f, $f) {
+ printdebug "linked.\n";
+ } elsif ((printdebug "($!) "),
+ $! != ENOENT) {
+ fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
+ } else {
+ printdebug "absent.\n";
+ }
+
+ my $refetched;
+ complete_file_from_dsc('.', $fi, \$refetched)
+ or next;
+
+ printdebug "considering saving $f: ";
+
+ if (rename_link_xf 1, $f, $upper_f) {
+ printdebug "linked.\n";
+ } elsif ((printdebug "($@) "),
+ $! != EEXIST) {
+ fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
+ } elsif (!$refetched) {
+ printdebug "no need.\n";
+ } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
+ printdebug "linked (using ...,fetch).\n";
+ } elsif ((printdebug "($@) "),
+ $! != EEXIST) {
+ fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
+ } else {
+ printdebug "cannot.\n";
+ }
+ }
+
+ my @tartrees;
+ @tartrees = import_tarball_tartrees($upstreamv, \@dfi)
+ unless @dfi == 1; # only one file in .dsc
+
+ 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(__ "source package");
+ 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';
+ $dappliedtree = git_add_write_tree();
+ }
+
+ my ($authline, $r1authline, $clogp, $changes) =
+ import_tarball_commits(\@tartrees, $upstreamv);
+
+ my $cversion = getfield $clogp, 'Version';
+
printdebug "import main commit\n";
open C, ">../commit.tmp" or confess "$!";
if ($vcmp < 0) {
@output = ($rawimport_mergeinput, $lastpush_mergeinput,
{ ReverseParents => 1,
- Message => (f_ <<END, $package, $cversion, $csuite) });
+ # untranslated so that different people's pseudomerges
+ # are not needlessly different (although they will
+ # still differ if the series of pulls is different)
+ Message => (sprintf <<END, $package, $cversion, $csuite) });
Record %s (%s) in archive suite %s
END
} elsif ($vcmp > 0) {
printdone f_ "ready for work in %s", $dstdir;
}
+sub vcs_git_url_of_ctrl ($) {
+ my ($ctrl) = @_;
+ my $vcsgiturl = $ctrl->{'Vcs-Git'};
+ if (length $vcsgiturl) {
+ $vcsgiturl =~ s/\s+-b\s+\S+//g;
+ $vcsgiturl =~ s/\s+\[[^][]*\]//g;
+ }
+ return $vcsgiturl;
+}
+
sub clone ($) {
# in multisuite, returns twice!
# once in parent after first suite fetched,
record_maindir();
setup_new_tree();
clone_set_head();
- my $giturl = access_giturl(1);
- if (defined $giturl) {
- runcmd @git, qw(remote add), 'origin', $giturl;
- }
if ($hasgit) {
progress __ "fetching existing git history";
git_fetch_us();
- runcmd_ordryrun_local @git, qw(fetch origin);
} else {
progress __ "starting new git history";
}
fetch_from_archive() or no_such_package;
- my $vcsgiturl = $dsc->{'Vcs-Git'};
+ my $vcsgiturl = vcs_git_url_of_ctrl $dsc;
if (length $vcsgiturl) {
- $vcsgiturl =~ s/\s+-b\s+\S+//g;
runcmd @git, qw(remote add vcs-git), $vcsgiturl;
}
clone_finish($dstdir);
}
$_ = <F>;
F->error and confess "$!";
+ close F;
chomp;
return ($_, \%options);
}
my $cversion = getfield $clogp, 'Version';
my $clogsuite = getfield $clogp, 'Distribution';
+ my $format = getfield $dsc, 'Format';
# We make the git tag by hand because (a) that makes it easier
# to control the "tagger" (b) we can do remote signing
my $authline = clogp_authline $clogp;
- my $delibs = join(" ", "",@deliberatelies);
my $mktag = sub {
my ($tw) = @_;
tagger $authline
END
+
+ my @dtxinfo = @deliberatelies;
+ unshift @dtxinfo, "--quilt=$quilt_mode" if madformat($format);
+ unshift @dtxinfo, do_split_brain() ? "split" : "no-split"
+ # rpush protocol 5 and earlier don't tell us
+ unless $we_are_initiator && $protovsn < 6;
+ my $dtxinfo = join(" ", "",@dtxinfo);
+ my $tag_metadata = <<END;
+[dgit distro=$declaredistro$dtxinfo]
+END
+ foreach my $ref (sort keys %previously) {
+ $tag_metadata .= <<END or confess "$!";
+[dgit previously:$ref=$previously{$ref}]
+END
+ }
+
if ($tw->{View} eq 'dgit') {
- print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
+ print TO sprintf <<ENDT, $package, $cversion, $clogsuite, $csuite
%s release %s for %s (%s) [dgit]
ENDT
or confess "$!";
- print TO <<END or confess "$!";
-[dgit distro=$declaredistro$delibs]
-END
- foreach my $ref (sort keys %previously) {
- print TO <<END or confess "$!";
-[dgit previously:$ref=$previously{$ref}]
-END
- }
} elsif ($tw->{View} eq 'maint') {
- print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
+ print TO sprintf <<END, $package, $cversion, $clogsuite, $csuite;
%s release %s for %s (%s)
+
+END
+ print TO f_ <<END,
(maintainer view tag generated by dgit --quilt=%s)
END
$quilt_mode
} else {
confess Dumper($tw)."?";
}
+ print TO "\n", $tag_metadata;
close TO or confess "$!";
responder_send_command("param csuite $csuite");
responder_send_command("param isuite $isuite");
responder_send_command("param tagformat new"); # needed in $protovsn==4
+ responder_send_command("param splitbrain $do_split_brain");
if (defined $maintviewhead) {
responder_send_command("param maint-view $maintviewhead");
}
sub cmd_pull {
parseopts();
fetchpullargs();
- determine_whether_split_brain();
+ determine_whether_split_brain get_source_format();
if (do_split_brain()) {
my ($format, $fopts) = get_source_format();
madformat($format) and fail f_ <<END, $quilt_mode
get_archive_dsc();
$ctrl = $dsc;
}
- my $url = getfield $ctrl, 'Vcs-Git';
+ my $url = vcs_git_url_of_ctrl $ctrl;
+ fail 'no Vcs-Git header in control file' unless length $url;
my @cmd;
my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
print STDERR f_ "setting up vcs-git: %s\n", $url;
@cmd = (@git, qw(remote add vcs-git), $url);
} elsif ($orgurl eq $url) {
- print STDERR f_ "vcs git already configured: %s\n", $url;
+ print STDERR f_ "vcs git unchanged: %s\n", $url;
} else {
print STDERR f_ "changing vcs-git url to: %s\n", $url;
@cmd = (@git, qw(remote set-url vcs-git), $url);
}
- runcmd_ordryrun_local @cmd;
+ runcmd_ordryrun_local @cmd if @cmd;
if ($dofetch) {
print f_ "fetching (%s)\n", "@ARGV";
runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
}
our %i_wanted;
+our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
sub i_resp_want ($) {
my ($keyword) = @_;
$isuite = $i_param{'isuite'} // $i_param{'csuite'};
die unless $isuite =~ m/^$suite_re$/;
- pushing();
- rpush_handle_protovsn_bothends();
+ if (!defined $dsc) {
+ pushing();
+ rpush_handle_protovsn_bothends();
+ push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
+ if ($protovsn >= 6) {
+ determine_whether_split_brain getfield $dsc, 'Format';
+ $do_split_brain eq ($i_param{'splitbrain'} // '<unsent>')
+ or badproto \*RO,
+ "split brain mismatch, $do_split_brain != $i_param{'split_brain'}";
+ printdebug "rpush split brain $do_split_brain\n";
+ }
+ }
my @localpaths = i_method "i_want", $keyword;
printdebug "[[ $keyword @localpaths\n";
print RI "files-end\n" or confess "$!";
}
-our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
-
sub i_localname_parsed_changelog {
return "remote-changelog.822";
}
die unless $i_param{'csuite'} =~ m/^$suite_re$/;
$csuite = $&;
- push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
+ defined $dsc or badproto \*RO, "dsc (before parsed-changelog)";
my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
$editedignores, $cachekey) = @_;
my $gitignore_special = 1;
- if ($quilt_mode !~ m/gbp|dpm/) {
+ if ($quilt_mode !~ m/gbp|dpm|baredebian/) {
# treat .gitignore just like any other upstream file
$diffbits = { %$diffbits };
$_ = !!$_ foreach values %$diffbits;
$cmd;
};
- if ($quilt_mode =~ m/gbp|unapplied/ &&
+ if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
($diffbits->{O2H} & 01)) {
my $msg = f_
"--quilt=%s specified, implying patches-unapplied git tree\n".
" but git tree differs from orig in upstream files.",
$quilt_mode;
$msg .= $fulldiffhint->($unapplied, 'HEAD');
- if (!stat_exists "debian/patches") {
+ if (!stat_exists "debian/patches" and $quilt_mode !~ m/baredebian/) {
$msg .= __
"\n ... debian/patches is missing; perhaps this is a patch queue branch?";
}
but git tree differs from result of applying debian/patches to upstream
END
}
- if ($quilt_mode =~ m/gbp|unapplied/ &&
+ if ($quilt_mode =~ m/baredebian/) {
+ # We need to construct a merge which has upstream files from
+ # upstream and debian/ files from HEAD.
+
+ read_tree_upstream $quilt_upstream_commitish, 1, $headref;
+ my $version = getfield $clogp, 'Version';
+ my $upsversion = upstreamversion $version;
+ my $merge = make_commit
+ [ $headref, $quilt_upstream_commitish ],
+ [ +(f_ <<ENDT, $upsversion), $quilt_upstream_commitish_message, <<ENDU ];
+Combine debian/ with upstream source for %s
+ENDT
+[dgit ($our_version) baredebian-merge $version $quilt_upstream_commitish_used]
+ENDU
+ runcmd @git, qw(reset -q --hard), $merge;
+ }
+ if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
($diffbits->{O2A} & 01)) { # some patches
progress __ "dgit view: creating patches-applied version using gbp pq";
runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
return (undef, $splitbrain_cachekey);
}
+sub baredebian_origtarballs_scan ($$$) {
+ my ($fakedfi, $upstreamversion, $dir) = @_;
+ if (!opendir OD, $dir) {
+ return if $! == ENOENT;
+ fail "opendir $dir (origs): $!";
+ }
+
+ while ($!=0, defined(my $leaf = readdir OD)) {
+ {
+ local ($debuglevel) = $debuglevel-1;
+ printdebug "BDOS $dir $leaf ?\n";
+ }
+ next unless is_orig_file_of_vsn $leaf, $upstreamversion;
+ next if grep { $_->{Filename} eq $leaf } @$fakedfi;
+ push @$fakedfi, {
+ Filename => $leaf,
+ Path => "$dir/$leaf",
+ };
+ }
+
+ die "$dir; $!" if $!;
+ closedir OD;
+}
+
sub quilt_fixup_multipatch ($$$) {
my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
# We calculate some guesswork now about what kind of tree this might
# be. This is mostly for error reporting.
+ my $tentries = cmdoutput @git, qw(ls-tree --name-only -z), $headref;
+ my $onlydebian = $tentries eq "debian\0";
+
my $uheadref = $headref;
my $uhead_whatshort = 'HEAD';
+ if ($quilt_mode =~ m/baredebian\+tarball/) {
+ # We need to make a tarball import. Yuk.
+ # We want to do this here so that we have a $uheadref value
+
+ my @fakedfi;
+ baredebian_origtarballs_scan \@fakedfi, $upstreamversion, bpd_abs();
+ baredebian_origtarballs_scan \@fakedfi, $upstreamversion,
+ "$maindir/.." unless $buildproductsdir eq '..';
+ changedir '..';
+
+ my @tartrees = import_tarball_tartrees $upstreamversion, \@fakedfi;
+
+ fail __ "baredebian quilt fixup: could not find any origs"
+ unless @tartrees;
+
+ changedir 'work';
+ my ($authline, $r1authline, $clogp,) =
+ import_tarball_commits \@tartrees, $upstreamversion;
+
+ if (@tartrees == 1) {
+ $uheadref = $tartrees[0]{Commit};
+ # TRANSLATORS: this translation must fit in the ASCII art
+ # quilt differences display. The untranslated display
+ # says %9.9s, so with that display it must be at most 9
+ # characters.
+ $uhead_whatshort = __ 'tarball';
+ } else {
+ # on .dsc import we do not make a separate commit, but
+ # here we need to do so
+ rm_subdir_cached '.';
+ my $parents;
+ foreach my $ti (@tartrees) {
+ my $c = $ti->{Commit};
+ if ($ti->{OrigPart} eq 'orig') {
+ runcmd qw(git read-tree), $c;
+ } elsif ($ti->{OrigPart} =~ m/orig-/) {
+ read_tree_subdir $', $c;
+ } else {
+ confess "$ti->OrigPart} ?"
+ }
+ $parents .= "parent $c\n";
+ }
+ my $tree = git_write_tree();
+ my $mbody = f_ 'Combine orig tarballs for %s %s',
+ $package, $upstreamversion;
+ $uheadref = hash_commit_text <<END;
+tree $tree
+${parents}author $r1authline
+committer $r1authline
+
+$mbody
+
+[dgit import tarballs combine $package $upstreamversion]
+END
+ # TRANSLATORS: this translation must fit in the ASCII art
+ # quilt differences display. The untranslated display
+ # says %9.9s, so with that display it must be at most 9
+ # characters. This fragmentt is referring to multiple
+ # orig tarballs in a source package.
+ $uhead_whatshort = __ 'tarballs';
+
+ runcmd @git, qw(reset -q);
+ }
+ $quilt_upstream_commitish = $uheadref;
+ $quilt_upstream_commitish_used = '*orig*';
+ $quilt_upstream_commitish_message = '';
+ }
+ if ($quilt_mode =~ m/baredebian$/) {
+ $uheadref = $quilt_upstream_commitish;
+ # TRANSLATORS: this translation must fit in the ASCII art
+ # quilt differences display. The untranslated display
+ # says %9.9s, so with that display it must be at most 9
+ # characters.
+ $uhead_whatshort = __ 'upstream';
+ }
+
my %editedignores;
my @unrepres;
my $diffbits = {
progress f_
"%s: base trees orig=%.20s o+d/p=%.20s",
$us, $unapplied, $oldtiptree;
+ # TRANSLATORS: Try to keep this ascii-art layout right. The 0s in
+ # %9.00009s will be ignored and are there to make the format the
+ # same length (9 characters) as the output it generates. If you
+ # change the value 9, your translations of "upstream" and
+ # 'tarball' must fit into the new length, and you should change
+ # the number of 0s. Do not reduce it below 4 as HEAD has to fit
+ # too.
progress f_
"%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
"%s: quilt differences: %9.00009s %s o+d/p %9.00009s %s o+d/p",
$us, $dl[0], $dl[1], $dl[3], $dl[4],
$us, $uhead_whatshort, $dl[2], $uhead_whatshort, $dl[5];
- if (@unrepres) {
+ if (@unrepres && $quilt_mode !~ m/baredebian/) {
+ # With baredebian, even if the upstream commitish has this
+ # problem, we don't want to print this message, as nothing
+ # is going to try to make a patch out of it anyway.
print STDERR f_ "dgit: cannot represent change: %s: %s\n",
$_->[1], $_->[0]
foreach @unrepres;
}
my @failsuggestion;
- if (!($diffbits->{O2H} & $diffbits->{O2A})) {
+ if ($onlydebian) {
+ push @failsuggestion, [ 'onlydebian', __
+ "This has only a debian/ directory; you probably want --quilt=bare debian." ]
+ unless $quilt_mode =~ m/baredebian/;
+ } elsif (!($diffbits->{O2H} & $diffbits->{O2A})) {
push @failsuggestion, [ 'unapplied', __
"This might be a patches-unapplied branch." ];
} elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
if stat_exists '.gitattributes';
push @failsuggestion, [ 'origs', __
- "Maybe orig tarball(s) are not identical to git representation?" ];
+ "Maybe orig tarball(s) are not identical to git representation?" ]
+ unless $onlydebian && $quilt_mode !~ m/baredebian/;
+ # ^ in that case, we didn't really look properly
if (quiltmode_splitting()) {
quiltify_splitting($clogp, $unapplied, $headref, $oldtiptree,
}
sub maybe_apply_patches_dirtily () {
- return unless $quilt_mode =~ m/gbp|unapplied/;
+ return unless $quilt_mode =~ m/gbp|unapplied|baredebian/;
print STDERR __ <<END or confess "$!";
dgit: Building, or cleaning with rules target, in patches-unapplied tree.
sub clean_tree () {
# We always clean the tree ourselves, rather than leave it to the
# builder (dpkg-source, or soemthing which calls dpkg-source).
+ if ($quilt_mode =~ m/baredebian/ and $cleanmode =~ m/git/) {
+ fail f_ <<END, $quilt_mode, $cleanmode;
+quilt mode %s (generally needs untracked upstream files)
+contradicts clean mode %s (which would delete them)
+END
+ # This is not 100% true: dgit build-source and push-source
+ # (for example) could operate just fine with no upstream
+ # source in the working tree. But it doesn't seem likely that
+ # the user wants dgit to proactively delete such things.
+ # -wn, for example, would produce identical output without
+ # deleting anything from the working tree.
+ }
if ($cleanmode =~ m{^dpkg-source}) {
my @cmd = @dpkgbuildpackage;
push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
sub build_or_push_prep_early () {
our $build_or_push_prep_early_done //= 0;
return if $build_or_push_prep_early_done++;
- badusage f_ "-p is not allowed with dgit %s", $subcommand
- if defined $package;
my $clogp = parsechangelog();
$isuite = getfield $clogp, 'Distribution';
- $package = getfield $clogp, 'Source';
+ my $gotpackage = getfield $clogp, 'Source';
$version = getfield $clogp, 'Version';
+ $package //= $gotpackage;
+ if ($package ne $gotpackage) {
+ fail f_ "-p specified package %s, but changelog says %s",
+ $package, $gotpackage;
+ }
$dscfn = dscfn($version);
}
sub build_or_push_prep_modes () {
- my ($format,) = determine_whether_split_brain();
+ my ($format) = get_source_format();
+ determine_whether_split_brain($format);
fail __ "dgit: --include-dirty is not supported with split view".
" (including with view-splitting quilt modes)"
if do_split_brain() && $includedirty;
if (madformat_wantfixup $format and $quilt_mode =~ m/baredebian$/) {
- my ($dummy, $umessage);
- ($quilt_upstream_commitish, $dummy, $umessage) =
- resolve_upstream_version
+ ($quilt_upstream_commitish, $quilt_upstream_commitish_used,
+ $quilt_upstream_commitish_message)
+ = resolve_upstream_version
$quilt_upstream_commitish, upstreamversion $version;
- progress f_ "dgit: --quilt=%s, %s", $quilt_mode, $umessage;
+ progress f_ "dgit: --quilt=%s, %s", $quilt_mode,
+ $quilt_upstream_commitish_message;
} elsif (defined $quilt_upstream_commitish) {
fail __
"dgit: --upstream-commitish only makes sense with --quilt=baredebian"
badusage __ "need only 1 subpath argument" unless @ARGV==1;
my ($subpath) = @ARGV;
local $isuite = 'DGIT-API-QUERY-CMD';
- my @cmd = archive_api_query_cmd($subpath);
- push @cmd, qw(-f);
- debugcmd ">",@cmd;
- exec @cmd or fail f_ "exec curl: %s\n", $!;
+ my $json = api_query_raw $subpath;
+ print $json or die "$!";
}
sub repos_server_url () {
push @ropts, $_;
my $cmd = shift @$om;
@$om = ($cmd, grep { $_ ne $2 } @$om);
- } elsif (m/^--(gbp|dpm)$/s) {
+ } elsif (m/^--($quilt_options_re)$/s) {
push @ropts, "--quilt=$1";
$quilt_mode = $1;
} elsif (m/^--(?:ignore|include)-dirty$/s) {
f_ "%s: warning: ignoring unknown force option %s\n",
$us, $_;
$_='';
+ } elsif (m/^--for-push$/s) {
+ push @ropts, $_;
+ $access_forpush = 1;
} elsif (m/^--config-lookup-explode=(.+)$/s) {
# undocumented, for testing
push @ropts, $_;
or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
$quilt_mode = $1;
}
+ $quilt_mode =~ s/^(baredebian)\+git$/$1/;
foreach my $moc (@modeopt_cfgs) {
local $access_forpush;