X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=49350ee70782bd08eb10d4a005d315c3f4e58252;hp=bc9f74e1b82815f2e0f4dec6708b37f134480672;hb=675a7f895eb4768ae4078342f880852196626948;hpb=59fbae9cfaa385e896af7714ee697a675de557ec diff --git a/dgit b/dgit index bc9f74e1..49350ee7 100755 --- a/dgit +++ b/dgit @@ -2,7 +2,8 @@ # dgit # Integration between git and Debian-style archives # -# Copyright (C)2013-2016 Ian Jackson +# Copyright (C)2013-2017 Ian Jackson +# Copyright (C)2017 Sean Whitton # # 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 @@ -19,7 +20,7 @@ use strict; -use Debian::Dgit; +use Debian::Dgit qw(:DEFAULT :playground); setup_sigwarn(); use IO::Handle; @@ -30,11 +31,12 @@ use File::Path; use File::Temp qw(tempdir); use File::Basename; use Dpkg::Version; +use Dpkg::Compression; +use Dpkg::Compression::Process; use POSIX; use IPC::Open2; use Digest::SHA; use Digest::MD5; -use List::Util qw(any); use List::MoreUtils qw(pairwise); use Text::Glob qw(match_glob); use Fcntl qw(:DEFAULT :flock); @@ -48,7 +50,9 @@ our $absurdity = undef; ###substituted### our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format our $protovsn; -our $isuite = 'unstable'; +our $cmd; +our $subcommand; +our $isuite; our $idistro; our $package; our @ropts; @@ -69,13 +73,16 @@ 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 $dodep14tag; our $split_brain_save; our $we_are_responder; +our $we_are_initiator; our $initiator_tempdir; our $patches_applied_dirtily = 00; our $tagformat_want; our $tagformat; our $tagformatfn; +our $chase_dsc_distro=1; our %forceopts = map { $_=>0 } qw(unrepresentable unsupported-source-format @@ -88,16 +95,19 @@ 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_comp_re = qr{orig(?:-$extra_orig_namepart_re)?}; 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 $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); +our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L)); our (@dput) = qw(dput); our (@debsign) = qw(debsign); our (@gpg) = qw(gpg); @@ -106,8 +116,8 @@ our (@ssh) = 'ssh'; our (@dgit) = qw(dgit); our (@aptget) = qw(apt-get); our (@aptcache) = qw(apt-cache); -our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git); -our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git); +our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores); +our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores); our (@dpkggenchanges) = qw(dpkg-genchanges); our (@mergechanges) = qw(mergechanges -f); our (@gbp_build) = (''); @@ -139,8 +149,11 @@ our %opts_cfg_insertpos = map { scalar @{ $opts_opt_map{$_} } } keys %opts_opt_map; -sub finalise_opts_opts(); +sub parseopts_late_defaults(); +sub setup_gitattrs(;$); +sub check_gitattrs($$); +our $playground; our $keyid; autoflush STDOUT 1; @@ -151,6 +164,7 @@ our $split_brain = 0; END { local ($@, $?); + return unless forkcheck_mainprocess(); print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg; } @@ -171,8 +185,7 @@ sub debiantag ($$) { sub debiantag_maintview ($$) { my ($v,$distro) = @_; - $v =~ y/~:/_%/; - return "$distro/$v"; + return "$distro/".dep14_version_mangle $v; } sub madformat ($) { $_[0] eq '3.0 (quilt)' } @@ -183,30 +196,6 @@ sub lref () { return "refs/heads/".lbranch(); } sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); } sub rrref () { return server_ref($csuite); } -sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; } -sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); } - -# We fetch some parts of lrfetchrefs/*. Ideally we delete these -# locally fetched refs because they have unhelpful names and clutter -# up gitk etc. So we track whether we have "used up" head ref (ie, -# whether we have made another local ref which refers to this object). -# -# (If we deleted them unconditionally, then we might end up -# re-fetching the same git objects each time dgit fetch was run.) -# -# So, leach use of lrfetchrefs needs to be accompanied by arrangements -# in git_fetch_us to fetch the refs in question, and possibly a call -# to lrfetchref_used. - -our (%lrfetchrefs_f, %lrfetchrefs_d); -# $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid - -sub lrfetchref_used ($) { - my ($fullrefname) = @_; - my $objid = $lrfetchrefs_f{$fullrefname}; - $lrfetchrefs_d{$fullrefname} = $objid if defined $objid; -} - sub stripepoch ($) { my ($vsn) = @_; $vsn =~ s/^\d+\://; @@ -240,6 +229,7 @@ initdebug(''); our @end; END { local ($?); + return unless forkcheck_mainprocess(); foreach my $f (@end) { eval { $f->(); }; print STDERR "$us: cleanup: $@" if length $@; @@ -267,12 +257,6 @@ sub no_such_package () { exit 4; } -sub changedir ($) { - my ($newdir) = @_; - printdebug "CD $newdir\n"; - chdir $newdir or confess "chdir: $newdir: $!"; -} - sub deliberately ($) { my ($enquiry) = @_; return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies; @@ -299,6 +283,10 @@ sub gbp_pq { return opts_opt_multi_cmd @gbp_pq; } +sub dgit_privdir () { + our $dgit_privdir_made //= ensure_a_playground 'dgit'; +} + #---------- remote protocol support, common ---------- # remote push initiator/responder protocol: @@ -334,6 +322,9 @@ sub gbp_pq { # > param tagformat old|new # > param maint-view MAINT-VIEW-HEAD # +# > param buildinfo-filename P_V_X.buildinfo # zero or more times +# > file buildinfo # for buildinfos to sign +# # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward # # goes into tag, for replay prevention # @@ -350,6 +341,9 @@ sub gbp_pq { # [etc] # < data-block NBYTES [transfer of signed changes] # [etc] +# < data-block NBYTES [transfer of each signed buildinfo +# [etc] same number and order as "file buildinfo"] +# ... # < files-end # # > complete @@ -505,12 +499,6 @@ sub url_get { our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn); -sub runcmd { - debugcmd "+",@_; - $!=0; $?=-1; - failedcmd @_ if system @_; -} - sub act_local () { return $dryrun_level <= 1; } sub act_scary () { return !$dryrun_level; } @@ -554,6 +542,7 @@ main usages: dgit [dgit-opts] build [dpkg-buildpackage-opts] dgit [dgit-opts] sbuild [sbuild-opts] dgit [dgit-opts] push [dgit-opts] [suite] + dgit [dgit-opts] push-source [dgit-opts] [suite] dgit [dgit-opts] rpush build-host:build-dir ... important dgit options: -k sign tag and package with instead of default @@ -578,6 +567,9 @@ sub nextarg { return scalar shift @ARGV; } +sub pre_help () { + not_necessarily_a_tree(); +} sub cmd_help () { print $helpmsg or die $!; exit 0; @@ -586,6 +578,8 @@ sub cmd_help () { our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset"; our %defcfg = ('dgit.default.distro' => 'debian', + 'dgit.default.default-suite' => 'unstable', + 'dgit.default.old-dsc-distro' => 'debian', 'dgit-suite.*-security.distro' => 'debian-security', 'dgit.default.username' => '', 'dgit.default.archive-query-default-component' => 'main', @@ -594,6 +588,10 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit.default.sshpsql-dbname' => 'service=projectb', 'dgit.default.aptget-components' => 'main', 'dgit.default.dgit-tag-format' => 'new,old,maint', + 'dgit.dsc-url-proto-ok.http' => 'true', + 'dgit.dsc-url-proto-ok.https' => 'true', + 'dgit.dsc-url-proto-ok.git' => 'true', + 'dgit.default.dsc-url-proto-ok' => 'false', # 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" @@ -648,32 +646,17 @@ our %defcfg = ('dgit.default.distro' => 'debian', our %gitcfgs; our @gitcfgsources = qw(cmdline local global system); +our $invoked_in_git_tree = 1; sub git_slurp_config () { - local ($debuglevel) = $debuglevel-2; - local $/="\0"; - # 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 () { - chomp or die; - printdebug "=> ", (messagequote $_), "\n"; - m/\n/ or die "$_ ?"; - push @{ $gitcfgs{$src}{$`} }, $'; #'; - } - $!=0; $?=0; - close GITS - or ($!==0 && $?==256) - or failedcmd @cmd; + $gitcfgs{$src} = git_slurp_config_src $src; } } @@ -681,7 +664,10 @@ sub git_get_config ($) { my ($c) = @_; foreach my $src (@gitcfgsources) { my $l = $gitcfgs{$src}{$c}; - printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n" + confess "internal error ($l $c)" if $l && !ref $l; + printdebug"C $c ".(defined $l ? + join " ", map { messagequote "'$_'" } @$l : + "undef")."\n" if $debuglevel >= 4; $l or next; @$l==1 or badcfg "multiple values for $c". @@ -694,16 +680,26 @@ sub git_get_config ($) { sub cfg { foreach my $c (@_) { return undef if $c =~ /RETURN-UNDEF/; + printdebug "C? $c\n" if $debuglevel >= 5; my $v = git_get_config($c); return $v if defined $v; my $dv = $defcfg{$c}; - return $dv if defined $dv; + if (defined $dv) { + printdebug "CD $c $dv\n" if $debuglevel >= 4; + return $dv; + } } badcfg "need value for one of: @_\n". "$us: distro or suite appears not to be (properly) supported"; } -sub access_basedistro () { +sub not_necessarily_a_tree () { + # needs to be called from pre_* + @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources; + $invoked_in_git_tree = 0; +} + +sub access_basedistro__noalias () { if (defined $idistro) { return $idistro; } else { @@ -723,9 +719,18 @@ sub access_basedistro () { } } +sub access_basedistro () { + my $noalias = access_basedistro__noalias(); + my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF'); + return $canon // $noalias; +} + sub access_nomdistro () { my $base = access_basedistro(); - return cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base; + my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base; + $r =~ m/^$distro_re$/ or badcfg + "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)"; + return $r; } sub access_quirk () { @@ -789,11 +794,11 @@ sub pushing () { Push failed, before we got started. You can retry the push, after fixing the problem, if you like. END - finalise_opts_opts(); + parseopts_late_defaults(); } sub notpushing () { - finalise_opts_opts(); + parseopts_late_defaults(); } sub supplementary_message ($) { @@ -986,19 +991,13 @@ sub commit_getclogp ($) { our %commit_getclogp_memo; my $memo = $commit_getclogp_memo{$objid}; return $memo if $memo; - mkpath '.git/dgit'; - my $mclog = ".git/dgit/clog-$objid"; + + my $mclog = dgit_privdir()."clog"; runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob), "$objid:debian/changelog"; $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog"); } -sub must_getcwd () { - my $d = getcwd(); - defined $d or fail "getcwd failed: $!"; - return $d; -} - sub parse_dscdata () { my $dscfh = new IO::File \$dscdata, '<' or die $!; printdebug Dumper($dscdata) if $debuglevel>1; @@ -1010,6 +1009,8 @@ our %rmad; sub archive_query ($;@) { my ($method) = shift @_; + fail "this operation does not support multiple comma-separated suites" + if $isuite =~ m/,/; my $query = access_cfg('archive-query','RETURN-UNDEF'); $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'"; my $proto = $1; @@ -1162,7 +1163,7 @@ sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; } sub aptget_cache_clean { runcmd_ordryrun_local qw(sh -ec), - 'cd "$1"; pwd; find -atime +30 -type f -print0 | xargs -0r echo rm --', + 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --', 'x', $aptget_base; } @@ -1313,6 +1314,8 @@ sub archive_query_aptget { return [ (getfield $pre_dsc, 'Version'), $uri ]; } +sub file_in_archive_aptget () { return undef; } + #---------- `dummyapicat' archive query method ---------- sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; } @@ -1518,6 +1521,15 @@ sub access_cfg_tagformats () { split /\,/, access_cfg('dgit-tag-format'); } +sub access_cfg_tagformats_can_splitbrain () { + my %y = map { $_ => 1 } access_cfg_tagformats; + foreach my $needtf (qw(new maint)) { + next if $y{$needtf}; + return 0; + } + return 1; +} + sub need_tagformat ($$) { my ($fmt, $why) = @_; fail "need to use tag format $fmt ($why) but also need". @@ -1562,6 +1574,8 @@ sub canonicalise_suite () { $csuite = archive_query('canonicalise_suite'); if ($isuite ne $csuite) { progress "canonical suite name for $isuite is $csuite"; + } else { + progress "canonical suite name is $csuite"; } } @@ -1665,22 +1679,16 @@ sub create_remote_git_repo () { } our ($dsc_hash,$lastpush_mergeinput); +our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url); -our $ud = '.git/dgit/unpack'; -sub prep_ud (;$) { - my ($d) = @_; - $d //= $ud; - rmtree($d); - mkpath '.git/dgit'; - mkdir $d or die $!; +sub prep_ud () { + dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir + $playground = fresh_playground 'dgit/unpack'; } sub mktree_in_ud_here () { - runcmd qw(git init -q); - runcmd qw(git config gc.auto 0); - rmtree('.git/objects'); - symlink '../../../../objects','.git/objects' or die $!; + playtree_setup $gitcfgs{local}; } sub git_write_tree () { @@ -1689,7 +1697,13 @@ sub git_write_tree () { return $tree; } -sub remove_stray_gits () { +sub git_add_write_tree () { + runcmd @git, qw(add -Af .); + return git_write_tree(); +} + +sub remove_stray_gits ($) { + my ($what) = @_; my @gitscmd = qw(find -name .git -prune -print0); debugcmd "|",@gitscmd; open GITS, "-|", @gitscmd or die $!; @@ -1697,7 +1711,7 @@ sub remove_stray_gits () { local $/="\0"; while () { chomp or die; - print STDERR "$us: warning: removing from source package: ", + print STDERR "$us: warning: removing from $what: ", (messagequote $_), "\n"; rmtree $_; } @@ -1705,17 +1719,17 @@ sub remove_stray_gits () { $!=0; $?=0; close GITS or failedcmd @gitscmd; } -sub mktree_in_ud_from_only_subdir (;$) { - my ($raw) = @_; - +sub mktree_in_ud_from_only_subdir ($;$) { + my ($what,$raw) = @_; # changes into the subdir + my (@dirs) = <*/.>; die "expected one subdir but found @dirs ?" unless @dirs==1; $dirs[0] =~ m#^([^/]+)/\.$# or die; my $dir = $1; changedir $dir; - remove_stray_gits(); + remove_stray_gits($what); mktree_in_ud_here(); if (!$raw) { my ($format, $fopts) = get_source_format(); @@ -1724,8 +1738,7 @@ sub mktree_in_ud_from_only_subdir (;$) { } } - runcmd @git, qw(add -Af); - my $tree=git_write_tree(); + my $tree=git_add_write_tree(); return ($tree,$dir); } @@ -1838,6 +1851,40 @@ sub is_orig_file_of_vsn ($$) { return 1; } +# This function determines whether a .changes file is source-only from +# the point of view of dak. Thus, it permits *_source.buildinfo +# files. +# +# It does not, however, permit any other buildinfo files. After a +# source-only upload, the buildds will try to upload files like +# foo_1.2.3_amd64.buildinfo. If the package maintainer included files +# named like this in their (otherwise) source-only upload, the uploads +# of the buildd can be rejected by dak. Fixing the resultant +# situation can require manual intervention. So we block such +# .buildinfo files when the user tells us to perform a source-only +# upload (such as when using the push-source subcommand with the -C +# option, which calls this function). +# +# Note, though, that when dgit is told to prepare a source-only +# upload, such as when subcommands like build-source and push-source +# without -C are used, dgit has a more restrictive notion of +# source-only .changes than dak: such uploads will never include +# *_source.buildinfo files. This is because there is no use for such +# files when using a tool like dgit to produce the source package, as +# dgit ensures the source is identical to git HEAD. +sub test_source_only_changes ($) { + my ($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)$/) { + print "purportedly source-only changes polluted by $&\n"; + return 0; + } + } + return 1; +} + sub changes_update_origs_from_dsc ($$$$) { my ($dsc, $changes, $upstreamvsn, $changesfile) = @_; my %changes_f; @@ -1887,7 +1934,8 @@ END push @found_differ, "archive $h->{filename}: ".join "; ", @differ if @differ; } - print "origs $file f.same=$found_same #f._differ=$#found_differ\n"; + printdebug "origs $file f.same=$found_same". + " #f._differ=$#found_differ\n"; if (@found_differ && !$found_same) { fail join "\n", "archive contains $file with different checksum", @@ -1963,7 +2011,14 @@ sub make_commit_text ($) { sub clogp_authline ($) { my ($clogp) = @_; my $author = getfield $clogp, 'Maintainer'; - $author =~ s#,.*##ms; + if ($author =~ m/^[^"\@]+\,/) { + # single entry Maintainer field with unquoted comma + $author = ($& =~ y/,//rd).$'; # strip the comma + } + # git wants a single author; any remaining commas in $author + # are by now preceded by @ (or "). It seems safer to punt on + # "..." for now rather than attempting to dequote or something. + $author =~ s#,.*##ms unless $author =~ m/"/; my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date'); my $authline = "$author $date"; $authline =~ m/$git_authline_re/o or @@ -2042,29 +2097,50 @@ sub generate_commits_from_dsc () { # See big comment in fetch_from_archive, below. # See also README.dsc-import. prep_ud(); - changedir $ud; + changedir $playground; my @dfi = dsc_files_info(); foreach my $fi (@dfi) { my $f = $fi->{Filename}; die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#; + my $upper_f = "$maindir/../$f"; + + printdebug "considering reusing $f: "; + + if (link_ltarget "$upper_f,fetch", $f) { + printdebug "linked (using ...,fetch).\n"; + } elsif ((printdebug "($!) "), + $! != ENOENT) { + fail "accessing ../$f,fetch: $!"; + } elsif (link_ltarget $upper_f, $f) { + printdebug "linked.\n"; + } elsif ((printdebug "($!) "), + $! != ENOENT) { + fail "accessing ../$f: $!"; + } else { + printdebug "absent.\n"; + } - printdebug "considering linking $f: "; - - link_ltarget "../../../../$f", $f - or ((printdebug "($!) "), 0) - or $!==&ENOENT - or die "$f $!"; - - printdebug "linked.\n"; - - complete_file_from_dsc('.', $fi) + my $refetched; + complete_file_from_dsc('.', $fi, \$refetched) or next; - if (is_orig_file_in_dsc($f, \@dfi)) { - link $f, "../../../../$f" - or $!==&EEXIST - or die "$f $!"; + printdebug "considering saving $f: "; + + if (link $f, $upper_f) { + printdebug "linked.\n"; + } elsif ((printdebug "($!) "), + $! != EEXIST) { + fail "saving ../$f: $!"; + } elsif (!$refetched) { + printdebug "no need.\n"; + } elsif (link $f, "$upper_f,fetch") { + printdebug "linked (using ...,fetch).\n"; + } elsif ((printdebug "($!) "), + $! != EEXIST) { + fail "saving ../$f,fetch: $!"; + } else { + printdebug "cannot.\n"; } } @@ -2107,7 +2183,7 @@ sub generate_commits_from_dsc () { if defined $compr_ext && !defined $cname; my $compr_proc = new Dpkg::Compression::Process compression => $cname; - my @compr_cmd = $compr_proc->get_uncompress_cmdline(); + @compr_cmd = $compr_proc->get_uncompress_cmdline(); my $compr_fh = new IO::Handle; my $compr_pid = open $compr_fh, "-|" // die $!; if (!$compr_pid) { @@ -2118,14 +2194,14 @@ sub generate_commits_from_dsc () { $input = $compr_fh; } - rmtree "../unpack-tar"; - mkdir "../unpack-tar" or die $!; + rmtree "_unpack-tar"; + mkdir "_unpack-tar" or die $!; my @tarcmd = qw(tar -x -f - --no-same-owner --no-same-permissions --no-acls --no-xattrs --no-selinux); my $tar_pid = fork // die $!; if (!$tar_pid) { - chdir "../unpack-tar" or die $!; + chdir "_unpack-tar" or die $!; open STDIN, "<&", $input or die $!; exec @tarcmd; die "dgit (child): exec $tarcmd[0]: $!"; @@ -2134,16 +2210,26 @@ sub generate_commits_from_dsc () { !$? or failedcmd @tarcmd; close $input or - (@compr_cmd ? failedcmd @compr_cmd + (@compr_cmd ? ($?==SIGPIPE || 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"; + runcmd qw(chmod -R +rwX _unpack-tar); + changedir "_unpack-tar"; + remove_stray_gits($f); + mktree_in_ud_here(); + + my ($tree) = git_add_write_tree(); + my $tentries = cmdoutput @git, qw(ls-tree -z), $tree; + if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) { + $tree = $1; + printdebug "one subtree $1\n"; + } else { + printdebug "multiple subtrees\n"; + } + changedir ".."; + rmtree "_unpack-tar"; my $ent = [ $f, $tree ]; push @tartrees, { @@ -2182,7 +2268,7 @@ sub generate_commits_from_dsc () { push @cmd, qw(-x --), $dscfn; runcmd @cmd; - my ($tree,$dir) = mktree_in_ud_from_only_subdir(); + my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package"); if (madformat $dsc->{format}) { check_for_vendor_patches(); } @@ -2192,8 +2278,7 @@ sub generate_commits_from_dsc () { my @pcmd = qw(dpkg-source --before-build .); runcmd shell_cmd 'exec >/dev/null', @pcmd; rmtree '.pc'; - runcmd @git, qw(add -Af); - $dappliedtree = git_write_tree(); + $dappliedtree = git_add_write_tree(); } my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all); @@ -2255,6 +2340,7 @@ sub generate_commits_from_dsc () { my $authline = clogp_authline $clogp; my $changes = getfield $clogp, 'Changes'; + $changes =~ s/^\n//; # Changes: \n my $cversion = getfield $clogp, 'Version'; if (@tartrees) { @@ -2337,7 +2423,13 @@ END my $path = $ENV{PATH} or die; + # we use ../../gbp-pq-output, which (given that we are in + # $playground/PLAYTREE, and $playground is .git/dgit/unpack, + # is .git/dgit. + foreach my $use_absurd (qw(0 1)) { + runcmd @git, qw(checkout -q unpa); + runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa); local $ENV{PATH} = $path; if ($use_absurd) { chomp $@; @@ -2354,11 +2446,12 @@ END die "only absurd git-apply!\n" if !$use_absurd && forceing [qw(import-gitapply-absurd)]; - local $ENV{PATH} = $path if $use_absurd; + local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd; + local $ENV{PATH} = $path if $use_absurd; my @showcmd = (gbp_pq, qw(import)); my @realcmd = shell_cmd - 'exec >/dev/null 2>../../gbp-pq-output', @showcmd; + 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd; debugcmd "+",@realcmd; if (system @realcmd) { die +(shellquote @showcmd). @@ -2418,44 +2511,61 @@ END @output = $lastpush_mergeinput; } } - changedir '../../../..'; - rmtree($ud); + changedir $maindir; + rmtree $playground; return @output; } -sub complete_file_from_dsc ($$) { - our ($dstdir, $fi) = @_; - # Ensures that we have, in $dir, the file $fi, with the correct +sub complete_file_from_dsc ($$;$) { + our ($dstdir, $fi, $refetched) = @_; + # Ensures that we have, in $dstdir, the file $fi, with the correct # contents. (Downloading it from alongside $dscurl if necessary.) + # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}" + # and will set $$refetched=1 if it did so (or tried to). my $f = $fi->{Filename}; my $tf = "$dstdir/$f"; my $downloaded = 0; + my $got; + my $checkhash = sub { + open F, "<", "$tf" or die "$tf: $!"; + $fi->{Digester}->reset(); + $fi->{Digester}->addfile(*F); + F->error and die $!; + $got = $fi->{Digester}->hexdigest(); + return $got eq $fi->{Hash}; + }; + if (stat_exists $tf) { - progress "using existing $f"; + if ($checkhash->()) { + progress "using existing $f"; + return 1; + } + if (!$refetched) { + fail "file $f has hash $got but .dsc". + " demands hash $fi->{Hash} ". + "(perhaps you should delete this file?)"; + } + progress "need to fetch correct version of $f"; + unlink $tf or die "$tf $!"; + $$refetched = 1; } else { printdebug "$tf does not exist, need to fetch\n"; - my $furl = $dscurl; - $furl =~ s{/[^/]+$}{}; - $furl .= "/$f"; - die "$f ?" unless $f =~ m/^\Q${package}\E_/; - die "$f ?" if $f =~ m#/#; - runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl"; - return 0 if !act_local(); - $downloaded = 1; - } - - open F, "<", "$tf" or die "$tf: $!"; - $fi->{Digester}->reset(); - $fi->{Digester}->addfile(*F); - F->error and die $!; - my $got = $fi->{Digester}->hexdigest(); - $got eq $fi->{Hash} or + } + + my $furl = $dscurl; + $furl =~ s{/[^/]+$}{}; + $furl .= "/$f"; + die "$f ?" unless $f =~ m/^\Q${package}\E_/; + die "$f ?" if $f =~ m#/#; + runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl"; + return 0 if !act_local(); + + $checkhash->() or fail "file $f has hash $got but .dsc". " demands hash $fi->{Hash} ". - ($downloaded ? "(got wrong file from archive!)" - : "(perhaps you should delete this file?)"); + "(got wrong file from archive!)"; return 1; } @@ -2470,18 +2580,41 @@ sub ensure_we_have_orig () { } } -sub git_fetch_us () { - # Want to fetch only what we are going to use, unless - # deliberately-not-ff, in which case we must fetch everything. +#---------- git fetch ---------- - my @specs = deliberately_not_fast_forward ? qw(tags/*) : - map { "tags/$_" } - (quiltmode_splitbrain - ? (map { $_->('*',access_nomdistro) } - \&debiantag_new, \&debiantag_maintview) - : debiantags('*',access_nomdistro)); - push @specs, server_branch($csuite); - push @specs, qw(heads/*) if deliberately_not_fast_forward; +sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); } +sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); } + +# We fetch some parts of lrfetchrefs/*. Ideally we delete these +# locally fetched refs because they have unhelpful names and clutter +# up gitk etc. So we track whether we have "used up" head ref (ie, +# whether we have made another local ref which refers to this object). +# +# (If we deleted them unconditionally, then we might end up +# re-fetching the same git objects each time dgit fetch was run.) +# +# So, each use of lrfetchrefs needs to be accompanied by arrangements +# in git_fetch_us to fetch the refs in question, and possibly a call +# to lrfetchref_used. + +our (%lrfetchrefs_f, %lrfetchrefs_d); +# $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid + +sub lrfetchref_used ($) { + my ($fullrefname) = @_; + my $objid = $lrfetchrefs_f{$fullrefname}; + $lrfetchrefs_d{$fullrefname} = $objid if defined $objid; +} + +sub git_lrfetch_sane { + my ($url, $supplementary, @specs) = @_; + # Make a 'refs/'.lrfetchrefs.'/*' be just like on server, + # at least as regards @specs. Also leave the results in + # %lrfetchrefs_f, and arrange for lrfetchref_used to be + # able to clean these up. + # + # With $supplementary==1, @specs must not contain wildcards + # and we add to our previous fetches (non-atomically). # This is rather miserable: # When git fetch --prune is passed a fetchspec ending with a *, @@ -2505,30 +2638,31 @@ sub git_fetch_us () { # git fetch to try to generate it. If we don't manage to generate # the target state, we try again. - printdebug "git_fetch_us specs @specs\n"; + printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n"; my $specre = join '|', map { my $x = $_; $x =~ s/\W/\\$&/g; - $x =~ s/\\\*$/.*/; + my $wildcard = $x =~ s/\\\*$/.*/; + die if $wildcard && $supplementary; "(?:refs/$x)"; } @specs; - printdebug "git_fetch_us specre=$specre\n"; + printdebug "git_lrfetch_sane specre=$specre\n"; my $wanted_rref = sub { local ($_) = @_; - return m/^(?:$specre)$/o; + return m/^(?:$specre)$/; }; my $fetch_iteration = 0; FETCH_ITERATION: for (;;) { - printdebug "git_fetch_us iteration $fetch_iteration\n"; + printdebug "git_lrfetch_sane iteration $fetch_iteration\n"; if (++$fetch_iteration > 10) { fail "too many iterations trying to get sane fetch!"; } my @look = map { "refs/$_" } @specs; - my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look); + my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look); debugcmd "|",@lcmd; my %wantr; @@ -2554,13 +2688,14 @@ END "+refs/$_:".lrfetchrefs."/$_"; } @specs; - printdebug "git_fetch_us fspecs @fspecs\n"; + printdebug "git_lrfetch_sane fspecs @fspecs\n"; - my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs); - runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), - @fspecs; + my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs); + runcmd_ordryrun_local @fcmd if @fspecs; - %lrfetchrefs_f = (); + if (!$supplementary) { + %lrfetchrefs_f = (); + } my %objgot; git_for_each_ref(lrfetchrefs, sub { @@ -2569,6 +2704,10 @@ END $objgot{$objid} = 1; }); + if ($supplementary) { + last; + } + foreach my $lrefname (sort keys %lrfetchrefs_f) { my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs); if (!exists $wantr{$rrefname}) { @@ -2610,8 +2749,36 @@ END } last; } - printdebug "git_fetch_us: git fetch --no-insane emulation complete\n", + + if (defined $csuite) { + printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n"; + git_for_each_ref("refs/dgit-fetch/$csuite", sub { + my ($objid,$objtype,$lrefname,$reftail) = @_; + next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ? + runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname; + }); + } + + printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n", Dumper(\%lrfetchrefs_f); +} + +sub git_fetch_us () { + # Want to fetch only what we are going to use, unless + # deliberately-not-ff, in which case we must fetch everything. + + my @specs = deliberately_not_fast_forward ? qw(tags/*) : + map { "tags/$_" } + (quiltmode_splitbrain + ? (map { $_->('*',access_nomdistro) } + \&debiantag_new, \&debiantag_maintview) + : debiantags('*',access_nomdistro)); + push @specs, server_branch($csuite); + push @specs, $rewritemap; + push @specs, qw(heads/*) if deliberately_not_fast_forward; + + my $url = access_giturl(); + git_lrfetch_sane $url, 0, @specs; my %here; my @tagpats = debiantags('*',access_nomdistro); @@ -2632,12 +2799,14 @@ END } elsif ($here{$lref} eq $objid) { lrfetchref_used $fullrefname; } else { - print STDERR \ - "Not updateting $lref from $here{$lref} to $objid.\n"; + print STDERR + "Not updating $lref from $here{$lref} to $objid.\n"; } }); } +#---------- dsc and archive handling ---------- + sub mergeinfo_getclogp ($) { # Ensures thit $mi->{Clogp} exists and returns it my ($mi) = @_; @@ -2648,6 +2817,150 @@ sub mergeinfo_version ($) { return getfield( (mergeinfo_getclogp $_[0]), 'Version' ); } +sub fetch_from_archive_record_1 ($) { + my ($hash) = @_; + runcmd @git, qw(update-ref -m), "dgit fetch $csuite", + 'DGIT_ARCHIVE', $hash; + cmdoutput @git, qw(log -n2), $hash; + # ... gives git a chance to complain if our commit is malformed +} + +sub fetch_from_archive_record_2 ($) { + my ($hash) = @_; + my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash); + if (act_local()) { + cmdoutput @upd_cmd; + } else { + dryrun_report @upd_cmd; + } +} + +sub parse_dsc_field_def_dsc_distro () { + $dsc_distro //= cfg qw(dgit.default.old-dsc-distro + dgit.default.distro); +} + +sub parse_dsc_field ($$) { + my ($dsc, $what) = @_; + my $f; + foreach my $field (@ourdscfield) { + $f = $dsc->{$field}; + last if defined $f; + } + + if (!defined $f) { + progress "$what: NO git hash"; + parse_dsc_field_def_dsc_distro(); + } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url) + = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) { + progress "$what: specified git info ($dsc_distro)"; + $dsc_hint_tag = [ $dsc_hint_tag ]; + } elsif ($f =~ m/^\w+\s*$/) { + $dsc_hash = $&; + parse_dsc_field_def_dsc_distro(); + $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'), + $dsc_distro ]; + progress "$what: specified git hash"; + } else { + fail "$what: invalid Dgit info"; + } +} + +sub resolve_dsc_field_commit ($$) { + my ($already_distro, $already_mapref) = @_; + + return unless defined $dsc_hash; + + my $mapref = + defined $already_mapref && + ($already_distro eq $dsc_distro || !$chase_dsc_distro) + ? $already_mapref : undef; + + my $do_fetch; + $do_fetch = sub { + my ($what, @fetch) = @_; + + local $idistro = $dsc_distro; + my $lrf = lrfetchrefs; + + if (!$chase_dsc_distro) { + progress + "not chasing .dsc distro $dsc_distro: not fetching $what"; + return 0; + } + + progress + ".dsc names distro $dsc_distro: fetching $what"; + + my $url = access_giturl(); + if (!defined $url) { + defined $dsc_hint_url or fail <("rewrite map", $rewritemap) or return; + $mapref = $lrf.'/'.$rewritemap; + } + my $rewritemapdata = git_cat_file $mapref.':map'; + if (defined $rewritemapdata + && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) { + progress + "server's git history rewrite map contains a relevant entry!"; + + $dsc_hash = $1; + if (defined $dsc_hash) { + progress "using rewritten git hash in place of .dsc value"; + } else { + progress "server data says .dsc hash is to be disregarded"; + } + } + } + + if (!defined git_cat_file $dsc_hash) { + my @tags = map { "tags/".$_ } @$dsc_hint_tag; + my $lrf = $do_fetch->("additional commits", @tags) && + defined git_cat_file $dsc_hash + or fail <{$field}; - last if defined $dsc_hash; - } - if (defined $dsc_hash) { - $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'"; - $dsc_hash = $&; - progress "last upload to archive specified git hash"; - } else { - progress "last upload to archive has NO git hash"; - } + parse_dsc_field($dsc, 'last upload to archive'); + resolve_dsc_field_commit access_basedistro, + lrfetchrefs."/".$rewritemap } else { progress "no version available from the archive"; } @@ -2904,7 +3209,7 @@ END my $author = clogp_authline $useclogp; my $cversion = getfield $useclogp, 'Version'; - my $mcf = ".git/dgit/mergecommit"; + my $mcf = dgit_privdir()."/mergecommit"; open MC, ">", $mcf or die "$mcf $!"; print MC <($lastfetch_hash, 'local tracking tip (last fetch)'); - runcmd @git, qw(update-ref -m), "dgit fetch $csuite", - 'DGIT_ARCHIVE', $hash; - cmdoutput @git, qw(log -n2), $hash; - # ... gives git a chance to complain if our commit is malformed + fetch_from_archive_record_1($hash); if (defined $skew_warning_vsn) { - mkpath '.git/dgit'; printdebug "SKEW CHECK WANT $skew_warning_vsn\n"; my $gotclogp = commit_getclogp($hash); my $got_vsn = getfield $gotclogp, 'Version'; @@ -2984,16 +3285,13 @@ END } if ($lastfetch_hash ne $hash) { - my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash); - if (act_local()) { - cmdoutput @upd_cmd; - } else { - dryrun_report @upd_cmd; - } + fetch_from_archive_record_2($hash); } lrfetchref_used lrfetchref(); + check_gitattrs($hash, "fetched source tree"); + unshift @end, $del_lrfetchrefs; return $hash; } @@ -3009,8 +3307,9 @@ sub setup_mergechangelogs (;$) { my $driver = 'dpkg-mergechangelogs'; my $cb = "merge.$driver"; - my $attrs = '.git/info/attributes'; - ensuredir '.git/info'; + confess unless defined $maindir; + my $attrs = "$maindir_gitcommon/info/attributes"; + ensuredir "$maindir_gitcommon/info"; open NATTRS, ">", "$attrs.new" or die "$attrs.new $!"; if (!open ATTRS, "<", $attrs) { @@ -3055,24 +3354,299 @@ sub ensure_setup_existing_tree () { set_local_git_config $k, 'true'; } +sub open_main_gitattrs () { + confess 'internal error no maindir' unless defined $maindir; + my $gai = new IO::File "$maindir_gitcommon/info/attributes" + or $!==ENOENT + or die "open $maindir_gitcommon/info/attributes: $!"; + return $gai; +} + +sub is_gitattrs_setup () { + my $gai = open_main_gitattrs(); + return 0 unless $gai; + while (<$gai>) { + return 1 if m{^\[attr\]dgit-defuse-attrs\s}; + } + $gai->error and die $!; + return 0; +} + +sub setup_gitattrs (;$) { + my ($always) = @_; + return unless $always || access_cfg_bool(1, 'setup-gitattributes'); + + if (is_gitattrs_setup()) { + progress < $af.new" or die $!; + print GAO <) { + chomp; + print GAO $_, "\n" or die $!; + } + $gai->error and die $!; + } + close GAO or die $!; + rename "$af.new", "$af" or die "install $af: $!"; +} + sub setup_new_tree () { setup_mergechangelogs(); setup_useremail(); + setup_gitattrs(); +} + +sub check_gitattrs ($$) { + my ($treeish, $what) = @_; + + return if is_gitattrs_setup; + + local $/="\0"; + my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:"); + debugcmd "|",@cmd; + my $gafl = new IO::File; + open $gafl, "-|", @cmd or die $!; + while (<$gafl>) { + chomp or die; + s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die; + next if $1 == 0; + next unless m{(?:^|/)\.gitattributes$}; + + # oh dear, found one + print STDERR <(), and returns undef + # in parent, returns canonical suite name for $tsuite + my $canonsuitefh = IO::File::new_tmpfile; + my $pid = fork // die $!; + if (!$pid) { + forkcheck_setup(); + $isuite = $tsuite; + $us .= " [$isuite]"; + $debugprefix .= " "; + progress "fetching $tsuite..."; + canonicalise_suite(); + print $canonsuitefh $csuite, "\n" or die $!; + close $canonsuitefh or die $!; + $fn->(); + return undef; + } + waitpid $pid,0 == $pid or die $!; + fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4; + seek $canonsuitefh,0,0 or die $!; + local $csuite = <$canonsuitefh>; + die $! unless defined $csuite && chomp $csuite; + if ($? == 256*4) { + printdebug "multisuite $tsuite missing\n"; + return $csuite; + } + printdebug "multisuite $tsuite ok (canon=$csuite)\n"; + push @$merginputs, { + Ref => lrref, + Info => $csuite, + }; + return $csuite; +} + +sub fork_for_multisuite ($) { + my ($before_fetch_merge) = @_; + # if nothing unusual, just returns '' + # + # if multisuite: + # returns 0 to caller in child, to do first of the specified suites + # in child, $csuite is not yet set + # + # returns 1 to caller in parent, to finish up anything needed after + # in parent, $csuite is set to canonicalised portmanteau + + my $org_isuite = $isuite; + my @suites = split /\,/, $isuite; + return '' unless @suites > 1; + printdebug "fork_for_multisuite: @suites\n"; + + my @mergeinputs; + + my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs, + sub { }); + return 0 unless defined $cbasesuite; + + fail "package $package missing in (base suite) $cbasesuite" + unless @mergeinputs; + + my @csuites = ($cbasesuite); + + $before_fetch_merge->(); + + foreach my $tsuite (@suites[1..$#suites]) { + $tsuite =~ s/^-/$cbasesuite-/; + my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs, + sub { + @end = (); + fetch(); + exit 0; + }); + # xxx collecte the ref here + + $csubsuite =~ s/^\Q$cbasesuite\E-/-/; + push @csuites, $csubsuite; + } + + foreach my $mi (@mergeinputs) { + my $ref = git_get_ref $mi->{Ref}; + die "$mi->{Ref} ?" unless length $ref; + $mi->{Commit} = $ref; + } + + $csuite = join ",", @csuites; + + my $previous = git_get_ref lrref; + if ($previous) { + unshift @mergeinputs, { + Commit => $previous, + Info => "local combined tracking branch", + Warning => + "archive seems to have rewound: local tracking branch is ahead!", + }; + } + + foreach my $ix (0..$#mergeinputs) { + $mergeinputs[$ix]{Index} = $ix; + } + + @mergeinputs = sort { + -version_compare(mergeinfo_version $a, + mergeinfo_version $b) # highest version first + or + $a->{Index} <=> $b->{Index}; # earliest in spec first + } @mergeinputs; + + my @needed; + + NEEDED: + foreach my $mi (@mergeinputs) { + printdebug "multisuite merge check $mi->{Info}\n"; + foreach my $previous (@needed) { + next unless is_fast_fwd $mi->{Commit}, $previous->{Commit}; + printdebug "multisuite merge un-needed $previous->{Info}\n"; + next NEEDED; + } + push @needed, $mi; + printdebug "multisuite merge this-needed\n"; + $mi->{Character} = '+'; + } + + $needed[0]{Character} = '*'; + + my $output = $needed[0]{Commit}; + + if (@needed > 1) { + printdebug "multisuite merge nontrivial\n"; + my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':'; + + my $commit = "tree $tree\n"; + my $msg = "Combine archive branches $csuite [dgit]\n\n". + "Input branches:\n"; + + foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) { + printdebug "multisuite merge include $mi->{Info}\n"; + $mi->{Character} //= ' '; + $commit .= "parent $mi->{Commit}\n"; + $msg .= sprintf " %s %-25s %s\n", + $mi->{Character}, + (mergeinfo_version $mi), + $mi->{Info}; + } + my $authline = clogp_authline mergeinfo_getclogp $needed[0]; + $msg .= "\nKey\n". + " * marks the highest version branch, which choose to use\n". + " + marks each branch which was not already an ancestor\n\n". + "[dgit multi-suite $csuite]\n"; + $commit .= + "author $authline\n". + "committer $authline\n\n"; + $output = make_commit_text $commit.$msg; + printdebug "multisuite merge generated $output\n"; + } + + fetch_from_archive_record_1($output); + fetch_from_archive_record_2($output); + + progress "calculated combined tracking suite $csuite"; + + return 1; +} + +sub clone_set_head () { + open H, "> .git/HEAD" or die $!; + print H "ref: ".lref()."\n" or die $!; + close H or die $!; +} +sub clone_finish ($) { + my ($dstdir) = @_; + runcmd @git, qw(reset --hard), lrref(); + runcmd qw(bash -ec), <<'END'; + set -o pipefail + git ls-tree -r --name-only -z HEAD | \ + xargs -0r touch -h -r . -- +END + printdone "ready for work in $dstdir"; } sub clone ($) { + # in multisuite, returns twice! + # once in parent after first suite fetched, + # and then again in child after everything is finished my ($dstdir) = @_; - canonicalise_suite(); badusage "dry run makes no sense with clone" unless act_local(); + + my $multi_fetched = fork_for_multisuite(sub { + printdebug "multi clone before fetch merge\n"; + changedir $dstdir; + record_maindir(); + }); + if ($multi_fetched) { + printdebug "multi clone after fetch merge\n"; + clone_set_head(); + clone_finish($dstdir); + return; + } + printdebug "clone main body\n"; + + canonicalise_suite(); my $hasgit = check_for_git(); mkdir $dstdir or fail "create \`$dstdir': $!"; changedir $dstdir; runcmd @git, qw(init -q); + record_maindir(); + setup_new_tree(); + clone_set_head(); my $giturl = access_giturl(1); if (defined $giturl) { - open H, "> .git/HEAD" or die $!; - print H "ref: ".lref()."\n" or die $!; - close H or die $!; runcmd @git, qw(remote add), 'origin', $giturl; } if ($hasgit) { @@ -3088,17 +3662,11 @@ sub clone ($) { $vcsgiturl =~ s/\s+-b\s+\S+//g; runcmd @git, qw(remote add vcs-git), $vcsgiturl; } - setup_new_tree(); - runcmd @git, qw(reset --hard), lrref(); - runcmd qw(bash -ec), <<'END'; - set -o pipefail - git ls-tree -r --name-only -z HEAD | \ - xargs -0r touch -r . -- -END - printdone "ready for work in $dstdir"; + clone_finish($dstdir); } sub fetch () { + canonicalise_suite(); if (check_for_git()) { git_fetch_us(); } @@ -3107,7 +3675,9 @@ sub fetch () { } sub pull () { - fetch(); + my $multi_fetched = fork_for_multisuite(sub { }); + fetch() unless $multi_fetched; # parent + return if $multi_fetched eq '0'; # child runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]", lrref(); printdone "fetched to ".lrref()." and merged into HEAD"; @@ -3122,15 +3692,7 @@ sub check_not_dirty () { return if $ignoredirty; - my @cmd = (@git, qw(diff --quiet HEAD)); - debugcmd "+",@cmd; - $!=0; $?=-1; system @cmd; - return if !$?; - if ($?==256) { - fail "working tree is dirty (does not match HEAD)"; - } else { - failedcmd @cmd; - } + git_check_unmodified(); } sub commit_admin ($) { @@ -3212,7 +3774,7 @@ sub maybe_split_brain_save ($$$) { my ($headref, $dgitview, $msg) = @_; # => message fragment "$saved" describing disposition of $dgitview return "commit id $dgitview" unless defined $split_brain_save; - my @cmd = (shell_cmd "cd ../../../..", + my @cmd = (shell_cmd 'cd "$1"; shift', $maindir, @git, qw(update-ref -m), "dgit --dgit-view-save $msg HEAD=$headref", $split_brain_save, $dgitview); @@ -3270,18 +3832,28 @@ sub pseudomerge_version_check ($$) { } else { my $v = $i_arch_v->[0]; progress "Checking package changelog for archive version $v ..."; + my $cd; eval { my @xa = ("-f$v", "-t$v"); my $vclogp = parsechangelog @xa; - my $cv = [ (getfield $vclogp, 'Version'), - "Version field from dpkg-parsechangelog @xa" ]; + my $gf = sub { + my ($fn) = @_; + [ (getfield $vclogp, $fn), + "$fn field from dpkg-parsechangelog @xa" ]; + }; + my $cv = $gf->('Version'); infopair_cond_equal($i_arch_v, $cv); + $cd = $gf->('Distribution'); }; if ($@) { $@ =~ s/^dgit: //gm; fail "$@". "Perhaps debian/changelog does not mention $v ?"; } + fail <[0] =~ m/UNRELEASED/; +$cd->[1] is $cd->[0] +Your tree seems to based on earlier (not uploaded) $v. +END } } @@ -3303,15 +3875,14 @@ sub pseudomerge_make_commit ($$$$ $$) { : !length $overwrite_version ? " --overwrite" : " --overwrite=".$overwrite_version; - mkpath '.git/dgit'; - my $pmf = ".git/dgit/pseudomerge"; + my $pmf = dgit_privdir()."/pseudomerge"; open MC, ">", $pmf or die "$pmf $!"; print MC < '-maintview', View => 'maint', }; - } + } elsif ($dodep14tag eq 'no' ? 0 + : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain + : $dodep14tag eq 'always' + ? (access_cfg_tagformats_can_splitbrain or fail < \&debiantag_maintview, + Objid => $dgithead, + TfSuffix => '-dgit', + View => 'dgit', + }; + }; foreach my $tw (@tagwants) { $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro); $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; }; @@ -3468,7 +4058,11 @@ sub push_mktags ($$ $$ $) { die unless $tagwants->[0]{View} eq 'dgit'; - $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid}; + my $declaredistro = access_nomdistro(); + my $reader_giturl = do { local $access_forpush=0; access_giturl(); }; + $dsc->{$ourdscfield[0]} = join " ", + $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag}, + $reader_giturl; $dsc->save("$dscfn.tmp") or die $!; my $changes = parsecontrol($changesfile,$changesfilewhat); @@ -3485,7 +4079,6 @@ sub push_mktags ($$ $$ $) { # to control the "tagger" (b) we can do remote signing my $authline = clogp_authline $clogp; my $delibs = join(" ", "",@deliberatelies); - my $declaredistro = access_nomdistro(); my $mktag = sub { my ($tw) = @_; @@ -3587,9 +4180,10 @@ END prep_ud(); access_giturl(); # check that success is vaguely likely + rpush_handle_protovsn_bothends() if $we_are_initiator; select_tagformat(); - my $clogpfn = ".git/dgit/changelog.822.tmp"; + my $clogpfn = dgit_privdir()."/changelog.822.tmp"; runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog); responder_send_file('parsed-changelog', $clogpfn); @@ -3599,7 +4193,7 @@ END my $dscpath = "$buildproductsdir/$dscfn"; stat_exists $dscpath or - fail "looked for .dsc $dscfn, but $!;". + fail "looked for .dsc $dscpath, but $!;". " maybe you forgot to build"; responder_send_file('dsc', $dscpath); @@ -3618,20 +4212,20 @@ END if (madformat_wantfixup($format)) { # user might have not used dgit build, so maybe do this now: if (quiltmode_splitbrain()) { - changedir $ud; + changedir $playground; quilt_make_fake_dsc($upstreamversion); my $cachekey; ($dgithead, $cachekey) = quilt_check_splitbrain_cache($actualhead, $upstreamversion); $dgithead or fail "--quilt=$quilt_mode but no cached dgit view: - perhaps tree changed since dgit build[-source] ?"; + perhaps HEAD changed since dgit build[-source] ?"; $split_brain = 1; $dgithead = splitbrain_pseudomerge($clogp, $actualhead, $dgithead, $archive_hash); $maintviewhead = $actualhead; - changedir '../../../..'; + changedir $maindir; prep_ud(); # so _only_subdir() works, below } else { commit_quilty_patch(); @@ -3662,26 +4256,55 @@ END } } - changedir $ud; + changedir $playground; progress "checking that $dscfn corresponds to HEAD"; runcmd qw(dpkg-source -x --), - $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath"; - my ($tree,$dir) = mktree_in_ud_from_only_subdir(); + $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath"; + my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package"); check_for_vendor_patches() if madformat($dsc->{format}); - changedir '../../../..'; + changedir $maindir; my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead); debugcmd "+",@diffcmd; $!=0; $?=-1; my $r = system @diffcmd; if ($r) { if ($r==256) { + my $referent = $split_brain ? $dgithead : 'HEAD'; my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead; - fail <= 4; responder_send_command("param maint-view $maintviewhead"); } + # Perhaps send buildinfo(s) for signing + my $changes_files = getfield $changes, 'Files'; + my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg); + foreach my $bi (@buildinfos) { + responder_send_command("param buildinfo-filename $bi"); + responder_send_file('buildinfo', "$buildproductsdir/$bi"); + } + if (deliberately_not_fast_forward) { git_for_each_ref(lrfetchrefs, sub { my ($objid,$objtype,$lrfetchrefname,$reftail) = @_; @@ -3731,7 +4363,7 @@ END } my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead, - ".git/dgit/tag"); + dgit_privdir()."/tag"); my @tagobjfns; supplementary_message(<<'END'); @@ -3782,14 +4414,19 @@ END runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead; supplementary_message(<<'END'); -Push failed, after updating the remote git repository. -If you want to try again, you must use a new version number. +Push failed, while obtaining signatures on the .changes and .dsc. +If it was just that the signature failed, you may try again by using +debsign by hand to sign the changes + $changesfile +and then dput to complete the upload. +If you need to change the package, you must use a new version number. END if ($we_are_responder) { my $dryrunsuffix = act_local() ? "" : ".tmp"; + my @rfiles = ($dscpath, $changesfile); + push @rfiles, map { "$buildproductsdir/$_" } @buildinfos; responder_receive_files('signed-dsc-changes', - "$dscpath$dryrunsuffix", - "$changesfile$dryrunsuffix"); + map { "$_$dryrunsuffix" } @rfiles); } else { if (act_local()) { rename "$dscpath.tmp",$dscpath or die "$dscfn $!"; @@ -3815,9 +4452,11 @@ END responder_send_command("complete"); } +sub pre_clone () { + not_necessarily_a_tree(); +} sub cmd_clone { parseopts(); - notpushing(); my $dstdir; badusage "-p is not allowed with clone; specify as argument instead" if defined $package; @@ -3832,8 +4471,9 @@ sub cmd_clone { } else { badusage "incorrect arguments to dgit clone"; } - $dstdir ||= "$package"; + notpushing(); + $dstdir ||= "$package"; if (stat_exists $dstdir) { fail "$dstdir already exists"; } @@ -3847,6 +4487,7 @@ sub cmd_clone { return if $!==&ENOENT; die "chdir $cwd_remove: $!"; } + printdebug "clone rmonerror removing $dstdir\n"; if (stat $dstdir) { rmtree($dstdir) or die "remove $dstdir: $!\n"; } elsif (grep { $! == $_ } @@ -3862,8 +4503,8 @@ sub cmd_clone { } sub branchsuite () { - my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD); - if ($branch =~ m#$lbranch_re#o) { + my $branch = git_get_symref(); + if (defined $branch && $branch =~ m#$lbranch_re#o) { return $1; } else { return undef; @@ -3871,30 +4512,30 @@ sub branchsuite () { } sub fetchpullargs () { - notpushing(); if (!defined $package) { my $sourcep = parsecontrol('debian/control','debian/control'); $package = getfield $sourcep, 'Source'; } if (@ARGV==0) { -# $isuite = branchsuite(); # this doesn't work because dak hates canons + $isuite = branchsuite(); if (!$isuite) { my $clogp = parsechangelog(); - $isuite = getfield $clogp, 'Distribution'; + my $clogsuite = getfield $clogp, 'Distribution'; + $isuite= $clogsuite if $clogsuite ne 'UNRELEASED'; } - canonicalise_suite(); - progress "fetching from suite $csuite"; } elsif (@ARGV==1) { ($isuite) = @ARGV; - canonicalise_suite(); } else { badusage "incorrect arguments to dgit fetch or dgit pull"; } + notpushing(); } sub cmd_fetch { parseopts(); fetchpullargs(); + my $multi_fetched = fork_for_multisuite(sub { }); + exit 0 if $multi_fetched; fetch(); } @@ -3910,21 +4551,18 @@ END pull(); } -sub cmd_push { +sub prep_push () { parseopts(); + build_or_push_prep_early(); pushing(); - badusage "-p is not allowed with dgit push" if defined $package; check_not_dirty(); - my $clogp = parsechangelog(); - $package = getfield $clogp, 'Source'; my $specsuite; if (@ARGV==0) { } elsif (@ARGV==1) { ($specsuite) = (@ARGV); } else { - badusage "incorrect arguments to dgit push"; + badusage "incorrect arguments to dgit $subcommand"; } - $isuite = getfield $clogp, 'Distribution'; if ($new_package) { local ($package) = $existing_package; # this is a hack canonicalise_suite(); @@ -3934,15 +4572,34 @@ sub cmd_push { if (defined $specsuite && $specsuite ne $isuite && $specsuite ne $csuite) { - fail "dgit push: changelog specifies $isuite ($csuite)". + fail "dgit $subcommand: changelog specifies $isuite ($csuite)". " but command line specifies $specsuite"; } +} + +sub cmd_push { + prep_push(); + dopush(); +} + +sub cmd_push_source { + prep_push(); + if ($changesfile) { + my $changes = parsecontrol("$buildproductsdir/$changesfile", + "source changes file"); + unless (test_source_only_changes($changes)) { + fail "user-specified changes file is not source-only"; + } + } else { + # Building a source package is very fast, so just do it + build_source_for_push(); + } dopush(); } #---------- remote commands' implementation ---------- -sub cmd_remote_push_build_host { +sub pre_remote_push_build_host { my ($nrargs) = shift @ARGV; my (@rargs) = @ARGV[0..$nrargs-1]; @ARGV = @ARGV[$nrargs..$#ARGV]; @@ -3955,8 +4612,6 @@ sub cmd_remote_push_build_host { $we_are_responder = 1; $us .= " (build host)"; - pushing(); - open PI, "<&STDIN" or die $!; open STDIN, "/dev/null" or die $!; open PO, ">&STDOUT" or die $!; @@ -3974,12 +4629,14 @@ sub cmd_remote_push_build_host { " but invocation host has $vsnwant" unless defined $protovsn; - responder_send_command("dgit-remote-push-ready $protovsn"); - rpush_handle_protovsn_bothends(); changedir $dir; +} +sub cmd_remote_push_build_host { + responder_send_command("dgit-remote-push-ready $protovsn"); &cmd_push; } +sub pre_remote_push_responder { pre_remote_push_build_host(); } sub cmd_remote_push_responder { cmd_remote_push_build_host(); } # ... for compatibility with proto vsn.1 dgit (just so that user gets # a good error message) @@ -4008,7 +4665,10 @@ sub i_cleanup { } } -END { i_cleanup(); } +END { + return unless forkcheck_mainprocess(); + i_cleanup(); +} sub i_method { my ($base,$selector,@args) = @_; @@ -4016,8 +4676,10 @@ sub i_method { { no strict qw(refs); &{"${base}_${selector}"}(@args); } } +sub pre_rpush () { + not_necessarily_a_tree(); +} sub cmd_rpush { - pushing(); my $host = nextarg; my $dir; if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) { @@ -4037,6 +4699,8 @@ sub cmd_rpush { my @cmd = (@ssh, $host, shellquote @rdgit); debugcmd "+",@cmd; + $we_are_initiator=1; + if (defined $initiator_tempdir) { rmtree $initiator_tempdir; mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!"; @@ -4050,11 +4714,6 @@ sub cmd_rpush { die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support; $supplementary_message = '' unless $protovsn >= 3; - fail "rpush negotiated protocol version $protovsn". - " which does not support quilt mode $quilt_mode" - if quiltmode_splitbrain; - - rpush_handle_protovsn_bothends(); for (;;) { my ($icmd,$iargs) = initiator_expect { m/^(\S+)(?: (.*))?$/; @@ -4118,6 +4777,18 @@ our %i_wanted; sub i_resp_want ($) { my ($keyword) = @_; die "$keyword ?" if $i_wanted{$keyword}++; + + defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite"; + $isuite = $i_param{'isuite'} // $i_param{'csuite'}; + die unless $isuite =~ m/^$suite_re$/; + + pushing(); + rpush_handle_protovsn_bothends(); + + fail "rpush negotiated protocol version $protovsn". + " which does not support quilt mode $quilt_mode" + if quiltmode_splitbrain; + my @localpaths = i_method "i_want", $keyword; printdebug "[[ $keyword @localpaths\n"; foreach my $localpath (@localpaths) { @@ -4126,7 +4797,7 @@ sub i_resp_want ($) { print RI "files-end\n" or die $!; } -our ($i_clogp, $i_version, $i_dscfn, $i_changesfn); +our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos); sub i_localname_parsed_changelog { return "remote-changelog.822"; @@ -4143,6 +4814,31 @@ sub i_localname_dsc { } sub i_file_dsc { } +sub i_localname_buildinfo ($) { + my $bi = $i_param{'buildinfo-filename'}; + defined $bi or badproto \*RO, "buildinfo before filename"; + defined $i_changesfn or badproto \*RO, "buildinfo before changes"; + $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s + or badproto \*RO, "improper buildinfo filename"; + return $&; +} +sub i_file_buildinfo { + my $bi = $i_param{'buildinfo-filename'}; + my $bd = parsecontrol "$i_tmp/$bi", $bi; + my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes'; + if (!forceing [qw(buildinfo-changes-mismatch)]) { + files_compare_inputs($bd, $ch); + (getfield $bd, $_) eq (getfield $ch, $_) or + fail "buildinfo mismatch $_" + foreach qw(Source Version); + !defined $bd->{$_} or + fail "buildinfo contains $_" + foreach qw(Changes Changed-by Distribution); + } + push @i_buildinfos, $bi; + delete $i_param{'buildinfo-filename'}; +} + sub i_localname_changes { defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)"; $i_changesfn = $i_dscfn; @@ -4184,7 +4880,7 @@ sub i_want_signed_tag { sub i_want_signed_dsc_changes { rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!"; sign_changes $i_changesfn; - return ($i_dscfn, $i_changesfn); + return ($i_dscfn, $i_changesfn, @i_buildinfos); } #---------- building etc. ---------- @@ -4201,7 +4897,7 @@ sub quiltify_dpkg_commit ($$$;$) { my ($patchname,$author,$msg, $xinfo) = @_; $xinfo //= ''; - mkpath '.git/dgit'; + mkpath '.git/dgit'; # we are in playtree my $descfn = ".git/dgit/quilt-description.tmp"; open O, '>', $descfn or die "$descfn: $!"; $msg =~ s/\n+/\n\n/; @@ -4217,7 +4913,7 @@ END local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0; local $ENV{'VISUAL'} = $ENV{'EDITOR'}; local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn; - runcmd @dpkgsource, qw(--commit .), $patchname; + runcmd @dpkgsource, qw(--commit --include-removal .), $patchname; } } @@ -4233,7 +4929,7 @@ sub quiltify_trees_differ ($$;$$$) { # a list of unrepresentable changes (removals of upstream files # (as messages) local $/=undef; - my @cmd = (@git, qw(diff-tree -z)); + my @cmd = (@git, qw(diff-tree -z --no-renames)); push @cmd, qw(--name-only) unless $unrepres; push @cmd, qw(-r) if $finegrained || $unrepres; push @cmd, $x, $y; @@ -4252,17 +4948,28 @@ sub quiltify_trees_differ ($$;$$$) { 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; + die "not a plain file or symlink\n" + unless $newmode =~ m/^(?:10|12)\d{4}$/ || + $oldmode =~ m/^(?:10|12)\d{4}$/; + if ($oldmode =~ m/[^0]/ && + $newmode =~ m/[^0]/) { + # both old and new files exist + die "mode or type changed\n" if $oldmode ne $newmode; + die "modified symlink\n" unless $newmode =~ m/^10/; + } elsif ($oldmode =~ m/[^0]/) { + # deletion + die "deletion of symlink\n" + unless $oldmode =~ m/^10/; } else { - die "non-default mode\n" unless $newmode =~ m/^100644$/; + # creation + die "creation with non-default mode\n" + unless $newmode =~ m/^100644$/ or + $newmode =~ m/^120000$/; } }; if ($@) { local $/="\n"; chomp $@; - push @$unrepres, [ $f, $@ ]; + push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ]; } } @@ -4383,11 +5090,11 @@ END my $dgitview = git_rev_parse 'HEAD'; - changedir '../../../..'; + changedir $maindir; # 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", '>>' + ensuredir "$maindir_gitcommon/logs/refs/dgit-intern"; + my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>' or die $!; my $oldcache = git_get_ref "refs/$splitbraincache"; @@ -4408,7 +5115,7 @@ END runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache", $dgitview; - changedir '.git/dgit/unpack/work'; + changedir "$playground/work"; my $saved = maybe_split_brain_save $headref, $dgitview, "converted"; progress "dgit view: created ($saved)"; @@ -4612,6 +5319,7 @@ sub quiltify ($$$$) { 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 "is series file\n" if m{$series_filename_re}o; die "too long" if length > 200; }; return $_ unless $@; @@ -4650,6 +5358,7 @@ sub quiltify ($$$$) { $patchname =~ y/-a-z0-9_.+=~//cd; $patchname =~ s/^\W/x-$&/; $patchname = substr($patchname,0,40); + $patchname .= ".patch"; } if (!defined $patchdir) { $patchdir = ''; @@ -4695,20 +5404,17 @@ sub build_maybe_quilt_fixup () { check_for_vendor_patches(); if (quiltmode_splitbrain) { - foreach my $needtf (qw(new maint)) { - next if grep { $_ eq $needtf } access_cfg_tagformats; - fail <($leafname); - foreach my $f (<../../../../*>) { #/){ + foreach my $f (<$maindir/../*>) { #/){ my $b=$f; $b =~ s{.*/}{}; { local ($debuglevel) = $debuglevel-1; @@ -4817,12 +5523,12 @@ END debian/control debian/changelog); foreach my $maybe (qw(debian/patches debian/source/options debian/tests/control)) { - next unless stat_exists "../../../$maybe"; + next unless stat_exists "$maindir/$maybe"; push @files, $maybe; } my $debtar= srcfn $fakeversion,'.debian.tar.gz'; - runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files; + runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files; $dscaddfile->($debtar); close $fakedsc or die $!; @@ -4831,7 +5537,7 @@ END sub quilt_check_splitbrain_cache ($$) { my ($headref, $upstreamversion) = @_; # Called only if we are in (potentially) split brain mode. - # Called in $ud. + # Called in playground. # Computes the cache key and looks in the cache. # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey) @@ -4865,8 +5571,8 @@ sub quilt_check_splitbrain_cache ($$) { debugcmd "|(probably)",@cmd; my $child = open GC, "-|"; defined $child or die $!; if (!$child) { - chdir '../../..' or die $!; - if (!stat ".git/logs/refs/$splitbraincache") { + chdir $maindir or die $!; + if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") { $! == ENOENT or die $!; printdebug ">(no reflog)\n"; exit 0; @@ -4990,13 +5696,14 @@ sub quilt_fixup_multipatch ($$$) { changedir 'fake'; - remove_stray_gits(); + remove_stray_gits("source package"); mktree_in_ud_here(); rmtree '.pc'; - runcmd @git, qw(add -Af .); - my $unapplied=git_write_tree(); + rmtree 'debian'; # git checkout commitish paths does not delete! + runcmd @git, qw(checkout -f), $headref, qw(-- debian); + my $unapplied=git_add_write_tree(); printdebug "fake orig tree object $unapplied\n"; ensuredir '.pc'; @@ -5028,8 +5735,7 @@ END changedir '../fake'; rmtree '.pc'; - runcmd @git, qw(add -Af .); - my $oldtiptree=git_write_tree(); + my $oldtiptree=git_add_write_tree(); printdebug "fake o+d/p tree object $unapplied\n"; changedir '../work'; @@ -5188,15 +5894,19 @@ sub cmd_clean () { maybe_unapply_patches_again(); } -sub build_prep_early () { - our $build_prep_early_done //= 0; - return if $build_prep_early_done++; - notpushing(); - badusage "-p is not allowed when building" if defined $package; +sub build_or_push_prep_early () { + our $build_or_push_prep_early_done //= 0; + return if $build_or_push_prep_early_done++; + badusage "-p is not allowed with dgit $subcommand" if defined $package; my $clogp = parsechangelog(); $isuite = getfield $clogp, 'Distribution'; $package = getfield $clogp, 'Source'; $version = getfield $clogp, 'Version'; +} + +sub build_prep_early () { + build_or_push_prep_early(); + notpushing(); check_not_dirty(); } @@ -5379,6 +6089,7 @@ sub postbuild_mergechanges_vanilla ($) { } sub cmd_build { + build_prep_early(); my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV); my $wantsrc = massage_dbp_args \@dbp; if ($wantsrc > 0) { @@ -5432,15 +6143,17 @@ sub cmd_gbp_build { } my @cmd = opts_opt_multi_cmd @gbp_build; - push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp"); + push @cmd, (qw(-us -uc --git-no-sign-tags), + "--git-builder=".(shellquote @dbp)); if ($gbp_make_orig) { - ensuredir '.git/dgit'; - my $ok = '.git/dgit/origs-gen-ok'; + my $priv = dgit_privdir(); + my $ok = "$priv/origs-gen-ok"; unlink $ok or $!==&ENOENT or die $!; my @origs_cmd = @cmd; push @origs_cmd, qw(--git-cleaner=true); - push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok"; + push @origs_cmd, "--git-prebuild=". + "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok"); push @origs_cmd, @ARGV; if (act_local()) { debugcmd @origs_cmd; @@ -5470,20 +6183,14 @@ sub cmd_gbp_build { } sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0 +sub build_source_for_push { + build_source(); + maybe_unapply_patches_again(); + $changesfile = $sourcechanges; +} + sub build_source { - my $our_cleanmode = $cleanmode; - if ($need_split_build_invocation) { - # Pretend that clean is being done some other way. This - # forces us not to try to use dpkg-buildpackage to clean and - # build source all in one go; and instead we run dpkg-source - # (and build_prep() will do the clean since $clean_using_builder - # is false). - $our_cleanmode = 'ELSEWHERE'; - } - if ($our_cleanmode =~ m/^dpkg-source/) { - # dpkg-source invocation (below) will clean, so build_prep shouldn't - $clean_using_builder = 1; - } + build_prep_early(); build_prep(); $sourcechanges = changespat $version,'source'; if (act_local()) { @@ -5491,46 +6198,37 @@ sub build_source { or fail "remove $sourcechanges: $!"; } $dscfn = dscfn($version); - if ($our_cleanmode eq 'dpkg-source') { - maybe_apply_patches_dirtily(); - runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S), - changesopts(); - } elsif ($our_cleanmode eq 'dpkg-source-d') { - maybe_apply_patches_dirtily(); - runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d), - changesopts(); + my @cmd = (@dpkgsource, qw(-b --)); + if ($split_brain) { + changedir $playground; + runcmd_ordryrun_local @cmd, "work"; + my @udfiles = <${package}_*>; + changedir $maindir; + foreach my $f (@udfiles) { + printdebug "source copy, found $f\n"; + next unless + $f eq $dscfn or + ($f =~ m/\.debian\.tar(?:\.\w+)$/ && + $f eq srcfn($version, $&)); + printdebug "source copy, found $f - renaming\n"; + rename "$playground/$f", "../$f" or $!==ENOENT + or fail "put in place new source file ($f): $!"; + } } else { - my @cmd = (@dpkgsource, qw(-b --)); - if ($split_brain) { - changedir $ud; - runcmd_ordryrun_local @cmd, "work"; - my @udfiles = <${package}_*>; - changedir "../../.."; - foreach my $f (@udfiles) { - printdebug "source copy, found $f\n"; - next unless - $f eq $dscfn or - ($f =~ m/\.debian\.tar(?:\.\w+)$/ && - $f eq srcfn($version, $&)); - printdebug "source copy, found $f - renaming\n"; - rename "$ud/$f", "../$f" or $!==ENOENT - or fail "put in place new source file ($f): $!"; - } - } else { - my $pwd = must_getcwd(); - my $leafdir = basename $pwd; - changedir ".."; - runcmd_ordryrun_local @cmd, $leafdir; - changedir $pwd; - } - runcmd_ordryrun_local qw(sh -ec), - 'exec >$1; shift; exec "$@"','x', - "../$sourcechanges", - @dpkggenchanges, qw(-S), changesopts(); + my $pwd = must_getcwd(); + my $leafdir = basename $pwd; + changedir ".."; + runcmd_ordryrun_local @cmd, $leafdir; + changedir $pwd; } + runcmd_ordryrun_local qw(sh -ec), + 'exec >$1; shift; exec "$@"','x', + "../$sourcechanges", + @dpkggenchanges, qw(-S), changesopts(); } sub cmd_build_source { + build_prep_early(); badusage "build-source takes no additional arguments" if @ARGV; build_source(); maybe_unapply_patches_again(); @@ -5559,14 +6257,20 @@ END sub cmd_quilt_fixup { badusage "incorrect arguments to dgit quilt-fixup" if @ARGV; - my $clogp = parsechangelog(); - $version = getfield $clogp, 'Version'; - $package = getfield $clogp, 'Source'; - check_not_dirty(); + build_prep_early(); clean_tree(); build_maybe_quilt_fixup(); } +sub import_dsc_result { + my ($dstref, $newhash, $what_log, $what_msg) = @_; + my @cmd = (@git, qw(update-ref -m), $what_log, $dstref, $newhash); + runcmd @cmd; + check_gitattrs($newhash, "source tree"); + + progress "dgit: import-dsc: $what_msg"; +} + sub cmd_import_dsc { my $needsig = 0; @@ -5630,32 +6334,42 @@ sub cmd_import_dsc { parse_dscdata(); - my $dgit_commit = $dsc->{$ourdscfield[0]}; - if (defined $dgit_commit && - !forceing [qw(import-dsc-with-dgit-field)]) { - $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc"; + $package = getfield $dsc, 'Source'; + + parse_dsc_field($dsc, "Dgit metadata in .dsc") + unless forceing [qw(import-dsc-with-dgit-field)]; + parse_dsc_field_def_dsc_distro(); + + $isuite = 'DGIT-IMPORT-DSC'; + $idistro //= $dsc_distro; + + notpushing(); + + if (defined $dsc_hash) { progress "dgit: import-dsc of .dsc with Dgit field, using git hash"; + resolve_dsc_field_commit undef, undef; + } + if (defined $dsc_hash) { my @cmd = (qw(sh -ec), - "echo $dgit_commit | git cat-file --batch-check"); + "echo $dsc_hash | git cat-file --batch-check"); my $objgot = cmdoutput @cmd; if ($objgot =~ m#^\w+ missing\b#) { fail < 0) { progress "Not fast forward, forced update."; } else { - fail "Not fast forward to $dgit_commit"; + fail "Not fast forward to $dsc_hash"; } } - @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info", - $dstbranch, $dgit_commit); - runcmd @cmd; - progress "dgit: import-dsc updated git ref $dstbranch"; + import_dsc_result $dstbranch, $dsc_hash, + "dgit import-dsc (Dgit): $info", + "updated git ref $dstbranch"; return 0; } @@ -5666,12 +6380,14 @@ Specify +$specbranch to overwrite, discarding existing history END if $oldhash && !$force; - $package = getfield $dsc, 'Source'; my @dfi = dsc_files_info(); foreach my $fi (@dfi) { my $f = $fi->{Filename}; my $here = "../$f"; - next if lstat $here; + if (lstat $here) { + next if stat $here; + fail "lstat $here works but stat gives $! !"; + } fail "stat $here: $!" unless $! == ENOENT; my $there = $dscfn; if ($dscfn =~ m#^(?:\./+)?\.\./+#) { @@ -5682,11 +6398,13 @@ END fail "cannot import $dscfn which seems to be inside working tree!"; } $there =~ s#/+[^/]+$## or - fail "cannot import $dscfn which seems to not have a basename"; + fail "import $dscfn requires ../$f, but it does not exist"; $there .= "/$f"; + my $test = $there =~ m{^/} ? $there : "../$there"; + stat $test or fail "import $dscfn requires $test, but: $!"; symlink $there, $here or fail "symlink $there to $here: $!"; progress "made symlink $here -> $there"; - print STDERR Dumper($fi); +# print STDERR Dumper($fi); } my @mergeinputs = generate_commits_from_dsc(); die unless @mergeinputs == 1; @@ -5700,10 +6418,14 @@ END progress "Import, merging."; my $tree = cmdoutput @git, qw(rev-parse), "$newhash:"; my $version = getfield $dsc, 'Version'; + my $clogp = commit_getclogp $newhash; + my $authline = clogp_authline $clogp; $newhash = make_commit_text <",@cmd; exec @cmd or fail "exec curl: $!\n"; } +sub repos_server_url () { + $package = '_dgit-repos-server'; + local $access_forpush = 1; + local $isuite = 'DGIT-REPOS-SERVER'; + my $url = access_giturl(); +} + +sub pre_clone_dgit_repos_server () { + not_necessarily_a_tree(); +} sub cmd_clone_dgit_repos_server { badusage "need destination argument" unless @ARGV==1; my ($destdir) = @ARGV; - $package = '_dgit-repos-server'; - my @cmd = (@git, qw(clone), access_giturl(), $destdir); + my $url = repos_server_url(); + my @cmd = (@git, qw(clone), $url, $destdir); debugcmd ">",@cmd; exec @cmd or fail "exec git clone: $!\n"; } +sub pre_print_dgit_repos_server_source_url () { + not_necessarily_a_tree(); +} +sub cmd_print_dgit_repos_server_source_url { + badusage "no arguments allowed to dgit print-dgit-repos-server-source-url" + if @ARGV; + my $url = repos_server_url(); + print $url, "\n" or die $!; +} + +sub pre_print_dpkg_source_ignores { + not_necessarily_a_tree(); +} +sub cmd_print_dpkg_source_ignores { + badusage "no arguments allowed to dgit print-dpkg-source-ignores" + if @ARGV; + print "@dpkg_source_ignores\n" or die $!; +} + sub cmd_setup_mergechangelogs { badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV; + local $isuite = 'DGIT-SETUP-TREE'; setup_mergechangelogs(1); } sub cmd_setup_useremail { - badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV; + badusage "no arguments allowed to dgit setup-useremail" if @ARGV; + local $isuite = 'DGIT-SETUP-TREE'; setup_useremail(1); } +sub cmd_setup_gitattributes { + badusage "no arguments allowed to dgit setup-useremail" if @ARGV; + local $isuite = 'DGIT-SETUP-TREE'; + setup_gitattrs(1); +} + sub cmd_setup_new_tree { badusage "no arguments allowed to dgit setup-tree" if @ARGV; + local $isuite = 'DGIT-SETUP-TREE'; setup_new_tree(); } @@ -5759,7 +6522,9 @@ sub cmd_version { } our (%valopts_long, %valopts_short); +our (%funcopts_long); our @rvalopts; +our (@modeopt_cfgs); sub defvalopt ($$$$) { my ($long,$short,$val_re,$how) = @_; @@ -5795,6 +6560,26 @@ defvalopt '--initiator-tempdir','','.*', sub { " absolute, not relative, directory." }; +sub defoptmodes ($@) { + my ($varref, $cfgkey, $default, %optmap) = @_; + my %permit; + while (my ($opt,$val) = each %optmap) { + $funcopts_long{$opt} = sub { $$varref = $val; }; + $permit{$val} = $val; + } + push @modeopt_cfgs, { + Var => $varref, + Key => $cfgkey, + Default => $default, + Vals => \%permit + }; +} + +defoptmodes \$dodep14tag, qw( dep14tag want + --dep14tag want + --no-dep14tag no + --always-dep14tag always ); + sub parseopts () { my $om; @@ -5868,6 +6653,9 @@ sub parseopts () { } elsif (m/^--no-rm-on-error$/s) { push @ropts, $_; $rmonerror = 0; + } elsif (m/^--no-chase-dsc-distro$/s) { + push @ropts, $_; + $chase_dsc_distro = 0; } elsif (m/^--overwrite$/s) { push @ropts, $_; $overwrite_version = ''; @@ -5904,9 +6692,17 @@ sub parseopts () { # undocumented, for testing push @ropts, $_; $need_split_build_invocation = 1; + } elsif (m/^--config-lookup-explode=(.+)$/s) { + # undocumented, for testing + push @ropts, $_; + $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE'; + # ^ it's supposed to be an array ref } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) { $val = $2 ? $' : undef; #'; $valopt->($oi->{Long}); + } elsif ($funcopts_long{$_}) { + push @ropts, $_; + $funcopts_long{$_}(); } else { badusage "unknown long option \`$_'"; } @@ -5992,7 +6788,11 @@ END } -sub finalise_opts_opts () { +sub parseopts_late_defaults () { + $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF') + if defined $idistro; + $isuite //= cfg('dgit.default.default-suite'); + foreach my $k (keys %opts_opt_map) { my $om = $opts_opt_map{$k}; @@ -6019,6 +6819,42 @@ sub finalise_opts_opts () { @$om[$insertpos..$#$om] ); } } + + if (!defined $rmchanges) { + local $access_forpush; + $rmchanges = access_cfg_bool(0, 'rm-old-changes'); + } + + if (!defined $quilt_mode) { + local $access_forpush; + $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF') + // access_cfg('quilt-mode', 'RETURN-UNDEF') + // 'linear'; + $quilt_mode =~ m/^($quilt_modes_re)$/ + or badcfg "unknown quilt-mode \`$quilt_mode'"; + $quilt_mode = $1; + } + + foreach my $moc (@modeopt_cfgs) { + local $access_forpush; + my $vr = $moc->{Var}; + next if defined $$vr; + $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default}; + my $v = $moc->{Vals}{$$vr}; + badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v; + $$vr = $v; + } + + $need_split_build_invocation ||= quiltmode_splitbrain(); + + if (!defined $cleanmode) { + local $access_forpush; + $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF'); + $cleanmode //= 'dpkg-source'; + + badcfg "unknown clean-mode \`$cleanmode'" unless + $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s; + } } if ($ENV{$fakeeditorenv}) { @@ -6028,7 +6864,6 @@ if ($ENV{$fakeeditorenv}) { parseopts(); check_env_sanity(); -git_slurp_config(); print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1; print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n" @@ -6037,37 +6872,14 @@ if (!@ARGV) { print STDERR $helpmsg or die $!; exit 8; } -my $cmd = shift @ARGV; +$cmd = $subcommand = 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'); -} - -if (!defined $quilt_mode) { - local $access_forpush; - $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF') - // access_cfg('quilt-mode', 'RETURN-UNDEF') - // 'linear'; - $quilt_mode =~ m/^($quilt_modes_re)$/ - or badcfg "unknown quilt-mode \`$quilt_mode'"; - $quilt_mode = $1; -} - -$need_split_build_invocation ||= quiltmode_splitbrain(); - -if (!defined $cleanmode) { - local $access_forpush; - $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF'); - $cleanmode //= 'dpkg-source'; - - badcfg "unknown clean-mode \`$cleanmode'" unless - $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s; -} +record_maindir if $invoked_in_git_tree; +git_slurp_config(); my $fn = ${*::}{"cmd_$cmd"}; $fn or badusage "unknown operation $cmd";