X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=145fa9bb044be29d383f8849f7766ff0a72f2eab;hb=193cfa37a544a2c44f9252b83da54ca1af01c01f;hp=e179e3608abe1621aec27573fda68115e298574a;hpb=1523ee812507d8d3f90136d7062c995ed2e6108f;p=dgit.git diff --git a/dgit b/dgit index e179e360..145fa9bb 100755 --- a/dgit +++ b/dgit @@ -2,8 +2,9 @@ # 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 @@ -29,12 +30,13 @@ setup_sigwarn(); use IO::Handle; use Data::Dumper; -use LWP::UserAgent; +use WWW::Curl::Easy; use Dpkg::Control::Hash; use File::Path; use File::Spec; use File::Temp qw(tempdir); use File::Basename; +use File::Copy (); use Dpkg::Version; use Dpkg::Compression; use Dpkg::Compression::Process; @@ -45,6 +47,7 @@ use Digest::SHA; use Digest::MD5; use List::MoreUtils qw(pairwise); use Text::Glob qw(match_glob); +use Text::CSV; use Fcntl qw(:DEFAULT :flock); use Carp; @@ -53,7 +56,9 @@ use Debian::Dgit; our $our_version = 'UNRELEASED'; ###substituted### our $absurdity = undef; ###substituted### -our @rpushprotovsn_support = qw(4); # 4 is new tag format +$SIG{INT} = 'DEFAULT'; # work around #932841 + +our @rpushprotovsn_support = qw(6 5 4); # Reverse order! our $protovsn; our $cmd; @@ -79,7 +84,13 @@ 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|dpm|unapplied'; +our $quilt_upstream_commitish; +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 %internal_object_save; our $we_are_responder; @@ -92,13 +103,13 @@ our %forceopts = map { $_=>0 } qw(unrepresentable unsupported-source-format dsc-changes-mismatch changes-origs-exactly uploading-binaries uploading-source-only + reusing-version 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 = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )? | (?: git | git-ff ) (?: ,always )? | check (?: ,ignores )? @@ -111,7 +122,6 @@ our $rewritemap = 'dgit-rewrite/map'; 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); @@ -173,11 +183,11 @@ autoflush STDOUT 1; our $supplementary_message = ''; our $made_split_brain = 0; -our $do_split_brain = 0; +our $do_split_brain; # Interactions between quilt mode and split brain # (currently, split brain only implemented iff -# madformat_wantfixup && quiltmode_splitbrain) +# madformat_wantfixup && quiltmode_splitting) # # source format sane `3.0 (quilt)' # madformat_wantfixup() @@ -189,7 +199,7 @@ our $do_split_brain = 0; # # no split no q cache no q cache forbidden, # brain PM on master q fixup on master prevented -# !$do_split_brain PM on master +# !do_split_brain() PM on master # # split brain no q cache q fixup cached, to dgit view # PM in dgit view PM in dgit view @@ -214,11 +224,6 @@ if (!defined $absurdity) { $absurdity =~ s{/[^/]+$}{/absurd} or die; } -sub debiantag ($$) { - my ($v,$distro) = @_; - return debiantag_new($v, $distro); -} - sub madformat ($) { $_[0] eq '3.0 (quilt)' } sub lbranch () { return "$branchprefix/$csuite"; } @@ -296,9 +301,15 @@ sub deliberately_not_fast_forward () { } } -sub quiltmode_splitbrain () { - $quilt_mode =~ m/gbp|dpm|unapplied/; +sub quiltmode_splitting () { + $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) } sub opts_opt_multi_cmd { my $extra = shift; @@ -465,7 +476,8 @@ sub branch_is_gdr ($) { # # > param head DGIT-VIEW-HEAD # > param csuite SUITE -# > param tagformat new # $protovsn >= 4 +# > 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 @@ -630,20 +642,6 @@ sub progress { 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; } @@ -776,6 +774,12 @@ our %defcfg = ('dgit.default.distro' => 'debian', '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", @@ -866,6 +870,22 @@ sub access_basedistro__noalias () { return $kl->{$k}; } } + foreach my $csvf () { + my $csv_distro = + $csvf =~ m{/(\w+)\.csv$} ? $1 : do { + printdebug "skipping $csvf\n"; + next; + }; + my $csv = Text::CSV->new({ binary => 1, auto_diag => 2 }) or die; + my $fh = new IO::File $csvf, "<:encoding(utf8)" + or die "open $csvf: $!"; + while (my $cols = $csv->getline($fh)) { + next unless $cols->[2] eq $isuite; + return $csv_distro; + } + die "$csvf $!" if $fh->error; + close $fh; + } return cfg("dgit.default.distro"); } } @@ -970,6 +990,27 @@ sub notpushing () { parseopts_late_defaults(); } +sub determine_whether_split_brain ($) { + my ($format) = @_; + { + local $access_forpush; + default_from_access_cfg(\$splitview_mode, 'split-view', 'auto', + $splitview_modes_re); + $do_split_brain = 1 if $splitview_mode eq 'always'; + } + + printdebug "format $format, quilt mode $quilt_mode\n"; + + 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'", + $quilt_mode, $format, $splitview_mode; + $do_split_brain = 1; + } + $do_split_brain //= 0; +} + sub supplementary_message ($) { my ($msg) = @_; if (!$we_are_responder) { @@ -1156,56 +1197,75 @@ sub cfg_apply_map ($$$) { $$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_FOLLOWLOCATION, 1); + $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); } @@ -1407,11 +1467,11 @@ sub canonicalise_suite_aptget { 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 } } @@ -1696,7 +1756,7 @@ sub get_archive_dsc () { foreach my $vinfo (@vsns) { my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo; $dscurl = $vsn_dscurl; - $dscdata = url_get($dscurl); + $dscdata = url_fetch($dscurl, Ok404 => 1 ); if (!$dscdata) { $skew_warning_vsn = $vsn if !defined $skew_warning_vsn; next; @@ -1750,22 +1810,13 @@ sub check_for_git () { 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') { @@ -1800,7 +1851,7 @@ sub prep_ud () { } sub mktree_in_ud_here () { - playtree_setup $gitcfgs{local}; + playtree_setup(); } sub git_write_tree () { @@ -1984,7 +2035,7 @@ sub test_source_only_changes ($) { foreach my $l (split /\n/, getfield $changes, 'Files') { $l =~ m/\S+$/ or next; # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages - unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) { + unless ($& =~ m/(?:\.dsc|\.diff\.gz|$tarball_f_ext_re|_source\.buildinfo)$/) { print f_ "purportedly source-only changes polluted by %s\n", $&; return 0; } @@ -2091,11 +2142,6 @@ END } } -sub make_commit ($) { - my ($file) = @_; - return cmdoutput @git, qw(hash-object -w -t commit), $file; -} - sub clogp_authline ($) { my ($clogp) = @_; my $author = getfield $clogp, 'Maintainer'; @@ -2249,62 +2295,9 @@ sub dotdot_bpd_transfer_origs ($$$) { 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. @@ -2314,14 +2307,13 @@ sub generate_commits_from_dsc () { 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; @@ -2333,6 +2325,7 @@ sub generate_commits_from_dsc () { $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; @@ -2398,6 +2391,7 @@ sub generate_commits_from_dsc () { 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, }; @@ -2411,36 +2405,15 @@ sub generate_commits_from_dsc () { $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; @@ -2494,20 +2467,22 @@ sub generate_commits_from_dsc () { $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}; - $tt->{Commit} = make_commit_text($tt->{Orig} ? <{F}; + $tt->{Commit} = hash_commit_text($tt->{Orig} ? <{Tree} author $r1authline committer $r1authline @@ -2527,6 +2502,104 @@ END_T } } + 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 "$!"; @@ -2546,14 +2619,14 @@ $changes END close C or confess "$!"; - my $rawimport_hash = make_commit qw(../commit.tmp); + my $rawimport_hash = hash_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(<../../absurd-apply-warnings" or die $!; + close T or die $!; progress f_ "%s: trying slow absurd-git-apply...", $us; rename "../../gbp-pq-output","../../gbp-pq-output.0" or $!==ENOENT @@ -2621,6 +2696,11 @@ gbp-pq import and dpkg-source disagree! dpkg-source --before-build gave tree %s END $rawimport_hash = $gapplied; + + if ($use_absurd) { + File::Copy::copy("../../absurd-apply-warnings", \*STDERR) + or die $!; + } }; last unless $@; } @@ -2646,7 +2726,10 @@ END if ($vcmp < 0) { @output = ($rawimport_mergeinput, $lastpush_mergeinput, { ReverseParents => 1, - Message => (f_ < (sprintf < 0) { @@ -2927,11 +3010,7 @@ sub git_fetch_us () { # deliberately-not-ff, in which case we must fetch everything. my @specs = deliberately_not_fast_forward ? qw(tags/*) : - map { "tags/$_" } - (quiltmode_splitbrain - ? (map { $_->('*',access_nomdistro) } - \&debiantag_new, \&debiantag_maintview) - : debiantags('*',access_nomdistro)); + map { "tags/$_" } debiantags('*',access_nomdistro); push @specs, server_branch($csuite); push @specs, $rewritemap; push @specs, qw(heads/*) if deliberately_not_fast_forward; @@ -3407,7 +3486,7 @@ END } close MC or confess "$!"; - $hash = make_commit $mcf; + $hash = hash_commit $mcf; } else { $hash = $mergeinputs[0]{Commit}; } @@ -3529,7 +3608,7 @@ sub is_gitattrs_setup () { # 0: there is a dgit-defuse-attrs but it needs fixing # undef: there is none my $gai = open_main_gitattrs(); - return 0 unless $gai; + return undef unless $gai; while (<$gai>) { next unless m{$gitattrs_ourmacro_re}; return 1 if m{\s-working-tree-encoding\s}; @@ -3768,7 +3847,7 @@ sub fork_for_multisuite ($) { $commit .= "author $authline\n". "committer $authline\n\n"; - $output = make_commit_text $commit.$msg; + $output = hash_commit_text $commit.$msg; printdebug "multisuite merge generated $output\n"; } @@ -3796,6 +3875,16 @@ END 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, @@ -3827,21 +3916,15 @@ sub clone ($) { 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); @@ -3977,6 +4060,7 @@ sub get_source_format () { } $_ = ; F->error and confess "$!"; + close F; chomp; return ($_, \%options); } @@ -4095,7 +4179,7 @@ END return $i_arch_v; } -sub pseudomerge_make_commit ($$$$ $$) { +sub pseudomerge_hash_commit ($$$$ $$) { my ($clogp, $dgitview, $archive_hash, $i_arch_v, $msg_cmd, $msg_msg) = @_; progress f_ "Declaring that HEAD includes all changes in %s...", @@ -4127,7 +4211,7 @@ $msg_msg END close MC or confess "$!"; - return make_commit($pmf); + return hash_commit($pmf); } sub splitbrain_pseudomerge ($$$$) { @@ -4185,7 +4269,7 @@ ENDT } my $arch_v = $i_arch_v->[0]; - my $r = pseudomerge_make_commit + my $r = pseudomerge_hash_commit $clogp, $dgitview, $archive_hash, $i_arch_v, "dgit --quilt=$quilt_mode", (defined $overwrite_version @@ -4209,7 +4293,7 @@ sub plain_overwrite_pseudomerge ($$$) { my $m = f_ "Declare fast forward from %s", $i_arch_v->[0]; - my $r = pseudomerge_make_commit + my $r = pseudomerge_hash_commit $clogp, $head, $archive_hash, $i_arch_v, "dgit", $m; @@ -4234,7 +4318,7 @@ sub push_parse_changelog ($) { if (!$we_are_initiator) { # rpush initiator can't do this because it doesn't have $isuite yet - my $tag = debiantag($cversion, access_nomdistro); + my $tag = debiantag_new($cversion, access_nomdistro); runcmd @git, qw(check-ref-format), $tag; } @@ -4258,7 +4342,7 @@ sub push_tagwants ($$$$) { my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_; my @tagwants; push @tagwants, { - TagFn => \&debiantag, + TagFn => \&debiantag_new, Objid => $dgithead, TfSuffix => '', View => 'dgit', @@ -4270,10 +4354,7 @@ sub push_tagwants ($$$$) { TfSuffix => '-maintview', View => 'maint', }; - } elsif ($dodep14tag eq 'no' ? 0 - : $dodep14tag eq 'want' ? 1 - : $dodep14tag eq 'always' ? 1 - : die "$dodep14tag ?") { + } elsif ($dodep14tag ne 'no') { push @tagwants, { TagFn => \&debiantag_maintview, Objid => $dgithead, @@ -4312,11 +4393,11 @@ sub push_mktags ($$ $$ $) { 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) = @_; @@ -4332,22 +4413,33 @@ tag $tag 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 = <{View} eq 'dgit') { - print TO f_ <{View} eq 'maint') { - print TO f_ <= 6) { + determine_whether_split_brain getfield $dsc, 'Format'; + $do_split_brain eq ($i_param{'splitbrain'} // '') + 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"; @@ -5150,8 +5271,6 @@ sub i_resp_want ($) { 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"; } @@ -5211,7 +5330,7 @@ sub i_want_signed_tag { my $maintview = $i_param{'maint-view'}; die if defined $maintview && $maintview =~ m/[^0-9a-f]/; - if ($protovsn >= 4) { + if ($protovsn == 4) { my $p = $i_param{'tagformat'} // ''; $p eq 'new' or badproto \*RO, "tag format mismatch: $p vs. new"; @@ -5219,7 +5338,7 @@ sub i_want_signed_tag { 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"; @@ -5342,11 +5461,11 @@ sub quiltify_tree_sentinelfiles ($) { return $r; } -sub quiltify_splitbrain ($$$$$$$) { +sub quiltify_splitting ($$$$$$$) { 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; @@ -5361,7 +5480,7 @@ sub quiltify_splitbrain ($$$$$$$) { local $ENV{GIT_AUTHOR_EMAIL} = $authline[1]; local $ENV{GIT_AUTHOR_DATE} = $authline[2]; - confess unless $do_split_brain; + confess unless do_split_brain(); my $fulldiffhint = sub { my ($x,$y) = @_; @@ -5371,14 +5490,14 @@ sub quiltify_splitbrain ($$$$$$$) { $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?"; } @@ -5391,7 +5510,23 @@ sub quiltify_splitbrain ($$$$$$$) { 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_ <{O2A} & 01)) { # some patches progress __ "dgit view: creating patches-applied version using gbp pq"; runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import); @@ -5747,7 +5882,7 @@ sub build_maybe_quilt_fixup () { my $splitbrain_cachekey; - if ($do_split_brain) { + if (do_split_brain()) { my $cachehit; ($cachehit, $splitbrain_cachekey) = quilt_check_splitbrain_cache($headref, $upstreamversion); @@ -5758,7 +5893,7 @@ sub build_maybe_quilt_fixup () { } unpack_playtree_need_cd_work($headref); - if ($do_split_brain) { + if (do_split_brain()) { runcmd @git, qw(checkout -q -b dgit-view); # so long as work is not deleted, its current branch will # remain dgit-view, rather than master, so subsequent calls to @@ -5773,14 +5908,14 @@ sub build_maybe_quilt_fixup () { fail f_ "quilt mode %s does not make sense (or is not supported) with single-debian-patch", $quilt_mode - if quiltmode_splitbrain(); + if quiltmode_splitting(); quilt_fixup_singlepatch($clogp, $headref, $upstreamversion); } else { quilt_fixup_multipatch($clogp, $headref, $upstreamversion, $splitbrain_cachekey); } - if ($do_split_brain) { + if (do_split_brain()) { my $dgitview = git_rev_parse 'HEAD'; changedir $maindir; @@ -5972,6 +6107,7 @@ sub quilt_check_splitbrain_cache ($$) { push @cachekey, $upstreamversion; push @cachekey, $quilt_mode; push @cachekey, $headref; + push @cachekey, $quilt_upstream_commitish // '-'; push @cachekey, hashfile('fake.dsc'); @@ -6008,6 +6144,30 @@ sub quilt_check_splitbrain_cache ($$) { 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) = @_; @@ -6155,15 +6315,97 @@ END # 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 < quiltify_trees_differ($unapplied,$headref, 1, + O2H => quiltify_trees_differ($unapplied,$uheadref, 1, \%editedignores, \@unrepres), - H2A => quiltify_trees_differ($headref, $oldtiptree,1), + H2A => quiltify_trees_differ($uheadref, $oldtiptree,1), O2A => quiltify_trees_differ($unapplied,$oldtiptree,1), }; @@ -6178,13 +6420,23 @@ END 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: HEAD %s o+d/p HEAD %s o+d/p", +"%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, $dl[2], $dl[5]; + $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; @@ -6194,7 +6446,11 @@ END } 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})) { @@ -6209,18 +6465,20 @@ END if stat_exists '.gitattributes'; push @failsuggestion, [ 'origs', __ - "Maybe orig tarball(s) are not identical to git representation?" ]; - - if (quiltmode_splitbrain()) { - quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree, - $diffbits, \%editedignores, - $splitbrain_cachekey); + "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, + $diffbits, \%editedignores, + $splitbrain_cachekey); return; } progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode; quiltify($clogp,$headref,$oldtiptree,\@failsuggestion); - runcmd @git, qw(checkout -q), (qw(master dgit-view)[!!$do_split_brain]); + runcmd @git, qw(checkout -q), (qw(master dgit-view)[do_split_brain()]); if (!open P, '>>', ".pc/applied-patches") { $!==&ENOENT or confess "$!"; @@ -6255,7 +6513,7 @@ sub quilt_fixup_editor () { } sub maybe_apply_patches_dirtily () { - return unless $quilt_mode =~ m/gbp|unapplied/; + return unless $quilt_mode =~ m/gbp|unapplied|baredebian/; print STDERR __ <",@cmd; - exec @cmd or fail f_ "exec curl: %s\n", $!; + my $json = api_query_raw $subpath; + print $json or die "$!"; } sub repos_server_url () { @@ -7309,7 +7620,7 @@ sub parseopts () { 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) { @@ -7327,12 +7638,21 @@ sub parseopts () { } elsif (m/^--overwrite$/s) { push @ropts, $_; $overwrite_version = ''; + } elsif (m/^--split-(?:view|brain)$/s) { + push @ropts, $_; + $splitview_mode = 'always'; + } elsif (m/^--split-(?:view|brain)=($splitview_modes_re)$/s) { + push @ropts, $_; + $splitview_mode = $1; } elsif (m/^--overwrite=(.+)$/s) { push @ropts, $_; $overwrite_version = $1; } elsif (m/^--delayed=(\d+)$/s) { push @ropts, $_; push @dput, $_; + } elsif (m/^--upstream-commitish=(.+)$/s) { + push @ropts, $_; + $quilt_upstream_commitish = $1; } elsif (m/^--save-(dgit-view)=(.+)$/s || m/^--(dgit-view)-save=(.+)$/s ) { @@ -7355,6 +7675,9 @@ sub parseopts () { 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, $_; @@ -7500,6 +7823,7 @@ sub parseopts_late_defaults () { 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;