#!/usr/bin/perl -w
# dgit
# Integration between git and Debian-style archives
#
# Copyright (C)2013-2024           Ian Jackson
# Copyright (C)2017-2019,2023-2025 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
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <https://www.gnu.org/licenses/>.

END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
use Debian::Dgit::ExitStatus;
use Debian::Dgit::I18n;

use 5.024;
use strict;

use Debian::Dgit qw(:DEFAULT :playground);
setup_sigwarn();

use IO::Handle;
use Data::Dumper;
use WWW::Curl::Easy;
use Dpkg::Control::Hash;
use File::Path qw(mkpath);
use File::Spec;
use File::Temp qw(tempdir);
use File::Basename;
use File::Copy ();
use Dpkg::Version;
use Dpkg::Compression;
use Dpkg::Compression::Process;
use POSIX;
use Locale::gettext;
use IPC::Open2;
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;

use Debian::Dgit;
use Debian::Dgit::ProtoConn;

our $our_version = 'UNRELEASED'; ###substituted###
our $absurdity = undef; ###substituted###

$SIG{INT} = 'DEFAULT'; # work around #932841

our @rpushprotovsn_support = qw(7 6 5 4); # Reverse order!
our $protovsn;
our $rpush_verb; # "push" or "push-source"

our $cmd;
our $subcommand;
our $isuite;
our $idistro;
our $package;
our $expected_suite;
our $expected_version;
our @ropts;

our $allow_unrelated_histories = 0;
our $sign = 1;
our $dryrun_level = 0;
our $changesfile;
our $buildproductsdir;
our $bpd_glob;
our $new_package = 0;
our $includedirty = 0;
our $t2u_bmode = 0;
our $t2u_upstream;
our $t2u_upstreamc;
our $rmonerror = 1;
our @deliberatelies;
our %previously;
our $existing_package = 'dpkg';
our $cleanmode;
our $changes_since_version;
our $rmchanges;
our $keep_playground;
our $overwrite_version; # undef: not specified; '': check changelog
our $quilt_mode;
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|try-linear|auto|single|nofix|nocheck|unapplied|$quilt_options_re";
our $splitview_mode;
our $splitview_modes_re = qr{auto|always|never};
our $dgitview_saved;
our $dodep14tag;
our $dep14tag_reuse;
our $dep14tag_reuse_re = qr{replace|replace-unsuitable|if-exists|must};
our $dep14tag_verify;
our %internal_object_save;
our $we_are_responder;
our $we_are_initiator;
our $initiator_tempdir;
our $patches_applied_dirtily = 00;
our $chase_dsc_distro=1;

our %forceopts = map { $_=>0 }
    qw(unrepresentable unsupported-source-format
       dsc-changes-mismatch changes-origs-exactly
       uploading-binaries uploading-old-version uploading-source-only
       reusing-version
       push-tainted
       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 $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
                     | (?: git | git-ff ) (?: ,always )?
                         | check (?: ,ignores )?
                         | none
                         )}x;

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 (@dget) = qw(dget);
our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
our (@dput) = qw(dput);
our (@debsign) = qw(debsign);
our (@gpg) = qw(gpg);
our (@sbuild) = (qw(sbuild --no-source --no-source-only-changes));
our (@ssh) = 'ssh';
our (@dgit) = qw(dgit);
our (@git_debrebase) = qw(git-debrebase);
our (@aptget) = qw(apt-get);
our (@aptcache) = qw(apt-cache);
our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
our (@dpkggenchanges) = qw(dpkg-genchanges);
our (@dpkggenbuildinfo) = qw(dpkg-genbuildinfo);
our (@dpkgquery) = qw(dpkg-query);
our (@mergechanges) = qw(mergechanges -f);
our (@gbp_build) = ('');
our (@gbp_pq) = ('gbp pq');
our (@changesopts) = ('');
our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
our (@mgtf) = qw(mini-git-tag-fsck);

# Commands that we run and that the user can override with --PROGRAM=...
# We also honour access-cfg settings.
# If not in `%opts_opt_cmdonly`, also support --PROGRAM:... & --PROGRAM...
# If ->[0] is the empty string, we don't support overriding the command.
our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
		     'curl' => \@curl,
		     'dput' => \@dput,
		     'debsign' => \@debsign,
                     'gpg' => \@gpg,
                     'sbuild' => \@sbuild,
                     'ssh' => \@ssh,
                     'dgit' => \@dgit,
                     'git' => \@git,
		     'git-debrebase' => \@git_debrebase,
                     'apt-get' => \@aptget,
                     'apt-cache' => \@aptcache,
                     'dpkg-source' => \@dpkgsource,
                     'dpkg-buildpackage' => \@dpkgbuildpackage,
                     'dpkg-genchanges' => \@dpkggenchanges,
                     'dpkg-genbuildinfo' => \@dpkggenbuildinfo,
                     'dpkg-query' => \@dpkgquery,
                     'gbp-build' => \@gbp_build,
                     'gbp-pq' => \@gbp_pq,
                     'ch' => \@changesopts,
                     'mergechanges' => \@mergechanges,
                     'pbuilder' => \@pbuilder,
                     'cowbuilder' => \@cowbuilder,
                     'mini-git-tag-fsck' => \@mgtf);

our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);

our %opts_opt_orig = map { $_, [ @{ $opts_opt_map{$_} } ] } keys %opts_opt_map;
our @cmd_opts_opts;

sub parseopts_late_defaults();
sub quiltify_trees_differ ($$;$$$);
sub setup_gitattrs(;$);
sub check_gitattrs($$);

our $playground;
our $keyid;

autoflush STDOUT 1;

our $rpush_conn;
our $rparent_conn;
our $supplementary_message = '';
our $made_splitbrain_playtree = 0;
our $do_split_brain;

# Interactions between quilt mode and split brain
# (currently, split brain only implemented iff
#  madformat_wantfixup && quiltmode_splitting)
#
#   source format      |    sane           `3.0 (quilt)'
#                      |                   madformat_wantfixup()
#		       |
#   quilt mode         |                   normal              quiltmode
#                      |                   (eg linear)         _splitbrain
#		       |
#   -------------------+-------------------------------------------------
#		       |
#   no split           | no q cache        no q cache          forbidden,
#     brain            | PM on master      q fixup on master   prevented
#   !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
#
# PM = pseudomerge to make ff, due to overwrite (or split view)
# "no q cache" = do not record in cache on build, do not check cache
# `3.0 (quilt)' with --quilt=nocheck is treated as sane format

END {
    local ($@, $?);
    return unless forkcheck_mainprocess();
    print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
}

our $remotename = 'dgit';
our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
our $csuite;
our $instead_distro;
our %control_add;

our %i_param;

if (!defined $absurdity) {
    $absurdity = $0;
    $absurdity =~ s{/[^/]+$}{/absurd} or die;
}

sub madformat ($) { $_[0] eq '3.0 (quilt)' }

sub lbranch () { return "$branchprefix/$csuite"; }
my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
sub lref () { return "refs/heads/".lbranch(); }
sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
sub rrref () { return server_ref($csuite); }

sub srcfn ($$) {
    my ($vsn, $sfx) = @_;
    return &source_file_leafname($package, $vsn, $sfx);
}
sub is_orig_file_of_vsn ($$) {
    my ($f, $upstreamvsn) = @_;
    return is_orig_file_of_p_v($f, $package, $upstreamvsn);
}

sub dscfn ($) {
    my ($vsn) = @_;
    return srcfn($vsn,".dsc");
}

sub changespat ($;$) {
    my ($vsn, $arch) = @_;
    return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
}

our $us = 'dgit';
initdebug('');

our @end;
END { 
    local ($?);
    return unless forkcheck_mainprocess();
    foreach my $f (@end) {
	eval { $f->(); };
	print STDERR "$us: cleanup: $@" if length $@;
    }
};

sub badcfg {
    print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
    finish 12;
}

sub forceable_fail ($$) {
    my ($forceoptsl, $msg) = @_;
    fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
    print STDERR +(__ "warning: overriding problem due to --force:\n"),
      $msg. "\n";
}

sub forceing ($) {
    my ($forceoptsl) = @_;
    my @got = grep { $forceopts{$_} } @$forceoptsl;
    return 0 unless @got;
    print STDERR f_
	"warning: skipping checks or functionality due to --force-%s\n",
	$got[0];
}

sub no_such_package () {
    print STDERR f_ "%s: source package %s does not exist in suite %s\n",
	$us, $package, $isuite;
    finish 4;
}

sub deliberately ($) {
    my ($enquiry) = @_;
    return !!grep {
	$_ eq "--deliberately-$enquiry" or
	$_ eq "--deliberately-TEST-dgit-only-$enquiry"
    } @deliberatelies;
}

sub deliberately_not_fast_forward () {
    foreach (qw(not-fast-forward fresh-repo)) {
	return 1 if deliberately($_);
    }
}

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;
    my @cmd;
    push @cmd, split /\s+/, shift @_;
    push @cmd, @$extra;
    push @cmd, @_;
    @cmd;
}

sub gbp_pq {
    return opts_opt_multi_cmd [], @gbp_pq;
}

sub gbp_pq_pc_aside (&) {
  my ($f) = @_;
  my $undo = rename ".pc", "../pc-aside";
  confess "$!" unless $undo || $!==ENOENT;
  $f->();
  if ($undo) {
    rename "../pc-aside", ".pc", or confess $!;
  }
}

sub dgit_privdir () {
    our $dgit_privdir_made //= ensure_a_playground 'dgit';
}

sub bpd_abs () {
    my $r = $buildproductsdir;
    $r = "$maindir/$r" unless $r =~ m{^/};
    return $r;
}

sub get_tree_of_commit ($) {
    my ($commitish) = @_;
    my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
    $cdata =~ m/\n\n/;  $cdata = $`;
    $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
    return $1;
}

sub branch_gdr_info ($$) {
    my ($symref, $head) = @_;
    my ($status, $msg, $current, $ffq_prev, $gdrlast) =
	gdr_ffq_prev_branchinfo($symref);
    return () unless $status eq 'branch';
    $ffq_prev = git_get_ref $ffq_prev;
    $gdrlast  = git_get_ref $gdrlast;
    $gdrlast &&= is_fast_fwd $gdrlast, $head;
    return ($ffq_prev, $gdrlast);
}

sub branch_is_gdr_unstitched_ff ($$$) {
    my ($symref, $head, $ancestor) = @_;
    my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
    return 0 unless $ffq_prev;
    return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
    return 1;
}

sub branch_is_gdr ($) {
    my ($head) = @_;
    # This is quite like git-debrebase's keycommits.
    # We have our own implementation because:
    #  - our algorighm can do fewer tests so is faster
    #  - it saves testing to see if gdr is installed

    # NB we use this just for deciding whether to run gdr make-patches
    # Before reusing this algorithm for something else, its
    # suitability should be reconsidered.

    my $walk = $head;
    local $Debian::Dgit::debugcmd_when_debuglevel = 3;
    printdebug "branch_is_gdr $head...\n";
    my $get_patches = sub {
	my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
	return $t // '';
    };
    my $tip_patches = $get_patches->($head);
  WALK:
    for (;;) {
	my $cdata = git_cat_file $walk, 'commit';
	my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
	if ($msg =~ m{^\[git-debrebase\ (
			  anchor | changelog | make-patches | 
			  merged-breakwater | pseudomerge
		      ) [: ] }mx) {
	    # no need to analyse this - it's sufficient
	    # (gdr classifications: Anchor, MergedBreakwaters)
	    # (made by gdr: Pseudomerge, Changelog)
	    printdebug "branch_is_gdr  $walk gdr $1 YES\n";
	    return 1;
	}
	my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
	if (@parents==2) {
	    my $walk_tree = get_tree_of_commit $walk;
	    foreach my $p (@parents) {
		my $p_tree = get_tree_of_commit $p;
		if ($p_tree eq $walk_tree) { # pseudomerge contriburor
		    # (gdr classification: Pseudomerge; not made by gdr)
		    printdebug "branch_is_gdr  $walk unmarked pseudomerge\n"
			if $debuglevel >= 2;
		    $walk = $p;
		    next WALK;
		}
	    }
	    # some other non-gdr merge
	    # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
	    printdebug "branch_is_gdr  $walk ?-2-merge NO\n";
	    return 0;
	}
	if (@parents>2) {
	    # (gdr classification: ?)
	    printdebug "branch_is_gdr  $walk ?-octopus NO\n";
	    return 0;
	}
	if (!@parents) {
	    printdebug "branch_is_gdr  $walk origin\n";
	    return 0;
	}
	if ($get_patches->($walk) ne $tip_patches) {
	    # Our parent added, removed, or edited patches, and wasn't
	    # a gdr make-patches commit.  gdr make-patches probably
	    # won't do that well, then.
	    # (gdr classification of parent: AddPatches or ?)
	    printdebug "branch_is_gdr  $walk ?-patches NO\n";
	    return 0;
	}
	if ($tip_patches eq '' and
	    !defined git_cat_file "$walk~:debian" and
	    !quiltify_trees_differ "$walk~", $walk
	   ) {
	    # (gdr classification of parent: BreakwaterStart We cannot
	    # process this using git-debrebase, because this can misrecognise
	    # other kinds of branch contents, eg as in #1025451.  Not doing
	    # this via gdr is OK, because the normal quilt linearisation will
	    # do - doing it via gdr is just an optimisation.
	    printdebug "branch_is_gdr  $walk unmarked BreakwaterStart NO\n";
	    return 0;
	}
	# (gdr classification: Upstream Packaging Mixed Changelog)
	printdebug "branch_is_gdr  $walk plain\n"
	    if $debuglevel >= 2;
	$walk = $parents[0];
    }
}

#---------- remote protocol support, common ----------

# remote push initiator/responder protocol:
#
# (We see this from the POV of the responder, which mostly drives
# the protocol. So `>` is "from responder to initiator".)
#
#  $ dgit remote-push-source-build-host <n-rargs> <rargs>... <push-args>...
#  where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
#  > dgit-remote-push-source-ready <actual-proto-vsn>
#
# Or for push-built,
#  $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
#  > dgit-remote-push-ready <actual-proto-vsn>
#
# occasionally:
#
#  > progress NBYTES
#  [NBYTES message]
#
#  > supplementary-message NBYTES
#  [NBYTES message]
#
# main sequence:
#
#  > file parsed-changelog
#  [indicates that output of dpkg-parsechangelog follows]
#  > data-block NBYTES
#  > [NBYTES bytes of data (no newline)]
#  [maybe some more blocks]
#  > data-end
#
#  > file dsc
#  [etc]
#
#  > file changes
#  [etc]
#
#  > param head DGIT-VIEW-HEAD
#  > param csuite SUITE
#  > param tagformat new              # $protovsn == 4
#  > param splitbrain 0|1             # $protovsn >= 6
#  > param maint-view MAINT-VIEW-HEAD
#
#  > param buildinfo-filename P_V_X.buildinfo   # zero or more times
#  > file buildinfo                             # for buildinfos to sign
#
#  > previously REFNAME=OBJNAME       # if --deliberately-not-fast-forward
#                                     # goes into tag, for replay prevention
#
#  > param dep14tag 0|1   # responder needs initiator to make a DEP-14 tag ?
#                         # if unsent, use `1`.
#                         # (older responders don't ever send it)
#                         # must be honoured in $protovsn >= 7;
#                         # otherwise, uses dep14tag cfg and param splitbrain
#
#  > want signed-tag
#  [indicates that signed tag is wanted]
#
#  < data-block NBYTES
#  < [NBYTES bytes of dgit view tag data (no newline)]
#  [maybe some more blocks]
#  < data-end
#
#  < data-block NBYTES                                # if we're making
#  < [NBYTES bytes of DEP-14 tag data (no newline)]   #  a new DEP-14 tag
#  [maybe some more blocks]                           #
#  < data-end                                         #
#
#  < files-end
#
#  > want signed-dsc-changes
#  < data-block NBYTES    [transfer of signed dsc]
#  [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

our $i_child_pid;
our @i_child_cmd;

sub i_child_report ($) {
    my ($wflags) = @_;
    # Sees if our child has died, and reap it if so.  Returns a string
    # describing how it died if it failed, or undef otherwise.
    return undef unless $i_child_pid;
    my $got = waitpid $i_child_pid, $wflags;
    return undef if $got <= 0;
    die unless $got == $i_child_pid;
    $i_child_pid = undef;
    return undef unless $?;
    failedcmd @i_child_cmd;
    return f_ "build host child %s", waitstatusmsg();
}

#---------- remote protocol support, responder ----------

sub responder_send_command ($) {
    my ($command) = @_;
    return unless $we_are_responder;
    # called even without $we_are_responder
    $rparent_conn->send($command);
}    

sub responder_send_file ($$) {
    my ($keyword, $ourfn) = @_;
    return unless $we_are_responder;
    printdebug "]] $keyword $ourfn\n";
    responder_send_command "file $keyword";
    $rparent_conn->send_file($ourfn);
}

sub responder_receive_files ($@) {
    my ($keyword, @ourfns) = @_;
    die unless $we_are_responder;
    printdebug "[[ $keyword @ourfns\n";
    responder_send_command "want $keyword";
    foreach my $fn (@ourfns) {
	$rparent_conn->receive_file($fn);
    }
    printdebug "[[\$\n";
    $rparent_conn->expect(sub { m/^files-end$/ });
}

#---------- remote protocol support, initiator ----------

sub initiator_expect (&) {
    my ($match) = @_;
    $rpush_conn->expect($match);
}

#---------- end remote code ----------

sub progress {
    if ($we_are_responder) {
	my $m = join '', @_;
	$rparent_conn->send_counted_message("progress", $m);
    } else {
	print @_, "\n";
    }
}

our $ua;

our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);

sub act_local () { return $dryrun_level <= 1; }
sub act_scary () { return !$dryrun_level; }

sub printdone {
    if (!$dryrun_level) {
	progress f_ "%s ok: %s", $us, "@_";
    } else {
	progress f_ "would be ok: %s (but dry run only)", "@_";
    }
}

sub dryrun_report {
    printcmd(\*STDERR,$debugprefix."#",@_);
}

sub runcmd_ordryrun {
    if (act_scary()) {
	runcmd @_;
    } else {
	dryrun_report @_;
    }
}

sub runcmd_ordryrun_local {
    if (act_local()) {
	runcmd @_;
    } else {
	dryrun_report @_;
    }
}

our $helpmsg = i_ <<END;
main usages:
  dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
  dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
  dgit [dgit-opts] build [dpkg-buildpackage-opts]
  dgit [dgit-opts] sbuild [sbuild-opts]
  dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
  dgit [dgit-opts] push-source [dgit-opts] [suite]
  dgit [dgit-opts] push-built [dgit-opts] [suite]
  dgit [dgit-opts] rpush-source|rpush-built build-host:build-dir ...
important dgit options:
  -k<keyid>           sign tag and package with <keyid> instead of default
  --dry-run -n        do not change anything, but go through the motions
  --damp-run -L       like --dry-run but make local changes, without signing
  --new -N            allow introducing a new package
  --debug -D          increase debug level
  -c<name>=<value>    set git config option (used directly by dgit too)
END

our $later_warning_msg = i_ <<END;
Perhaps the upload is stuck in incoming.  Using the version from git.
END

sub badusage {
    print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
    finish 8;
}

sub nextarg {
    @ARGV or badusage __ "too few arguments";
    return scalar shift @ARGV;
}

sub pre_help () {
    not_necessarily_a_tree();
}
sub cmd_help () {
    print __ $helpmsg or confess "$!";
    finish 0;
}

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',
	       'dgit.default.ssh' => 'ssh',
	       'dgit.default.archive-query' => 'madison:',
	       'dgit.default.sshpsql-dbname' => 'service=projectb',
	       'dgit.default.aptget-components' => 'main',
	       'dgit.default.source-only-uploads' => 'ok',
	       'dgit.default.policy-query-supported-ssh' => 'unknown',
	       'dgit.dsc-url-proto-ok.http'    => 'true',
	       'dgit.dsc-url-proto-ok.https'   => 'true',
	       'dgit.dsc-url-proto-ok.git'     => 'true',
	       'dgit.vcs-git.suites',          => 'sid', # ;-separated
	       'dgit.default.dsc-url-proto-ok' => 'false',
	       # When changing to "source", probably after trixie, update:
	       #  - usage summary in the usage message
	       #  - usage summary in dgit(1)
	       #    + (I.e., restore plain 'push' to the summaries.
	       #      We removed it to avoid having anything in the usage
	       #      summary which would generate warnings.)
	       #  - principal documentation in dgit(1)
	       #  - maybe change push-source to push in workflow(7) (grep)
	       'dgit.default.push-subcmd' => 'warn,built',
	       'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
	       'dgit-distro.debian.git-check' => 'url',
	       'dgit-distro.debian.git-check-suffix' => '/info/refs',
	       'dgit-distro.debian.new-private-pushers' => 't',
	       'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
	       'dgit-distro.debian.policy-query-supported-ssh' => 'true',
	       'dgit-distro.debian/push.git-url' => '',
	       'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
	       'dgit-distro.debian/push.git-user-force' => 'dgit',
	       'dgit-distro.debian/push.git-proto' => 'git+ssh://',
	       'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
	       'dgit-distro.debian/push.git-create' => 'true',
	       'dgit-distro.debian/push.git-check' => 'ssh-cmd',
 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
# 'dgit-distro.debian.archive-query-tls-key',
#    '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
# ^ this does not work because curl is broken nowadays
# Fixing #790093 properly will involve providing providing the key
# in some pacagke and maybe updating these paths.
#
# 'dgit-distro.debian.archive-query-tls-curl-args',
#   '--ca-path=/etc/ssl/ca-debian',
# ^ this is a workaround but works (only) on DSA-administered machines
	       'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
	       'dgit-distro.debian.git-url-suffix' => '',
	       'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
	       'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
 'dgit-distro.debian-security.archive-query' => 'aptget:',
 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
 'dgit-distro.debian-security.aptget-suite-map' => 's#buster-security$#buster/updates#',
 'dgit-distro.debian-security.aptget-suite-rmap' => 's#buster$#buster-security#',
 'dgit-distro.debian-security.nominal-distro' => 'debian',
 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
 '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",
	       'dgit-distro.test-dummy.git-create' => "ssh-cmd",
	       'dgit-distro.test-dummy.git-url' => "$td/git",
	       'dgit-distro.test-dummy.git-host' => "git",
	       'dgit-distro.test-dummy.git-path' => "$td/git",
	       'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
	       'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
	       'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
	       'dgit-distro.test-dummy.upload-host' => 'test-dummy',
               );

our %gitcfgs;
our @gitcfgsources = qw(cmdline local global system);
our $invoked_in_git_tree = 1;

sub git_slurp_config () {
    # This algorithm 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

	$gitcfgs{$src} = git_slurp_config_src $src;
    }
}

sub git_get_config ($) {
    my ($c) = @_;
    foreach my $src (@gitcfgsources) {
	my $l = $gitcfgs{$src}{$c};
	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
	    f_ "multiple values for %s (in %s git config)", $c, $src
	    if @$l > 1;
	$l->[0] =~ m/\n/ and badcfg f_
 "value for config option %s (in %s git config) contains newline(s)!",
            $c, $src;
	return $l->[0];
    }
    return undef;
}

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};
	if (defined $dv) {
	    printdebug "CD $c $dv\n" if $debuglevel >= 4;
	    return $dv;
	}
    }
    badcfg f_
	"need value for one of: %s\n".
	"%s: distro or suite appears not to be (properly) supported",
	"@_", $us;
}

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 {	
	my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
	return $def if defined $def;
	foreach my $src (@gitcfgsources, 'internal') {
	    my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
	    next unless $kl;
	    foreach my $k (keys %$kl) {
		next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
		my $dpat = $1;
		next unless match_glob $dpat, $isuite;
		return $kl->{$k};
	    }
	}
	foreach my $csvf (</usr/share/distro-info/*.csv>) {
	    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");
    }
}

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();
    my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
    $r =~ m/^$distro_re$/ or badcfg
	f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
	$r, "/^$distro_re$/";
    return $r;
}

sub access_quirk () {
    # returns (quirk name, distro to use instead or undef, quirk-specific info)
    my $basedistro = access_basedistro();
    my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
			      'RETURN-UNDEF');
    if (defined $backports_quirk) {
	my $re = $backports_quirk;
	$re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
	$re =~ s/\*/.*/g;
	$re =~ s/\%/([-0-9a-z_]+)/
	    or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
	if ($isuite =~ m/^$re$/) {
	    return ('backports',"$basedistro-backports",$1);
	}
    }
    return ('none',undef);
}

our $access_forpush;

sub parse_cfg_bool ($$$) {
    my ($what,$def,$v) = @_;
    $v //= $def;
    return
	$v =~ m/^[ty1]/ ? 1 :
	$v =~ m/^[fn0]/ ? 0 :
	badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
	    $what, $v;
}	

sub access_forpush_config () {
    my $d = access_basedistro();

    return 1 if
	$new_package &&
	parse_cfg_bool('new-private-pushers', 0,
		       cfg("dgit-distro.$d.new-private-pushers",
			   'RETURN-UNDEF'));

    my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
    $v //= 'a';
    return
	$v =~ m/^[ty1]/ ? 0 : # force readonly,    forpush = 0
	$v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
	$v =~ m/^[a]/  ? '' : # auto,              forpush = ''
	badcfg __
	    "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
}

sub access_forpush () {
    $access_forpush //= access_forpush_config();
    return $access_forpush;
}

sub default_from_access_cfg ($$$;$) {
    my ($var, $keybase, $defval, $permit_re) = @_;
    return if defined $$var;

    $$var = access_cfg("$keybase-newer", 'RETURN-UNDEF');
    $$var = undef if $$var && $$var !~ m/^$permit_re$/;

    $$var //= access_cfg($keybase, 'RETURN-UNDEF');
    $$var //= $defval;

    badcfg f_ "unknown %s \`%s'", $keybase, $$var
	if defined $permit_re and $$var !~ m/$permit_re/;
}

sub pushing () {
    confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
	defined $access_forpush and !$access_forpush;
    badcfg __ "pushing but distro is configured readonly"
	if access_forpush_config() eq '0';
    $access_forpush = 1;
    $supplementary_message = __ <<'END' unless $we_are_responder;
Push failed, before we got started.
You can retry the push, after fixing the problem, if you like.
END
    parseopts_late_defaults();
}

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) {
	$supplementary_message = $msg;
	return;
    } else {
	$rparent_conn->send_counted_message("supplementary-message", $msg);
    }
}

sub access_distros () {
    # Returns list of distros to try, in order
    #
    # We want to try:
    #    0. `instead of' distro name(s) we have been pointed to
    #    1. the access_quirk distro, if any
    #    2a. the user's specified distro, or failing that  } basedistro
    #    2b. the distro calculated from the suite          }
    my @l = access_basedistro();

    my (undef,$quirkdistro) = access_quirk();
    unshift @l, $quirkdistro;
    unshift @l, $instead_distro;
    @l = grep { defined } @l;

    push @l, access_nomdistro();

    if (access_forpush()) {
	@l = map { ("$_/push", $_) } @l;
    }
    @l;
}

sub access_cfg_cfgs (@) {
    my (@keys) = @_;
    my @cfgs;
    # The nesting of these loops determines the search order.  We put
    # the key loop on the outside so that we search all the distros
    # for each key, before going on to the next key.  That means that
    # if access_cfg is called with a more specific, and then a less
    # specific, key, an earlier distro can override the less specific
    # without necessarily overriding any more specific keys.  (If the
    # distro wants to override the more specific keys it can simply do
    # so; whereas if we did the loop the other way around, it would be
    # impossible to for an earlier distro to override a less specific
    # key but not the more specific ones without restating the unknown
    # values of the more specific keys.
    my @realkeys;
    my @rundef;
    # We have to deal with RETURN-UNDEF specially, so that we don't
    # terminate the search prematurely.
    foreach (@keys) {
	if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
	push @realkeys, $_
    }
    foreach my $d (access_distros()) {
	push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
    }
    push @cfgs, map { "dgit.default.$_" } @realkeys;
    push @cfgs, @rundef;
    return @cfgs;
}

sub access_cfg (@) {
    my (@keys) = @_;
    my (@cfgs) = access_cfg_cfgs(@keys);
    my $value = cfg(@cfgs);
    return $value;
}

sub access_cfg_bool ($$) {
    my ($def, @keys) = @_;
    parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
}

sub string_to_ssh ($) {
    my ($spec) = @_;
    if ($spec =~ m/\s/) {
	return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
    } else {
	return ($spec);
    }
}

sub access_cfg_ssh () {
    my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
    if (!defined $gitssh) {
	return @ssh;
    } else {
	return string_to_ssh $gitssh;
    }
}

sub access_runeinfo ($) {
    my ($info) = @_;
    return ": dgit ".access_basedistro()." $info ;";
}

sub access_someuserhost ($) {
    my ($some) = @_;
    my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
    defined($user) && length($user) or
	$user = access_cfg("$some-user",'username');
    my $host = access_cfg("$some-host");
    return length($user) ? "$user\@$host" : $host;
}

sub access_gituserhost () {
    return access_someuserhost('git');
}

sub access_giturl (;$) {
    my ($optional) = @_;
    my $url = access_cfg('git-url','RETURN-UNDEF');
    my $suffix;
    if (!length $url) {
	my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
	return undef unless defined $proto;
	$url =
	    $proto.
	    access_gituserhost().
	    access_cfg('git-path');
    } else {
	$suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
    }
    $suffix //= '.git';
    return "$url/$package$suffix";
}	       

sub commit_getclogp ($) {
    # Returns the parsed changelog hashref for a particular commit
    my ($objid) = @_;
    our %commit_getclogp_memo;
    my $memo = $commit_getclogp_memo{$objid};
    return $memo if $memo;

    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 parse_dscdata () {
    my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
    printdebug Dumper($dscdata) if $debuglevel>1;
    $dsc = parsecontrolfh($dscfh,$dscurl,1);
    printdebug Dumper($dsc) if $debuglevel>1;
}

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;
    my $data = $'; #';
    { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
}

sub archive_query_prepend_mirror {
    my $m = access_cfg('mirror');
    return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
}

sub pool_dsc_subpath ($$) {
    my ($vsn,$component) = @_; # $package is implicit arg
    my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
    return "/pool/$component/$prefix/$package/".dscfn($vsn);
}

sub cfg_apply_map ($$$) {
    my ($varref, $what, $mapspec) = @_;
    return unless $mapspec;

    printdebug "config $what EVAL{ $mapspec; }\n";
    $_ = $$varref;
    eval "package Dgit::Config; $mapspec;";
    die $@ if $@;
    $$varref = $_;
}

sub url_fetch ($;@) {
    my ($url, %xopts) = @_;
    # Ok404 => 1   means give undef for 404
    # AccessBase => 'archive-query' (eg)
    # CurlOpts => { key => value }
    #
    # The return value is the fetched body, or simply `1`
    # if CURLOPT_WRITEDATA is set in CurlOpts.

    printdebug "query: fetching $url...\n";

    if ($xopts{Ok404} && $url =~ m{^file:/+(?=/)}) {
	my $file = $';
	$file =~ s{\%([0-9a-f][0-9a-f])}{chr hex $1}ge;
	# curl doesn't call this 404, it just fails
	printdebug "file: URL, checking for existence manually: $file\n";
	return undef unless stat_exists $file;
    }

    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');
	}
    }

    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/;

    if (defined $xopts{CurlOpts}{CURLOPT_WRITEDATA()}) {
	return 1;
    }

    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 ($$;$) {
    my ($data, $subpath, $ok404) = @_;
    use JSON;
    badcfg __ "ftpmasterapi archive query method takes no data part"
	if length $data;
    my $json = api_query_raw $subpath, $ok404;
    return undef unless defined $json;
    return decode_json($json);
}

sub canonicalise_suite_ftpmasterapi {
    my ($proto,$data) = @_;
    my $suites = api_query($data, 'suites');
    my @matched;
    foreach my $entry (@$suites) {
	next unless grep { 
	    my $v = $entry->{$_};
	    defined $v && $v eq $isuite;
	} qw(codename name);
	push @matched, $entry;
    }
    fail f_ "unknown suite %s, maybe -d would help", $isuite
	unless @matched;
    my $cn;
    eval {
	@matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
	$cn = "$matched[0]{codename}";
	defined $cn or die f_ "suite %s info has no codename\n", $isuite;
	$cn =~ m/^$suite_re$/
	    or die f_ "suite %s maps to bad codename\n", $isuite;
    };
    die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
	if length $@;
    return $cn;
}

sub archive_query_ftpmasterapi {
    my ($proto,$data) = @_;
    my $info = api_query($data, "dsc_in_suite/$isuite/$package");
    my @rows;
    my $digester = Digest::SHA->new(256);
    foreach my $entry (@$info) {
	eval {
	    my $vsn = "$entry->{version}";
	    my ($ok,$msg) = version_check $vsn;
	    die f_ "bad version: %s\n", $msg unless $ok;
	    my $component = "$entry->{component}";
	    $component =~ m/^$component_re$/ or die __ "bad component";
	    my $filename = "$entry->{filename}";
	    $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
		or die __ "bad filename";
	    my $sha256sum = "$entry->{sha256sum}";
	    $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
	    push @rows, [ $vsn, "/pool/$component/$filename",
			  $digester, $sha256sum ];
	};
	die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
	    if length $@;
    }
    @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
    return archive_query_prepend_mirror @rows;
}

# $filename is the leafname.  It may contain `*` for globbing.
sub file_in_archive_ftpmasterapi {
    my ($proto,$data,$filename) = @_;
    my $pat = $filename;
    $pat =~ s/_/\\_/g;
    $pat =~ s/\*/%/g;
    $pat = "%/$pat";
    $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
    my $info = api_query($data, "file_in_archive/$pat", 1);
}

sub package_not_wholly_new_ftpmasterapi {
    my ($proto,$data,$pkg) = @_;
    my $info = api_query($data,"madison?package=${pkg}&f=json");
    return !!@$info;
}

#---------- `aptget' archive query method ----------

our $aptget_base;
our $aptget_releasefile;
our $aptget_configpath;

sub aptget_aptget   () { return @aptget,   qw(-c), $aptget_configpath; }
sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }

sub aptget_cache_clean {
    runcmd_ordryrun_local qw(sh -ec),
	'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
	'x', $aptget_base;
}

sub aptget_lock_acquire () {
    my $lockfile = "$aptget_base/lock";
    open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
    flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
}

sub aptget_prep ($) {
    my ($data) = @_;
    return if defined $aptget_base;

    badcfg __ "aptget archive query method takes no data part"
	if length $data;

    my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";

    ensuredir $cache;
    ensuredir "$cache/dgit";
    my $cachekey =
	access_cfg('aptget-cachekey','RETURN-UNDEF')
	// access_nomdistro();

    $aptget_base = "$cache/dgit/aptget";
    ensuredir $aptget_base;

    my $quoted_base = $aptget_base;
    confess "$quoted_base contains bad chars, cannot continue"
	if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/

    ensuredir $aptget_base;

    aptget_lock_acquire();

    aptget_cache_clean();

    $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
    my $sourceslist = "source.list#$cachekey";

    my $aptsuites = $isuite;
    cfg_apply_map(\$aptsuites, 'suite map',
		  access_cfg('aptget-suite-map', 'RETURN-UNDEF'));

    open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
    printf SRCS "deb-src %s %s %s\n",
	access_cfg('mirror'),
	$aptsuites,
	access_cfg('aptget-components')
	or confess "$!";

    ensuredir "$aptget_base/cache";
    ensuredir "$aptget_base/lists";

    open CONF, ">", $aptget_configpath or confess "$!";
    print CONF <<END;
Debug::NoLocking "true";
APT::Get::List-Cleanup "false";
#clear APT::Update::Post-Invoke-Success;
Dir::Etc::SourceList "$quoted_base/$sourceslist";
Dir::State::Lists "$quoted_base/lists";
Dir::Etc::preferences "$quoted_base/preferences";
Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
END

    foreach my $key (qw(
			Dir::Cache
			Dir::State
			Dir::Cache::Archives
			Dir::Etc::SourceParts
			Dir::Etc::preferencesparts
		      )) {
	ensuredir "$aptget_base/$key";
	print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
    };

    my $oldatime = (time // confess "$!") - 1;
    foreach my $oldlist (<$aptget_base/lists/*Release>) {
	next unless stat_exists $oldlist;
	my ($mtime) = (stat _)[9];
	utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
    }

    runcmd_ordryrun_local aptget_aptget(), qw(update);

    my @releasefiles;
    foreach my $oldlist (<$aptget_base/lists/*Release>) {
	next unless stat_exists $oldlist;
	my ($atime) = (stat _)[8];
	next if $atime == $oldatime;
	push @releasefiles, $oldlist;
    }
    my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
    @releasefiles = @inreleasefiles if @inreleasefiles;
    if (!@releasefiles) {
	fail f_ <<END, $isuite, $cache;
apt seemed to not to update dgit's cached Release files for %s.
(Perhaps %s
 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
END
    }
    confess "apt updated too many Release files (@releasefiles), erk"
	unless @releasefiles == 1;

    ($aptget_releasefile) = @releasefiles;
}

sub canonicalise_suite_aptget {
    my ($proto,$data) = @_;
    aptget_prep($data);

    my $release = parsecontrol $aptget_releasefile, "Release file", 1;

    foreach my $name (qw(Codename Suite)) {
	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;
	    return $val
	}
    }
    return $isuite;
}

sub archive_query_aptget {
    my ($proto,$data) = @_;
    aptget_prep($data);

    ensuredir "$aptget_base/source";
    foreach my $old (<$aptget_base/source/*.dsc>) {
	unlink $old or die "$old: $!";
    }

    my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
    return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
    # avoids apt-get source failing with ambiguous error code

    runcmd_ordryrun_local
	shell_cmd 'cd "$1"/source; shift', $aptget_base,
	aptget_aptget(), qw(--download-only --only-source source), $package;

    my @dscs = <$aptget_base/source/*.dsc>;
    fail __ "apt-get source did not produce a .dsc" unless @dscs;
    fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
	unless @dscs==1;

    my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;

    use URI::Escape;
    my $uri = "file://". uri_escape $dscs[0];
    $uri =~ s{\%2f}{/}gi;
    return [ (getfield $pre_dsc, 'Version'), $uri ];
}

sub file_in_archive_aptget () { return undef; }
sub package_not_wholly_new_aptget () { return undef; }

#---------- `dummyapicat' archive query method ----------
# (untranslated, because this is for testing purposes etc.)

sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }

sub dummycatapi_run_in_mirror ($@) {
    # runs $fn with FIA open onto rune
    my ($rune, $argl, $fn) = @_;

    my $mirror = access_cfg('mirror');
    $mirror =~ s#^file://#/# or die "$mirror ?";
    my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
	       qw(x), $mirror, @$argl);
    debugcmd "-|", @cmd;
    open FIA, "-|", @cmd or confess "$!";
    my $r = $fn->();
    close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
    return $r;
}

sub file_in_archive_dummycatapi ($$$) {
    my ($proto,$data,$filename) = @_;
    my @out;
    dummycatapi_run_in_mirror '
            find -name "$1" -print0 |
            xargs -0r sha256sum
    ', [$filename], sub {
	while (<FIA>) {
	    chomp or die;
	    printdebug "| $_\n";
	    m{^(\w+)  \./pool/($component_re)/(\S+)$} or die "$_ ?";
	    push @out, { sha256sum => $1, component => $2, filename => $3 };
	}
    };
    return \@out;
}

sub package_not_wholly_new_dummycatapi {
    my ($proto,$data,$pkg) = @_;
    dummycatapi_run_in_mirror "
            find -name ${pkg}_*.dsc
    ", [], sub {
	local $/ = undef;
	!!<FIA>;
    };
}

#---------- `madison' archive query method ----------

sub archive_query_madison {
    return archive_query_prepend_mirror
	map { [ @$_[0..1] ] } madison_get_parse(@_);
}

sub madison_get_parse {
    my ($proto,$data) = @_;
    die unless $proto eq 'madison';
    if (!length $data) {
	$data= access_cfg('madison-distro','RETURN-UNDEF');
	$data //= access_basedistro();
    }
    $rmad{$proto,$data,$package} ||= cmdoutput
	qw(rmadison -asource),"-s$isuite","-u$data",$package;
    my $rmad = $rmad{$proto,$data,$package};

    my @out;
    foreach my $l (split /\n/, $rmad) {
	$l =~ m{^ \s*( [^ \t|]+ )\s* \|
                  \s*( [^ \t|]+ )\s* \|
                  \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
                  \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
	$1 eq $package or die "$rmad $package ?";
	my $vsn = $2;
	my $newsuite = $3;
	my $component;
	if (defined $4) {
	    $component = $4;
	} else {
	    $component = access_cfg('archive-query-default-component');
	}
	$5 eq 'source' or die "$rmad ?";
	push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
    }
    return sort { -version_compare($a->[0],$b->[0]); } @out;
}

sub canonicalise_suite_madison {
    # madison canonicalises for us
    my @r = madison_get_parse(@_);
    @r or fail f_
	"unable to canonicalise suite using package %s".
	" which does not appear to exist in suite %s;".
	" --existing-package may help",
	$package, $isuite;
    return $r[0][2];
}

sub file_in_archive_madison { return undef; }
sub package_not_wholly_new_madison { return undef; }

#---------- `sshpsql' archive query method ----------
# (untranslated, because this is obsolete)

sub sshpsql ($$$) {
    my ($data,$runeinfo,$sql) = @_;
    if (!length $data) {
	$data= access_someuserhost('sshpsql').':'.
	    access_cfg('sshpsql-dbname');
    }
    $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
    my ($userhost,$dbname) = ($`,$'); #';
    my @rows;
    my @cmd = (access_cfg_ssh, $userhost,
	       access_runeinfo("ssh-psql $runeinfo").
	       " export LC_MESSAGES=C; export LC_CTYPE=C;".
	       " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
    debugcmd "|",@cmd;
    open P, "-|", @cmd or confess "$!";
    while (<P>) {
	chomp or die;
	printdebug(">|$_|\n");
	push @rows, $_;
    }
    $!=0; $?=0; close P or failedcmd @cmd;
    @rows or die;
    my $nrows = pop @rows;
    $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
    @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
    @rows = map { [ split /\|/, $_ ] } @rows;
    my $ncols = scalar @{ shift @rows };
    die if grep { scalar @$_ != $ncols } @rows;
    return @rows;
}

sub sql_injection_check {
    foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
}

sub archive_query_sshpsql ($$) {
    my ($proto,$data) = @_;
    sql_injection_check $isuite, $package;
    my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
        SELECT source.version, component.name, files.filename, files.sha256sum
          FROM source
          JOIN src_associations ON source.id = src_associations.source
          JOIN suite ON suite.id = src_associations.suite
          JOIN dsc_files ON dsc_files.source = source.id
          JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
          JOIN component ON component.id = files_archive_map.component_id
          JOIN files ON files.id = dsc_files.file
         WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
           AND source.source='$package'
           AND files.filename LIKE '%.dsc';
END
    @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
    my $digester = Digest::SHA->new(256);
    @rows = map {
	my ($vsn,$component,$filename,$sha256sum) = @$_;
	[ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
    } @rows;
    return archive_query_prepend_mirror @rows;
}

sub canonicalise_suite_sshpsql ($$) {
    my ($proto,$data) = @_;
    sql_injection_check $isuite;
    my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
        SELECT suite.codename
          FROM suite where suite_name='$isuite' or codename='$isuite';
END
    @rows = map { $_->[0] } @rows;
    fail "unknown suite $isuite" unless @rows;
    die "ambiguous $isuite: @rows ?" if @rows>1;
    return $rows[0];
}

sub file_in_archive_sshpsql ($$$) { return undef; }
sub package_not_wholly_new_sshpsql ($$$) { return undef; }

#---------- `dummycat' archive query method ----------
# (untranslated, because this is for testing purposes etc.)

sub canonicalise_suite_dummycat ($$) {
    my ($proto,$data) = @_;
    my $dpath = "$data/suite.$isuite";
    if (!open C, "<", $dpath) {
	$!==ENOENT or die "$dpath: $!";
	printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
	return $isuite;
    }
    $!=0; $_ = <C>;
    chomp or die "$dpath: $!";
    close C;
    printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
    return $_;
}

sub archive_query_dummycat ($$) {
    my ($proto,$data) = @_;
    canonicalise_suite();
    my $dpath = "$data/package.$csuite.$package";
    if (!open C, "<", $dpath) {
	$!==ENOENT or die "$dpath: $!";
	printdebug "dummycat query $csuite $package $dpath ENOENT\n";
	return ();
    }
    my @rows;
    while (<C>) {
	next if m/^\#/;
	next unless m/\S/;
	die unless chomp;
	printdebug "dummycat query $csuite $package $dpath | $_\n";
	my @row = split /\s+/, $_;
	@row==2 or die "$dpath: $_ ?";
	push @rows, \@row;
    }
    C->error and die "$dpath: $!";
    close C;
    return archive_query_prepend_mirror
	sort { -version_compare($a->[0],$b->[0]); } @rows;
}

sub file_in_archive_dummycat () { return undef; }
sub package_not_wholly_new_dummycat () { return undef; }

#---------- archive query entrypoints and rest of program ----------

sub canonicalise_suite () {
    return if defined $csuite;
    fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
    $csuite = archive_query('canonicalise_suite');
    if ($isuite ne $csuite) {
	progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
    } else {
	progress f_ "canonical suite name is %s", $csuite;
    }
}

sub get_archive_dsc () {
    canonicalise_suite();
    my @vsns = archive_query('archive_query');
    foreach my $vinfo (@vsns) {
	my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
	$dscurl = $vsn_dscurl;
	$dscdata = url_fetch($dscurl, Ok404 => 1 );
	if (!$dscdata) {
	    $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
	    next;
	}
	if ($digester) {
	    $digester->reset();
	    $digester->add($dscdata);
	    my $got = $digester->hexdigest();
	    $got eq $digest or
		fail f_ "%s has hash %s but archive told us to expect %s",
		        $dscurl, $got, $digest;
	}
	parse_dscdata();
	my $fmt = getfield $dsc, 'Format';
	$format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
	    f_ "unsupported source format %s, sorry", $fmt;
	    
	$dsc_checked = !!$digester;
	printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
	return;
    }
    $dsc = undef;
    printdebug "get_archive_dsc: nothing in archive, returning undef\n";
}

sub check_for_git ();
sub check_for_git () {
    # returns 0 or 1
    my $how = access_cfg('git-check');
    if ($how eq 'ssh-cmd') {
	my @cmd =
	    (access_cfg_ssh, access_gituserhost(),
	     access_runeinfo("git-check $package").
	     " set -e; cd ".access_cfg('git-path').";".
	     " if test -d $package.git; then echo 1; else echo 0; fi");
	my $r= cmdoutput @cmd;
	if (defined $r and $r =~ m/^divert (\w+)$/) {
	    my $divert=$1;
	    my ($usedistro,) = access_distros();
	    # NB that if we are pushing, $usedistro will be $distro/push
	    $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
	    $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
	    progress f_ "diverting to %s (using config for %s)",
		        $divert, $instead_distro;
	    return check_for_git();
	}
	failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
	return $r+0;
    } elsif ($how eq 'url') {
	my $prefix = access_cfg('git-check-url','git-url');
	my $suffix = access_cfg('git-check-suffix','git-suffix',
				'RETURN-UNDEF') // '.git';
	my $url = "$prefix/$package$suffix";
	my $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') {
	return 0;
    } else {
	badcfg f_ "unknown git-check \`%s'", $how;
    }
}

sub create_remote_git_repo () {
    my $how = access_cfg('git-create');
    if ($how eq 'ssh-cmd') {
	runcmd_ordryrun
	    (access_cfg_ssh, access_gituserhost(),
	     access_runeinfo("git-create $package").
	     "set -e; cd ".access_cfg('git-path').";".
	     " cp -a _template $package.git");
    } elsif ($how eq 'true') {
	# nothing to do
    } else {
	badcfg f_ "unknown git-create \`%s'", $how;
    }
}

our ($dsc_hash,$lastpush_mergeinput);
our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);


sub prep_ud () {
    dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
    $playground = fresh_playground 'dgit/unpack';
}

sub mktree_in_ud_here () {
    playtree_setup();
}

sub git_write_tree () {
    my $tree = cmdoutput @git, qw(write-tree);
    $tree =~ m/^\w+$/ or die "$tree ?";
    return $tree;
}

sub git_add_write_tree () {
    runcmd @git, qw(add -Af .);
    return git_write_tree();
}

sub git_diff_programmatic (@) {
  # Ideally we would unset various git.diff config options here,
  # but there doesn't seem to be a way to *unset*
  # something on the command line
  (@git, qw(-c color.ui=never diff --no-ext-diff), @_)
}

sub remove_stray_gits ($) {
    my ($what) = @_;
    my @gitscmd = qw(find -name .git -prune -print0);
    debugcmd "|",@gitscmd;
    open GITS, "-|", @gitscmd or confess "$!";
    {
	local $/="\0";
	while (<GITS>) {
	    chomp or die;
	    print STDERR f_ "%s: warning: removing from %s: %s\n",
		$us, $what, (messagequote $_);
	    rmdir_r $_;
	}
    }
    $!=0; $?=0; close GITS or failedcmd @gitscmd;
}

sub mktree_in_ud_from_unpacked ($;$) {
    my ($what,$raw) = @_;
    # changes into the `unpacked` subdir

    changedir 'unpacked';

    remove_stray_gits($what);
    mktree_in_ud_here();
    if (!$raw) {
	my $format = get_source_format();
	if (madformat($format)) {
	    rmdir_r '.pc';
	}
    }

    my $tree=git_add_write_tree();
    return $tree;
}

our @files_csum_info_fields = 
    (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
     ['Checksums-Sha1',  'Digest::SHA', 'new(1)',   'sha1sum'],
     ['Files',           'Digest::MD5', 'new()',    'md5sum']);

sub dsc_files_info () {
    foreach my $csumi (@files_csum_info_fields) {
	my ($fname, $module, $method, $digest_name) = @$csumi;
	my $field = $dsc->{$fname};
	next unless defined $field;
	eval "use $module; 1;" or die $@;
	my @out;
	foreach (split /\n/, $field) {
	    next unless m/\S/;
	    m/^(\w+) (\d+) (\S+)$/ or
		fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
	    my $digester = eval "$module"."->$method;" or die $@;
	    push @out, {
		Hash => $1,
		Bytes => $2,
		Filename => $3,
                DigestName => $digest_name,
		Digester => $digester,
	    };
	}
	return @out;
    }
    fail f_ "missing any supported Checksums-* or Files field in %s",
	    $dsc->get_option('name');
}

sub dsc_files () {
    map { $_->{Filename} } dsc_files_info();
}

sub files_compare_inputs (@) {
    my $inputs = \@_;
    my %record;
    my %fchecked;

    my $showinputs = sub {
	return join "; ", map { $_->get_option('name') } @$inputs;
    };

    foreach my $in (@$inputs) {
	my $expected_files;
	my $in_name = $in->get_option('name');

	printdebug "files_compare_inputs $in_name\n";

	foreach my $csumi (@files_csum_info_fields) {
	    my ($fname) = @$csumi;
	    printdebug "files_compare_inputs $in_name $fname\n";

	    my $field = $in->{$fname};
	    next unless defined $field;

	    my @files;
	    foreach (split /\n/, $field) {
		next unless m/\S/;

		my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
		    fail "could not parse $in_name $fname line \`$_'";

		printdebug "files_compare_inputs $in_name $fname $f\n";

		push @files, $f;

		my $re = \ $record{$f}{$fname};
		if (defined $$re) {
		    $fchecked{$f}{$in_name} = 1;
		    $$re eq $info or
			fail f_
              "hash or size of %s varies in %s fields (between: %s)",
	                         $f, $fname, $showinputs->();
		} else {
		    $$re = $info;
		}
	    }
	    @files = sort @files;
	    $expected_files //= \@files;
	    "@$expected_files" eq "@files" or
		fail f_ "file list in %s varies between hash fields!",
		        $in_name;
	}
	$expected_files or
	    fail f_ "%s has no files list field(s)", $in_name;
    }
    printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
	if $debuglevel>=2;

    grep { keys %$_ == @$inputs-1 } values %fchecked
	or fail f_ "no file appears in all file lists (looked in: %s)",
  	           $showinputs->();
}

sub is_orig_file_in_dsc ($$) {
    my ($f, $dsc_files_info) = @_;
    return 0 if @$dsc_files_info <= 1;
    # One file means no origs, and the filename doesn't have a "what
    # part of dsc" component.  (Consider versions ending `.orig'.)
    return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
    return 1;
}

# 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.
# (An exception to this is when --tag2upload-builder-mode.)
sub test_source_only_changes ($) {
    my ($changes) = @_;
    my $arch = getfield $changes, 'Architecture';
    unless ($arch eq 'source') {
	print STDERR f_
	  "purportedly source-only changes has Architecture: %s\n",
	  $arch;
	return 0;
    }
    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
	$_ = $&;
	next if m/(?:\.dsc|\.diff\.gz|$tarball_f_ext_re)$/;
	next if m/_source\.buildinfo$/;
	print STDERR
	  f_ "purportedly source-only changes polluted by %s\n", $&;
	return 0;
    }
    return 1;
}

sub changes_update_origs_from_dsc ($$$$) {
    my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
    my %changes_f;
    printdebug "checking origs needed ($upstreamvsn)...\n";
    $_ = getfield $changes, 'Files';
    m/^\w+ \d+ (\S+ \S+) \S+$/m or
	fail __ "cannot find section/priority from .changes Files field";
    my $placementinfo = $1;
    my %changed;
    printdebug "checking origs needed placement '$placementinfo'...\n";
    foreach my $l (split /\n/, getfield $dsc, 'Files') {
	$l =~ m/\S+$/ or next;
	my $file = $&;
	printdebug "origs $file | $l\n";
	next unless is_orig_file_of_vsn $file, $upstreamvsn;
	printdebug "origs $file is_orig\n";
	my $have = archive_query('file_in_archive', $file);
	if (!defined $have) {
	    print STDERR __ <<END;
archive does not support .orig check; hope you used --ch:--sa/-sd if needed
END
	    return;
	}
	my $found_same = 0;
	my @found_differ;
	printdebug "origs $file \$#\$have=$#$have\n";
	foreach my $h (@$have) {
	    my $same = 0;
	    my @differ;
	    foreach my $csumi (@files_csum_info_fields) {
		my ($fname, $module, $method, $archivefield) = @$csumi;
		next unless defined $h->{$archivefield};
		$_ = $dsc->{$fname};
		next unless defined;
		m/^(\w+) .* \Q$file\E$/m or
		    fail f_ ".dsc %s missing entry for %s", $fname, $file;
		if ($h->{$archivefield} eq $1) {
		    $same++;
		} else {
		    push @differ, f_
			"%s: %s (archive) != %s (local .dsc)",
			$archivefield, $h->{$archivefield}, $1;
		}
	    }
	    confess "$file ".Dumper($h)." ?!" if $same && @differ;
	    $found_same++
		if $same;
	    push @found_differ,
		f_ "archive %s: %s", $h->{filename}, join "; ", @differ
		if @differ;
	}
	printdebug "origs $file f.same=$found_same".
	    " #f._differ=$#found_differ\n";
	if (@found_differ && !$found_same) {
	    fail join "\n",
		(f_ "archive contains %s with different checksum", $file),
		@found_differ;
	}
	# Now we edit the changes file to add or remove it
	foreach my $csumi (@files_csum_info_fields) {
	    my ($fname, $module, $method, $archivefield) = @$csumi;
	    next unless defined $changes->{$fname};
	    if ($found_same) {
		# in archive, delete from .changes if it's there
		$changed{$file} = "removed" if
		    $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
	    } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
		# not in archive, but it's here in the .changes
	    } else {
		my $dsc_data = getfield $dsc, $fname;
		$dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
		my $extra = $1;
		$extra =~ s/ \d+ /$&$placementinfo /
		    or confess "$fname $extra >$dsc_data< ?"
		    if $fname eq 'Files';
		$changes->{$fname} .= "\n". $extra;
		$changed{$file} = "added";
	    }
	}
    }
    if (%changed) {
	foreach my $file (keys %changed) {
	    progress f_
		"edited .changes for archive .orig contents: %s %s",
		$changed{$file}, $file;
	}
	my $chtmp = "$changesfile.tmp";
	$changes->save($chtmp);
	if (act_local()) {
	    rename $chtmp,$changesfile or die "$changesfile $!";
	} else {
	    progress f_ "[new .changes left in %s]", $changesfile;
	}
    } else {
	progress f_ "%s already has appropriate .orig(s) (if any)",
	            $changesfile;
    }
}

sub clogp_authline ($) {
    my ($clogp) = @_;
    my $author = getfield $clogp, 'Maintainer';
    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 = getfield($clogp,'Date');
    # try to pass through the changelog entry's timezone offset
    my $tz = $date =~ m{ ([-+]\d{4})$} ? $1 : " +0000";
    $date = cmdoutput qw(date), '+%s', qw(-d), $date;
    my $authline = "$author $date $tz";
    $authline =~ m/$git_authline_re/o or
	fail f_ "unexpected commit author line format \`%s'".
	        " (was generated from changelog Maintainer field)",
		$authline;
    return ($1,$2,$3) if wantarray;
    return $authline;
}

sub vendor_patches_distro ($$) {
    my ($checkdistro, $what) = @_;
    return unless defined $checkdistro;

    my $series = "debian/patches/\L$checkdistro\E.series";
    printdebug "checking for vendor-specific $series ($what)\n";

    if (!open SERIES, "<", $series) {
	confess "$series $!" unless $!==ENOENT;
	return;
    }
    while (<SERIES>) {
	next unless m/\S/;
	next if m/^\s+\#/;

	print STDERR __ <<END;

Unfortunately, this source package uses a feature of dpkg-source where
the same source package unpacks to different source code on different
distros.  dgit cannot safely operate on such packages on affected
distros, because the meaning of source packages is not stable.

Please ask the distro/maintainer to remove the distro-specific series
files and use a different technique (if necessary, uploading actually
different packages, if different distros are supposed to have
different code).

END
	fail f_ "Found active distro-specific series file for".
	        " %s (%s): %s, cannot continue",
		$checkdistro, $what, $series;
    }
    die "$series $!" if SERIES->error;
    close SERIES;
}

sub check_for_vendor_patches () {
    # This dpkg-source feature doesn't seem to be documented anywhere!
    # But it can be found in the changelog (reformatted):

    #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
    #   Author: Raphael Hertzog <hertzog@debian.org>
    #   Date: Sun  Oct  3  09:36:48  2010 +0200

    #   dpkg-source: correctly create .pc/.quilt_series with alternate
    #   series files
    #   
    #   If you have debian/patches/ubuntu.series and you were
    #   unpacking the source package on ubuntu, quilt was still
    #   directed to debian/patches/series instead of
    #   debian/patches/ubuntu.series.
    #   
    #   debian/changelog                        |    3 +++
    #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
    #   2 files changed, 6 insertions(+), 1 deletion(-)

    use Dpkg::Vendor;
    vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
    vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
			  __ "Dpkg::Vendor \`current vendor'");
    vendor_patches_distro(access_basedistro(),
			  __ "(base) distro being accessed");
    vendor_patches_distro(access_nomdistro(),
			  __ "(nominal) distro being accessed");
}

sub check_bpd_exists () {
    stat $buildproductsdir
	or fail f_ "build-products-dir %s is not accessible: %s\n",
	$buildproductsdir, $!;
}

sub dotdot_bpd_transfer_origs ($$$) {
    my ($bpd_abs, $upstreamversion, $wanted) = @_;
    # checks is_orig_file_of_vsn and if
    # calls $wanted->{$leaf} and expects boolish

    my $dotdot = $maindir;
    $dotdot =~ s{/[^/]+$}{};

    my %dupes;
    my $dupe_scan = sub {
	my ($dir, $why_token) = @_;

	if (!opendir SD, $dir) {
	    return if $! == ENOENT;
	    fail "opendir $why_token ($dir): $!";
	}
	while ($!=0, defined(my $leaf = readdir SD)) {
	    next unless is_orig_file_of_vsn $leaf, $upstreamversion;
	    next if $leaf =~ m{$orig_f_sig_re$};
	    next unless $leaf =~ m{\.tar(?:\.\w+)?$};
	    my $base = "$`.tar";
	    push @{ $dupes{$base}{$leaf} }, [$why_token, $dir];
	}
	die "$dir; $!" if $!;
    };
    $dupe_scan->($dotdot, "..");
    $dupe_scan->(bpd_abs(), 'build-products-dir') if $buildproductsdir ne '..';

    my $dupes_found = 0;
    foreach my $base (sort keys %dupes) {
	my $leaves = $dupes{$base};
	next if keys(%$leaves) == 1;
	$dupes_found = 1;
	print STDERR f_
	  "%s: multiple representations of similar orig %s:\n",
	  $us, $base;
	foreach my $leaf (keys %$leaves) {
	    foreach my $found (@{ $leaves->{$leaf} }) {
		print STDERR f_ "  %s: in %s (%s)\n",
		  $leaf, @$found;
	    }
	}
    }
    fail __ "Duplicate/inconsistent orig tarballs.  Delete the spurious ones."
      if $dupes_found;

    return if $buildproductsdir eq '..';

    my $warned;
    opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
    while ($!=0, defined(my $leaf = readdir DD)) {
	{
	    local ($debuglevel) = $debuglevel-1;
	    printdebug "DD_BPD $leaf ?\n";
	}
	next unless is_orig_file_of_vsn $leaf, $upstreamversion;
	next unless $wanted->($leaf);
	next if lstat "$bpd_abs/$leaf";

	print STDERR f_
 "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
	    $us
	    unless $warned++;
	$! == &ENOENT or fail f_
	    "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
	lstat "$dotdot/$leaf" or fail f_
	    "check orig file %s in ..: %s", $leaf, $!;
	if (-l _) {
	    stat "$dotdot/$leaf" or fail f_
		"check target of orig symlink %s in ..: %s", $leaf, $!;
	    my $ltarget = readlink "$dotdot/$leaf" or
		die "readlink $dotdot/$leaf: $!";
	    if ($ltarget !~ m{^/}) {
		$ltarget = "$dotdot/$ltarget";
	    }
	    symlink $ltarget, "$bpd_abs/$leaf"
		or die "$ltarget $bpd_abs $leaf: $!";
	    print STDERR f_
 "%s: cloned orig symlink from ..: %s\n",
		$us, $leaf;
	} elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
	    print STDERR f_
 "%s: hardlinked orig from ..: %s\n",
		$us, $leaf;
	} elsif ($! != EXDEV) {
	    fail f_ "failed to make %s a hardlink to %s: %s",
		"$bpd_abs/$leaf", "$dotdot/$leaf", $!;
	} else {
	    symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
		or die "$bpd_abs $dotdot $leaf $!";
	    print STDERR f_
 "%s: symmlinked orig from .. on other filesystem: %s\n",
		$us, $leaf;
	}
    }
    die "$dotdot; $!" if $!;
    closedir DD;
}

sub import_r1authline ($$) {
    my ($clogp_r, $upstreamv) = @_;
    my $r1clogp;

    my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);

    printdebug "import clog search...\n";
    parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
	my ($thisstanza, $desc) = @_;
	no warnings qw(exiting);

	$$clogp_r //= $thisstanza;

	printdebug "import clog $thisstanza->{version} $desc...\n";

	# We look for the first (most recent) changelog entry whose
	# version number is lower than the upstream version of this
	# package.  Then the last (least recent) previous changelog
	# entry is treated as the one which introduced this upstream
	# version and used for the synthetic commits for the upstream
	# tarballs.

	# One might think that a more sophisticated algorithm would be
	# necessary.  But: we do not want to scan the whole changelog
	# file.  Stopping when we see an earlier version, which
	# necessarily then is an earlier upstream version, is the only
	# realistic way to do that.  Then, either the earliest
	# changelog entry we have seen so far is indeed the earliest
	# upload of this upstream version; or there are only changelog
	# entries relating to later upstream versions (which is not
	# possible unless the changelog and .dsc disagree about the
	# version).  Then it remains to choose between the physically
	# last entry in the file, and the one with the lowest version
	# number.  If these are not the same, we guess that the
	# versions were created in a non-monotonic order rather than
	# that the changelog entries have been misordered.

	printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";

	last if version_compare($thisstanza->{version}, $upstreamv) < 0;
	$r1clogp = $thisstanza;

	printdebug "import clog $r1clogp->{version} becomes r1\n";
    };

    $r1clogp //= $$clogp_r; # maybe there's only one entry;
    return clogp_authline $r1clogp;
}

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.
    # But we can't make them into commits until we have the metadata
    # from the debian/changelog, so we record the tree objects now and
    # make them into commits later.
    my @tartrees;
    my $orig_f_base = srcfn $upstreamv, '';

    foreach my $fi (@$dfi) {
	# We actually import, and record as a commit, every tarball
	# (unless there is only one file, in which case there seems
	# little point.

	my $f = $fi->{Filename};
	printdebug "import considering $f ";
	(printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
	(printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
	my $compr_ext = $1;

	my ($orig_f_part) =
	    $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;

	printdebug "Y ", (join ' ', map { $_//"(none)" }
			  $compr_ext, $orig_f_part
			 ), "\n";

	my $path = $fi->{Path} // $f;
	my $input = new IO::File $f, '<' or die "$f $!";
	my $compr_pid;
	my @compr_cmd;

	if (defined $compr_ext) {
	    my $cname =
		Dpkg::Compression::compression_guess_from_filename $f;
	    fail "Dpkg::Compression cannot handle file $f in source package"
		if defined $compr_ext && !defined $cname;
	    my $compr_proc =
		new Dpkg::Compression::Process compression => $cname;
	    @compr_cmd = $compr_proc->get_uncompress_cmdline();
	    my $compr_fh = new IO::Handle;
	    my $compr_pid = open $compr_fh, "-|" // confess "$!";
	    if (!$compr_pid) {
		open STDIN, "<&", $input or confess "$!";
		exec @compr_cmd;
		die "dgit (child): exec $compr_cmd[0]: $!\n";
	    }
	    $input = $compr_fh;
	}

	rmdir_r "_unpack-tar";
	mkdir "_unpack-tar" or confess "$!";
	my @tarcmd = qw(tar -x -f -
			--no-same-owner --no-same-permissions
			--no-acls --no-xattrs --no-selinux);
	my $tar_pid = fork // confess "$!";
	if (!$tar_pid) {
	    chdir "_unpack-tar" or confess "$!";
	    open STDIN, "<&", $input or confess "$!";
	    exec @tarcmd;
	    die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
	}
	$!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
	!$? or failedcmd @tarcmd;

	close $input or
	    (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
	     : confess "$!");
	# finally, we have the results in "tarball", but maybe
	# with the wrong permissions

	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 "..";
	rmdir_r "_unpack-tar";

	my $ent = [ $f, $tree ];
	push @tartrees, {
            Orig => !!$orig_f_part,
            Sort => (!$orig_f_part         ? 2 :
		     $orig_f_part =~ m/-/g ? 1 :
		                             0),
            OrigPart => $orig_f_part, # 'orig', 'orig-PART', or undef 
            F => $f,
            Tree => $tree,
        };
    }

    @tartrees = sort {
	# put any without "_" first (spec is not clear whether files
	# are always in the usual order).  Tarballs without "_" are
	# the main orig or the debian tarball.
	$a->{Sort} <=> $b->{Sort} or
	$a->{F}    cmp $b->{F}
    } @tartrees;

    @tartrees;
}

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 $any_orig = grep { $_->{Orig} } @$tartrees;

    my $clogp;
    my $r1authline;
    if ($any_orig) {
	if (!eval {
	    local $failmsg_prefix = '  ';
	    $r1authline = import_r1authline(\$clogp, $upstreamv);
	    $clogp or fail __ "package changelog has no entries!";
	    1;
	}) {
	    chomp $@;
	    print STDERR f_ <<END, $upstreamv, $@;
warning: unable to find/parse changelog entry for first import of %s:
%s
END
	}
    }
    # Runs if $any_orig clause didn't set $clogp
    $clogp //= parsechangelog();
    my $authline = clogp_authline $clogp;
    # Runs if $any_orig clause didn't set $r1authline
    $r1authline //= $authline;

    my $changes = getfield $clogp, 'Changes';
    $changes =~ s/^\n//; # Changes: \n
    my $cversion = getfield $clogp, 'Version';

    if (@$tartrees) {
	printdebug "import tartrees authline   $authline\n";
	printdebug "import tartrees r1authline $r1authline\n";

	foreach my $tt (@$tartrees) {
	    printdebug "import tartree $tt->{F} $tt->{Tree}\n";

	    # untranslated so that different people's imports are identical
	    my $mbody = sprintf "Import %s", $tt->{F};
	    $tt->{Commit} = hash_commit_text($tt->{Orig} ? <<END_O : <<END_T);
tree $tt->{Tree}
author $r1authline
committer $r1authline

$mbody

[dgit import orig $tt->{F}]
END_O
tree $tt->{Tree}
author $authline
committer $authline

$mbody

[dgit import tarball $package $cversion $tt->{F}]
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 (!act_local()) {
	    printdebug "no - dry run.\n";
	} elsif (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, qw(unpacked);
    runcmd @cmd;

    my $tree = mktree_in_ud_from_unpacked(__ "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;
	rmdir_r '.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 "$!";
    print C <<END or confess "$!";
tree $tree
END
    print C <<END or confess "$!" foreach @tartrees;
parent $_->{Commit}
END
    print C <<END or confess "$!";
author $authline
committer $authline

$changes

[dgit import $treeimporthow $package $cversion]
END

    close C or confess "$!";
    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 = hash_commit_text(<<END);
tree $dappliedtree
author $authline
committer $authline

[dgit dummy commit]
END
	runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;

	runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;

	# We need the answers to be reproducible
	my @authline = clogp_authline($clogp);
	local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
	local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
	local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
	local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
	local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
	local $ENV{GIT_AUTHOR_DATE} =  $authline[2];

	my $path = $ENV{PATH} or die;

	# 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 $@;
		progress "warning: $@";
		$path = "$absurdity:$path";
		open T, ">../../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
		    or confess "$!";
	    }
	    eval {
		die "forbid absurd git-apply\n" if $use_absurd
		    && forceing [qw(import-gitapply-no-absurd)];
		die "only absurd git-apply!\n" if !$use_absurd
		    && forceing [qw(import-gitapply-absurd)];

		local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
		local $ENV{PATH} = $path                    if $use_absurd;

		if ($use_absurd) {
		    # We filter the series file, to contain only things
		    # that are actually requests to apply a patch.
		    #
		    # This is needed because sometimes a series file can
		    # contain strange things that gbp pq cannot cope with.
		    # Eg, form feeds.  See #1030093.
		    rename "debian/patches/series", "../series.orig"
		      or confess "$!";
		    open OS, "../series.orig" or confess $!;
		    open NS, ">debian/patches/series" or confess $!;
		    while (<OS>) {
			s/\#.*//;
			s/^\s+//;
			s/\s+$//;
			next unless m/\S/;
			print NS "$_\n" or confess $!;
		    }
		    confess $! if OS->error;
		    close NS or confess $!;
		    runcmd @git, qw(add debian/patches/series);
		    # This commit is spurious, but we must commit for gbp
		    # pq to work.  We filter it out of the branch later.
		    runcmd @git, qw(commit --quiet --allow-empty -m), <<END;
INTERNAL commit to launder series file

This commit should not escape into a public branch!
If you see it, this is due to a bug in dgit.

[dgit ($our_version) INTERNAL-quilt-fixup-series]
END
		}

		my @showcmd = (gbp_pq, qw(import));
		my @realcmd = shell_cmd
		    'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
		gbp_pq_pc_aside(sub {
		    debugcmd "+",@realcmd;
		    if (system @realcmd) {
			die f_ "%s failed: %s\n",
			    +(shellquote @showcmd),
			    failedcmd_waitstatus();
		    }
                });

		if ($use_absurd) {
		    # Perhaps we should be using git-filter-branch,
		    # but that's really considerably more awkward.
		    runcmd_quieten
		      @git, qw(rebase --keep-empty --allow-empty-message
			       --onto unpa~1 unpa);
		}

		my $gapplied = git_rev_parse('HEAD');
		my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
		$gappliedtree eq $dappliedtree or
		    fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
gbp-pq import and dpkg-source disagree!
 gbp-pq import gave commit %s
 gbp-pq import gave tree %s
 dpkg-source --before-build gave tree %s
END
		$rawimport_hash = $gapplied;

		if ($use_absurd) {
		    File::Copy::copy("../../absurd-apply-warnings", \*STDERR)
			or confess $!;
		}
	    };
	    last unless $@;
	}
	if ($@) {
	    { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
	    die $@;
	}
    }

    progress f_ "synthesised git commit from .dsc %s", $cversion;

    my $rawimport_mergeinput = {
        Commit => $rawimport_hash,
        Info => __ "Import of source package",
    };
    my @output = ($rawimport_mergeinput);

    if ($lastpush_mergeinput) {
	my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
	my $oversion = getfield $oldclogp, 'Version';
	my $vcmp =
	    version_compare($oversion, $cversion);
	if ($vcmp < 0) {
	    @output = ($rawimport_mergeinput, $lastpush_mergeinput,
		{ ReverseParents => 1,
		  # untranslated so that different people's pseudomerges
		  # are not needlessly different (although they will
		  # still differ if the series of pulls is different)
		  Message => (sprintf <<END, $package, $cversion, $csuite) });
Record %s (%s) in archive suite %s
END
	} elsif ($vcmp > 0) {
	    print STDERR f_ <<END, $cversion, $oversion,

Version actually in archive:   %s (older)
Last version pushed with dgit: %s (newer or same)
%s
END
		__ $later_warning_msg or confess "$!";
            @output = $lastpush_mergeinput;
        } else {
	    # Same version.  Use what's in the server git branch,
	    # discarding our own import.  (This could happen if the
	    # server automatically imports all packages into git.)
	    @output = $lastpush_mergeinput;
	}
    }
    changedir $maindir;
    rmdir_r $playground;
    return @output;
}

sub complete_file_from_dsc ($$;$$) {
    our ($dstdir, $fi, $refetched, $allow_404) = @_;
    # 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).
    #
    # Uses $fi->{Url} if it is defined; otherwise, sets it.
    #
    # Return value:
    # -1   we got HTTP 404 (with $allow_404 only)
    #  0   we didn't fetch the file because act_locak()
    #  1   the file was obtained (or reused) OK

    my $f = $fi->{Filename};
    my $tf = "$dstdir/$f";
    my $downloaded = 0;

    my $got;
    my $checkhash = sub {
	my ($tf) = @_;
	open F, "<", "$tf" or die "$tf: $!";
	$fi->{Digester}->reset();
	$fi->{Digester}->addfile(*F);
	F->error and confess "$!";
	$got = $fi->{Digester}->hexdigest();
	return $got eq $fi->{Hash};
    };

    if (stat_exists $tf) {
	if ($checkhash->($tf)) {
	    progress f_ "using existing %s", $f;
	    return 1;
	}
	if (!$refetched) {
	    fail f_ "file %s has hash %s but we need hash %s".
		    " (perhaps you should delete this file?)",
		    $f, $got, $fi->{Hash};
	}
	progress f_ "need to fetch correct version of %s", $f;
	unlink $tf or die "$tf $!";
	$$refetched = 1;
    } else {
	printdebug "$tf does not exist, need to fetch\n";
    }

    my $furl = $fi->{Url};
    if (!defined $furl) {
	$furl = $dscurl;
	$furl =~ s{/[^/]+$}{};
	$furl .= "/$f";
	die "$f ?" unless $f =~ m/^\Q${package}\E_/;
	die "$f ?" if $f =~ m#/#;
	$fi->{Url} = $furl;
    }

    open my $out, '>', "$tf.tmp" // confess "$tf.tmp: $!";
    my $found = url_fetch($furl,
              Ok404 => $allow_404,
	      CurlOpts => { CURLOPT_WRITEDATA() => $out });
    close $out or confess "$tf.tmp: $!";
    return -1 if !$found;
    return 0 if !act_local();

    $checkhash->("$tf.tmp") or
	fail f_ "file %s has hash %s but we need hash %s".
	        " (got wrong file from archive!)",
		$f, $got, $fi->{Hash};
        # In this exit path, we leave the .tmp file around, for debugging.

    rename "$tf.tmp", "$tf" or confess "$tf: $!";

    return 1;
}

sub ensure_we_have_orig () {
    my @dfi = dsc_files_info();
    foreach my $fi (@dfi) {
	my $f = $fi->{Filename};
	next unless is_orig_file_in_dsc($f, \@dfi);
	complete_file_from_dsc($buildproductsdir, $fi);
    }
}

#---------- git fetch ----------

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 *,
    # it does a plausible thing.  If there is no * then:
    # - it matches subpaths too, even if the supplied refspec
    #   starts refs, and behaves completely madly if the source
    #   has refs/refs/something.  (See, for example, Debian #NNNN.)
    # - if there is no matching remote ref, it bombs out the whole
    #   fetch.
    # We want to fetch a fixed ref, and we don't know in advance
    # if it exists, so this is not suitable.
    #
    # Our workaround is to use git ls-remote.  git ls-remote has its
    # own qairks.  Notably, it has the absurd multi-tail-matching
    # behaviour: git ls-remote R refs/foo can report refs/foo AND
    # refs/refs/foo etc.
    #
    # Also, we want an idempotent snapshot, but we have to make two
    # calls to the remote: one to git ls-remote and to git fetch.  The
    # solution is use git ls-remote to obtain a target state, and
    # git fetch to try to generate it.  If we don't manage to generate
    # the target state, we try again.

    printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";

    my $specre = join '|', map {
	my $x = $_;
	$x =~ s/\W/\\$&/g;
	my $wildcard = $x =~ s/\\\*$/.*/;
	die if $wildcard && $supplementary;
	"(?:refs/$x)";
    } @specs;
    printdebug "git_lrfetch_sane specre=$specre\n";
    my $wanted_rref = sub {
	local ($_) = @_;
	return m/^(?:$specre)$/;
    };

    my $fetch_iteration = 0;
    FETCH_ITERATION:
    for (;;) {
	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), $url, @look);
	debugcmd "|",@lcmd;

	my %wantr;
	open GITLS, "-|", @lcmd or confess "$!";
	while (<GITLS>) {
	    printdebug "=> ", $_;
	    m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
	    my ($objid,$rrefname) = ($1,$2);
	    if (!$wanted_rref->($rrefname)) {
		print STDERR f_ <<END, "@look", $rrefname;
warning: git ls-remote %s reported %s; this is silly, ignoring it.
END
		next;
	    }
	    $wantr{$rrefname} = $objid;
	}
	$!=0; $?=0;
	close GITLS or failedcmd @lcmd;

	# OK, now %want is exactly what we want for refs in @specs
	my @fspecs = map {
	    !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
	    "+refs/$_:".lrfetchrefs."/$_";
	} @specs;

	printdebug "git_lrfetch_sane fspecs @fspecs\n";

	my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
	runcmd_ordryrun_local @fcmd if @fspecs;

	if (!$supplementary) {
	    %lrfetchrefs_f = ();
	}
	my %objgot;

	git_for_each_ref(lrfetchrefs, sub {
	    my ($objid,$objtype,$lrefname,$reftail) = @_;
	    $lrfetchrefs_f{$lrefname} = $objid;
	    $objgot{$objid} = 1;
	});

	if ($supplementary) {
	    last;
	}

	foreach my $lrefname (sort keys %lrfetchrefs_f) {
	    my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
	    if (!exists $wantr{$rrefname}) {
		if ($wanted_rref->($rrefname)) {
		    printdebug <<END;
git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
END
		} else {
		    print STDERR f_ <<END, "@fspecs", $lrefname
warning: git fetch %s created %s; this is silly, deleting it.
END
		}
		runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
		delete $lrfetchrefs_f{$lrefname};
		next;
	    }
	}
	foreach my $rrefname (sort keys %wantr) {
	    my $lrefname = lrfetchrefs.substr($rrefname, 4);
	    my $got = $lrfetchrefs_f{$lrefname} // '<none>';
	    my $want = $wantr{$rrefname};
	    next if $got eq $want;
	    if (!defined $objgot{$want}) {
		fail f_ <<END, $rrefname unless act_local();
--dry-run specified but we actually wanted the results of git fetch,
so this is not going to work.  Try running dgit fetch first,
or using --damp-run instead of --dry-run.  (Wanted: %s.)
END
		print STDERR f_ <<END, $lrefname, $want;
warning: git ls-remote suggests we want %s
warning:  and it should refer to %s
warning:  but git fetch didn't fetch that object to any relevant ref.
warning:  This may be due to a race with someone updating the server.
warning:  Will try again...
END
		next FETCH_ITERATION;
	    }
	    printdebug <<END;
git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
END
	    runcmd_ordryrun_local @git, qw(update-ref -m),
		"dgit fetch git fetch fixup", $lrefname, $want;
	    $lrfetchrefs_f{$lrefname} = $want;
	}
	last;
    }

    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/$_" } 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);

    git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
	my ($objid,$objtype,$fullrefname,$reftail) = @_;
	printdebug "currently $fullrefname=$objid\n";
	$here{$fullrefname} = $objid;
    });
    git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
	my ($objid,$objtype,$fullrefname,$reftail) = @_;
	my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
	printdebug "offered $lref=$objid\n";
	if (!defined $here{$lref}) {
	    my @upd = (@git, qw(update-ref), $lref, $objid, '');
	    runcmd_ordryrun_local @upd;
	    lrfetchref_used $fullrefname;
	} elsif ($here{$lref} eq $objid) {
	    lrfetchref_used $fullrefname;
	} else {
	    print STDERR f_ "Not updating %s from %s to %s.\n",
		            $lref, $here{$lref}, $objid;
	}
    });
}

#---------- dsc and archive handling ----------

sub mergeinfo_getclogp ($) {
    # Ensures thit $mi->{Clogp} exists and returns it
    my ($mi) = @_;
    $mi->{Clogp} = commit_getclogp($mi->{Commit});
}

sub mergeinfo_version ($) {
    return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
}

sub fetch_from_archive_record_1 ($) {
    my ($hash) = @_;
    runcmd git_update_ref_cmd "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_update_ref_cmd '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 f_ "%s: NO git hash", $what;
	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 f_ "%s: specified git info (%s)", $what, $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 f_ "%s: specified git hash", $what;
    } else {
	fail f_ "%s: invalid Dgit info", $what;
    }
}

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 f_ "not chasing .dsc distro %s: not fetching %s",
		        $dsc_distro, $what;
	    return 0;
	}

	progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;

	my $url = access_giturl();
	if (!defined $url) {
	    defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
.dsc Dgit metadata is in context of distro %s
for which we have no configured url and .dsc provides no hint
END
	    my $proto =
		$dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
		$dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
	    parse_cfg_bool "dsc-url-proto-ok", 'false',
		cfg("dgit.dsc-url-proto-ok.$proto",
		    "dgit.default.dsc-url-proto-ok")
		or fail f_ <<END, $dsc_distro, $proto;
.dsc Dgit metadata is in context of distro %s
for which we have no configured url;
.dsc provides hinted url with protocol %s which is unsafe.
(can be overridden by config - consult documentation)
END
	    $url = $dsc_hint_url;
	}

	git_lrfetch_sane $url, 1, @fetch;

	return $lrf;
    };

    my $rewrite_enable = do {
	local $idistro = $dsc_distro;
	access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
    };

    if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
	if (!defined $mapref) {
	    my $lrf = $do_fetch->((__ "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 f_ <<END, $dsc_hash;
.dsc Dgit metadata requires commit %s
but we could not obtain that object anywhere.
END
	foreach my $t (@tags) {
	    my $fullrefname = $lrf.'/'.$t;
#	    print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
	    next unless $lrfetchrefs_f{$fullrefname};
	    next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
	    lrfetchref_used $fullrefname;
	}
    }
}

sub fetch_from_archive () {
    check_bpd_exists();
    ensure_setup_existing_tree();

    # Ensures that lrref() is what is actually in the archive, one way
    # or another, according to us - ie this client's
    # appropritaely-updated archive view.  Also returns the commit id.
    # If there is nothing in the archive, leaves lrref alone and
    # returns undef.  git_fetch_us must have already been called.
    get_archive_dsc();

    if ($dsc) {
	parse_dsc_field($dsc, __ 'last upload to archive');
	resolve_dsc_field_commit access_basedistro,
	    lrfetchrefs."/".$rewritemap
    } else {
	progress __ "no version available from the archive";
    }

    # If the archive's .dsc has a Dgit field, there are three
    # relevant git commitids we need to choose between and/or merge
    # together:
    #   1. $dsc_hash: the Dgit field from the archive
    #   2. $lastpush_hash: the suite branch on the dgit git server
    #   3. $lastfetch_hash: our local tracking branch for the suite
    #
    # These may all be distinct and need not be in any fast forward
    # relationship:
    #
    # If the dsc was pushed to this suite, then the server suite
    # branch will have been updated; but it might have been pushed to
    # a different suite and copied by the archive.  Conversely a more
    # recent version may have been pushed with dgit but not appeared
    # in the archive (yet).
    #
    # $lastfetch_hash may be awkward because archive imports
    # (particularly, imports of Dgit-less .dscs) are performed only as
    # needed on individual clients, so different clients may perform a
    # different subset of them - and these imports are only made
    # public during push.  So $lastfetch_hash may represent a set of
    # imports different to a subsequent upload by a different dgit
    # client.
    #
    # Our approach is as follows:
    #
    # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
    # descendant of $dsc_hash, then it was pushed by a dgit user who
    # had based their work on $dsc_hash, so we should prefer it.
    # Otherwise, $dsc_hash was installed into this suite in the
    # archive other than by a dgit push, and (necessarily) after the
    # last dgit push into that suite (since a dgit push would have
    # been descended from the dgit server git branch); thus, in that
    # case, we prefer the archive's version (and produce a
    # pseudo-merge to overwrite the dgit server git branch).
    #
    # (If there is no Dgit field in the archive's .dsc then
    # generate_commit_from_dsc uses the version numbers to decide
    # whether the suite branch or the archive is newer.  If the suite
    # branch is newer it ignores the archive's .dsc; otherwise it
    # generates an import of the .dsc, and produces a pseudo-merge to
    # overwrite the suite branch with the archive contents.)
    #
    # The outcome of that part of the algorithm is the `public view',
    # and is same for all dgit clients: it does not depend on any
    # unpublished history in the local tracking branch.
    #
    # As between the public view and the local tracking branch: The
    # local tracking branch is only updated by dgit fetch, and
    # whenever dgit fetch runs it includes the public view in the
    # local tracking branch.  Therefore if the public view is not
    # descended from the local tracking branch, the local tracking
    # branch must contain history which was imported from the archive
    # but never pushed; and, its tip is now out of date.  So, we make
    # a pseudo-merge to overwrite the old imports and stitch the old
    # history in.
    #
    # Finally: we do not necessarily reify the public view (as
    # described above).  This is so that we do not end up stacking two
    # pseudo-merges.  So what we actually do is figure out the inputs
    # to any public view pseudo-merge and put them in @mergeinputs.

    my @mergeinputs;
    # $mergeinputs[]{Commit}
    # $mergeinputs[]{Info}
    # $mergeinputs[0] is the one whose tree we use
    # @mergeinputs is in the order we use in the actual commit)
    #
    # Also:
    # $mergeinputs[]{Message} is a commit message to use
    # $mergeinputs[]{ReverseParents} if def specifies that parent
    #                                list should be in opposite order
    # Such an entry has no Commit or Info.  It applies only when found
    # in the last entry.  (This ugliness is to support making
    # identical imports to previous dgit versions.)

    my $lastpush_hash = git_get_ref(lrfetchref());
    printdebug "previous reference hash=$lastpush_hash\n";
    $lastpush_mergeinput = $lastpush_hash && {
        Commit => $lastpush_hash,
	Info => (__ "dgit suite branch on dgit git server"),
    };

    my $lastfetch_hash = git_get_ref(lrref());
    printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
    my $lastfetch_mergeinput = $lastfetch_hash && {
	Commit => $lastfetch_hash,
	Info => (__ "dgit client's archive history view"),
    };

    my $dsc_mergeinput = $dsc_hash && {
        Commit => $dsc_hash,
        Info => (__ "Dgit field in .dsc from archive"),
    };

    my $cwd = getcwd();
    my $del_lrfetchrefs = sub {
	changedir $cwd;
	my $gur;
	printdebug "del_lrfetchrefs...\n";
	foreach my $fullrefname (sort keys %lrfetchrefs_d) {
	    my $objid = $lrfetchrefs_d{$fullrefname};
	    printdebug "del_lrfetchrefs: $objid $fullrefname\n";
	    if (!$gur) {
		$gur ||= new IO::Handle;
		open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
	    }
	    printf $gur "delete %s %s\n", $fullrefname, $objid;
	}
	if ($gur) {
	    close $gur or failedcmd "git update-ref delete lrfetchrefs";
	}
    };

    if (defined $dsc_hash) {
	ensure_we_have_orig();
	if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
	    @mergeinputs = $dsc_mergeinput
	} elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
	    print STDERR f_ <<END, $dsc_hash, $lastpush_hash,

Git commit in archive is behind the last version allegedly pushed/uploaded.
Commit referred to by archive: %s
Last version pushed with dgit: %s
%s
END
		__ $later_warning_msg or confess "$!";
	    @mergeinputs = ($lastpush_mergeinput);
	} else {
	    # Archive has .dsc which is not a descendant of the last dgit
	    # push.  This can happen if the archive moves .dscs about.
	    # Just follow its lead.
	    if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
		progress __ "archive .dsc names newer git commit";
		@mergeinputs = ($dsc_mergeinput);
	    } else {
		progress __ "archive .dsc names other git commit, fixing up";
		@mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
	    }
	}
    } elsif ($dsc) {
	@mergeinputs = generate_commits_from_dsc();
	# We have just done an import.  Now, our import algorithm might
	# have been improved.  But even so we do not want to generate
	# a new different import of the same package.  So if the
	# version numbers are the same, just use our existing version.
	# If the version numbers are different, the archive has changed
	# (perhaps, rewound).
	if ($lastfetch_mergeinput &&
	    !version_compare( (mergeinfo_version $lastfetch_mergeinput),
			      (mergeinfo_version $mergeinputs[0]) )) {
	  @mergeinputs = ($lastfetch_mergeinput);
	}
    } elsif ($lastpush_hash) {
	# only in git, not in the archive yet
	@mergeinputs = ($lastpush_mergeinput);
	print STDERR f_ <<END,

Package not found in the archive, but has allegedly been pushed using dgit.
%s
END
	    __ $later_warning_msg or confess "$!";
    } else {
	printdebug "nothing found!\n";
	if (defined $skew_warning_vsn) {
	    print STDERR f_ <<END, $skew_warning_vsn or confess "$!";

Warning: relevant archive skew detected.
Archive allegedly contains %s
But we were not able to obtain any version from the archive or git.

END
	}
	unshift @end, $del_lrfetchrefs;
	return undef;
    }

    if ($lastfetch_hash &&
	!grep {
	    my $h = $_->{Commit};
	    $h and is_fast_fwd($lastfetch_hash, $h);
	    # If true, one of the existing parents of this commit
	    # is a descendant of the $lastfetch_hash, so we'll
	    # be ff from that automatically.
	} @mergeinputs
        ) {
	# Otherwise:
	push @mergeinputs, $lastfetch_mergeinput;
    }

    printdebug "fetch mergeinfos:\n";
    foreach my $mi (@mergeinputs) {
	if ($mi->{Info}) {
	    printdebug " commit $mi->{Commit} $mi->{Info}\n";
	} else {
	    printdebug sprintf " ReverseParents=%d Message=%s",
		$mi->{ReverseParents}, $mi->{Message};
	}
    }

    my $compat_info= pop @mergeinputs
	if $mergeinputs[$#mergeinputs]{Message};

    @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;

    my $hash;
    if (@mergeinputs > 1) {
	# here we go, then:
	my $tree_commit = $mergeinputs[0]{Commit};

	my $tree = get_tree_of_commit $tree_commit;;

	# We use the changelog author of the package in question the
	# author of this pseudo-merge.  This is (roughly) correct if
	# this commit is simply representing aa non-dgit upload.
	# (Roughly because it does not record sponsorship - but we
	# don't have sponsorship info because that's in the .changes,
	# which isn't in the archivw.)
	#
	# But, it might be that we are representing archive history
	# updates (including in-archive copies).  These are not really
	# the responsibility of the person who created the .dsc, but
	# there is no-one whose name we should better use.  (The
	# author of the .dsc-named commit is clearly worse.)

	my $useclogp = mergeinfo_getclogp $mergeinputs[0];
	my $author = clogp_authline $useclogp;
	my $cversion = getfield $useclogp, 'Version';

	my $mcf = dgit_privdir()."/mergecommit";
	open MC, ">", $mcf or die "$mcf $!";
	print MC <<END or confess "$!";
tree $tree
END

	my @parents = grep { $_->{Commit} } @mergeinputs;
	@parents = reverse @parents if $compat_info->{ReverseParents};
	print MC <<END or confess "$!" foreach @parents;
parent $_->{Commit}
END

	print MC <<END or confess "$!";
author $author
committer $author

END

	if (defined $compat_info->{Message}) {
	    print MC $compat_info->{Message} or confess "$!";
	} else {
	    print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
Record %s (%s) in archive suite %s

Record that
END
	    my $message_add_info = sub {
		my ($mi) = (@_);
		my $mversion = mergeinfo_version $mi;
		printf MC "  %-20s %s\n", $mversion, $mi->{Info}
		    or confess "$!";
	    };

	    $message_add_info->($mergeinputs[0]);
	    print MC __ <<END or confess "$!";
should be treated as descended from
END
	    $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
	}

	close MC or confess "$!";
	$hash = hash_commit $mcf;
    } else {
	$hash = $mergeinputs[0]{Commit};
    }
    printdebug "fetch hash=$hash\n";

    my $chkff = sub {
	my ($lasth, $what) = @_;
	return unless $lasth;
	confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
    };

    $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
	if $lastpush_hash;
    $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');

    fetch_from_archive_record_1($hash);

    if (defined $skew_warning_vsn) {
	printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
	my $gotclogp = commit_getclogp($hash);
	my $got_vsn = getfield $gotclogp, 'Version';
	printdebug "SKEW CHECK GOT $got_vsn\n";
	if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
	    print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";

Warning: archive skew detected.  Using the available version:
Archive allegedly contains    %s
We were able to obtain only   %s

END
	}
    }

    if ($lastfetch_hash ne $hash) {
	fetch_from_archive_record_2($hash);
    }

    lrfetchref_used lrfetchref();

    check_gitattrs($hash, __ "fetched source tree");

    unshift @end, $del_lrfetchrefs;
    return $hash;
}

sub set_local_git_config ($$) {
    my ($k, $v) = @_;
    runcmd @git, qw(config), $k, $v;
}

sub setup_mergechangelogs (;$) {
    my ($always) = @_;
    return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');

    my $driver = 'dpkg-mergechangelogs';
    my $cb = "merge.$driver";
    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) {
	$!==ENOENT or die "$attrs: $!";
    } else {
	while (<ATTRS>) {
	    chomp;
	    next if m{^debian/changelog\s};
	    print NATTRS $_, "\n" or confess "$!";
	}
	ATTRS->error and confess "$!";
	close ATTRS;
    }
    print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
    close NATTRS;

    set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
    set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';

    rename "$attrs.new", "$attrs" or die "$attrs: $!";
}

sub setup_useremail (;$) {
    my ($always) = @_;
    return unless $always || access_cfg_bool(1, 'setup-useremail');

    my $setup = sub {
	my ($k, $envvar) = @_;
	my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
	return unless defined $v;
	set_local_git_config "user.$k", $v;
    };

    $setup->('email', 'DEBEMAIL');
    $setup->('name', 'DEBFULLNAME');
}

sub ensure_setup_existing_tree () {
    my $k = "remote.$remotename.skipdefaultupdate";
    my $c = git_get_config $k;
    return if defined $c;
    set_local_git_config $k, 'true';
}

sub 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;
}

our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};

sub is_gitattrs_setup () {
    # return values:
    #  trueish
    #     1: gitattributes set up and should be left alone
    #  falseish
    #     0: there is a dgit-defuse-attrs but it needs fixing
    #     undef: there is none
    my $gai = open_main_gitattrs();
    return undef unless $gai;
    while (<$gai>) {
	next unless m{$gitattrs_ourmacro_re};
	return 1 if m{\s-working-tree-encoding\s};
	printdebug "is_gitattrs_setup: found old macro\n";
	return 0;
    }
    $gai->error and confess "$!";
    printdebug "is_gitattrs_setup: found nothing\n";
    return undef;
}    

sub setup_gitattrs (;$) {
    my ($always) = @_;
    return unless $always || access_cfg_bool(1, 'setup-gitattributes');

    my $already = is_gitattrs_setup();
    if ($already) {
	progress __ <<END;
[attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
 not doing further gitattributes setup
END
	return;
    }
    my $new = "[attr]dgit-defuse-attrs	$negate_harmful_gitattrs";
    my $af = "$maindir_gitcommon/info/attributes";
    ensuredir "$maindir_gitcommon/info";

    open GAO, "> $af.new" or confess "$!";
    print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
*	dgit-defuse-attrs
$new
END
# ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
ENDT
    my $gai = open_main_gitattrs();
    if ($gai) {
	while (<$gai>) {
	    if (m{$gitattrs_ourmacro_re}) {
		die unless defined $already;
		$_ = $new;
	    }
	    chomp;
	    print GAO $_, "\n" or confess "$!";
	}
	$gai->error and confess "$!";
    }
    close GAO or confess "$!";
    rename "$af.new", "$af" or fail f_ "install %s: %s", $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 confess "$!";
    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 f_ <<END, $what;
dgit: warning: %s contains .gitattributes
dgit: .gitattributes not (fully) defused.  Recommended: dgit setup-new-tree.
END
	close $gafl;
	return;
    }
    # tree contains no .gitattributes files
    $?=0; $!=0; close $gafl or failedcmd @cmd;
}


sub multisuite_suite_child ($$$) {
    my ($tsuite, $mergeinputs, $fn) = @_;
    # in child, sets things up, calls $fn->(), and returns undef
    # in parent, returns canonical suite name for $tsuite
    my $canonsuitefh = IO::File::new_tmpfile;
    my $pid = fork // confess "$!";
    if (!$pid) {
	forkcheck_setup();
	$isuite = $tsuite;
	$us .= " [$isuite]";
	$debugprefix .= " ";
	progress f_ "fetching %s...", $tsuite;
	canonicalise_suite();
	print $canonsuitefh $csuite, "\n" or confess "$!";
	close $canonsuitefh or confess "$!";
	$fn->();
	return undef;
    }
    waitpid $pid,0 == $pid or confess "$!";
    fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
	if $? && $?!=256*4;
    seek $canonsuitefh,0,0 or confess "$!";
    local $csuite = <$canonsuitefh>;
    confess "$!" unless defined $csuite && chomp $csuite;
    if ($? == 256*4) {
	printdebug "multisuite $tsuite missing\n";
	return $csuite;
    }
    printdebug "multisuite $tsuite ok (canon=$csuite)\n";
    push @$mergeinputs, {
        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 f_ "package %s missing in (base suite) %s", $package, $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_one();
	    finish 0;
	});

	$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 = f_ "Combine archive branches %s [dgit]\n\n".
	             "Input branches:\n",
		     $csuite;

	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";
	$msg .=
	    "[dgit multi-suite $csuite]\n";
	$commit .=
	    "author $authline\n".
	    "committer $authline\n\n";
	$output = hash_commit_text $commit.$msg;
	printdebug "multisuite merge generated $output\n";
    }

    fetch_from_archive_record_1($output);
    fetch_from_archive_record_2($output);

    progress f_ "calculated combined tracking suite %s", $csuite;

    return 1;
}

sub clone_set_head () {
    open H, "> .git/HEAD" or confess "$!";
    print H "ref: ".lref()."\n" or confess "$!";
    close H or confess "$!";
}
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 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,
    # and then again in child after everything is finished
    my ($dstdir) = @_;
    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";

    mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
    changedir $dstdir;
    check_bpd_exists();

    canonicalise_suite();
    my $hasgit = check_for_git();

    runcmd @git, qw(init -q);
    record_maindir();
    setup_new_tree();
    clone_set_head();
    if ($hasgit) {
	progress __ "fetching existing git history";
	git_fetch_us();
    } else {
	progress __ "starting new git history";
    }
    fetch_from_archive() or no_such_package;
    my $vcsgiturl = vcs_git_url_of_ctrl $dsc;
    if (length $vcsgiturl) {
	runcmd @git, qw(remote add vcs-git), $vcsgiturl;
    }
    clone_finish($dstdir);
}

sub fetch_one () {
    canonicalise_suite();
    if (check_for_git()) {
	git_fetch_us();
    }
    fetch_from_archive() or no_such_package();
    
    my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
    if (length $vcsgiturl and
	(grep { $csuite eq $_ }
	 split /\;/,
	 cfg 'dgit.vcs-git.suites')) {
	my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
	if (defined $current && $current ne $vcsgiturl) {
	    print STDERR f_ <<END, $csuite;
FYI: Vcs-Git in %s has different url to your vcs-git remote.
 Your vcs-git remote url may be out of date.  Use dgit update-vcs-git ?
END
	}
    }
    printdone f_ "fetched into %s", lrref();
}

sub dofetch () {
    my $multi_fetched = fork_for_multisuite(sub { });
    fetch_one() unless $multi_fetched; # parent
    finish 0 if $multi_fetched eq '0'; # child
}

sub pull () {
    dofetch();
    my @cmd = (@git, qw(merge));
    push @cmd, qw(--allow-unrelated-histories) if $allow_unrelated_histories;
    push @cmd, qw(-m), (f_ "Merge from %s [dgit]", $csuite), lrref();
    runcmd_ordryrun_local @cmd;
    printdone f_ "fetched to %s and merged into HEAD", lrref();
}

sub check_not_dirty () {
    my @forbid = qw(local-options local-patch-header);
    @forbid = map { "debian/source/$_" } @forbid;
    foreach my $f (@forbid) {
	if (stat_exists $f) {
	    fail f_ "git tree contains %s", $f;
	}
    }

    my @cmd = (@git, qw(status -uall --ignored --porcelain));
    push @cmd, qw(debian/source/format debian/source/options);
    push @cmd, @forbid;

    my $bad = cmdoutput @cmd;
    if (length $bad) {
	fail +(__
 "you have uncommitted changes to critical files, cannot continue:\n").
              $bad;
    }

    return if $includedirty;

    git_check_unmodified();
}

sub commit_admin ($) {
    my ($m) = @_;
    progress "$m";
    runcmd_ordryrun_local @git, qw(commit -m), $m;
}

sub quiltify_nofix_bail ($$) {
    my ($headinfo, $xinfo) = @_;
    if ($quilt_mode eq 'nofix') {
	fail f_
	    "quilt fixup required but quilt mode is \`nofix'\n".
	    "HEAD commit%s differs from tree implied by debian/patches%s",
	    $headinfo, $xinfo;
    }
}

sub commit_quilty_patch () {
    my $output = cmdoutput @git, qw(status --ignored --porcelain);
    my %adds;
    foreach my $l (split /\n/, $output) {
	next unless $l =~ m/\S/;
	if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
	    $adds{$1}++;
	}
    }
    delete $adds{'.pc'}; # if there wasn't one before, don't add it
    if (!%adds) {
	progress __ "nothing quilty to commit, ok.";
	return;
    }
    quiltify_nofix_bail "", __ " (wanted to commit patch update)";
    my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
    runcmd_ordryrun_local @git, qw(add -f), @adds;
    commit_admin +(__ <<ENDT).<<END
Commit Debian 3.0 (quilt) metadata

ENDT
[dgit ($our_version) quilt-fixup]
END
}

sub get_source_format () {
    my @options;
    if (open F, "debian/source/options") {
	while (<F>) {
	    next if m/^\s*\#/;
	    next unless m/\S/;
	    s/\s+$//; # ignore missing final newline
	    push @options, $_;
	}
	F->error and confess "$!";
	close F;
    } else {
	confess "$!" unless $!==&ENOENT;
    }

    if (!open F, "debian/source/format") {
	confess "$!" unless $!==&ENOENT;
	return '';
    }
    $_ = <F>;
    F->error and confess "$!";
    close F;
    chomp;
    return wantarray ? ($_, \@options) : $_;
}

sub madformat_wantfixup ($) {
    my ($format) = @_;
    return 0 unless $format eq '3.0 (quilt)';
    our $quilt_mode_warned;
    if ($quilt_mode eq 'nocheck') {
	progress f_ "Not doing any fixup of \`%s'".
	    " due to ----no-quilt-fixup or --quilt=nocheck", $format
	    unless $quilt_mode_warned++;
	return 0;
    }
    progress f_ "Format \`%s', need to check/update patch stack", $format
	unless $quilt_mode_warned++;
    return 1;
}

sub maybe_split_brain_save ($$$) {
    my ($headref, $dgitview, $msg) = @_;
    # => message fragment "$saved" describing disposition of $dgitview
    #    (used inside parens, in the English texts)
    $dgitview_saved = $dgitview;
    my $save = $internal_object_save{'dgit-view'};
    return f_ "commit id %s", $dgitview unless defined $save;
    my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
	       git_update_ref_cmd
	       "dgit --dgit-view-save $msg HEAD=$headref",
	       $save, $dgitview);
    runcmd @cmd;
    return f_ "and left in %s", $save;
}

# An "infopair" is a tuple [ $thing, $what ]
# (often $thing is a commit hash; $what is a description)

sub infopair_cond_equal ($$) {
    my ($x,$y) = @_;
    $x->[0] eq $y->[0] or fail <<END;
$x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
END
};

sub infopair_lrf_tag_lookup ($$) {
    my ($tagnames, $what) = @_;
    # $tagname may be an array ref
    my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
    printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
    foreach my $tagname (@tagnames) {
	my $lrefname = lrfetchrefs."/tags/$tagname";
	my $tagobj = $lrfetchrefs_f{$lrefname};
	next unless defined $tagobj;
	printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
	return [ git_rev_parse($tagobj), $what ];
    }
    fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
Wanted tag %s (%s) on dgit server, but not found
END
	              : (f_ <<END, $what, "@tagnames");
Wanted tag %s (one of: %s) on dgit server, but not found
END
}

sub infopair_cond_ff ($$) {
    my ($anc,$desc) = @_;
    is_fast_fwd($anc->[0], $desc->[0]) or
	fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
%s (%s) .. %s (%s) is not fast forward
END
};

sub pseudomerge_version_check ($$) {
    my ($clogp, $archive_hash) = @_;

    my $arch_clogp = commit_getclogp $archive_hash;
    my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
		     __ 'version currently in archive' ];
    if (defined $overwrite_version) {
	if (length $overwrite_version) {
	    infopair_cond_equal([ $overwrite_version,
				  '--overwrite= version' ],
				$i_arch_v);
	} else {
	    my $v = $i_arch_v->[0];
	    progress f_
		"Checking package changelog for archive version %s ...", $v;
	    my $cd;
            my $vclogp;
	    eval {
		my @xa = ("-f$v", "-t$v");
		$vclogp = parsechangelog @xa;
		my $gf = sub {
		    my ($fn) = @_;
		    [ (getfield $vclogp, $fn),
		      (f_ "%s field from dpkg-parsechangelog %s",
		          $fn, "@xa") ];
		};
		my $cv = $gf->('Version');
		infopair_cond_equal($i_arch_v, $cv);
		$cd = $gf->('Distribution');
	    };
	    if ($@) {
                $@ =~ s/^\n//s;
		$@ =~ s/^dgit: //gm;
		fail "$@".
		    f_ "Perhaps debian/changelog does not mention %s ?", $v;
	    }
	    fail f_ <<END, $cd->[1], $cd->[0], $v
%s is %s
Your tree seems to based on earlier (not uploaded) %s.
END
		if $cd->[0] =~ m/UNRELEASED/;
	    fail f_ <<END, $v, $v
d/changelog entry for %s is unfinalised!
Your tree seems to based on earlier (not uploaded) %s.
END
		unless defined $vclogp->{Date};
	}
    }
    
    printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
    return $i_arch_v;
}

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...",
	         $i_arch_v->[0];

    my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
    my $authline = clogp_authline $clogp;

    chomp $msg_msg;
    $msg_cmd .=
	!defined $overwrite_version ? ""
	: !length  $overwrite_version ? " --overwrite"
	: " --overwrite=".$overwrite_version;

    # Contributing parent is the first parent - that makes
    # git rev-list --first-parent DTRT.
    my $pmf = dgit_privdir()."/pseudomerge";
    open MC, ">", $pmf or die "$pmf $!";
    print MC <<END or confess "$!";
tree $tree
parent $dgitview
parent $archive_hash
author $authline
committer $authline

$msg_msg

[$msg_cmd]
END
    close MC or confess "$!";

    return hash_commit($pmf);
}

sub splitbrain_pseudomerge ($$$$) {
    my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
    # => $merged_dgitview
    printdebug "splitbrain_pseudomerge...\n";
    #
    #     We:      debian/PREVIOUS    HEAD($maintview)
    # expect:          o ----------------- o
    #                    \                   \
    #                     o                   o
    #                 a/d/PREVIOUS        $dgitview
    #                $archive_hash              \
    #  If so,                \                   \
    #  we do:                 `------------------ o
    #   this:                                   $dgitview'
    #

    return $dgitview unless defined $archive_hash;
    return $dgitview if deliberately_not_fast_forward();

    printdebug "splitbrain_pseudomerge...\n";

    my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);

    if (!defined $overwrite_version) {
	progress __ "Checking that HEAD includes all changes in archive...";
    }

    return $dgitview if is_fast_fwd $archive_hash, $dgitview;

    if (defined $overwrite_version) {
    } elsif (!eval {
	my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
	my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
					      __ "maintainer view tag");
	my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
	my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
	my $i_archive = [ $archive_hash, __ "current archive contents" ];

	printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";

	infopair_cond_equal($i_dgit, $i_archive);
	infopair_cond_ff($i_dep14, $i_dgit);
	infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
	1;
    }) {
        $@ =~ s/^\n//; chomp $@;
	print STDERR <<END.(__ <<ENDT);
$@
END
| Not fast forward; maybe --trust-changelog is needed ?  Please see dgit(1).
ENDT
	finish -1;
    }

    my $arch_v = $i_arch_v->[0];
    my $r = pseudomerge_hash_commit
	$clogp, $dgitview, $archive_hash, $i_arch_v,
	"dgit --quilt=$quilt_mode",
	(defined $overwrite_version
	 ? f_ "Declare fast forward from %s\n", $arch_v
	 : f_ "Make fast forward from %s\n",    $arch_v);

    maybe_split_brain_save $maintview, $r, "pseudomerge";

    progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
    return $r;
}	

sub plain_overwrite_pseudomerge ($$$) {
    my ($clogp, $head, $archive_hash) = @_;

    printdebug "plain_overwrite_pseudomerge...";

    my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);

    return $head if is_fast_fwd $archive_hash, $head;

    my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];

    my $r = pseudomerge_hash_commit
	$clogp, $head, $archive_hash, $i_arch_v,
	"dgit", $m;

    runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;

    progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
    return $r;
}


our %expected = ( Source => \$package,
		  Distribution => \$expected_suite,
		  Version => \$expected_version );

sub check_expected {
    my ($c, $desc) = @_;
    for (sort keys %expected) {
	my $v = getfield($c, $_); # assert field indeed present
	not defined ${$expected{$_}}
	  or $v eq ${$expected{$_}}
	  or fail f_ "%s field \`%s' is not expected \`%s'",
	  $desc, $_, ${$expected{$_}}
      }
}

sub push_parse_changelog ($) {
    my ($clogpfn) = @_;

    my $clogp = Dpkg::Control::Hash->new();
    $clogp->load($clogpfn) or die;

    check_expected($clogp, "changelog");
    $package //= getfield $clogp, 'Source';
    my $cversion = getfield $clogp, 'Version';

    if (!$we_are_initiator) {
	# rpush initiator can't do this because it doesn't have $isuite yet
	my $tag = debiantag_new($cversion, access_nomdistro);
	runcmd @git, qw(check-ref-format), $tag;
    }

    my $dscfn = dscfn($cversion);

    return ($clogp, $cversion, $dscfn);
}

sub push_parse_dsc ($$$) {
    my ($dscfn,$dscfnwhat, $cversion) = @_;
    $dsc = parsecontrol($dscfn,$dscfnwhat);
    my $dversion = getfield $dsc, 'Version';
    my $dscpackage = getfield $dsc, 'Source';
    ($dscpackage eq $package && $dversion eq $cversion) or
	fail f_ "%s is for %s %s but debian/changelog is for %s %s",
		$dscfn, $dscpackage, $dversion,
			$package,    $cversion;
}

sub dep14tag_reuse_tag_adjust_tagwants ($$) {
    # Adjusts the $tagwant->[] with {Dep14}, as necessary
    my ($cversion, $tagwants) = @_;

    my @adjust = grep { $_->{Dep14} } @$tagwants;
    return unless @adjust;
    confess unless @adjust == 1;

    my ($tw) = @adjust;

    printdebug "considering DEP-14 tag $tw->{Tag} reuse (--dep14tag-reuse=$dep14tag_reuse)\n";

    if ($we_are_initiator) {
	$tw->{ReuseExisting}  = !($i_param{'dep14tag'} // 1);
	printdebug sprintf "DEP-14: we are initiator, param %s, reuse %s\n",
	  ($i_param{'dep14tag'} // '<unset>'), 
	  ($tw->{ReuseExisting} // '<unset>');
	return;
    }

    # modes: must, if-exists, replace-unsuitable, replace
    # tag: might exist

    if ($dep14tag_reuse eq 'replace') {
	printdebug "existing DEP-14 tag: not examining\n";
	return;
    }

    # modes: must, if-exists, replace-unsuitable
    # tag: might exist

    my $existing_objid = git_get_ref "refs/tags/$tw->{Tag}";
    if (!$existing_objid) {
	printdebug "existing DEP-14 tag: nonexistent\n";
	if (grep { $dep14tag_reuse eq $_ } qw(if-exists replace-unsuitable)) {
	    return;
	} else { # `must`, since `replace` dealt with above
	    fail f_
	      "DEP-14 tag %s does not exist (--dep14tag-reuse=%s)",
	      $tw->{Tag}, $dep14tag_reuse;
	}
    }
    # modes: must, if-exists, replace-unsuitable
    # tag: does exist, may be unsuitable

    my $existing_unsuitable = dep14tag_reuse_unsuitable($tw, $existing_objid);
    if (defined $existing_unsuitable) {
	printdebug "existing DEP-14 tag: unsuitable\n";
	# modes: must, if-exists, replace-unsuitable
	# tag: does exist, but is unsuitable
	if ($dep14tag_reuse eq 'replace-unsuitable') {
	    print STDERR f_
	      "%s: making fresh DEP-14 tag %s (--dep14tag-reuse=%s), since existing tag unsuitable: %s",
	      $us, $tw->{Tag}, $dep14tag_reuse, $existing_unsuitable;
	    return;
	} else {
	    # modes: must, if-exists
	    # tag: does exist, but is unsuitable

	    # If -fforce-reusing-version we ignore `reuse=if-exists`,
	    # and remake the tag in that case, treating it as `if-unsuitable`.
	    forceable_fail [qw(reusing-version)], f_
	      "existing DEP-14 tag %s is unsuitable (--dep14tag-reuse=%s): %s",
	      $tw->{Tag}, $dep14tag_reuse, $existing_unsuitable;
	}
    }
    printdebug "existing DEP-14 tag: suitable\n";

    # modes: must, if-exists, replace-unsuitable
    # tag: does exist, is suitable

    # reuse the tag
    $tw->{ReuseExisting} = 1;
    responder_send_command("param dep14tag 0");
}

sub dep14tag_reuse_unsuitable ($$) {
    # Returns undef if the existing tag is OK.
    my ($tw, $existing_objid) = @_;

    my $existing_commitid = git_rev_parse $existing_objid;
    # Not `eval`, so we only tolerate precisely the errors we expect.
    if ($existing_commitid ne $tw->{Objid}) {
	return f_ "refers to commit %s, not %s",
	  $existing_commitid, $tw->{Objid};
    }

    if ($dep14tag_verify) {
	my @cmd = (@git, qw(verify-tag), $tw->{Tag});
	debugcmd '+', @cmd;
	$!=0; $?=-1;
	if (system @cmd) {
	    failedcmd_report_cmd 'existing DEP-14 tag verification used', @_;
	    return f_ "verification failed: git verify-tag: %s",
	      failedcmd_waitstatus();
	}
    }
    return undef;
}

sub push_tagwants ($$$$) {
    my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
    my @tagwants;
    push @tagwants, {
        TagFn => \&debiantag_new,
	Objid => $dgithead,
        TfSuffix => '',
        View => 'dgit',
    };
    my $maintview_tag;
    if (defined $maintviewhead) {
	push @tagwants, {
            TagFn => \&debiantag_maintview,
	    Objid => $maintviewhead,
	    TfSuffix => '-maintview',
            View => 'maint',
            Dep14 => 1,
        };
    } elsif ($dodep14tag ne 'no') {
	push @tagwants, {
	    TagFn => \&debiantag_maintview,
	    Objid => $dgithead,
	    TfSuffix => '-dgit',
	    View => 'dgit',
            Dep14 => 1,
        };
    };

    foreach my $tw (@tagwants) {
	$tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
	$tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
    }

    dep14tag_reuse_tag_adjust_tagwants($cversion, \@tagwants);

    printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
    return @tagwants;
}

sub check_dsc_vs_git ($$) {
    my ($dscfn, $dgithead) = @_;
    my $dscpath = "$buildproductsdir/$dscfn";
    # call in $playground
    progress f_ "checking that %s corresponds to HEAD", $dscfn;
    runcmd qw(dpkg-source -x --),
        ($dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath"),
	qw(unpacked);
    my $tree = mktree_in_ud_from_unpacked("source package");
    check_for_vendor_patches() if madformat($dsc->{format});
    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 = $made_splitbrain_playtree ? $dgithead : 'HEAD';
	    my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;

	    my @mode_changes;
	    my $raw = cmdoutput @git,
		qw(diff --no-renames -z -r --raw), $tree, $dgithead;
	    my $changed;
	    foreach (split /\0/, $raw) {
		if (defined $changed) {
		    push @mode_changes, "$changed: $_\n" if $changed;
		    $changed = undef;
		    next;
		} elsif (m/^:0+ 0+ /) {
		    $changed = '';
		} elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
		    $changed = "Mode change from $1 to $2"
		} else {
		    die "$_ ?";
		}
	    }
	    my $fail = sub {
		print STDERR failmsg @_;
		finish 6;
	    };
	    if (@mode_changes) {
		$fail->((f_ <<ENDT, $dscfn).<<END
HEAD specifies a different tree to %s:
ENDT
$diffs
END
		    .(join '', @mode_changes)
		    .(f_ <<ENDT, $tree, $referent));
There is a problem with your source tree (see dgit(7) for some hints).
To see a full diff, run git diff %s %s
ENDT
	    }

	    $fail->((f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent));
HEAD specifies a different tree to %s:
ENDT
$diffs
END
Perhaps you forgot to build.  Or perhaps there is a problem with your
 source tree (see dgit(7) for some hints).  To see a full diff, run
   git diff %s %s
ENDT
	} else {
	    failedcmd @diffcmd;
	}
    }
}

sub push_mktags ($$ $$ $) {
    my ($clogp,$dscfn,
	$changesfile,$changesfilewhat,
        $tagwants) = @_;

    my $add_fields = sub {
	my ($file, $desc, $opt_abbrevs) = @_;
	foreach my $opt_abbrev (@$opt_abbrevs) {
	    foreach my $field (sort keys $control_add{$opt_abbrev}->%*) {
		fail f_ "%s already contains field %s", $desc, $field
		  if exists $file->{$field};
		$file->{$field} = $control_add{$opt_abbrev}{$field};
	    }
	}
    };

    die unless $tagwants->[0]{View} eq 'dgit';

    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;
    $add_fields->($dsc, "dsc", [qw(dsc t2u)]);
    $dsc->save("$dscfn.tmp") or confess "$!";

    # Do this unconditionally, even if there are no entries in
    # $control_add{changes}, so that elsewhere we can assume there is
    # always a .tmp file for the .changes, too, which is simpler.
    my $changes = parsecontrol($changesfile,$changesfilewhat);
    $add_fields->($changes, "changes", [qw(ch t2u)]);
    $changes->save("$changesfile.tmp") or confess $!;

    # Calling check_expected is redundant with the proceeding check
    # against the values from the changelog because we can't reach
    # this point if the changelog values aren't what we expected.
    # But it is good to check the changes values are as expected
    # independently of the changelog checks, and this makes for more
    # useful error messages.
    check_expected($changes, "changes");
    foreach my $field (sort keys %expected) {
	$changes->{$field} eq $clogp->{$field} or
	    fail f_ "changes field %s \`%s' does not match changelog \`%s'",
	            $field, $changes->{$field}, $clogp->{$field};
    }

    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 $note_split_maint_view_tag = '';

    my $mktag = sub {
	my ($tw) = @_;
	my $tfn = $tw->{Tfn};
	my $head = $tw->{Objid};
	my $tag = $tw->{Tag};

	open TO, '>', $tfn->('.tmp') or confess "$!";
	print TO <<END or confess "$!";
object $head
type commit
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 = <<END;
[dgit distro=$declaredistro$dtxinfo]
END
	foreach my $ref (sort keys %previously) {
	    $tag_metadata .= <<END or confess "$!";
[dgit previously:$ref=$previously{$ref}]
END
	}
	$tag_metadata .= $note_split_maint_view_tag;


	if ($tw->{View} eq 'dgit') {
	    print TO sprintf <<ENDT, $package, $cversion, $clogsuite, $csuite
%s release %s for %s (%s) [dgit]
ENDT
		or confess "$!";
	} elsif ($tw->{View} eq 'maint') {
	    print TO sprintf <<END, $package, $cversion, $clogsuite, $csuite;
%s release %s for %s (%s)

END
	    print TO f_ <<END,
(maintainer view tag generated by dgit --quilt=%s)
END
		$quilt_mode
		or confess "$!";
	} else {
	    confess Dumper($tw)."?";
	}
	print TO "\n", $tag_metadata;

	close TO or confess "$!";

	my $tagobjfn = $tfn->('.tmp');
	if ($sign) {
	    if (!defined $keyid) {
		$keyid = access_cfg('keyid','RETURN-UNDEF');
	    }
	    if (!defined $keyid) {
		$keyid = getfield $clogp, 'Maintainer';
	    }
	    unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
	    my @sign_cmd = (@gpg, qw(--detach-sign --armor));
	    push @sign_cmd, qw(-u),$keyid if defined $keyid;
	    push @sign_cmd, $tfn->('.tmp');
	    runcmd_ordryrun @sign_cmd;
	    if (act_scary()) {
		$tagobjfn = $tfn->('.signed.tmp');
		runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
		    $tfn->('.tmp'), $tfn->('.tmp.asc');
	    }
	}
	if ($tw->{View} eq 'maint') {
	    # We might be reusing a tag.  Bind the tag we think is OK
	    # into *our* archive/ tag, so that it can be found later,
	    # even in the presence of multiple DEP-14 tags floating about.
	    my $o = cmdoutput @git, qw(hash-object -t tag), $tagobjfn;
	    $note_split_maint_view_tag = <<END
[dgit split-maint-view-tag=$o]
END
	}

	return $tagobjfn;
    };

    my @r = reverse map { $mktag->($_); } reverse @$tagwants;
    return @r;
}

sub sign_changes ($) {
    my ($changesfile) = @_;
    if ($sign) {
	my @debsign_cmd = @debsign;
	push @debsign_cmd, "-k$keyid" if defined $keyid;
	push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
	push @debsign_cmd, $changesfile;
	runcmd_ordryrun @debsign_cmd;
    }
}

sub tainted_objects_precheck ($$) {
    my ($json, $dgithead) = @_;
    my %taints;
  ROW: foreach my $row (@{ decode_json $json }) {
	foreach my $override (@{ $row->{overrides} }) {
	    if ($override =~ m{^--deliberately-} && deliberately($')) {
		printdebug "overriding $row->{gitobjid} $override\n";
		next ROW;
	    }
	}
	my $objid = $row->{gitobjid};
	my ($gtype, $dummy) = git_cat_file $objid, undef;
	next if $gtype eq 'missing';
	if ($row->{gitobjtype} and $gtype ne $row->{gitobjtype}) {
	    print STDERR f_ <<'END', $objid, $gtype, $row->{gitobjtype};
warning: server says object %s type %s is tainted, but here it has type %s
END
	}
	$taints{$objid}{Type} = $gtype;
	push @{ $taints{$objid}{Rows} }, $row;
    }

    open GRL, "-|",
      @git, qw(rev-list --objects --in-commit-order --pretty=format:),
            $dgithead
	    or confess "$!";
    my $trouble = 0;
    my %hinted;
    my $found = sub {
	my ($objid) = @_;
	my $t = $taints{$objid};
	return unless $t;

	foreach my $row (@{ $t->{Rows} }) {
	    # If it was actually overriding we don't get here, asd
	    # don't call tainted_objects_message.  Instead, the server
	    # will send such a message to our stderr (sadly, untranslated).
	    my $ovstatus =
	      (grep m{^--deliberately-}, @{ $row->{overrides} })
	      ? '' : undef;
	    print STDERR tainted_objects_message $row, $ovstatus, \%hinted;
	    $trouble = 1;
	}
    };
    my $c_commit;
    while (<GRL>) {
	if (m{^commit (\w+)$}) {
	    $c_commit = $1;
	    $found->($1, __ 'commit');
	} elsif (m{(^\w{20}\w*) } && defined $c_commit) {
	    $found->($1, f_ 'object within commit %s', $c_commit);
	} else {
	    confess "$_ ?";
	}
    }
    GRL->error and die $!;
    close GRL or confess "$? $!";
    forceable_fail [qw(push-tainted)],
      __ "pushing tainted objects (which server would reject)"
      if $trouble;
}

sub dopush () {
    printdebug "actually entering push\n";

    supplementary_message(__ <<'END');
Push failed, while checking state of the archive.
You can retry the push, after fixing the problem, if you like.
END
    if (check_for_git()) {
	git_fetch_us();
    }
    my $archive_hash = fetch_from_archive();
    my $archive_dsc = $dsc;
    if (!$archive_hash) {
	$new_package or
	    fail __ "package appears to be new in this suite;".
	            " if this is intentional, use --new";
    }

    supplementary_message(__ <<'END');
Push failed, while preparing your push.
You can retry the push, after fixing the problem, if you like.
END

    prep_ud();

    access_giturl(); # check that success is vaguely likely
    rpush_handle_protovsn_bothends() if $we_are_initiator;

    my $clogpfn = dgit_privdir()."/changelog.822.tmp";
    runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);

    responder_send_file('parsed-changelog', $clogpfn);

    my ($clogp, $cversion, $dscfn) =
	push_parse_changelog("$clogpfn");

    my $dscpath = "$buildproductsdir/$dscfn";
    stat_exists $dscpath or
	fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
	        $dscpath, $!;

    responder_send_file('dsc', $dscpath);

    push_parse_dsc($dscpath, $dscfn, $cversion);

    my $format = getfield $dsc, 'Format';

    my $symref = git_get_symref();
    my $actualhead = git_rev_parse('HEAD');

    if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
	if (quiltmode_splitting()) {
	    my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
	    fail f_ <<END, $ffq_prev, $quilt_mode;
Branch is managed by git-debrebase (%s
exists), but quilt mode (%s) implies a split view.
Pass the right --quilt option or adjust your git config.
Or, maybe, run git-debrebase forget-was-ever-debrebase.
END
	}
	runcmd_ordryrun_local @git_debrebase, 'stitch';
	$actualhead = git_rev_parse('HEAD');
    }

    my $dgithead = $actualhead;
    my $maintviewhead = undef;

    my $upstreamversion = upstreamversion $clogp->{Version};

    if (defined $archive_dsc && 
	version_compare($archive_dsc->{Version}, $cversion) >= 0 &&
	!forceing [qw(uploading-old-version)]) {
      fail f_ <<'END', $archive_dsc->{Version}, $csuite, $cversion;
You seem to be trying to push an old version.
Version current in archive:       %s (in suite %s)
Version you are trying to upload: %s
END
    }

    if (madformat_wantfixup($format)) {
	# user might have not used dgit build, so maybe do this now:
	if (do_split_brain()) {
	    changedir $playground;
	    my $cachekey;
	    ($dgithead, $cachekey) =
		quilt_check_splitbrain_cache($actualhead, $upstreamversion);
	    $dgithead or fail f_
 "--quilt=%s but no cached dgit view:
 perhaps HEAD changed since dgit build[-source] ?",
                              $quilt_mode;
	}
	if (!do_split_brain()) {
	    # In split brain mode, do not attempt to incorporate dirty
	    # stuff from the user's working tree.  That would be mad.
	    commit_quilty_patch();
	}
    }
    if (do_split_brain()) {
	$made_splitbrain_playtree = 1;
	$dgithead = splitbrain_pseudomerge($clogp,
					   $actualhead, $dgithead,
					   $archive_hash);
	$maintviewhead = $actualhead;
	changedir $maindir;
	prep_ud(); # so _only_subdir() works, below
    }

    if (defined $overwrite_version && !defined $maintviewhead
	&& $archive_hash) {
	$dgithead = plain_overwrite_pseudomerge($clogp,
						$dgithead,
						$archive_hash);
    }

    check_not_dirty();

    my $forceflag = '';
    if ($archive_hash) {
	if (is_fast_fwd($archive_hash, $dgithead)) {
	    # ok
	} elsif (deliberately_not_fast_forward) {
	    $forceflag = '+';
	} else {
	    fail __ "dgit push: HEAD is not a descendant".
	        " of the archive's version.\n".
		"To overwrite the archive's contents,".
		" pass --trust-changelog, or --overwrite=VERSION.\n".
		"To rewrite history, if permitted by the archive,".
		" use --deliberately-not-fast-forward.";
	}
    }

    confess unless !!$made_splitbrain_playtree == do_split_brain();

    my $tagname = debiantag_new $cversion, access_nomdistro();
    if (!(forceing[qw(reusing-version)]) && git_get_ref "refs/tags/$tagname") {
	supplementary_message '';
	print STDERR f_ <<END, $cversion;

Version %s has already been tagged (pushed?)
If this was a failed (or incomplete or rejected) upload by you, just
add a new changelog stanza for a new version number and try again.
END
	fail f_ <<END, $tagname;
Tag %s already exists.
END
    }

    changedir $playground;
    check_dsc_vs_git $dscfn, $dgithead;

    if (!$changesfile) {
	my $pat = changespat $cversion;
	my @cs = glob "$buildproductsdir/$pat";
	fail f_ "failed to find unique changes file".
		" (looked for %s in %s);".
		" perhaps you need to use dgit -C",
		$pat, $buildproductsdir
	    unless @cs==1;
	($changesfile) = @cs;
    } else {
	$changesfile = "$buildproductsdir/$changesfile";
    }

    # Check that changes and .dsc agree enough
    $changesfile =~ m{[^/]*$};
    my $changes = parsecontrol($changesfile,$&);
    files_compare_inputs($dsc, $changes)
	unless forceing [qw(dsc-changes-mismatch)];

    # Check whether this is a source only upload
    my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
    my $sourceonlypolicy = access_cfg 'source-only-uploads';
    if ($sourceonlypolicy eq 'ok') {
    } elsif ($sourceonlypolicy eq 'always') {
	forceable_fail [qw(uploading-binaries)],
	    __ "uploading binaries, although distro policy is source only"
	    if $hasdebs;
    } elsif ($sourceonlypolicy eq 'never') {
	forceable_fail [qw(uploading-source-only)],
	    __ "source-only upload, although distro policy requires .debs"
	    if !$hasdebs;
    } elsif ($sourceonlypolicy eq 'not-wholly-new') {
	forceable_fail [qw(uploading-source-only)],
	    f_ "source-only upload, though package appears entirely NEW\n".
	       "(this is probably contrary to policy in %s)",
	       access_nomdistro()
	    if !$hasdebs
	    && $new_package
	    && !(archive_query('package_not_wholly_new', $package) // 1);
    } else {
	badcfg f_ "unknown source-only-uploads policy \`%s'",
	          $sourceonlypolicy;
    }

    # Try to detect if we're about to be rejected due to tainted objects
    my $pq_supported = access_cfg 'policy-query-supported-ssh';
    $pq_supported =~ m{^(?:false|true|unknown)$} or badcfg f_
      "policy-query-supported-ssh value '%s' must be false/true/unknown",
      $pq_supported;
    if ($pq_supported !~ m/false/) {
	my @cmd =
	  (access_cfg_ssh, access_gituserhost(),
	   access_runeinfo("policy-client-query $package tainted-objects ".
			  join " ", $csuite).
	   " true");
	my $json = cmdoutput_errok @cmd;
	if (!defined $json) {
	    # "unknown" means try the call, but don't mind if it
	    # fails.  (This is OK, as a best effort, because then the
	    # server will enforce the check and this machinery is just
	    # to prevent late failures.)
	    failedcmd @cmd unless $pq_supported =~ m/unknown/;
	} else {
	    printdebug "tainted-objects: $json\n";
	    if (length $json) {
		tainted_objects_precheck $json, $dgithead;
	    }
	}
    }

    # Perhaps adjust .changes to contain right set of origs
    changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
				  $changesfile)
	unless forceing [qw(changes-origs-exactly)];

    # Checks complete, we're going to try and go ahead:

    responder_send_file('changes',$changesfile);
    responder_send_command("param head $dgithead");
    responder_send_command("param csuite $csuite");
    responder_send_command("param isuite $isuite");
    responder_send_command("param tagformat new"); # needed in $protovsn==4
    responder_send_command("param splitbrain $do_split_brain");
    if (defined $maintviewhead) {
	responder_send_command("param maint-view $maintviewhead");
    }

    # 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) = @_;
	    my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
	    responder_send_command("previously $rrefname=$objid");
	    $previously{$rrefname} = $objid;
	});
    }

    my @tagwants_all = push_tagwants($cversion, $dgithead, $maintviewhead,
				      dgit_privdir()."/tag");
    my @tagwants_make = grep { !$_->{ReuseExisting} } @tagwants_all;
    my @tagobjfns;

    supplementary_message(__ <<'END');
Push failed, while signing the tag.
You can retry the push, after fixing the problem, if you like.
END
    # If we manage to sign but fail to record it anywhere, it's fine.
    if ($we_are_responder) {
	@tagobjfns = ();
	my @tagobjfns_discard;
	foreach my $tw (@tagwants_all) {
	    if (!$tw->{ReuseExisting}) {
		push @tagobjfns, $tw->{Tfn}('.signed-tmp');
	    } elsif ($protovsn >= 7) {
		# we sent param dep14tag 0, and initiator understands it
	    } else {
		# Initiator is going to send us a tag we don't want this is
		# kind of gross - making a semantically weird signed tag
		# and then discarding it.  But it's better than the
		# alternatives.
		push @tagobjfns_discard, $tw->{Fn}('.discard-remade-tag');
	    }
	}
	responder_receive_files('signed-tag', @tagobjfns, @tagobjfns_discard);
    } else {
	@tagobjfns = push_mktags($clogp,$dscpath,
			      $changesfile,$changesfile,
			      \@tagwants_make);
    }
    supplementary_message(__ <<'END');
Push failed, *after* signing the tag.
If you want to try again, you should use a new version number.
END

    pairwise { $a->{TagObjFn} = $b } @tagwants_make, @tagobjfns;

    foreach my $tw (@tagwants_make) {
	my $tag = $tw->{Tag};
	my $tagobjfn = $tw->{TagObjFn};
	my $tag_obj_hash =
	    cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
	runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
	# ^ for a tag we're reusing, we verified it (if we needed to)
	#   earlier, via dep14tag_reuse_tag_adjust_tagwants
	runcmd_ordryrun_local
	    @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
    }

    supplementary_message(__ <<'END');
Push failed, while updating the remote git repository - see messages above.
If you want to try again, you should use a new version number.
END
    if (!check_for_git()) {
	create_remote_git_repo();
    }

    my @pushrefs = $forceflag.$dgithead.":".rrref();
    foreach my $tw (@tagwants_all) {
	push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
    }

    runcmd_ordryrun @git,
	qw(-c push.followTags=false push), access_giturl(), @pushrefs;
    runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;

    supplementary_message(__ <<'END');
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 file (see the command dgit tried,
above), and then dput that changes file 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',
				map { "$_$dryrunsuffix" } @rfiles);
    } else {
	if (act_local()) {
	    rename "$_.tmp", $_ or die "$_ $!"
	      for $dscpath, $changesfile;
	} else {
	    progress f_
	      "[new .dsc & .changes left in %s.tmp, %s.tmp]",
	      $dscpath, $changesfile;
	}
	sign_changes $changesfile;
    }

    supplementary_message(f_ <<END, $changesfile);
Push failed, while uploading package(s) to the archive server.
You can retry the upload of exactly these same files with dput of:
  %s
If that .changes file is broken, you will need to use a new version
number for your next attempt at the upload.
END
    my $host = access_cfg('upload-host','RETURN-UNDEF');
    my @hostarg = defined($host) ? ($host,) : ();
    runcmd_ordryrun @dput, @hostarg, $changesfile;
    printdone f_ "pushed and uploaded %s", $cversion;

    supplementary_message('');
    responder_send_command("complete");
}

sub pre_clone () {
    not_necessarily_a_tree();
}
sub cmd_clone {
    parseopts();
    my $dstdir;
    badusage __ "-p is not allowed with clone; specify as argument instead"
	if defined $package;
    if (@ARGV==1) {
	($package) = @ARGV;
    } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
	($package,$isuite) = @ARGV;
    } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
	($package,$dstdir) = @ARGV;
    } elsif (@ARGV==3) {
	($package,$isuite,$dstdir) = @ARGV;
    } else {
	badusage __ "incorrect arguments to dgit clone";
    }
    notpushing();

    $dstdir ||= "$package";
    if (stat_exists $dstdir) {
	fail f_ "%s already exists", $dstdir;
    }

    my $cwd_remove;
    if ($rmonerror && !$dryrun_level) {
	$cwd_remove= getcwd();
	unshift @end, sub { 
	    return unless defined $cwd_remove;
	    if (!chdir "$cwd_remove") {
		return if $!==&ENOENT;
		confess "chdir $cwd_remove: $!";
	    }
	    printdebug "clone rmonerror removing $dstdir\n";
	    if (stat $dstdir) {
		rmdir_r($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
	    } elsif (grep { $! == $_ }
		     (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
	    } else {
		print STDERR f_ "check whether to remove %s: %s\n",
		                $dstdir, $!;
	    }
	};
    }

    clone($dstdir);
    $cwd_remove = undef;
}

sub branchsuite () {
    my $branch = git_get_symref();
    if (defined $branch && $branch =~ m#$lbranch_re#o) {
	return $1;
    } else {
	return undef;
    }
}

sub package_from_d_control () {
    if (!defined $package) {
	my $sourcep = parsecontrol('debian/control','debian/control');
	$package = getfield $sourcep, 'Source';
    }
}

sub fetchpullargs () {
    package_from_d_control();
    if (@ARGV==0) {
	$isuite = branchsuite();
	if (!$isuite) {
	    my $clogp = parsechangelog();
	    my $clogsuite = getfield $clogp, 'Distribution';
	    $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
	}
    } elsif (@ARGV==1) {
	($isuite) = @ARGV;
    } else {
	badusage __ "incorrect arguments to dgit fetch or dgit pull";
    }
    notpushing();
}

sub cmd_fetch {
    parseopts();
    fetchpullargs();
    dofetch();
}

sub cmd_pull {
    parseopts();
    fetchpullargs();
    my $format = get_source_format();
    determine_whether_split_brain $format;
    if (do_split_brain()) {
	madformat($format) and fail f_ <<END, $quilt_mode
dgit pull not yet supported in split view mode (including with view-splitting quilt modes)
END
    }
    pull();
}

sub cmd_checkout {
    parseopts();
    package_from_d_control();
    @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
    ($isuite) = @ARGV;
    notpushing();

    foreach my $canon (qw(0 1)) {
	if (!$canon) {
	    $csuite= $isuite;
	} else {
	    undef $csuite;
	    canonicalise_suite();
	}
	if (length git_get_ref lref()) {
	    # local branch already exists, yay
	    last;
	}
	if (!length git_get_ref lrref()) {
	    if (!$canon) {
		# nope
		next;
	    }
	    dofetch();
	}
	# now lrref exists
	runcmd (@git, qw(update-ref), lref(), lrref(), '');
	last;
    }
    local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
        "dgit checkout $isuite";
    runcmd (@git, qw(checkout), lbranch());
}

sub cmd_update_vcs_git () {
    my $specsuite;
    if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
	($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
    } else {
	($specsuite) = (@ARGV);
	shift @ARGV;
    }
    my $dofetch=1;
    if (@ARGV) {
	if ($ARGV[0] eq '-') {
	    $dofetch = 0;
	} elsif ($ARGV[0] eq '-') {
	    shift;
	}
    }

    package_from_d_control();
    my $ctrl;
    if ($specsuite eq '.') {
	$ctrl = parsecontrol 'debian/control', 'debian/control';
    } else {
	$isuite = $specsuite;
	get_archive_dsc();
	$ctrl = $dsc;
    }
    my $url = vcs_git_url_of_ctrl $ctrl;
    fail 'no Vcs-Git header in control file' unless length $url;

    my @cmd;
    my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
    if (!defined $orgurl) {
	print STDERR f_ "setting up vcs-git: %s\n", $url;
	@cmd = (@git, qw(remote add vcs-git), $url);
    } elsif ($orgurl eq $url) {
	print STDERR f_ "vcs git unchanged: %s\n", $url;
    } else {
	print STDERR f_ "changing vcs-git url to: %s\n", $url;
	@cmd = (@git, qw(remote set-url vcs-git), $url);
    }
    runcmd_ordryrun_local @cmd if @cmd;
    if ($dofetch) {
	print f_ "fetching (%s)\n", "@ARGV";
	runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
    }
}

sub prep_push () {
    parseopts();
    build_or_push_prep_early();
    pushing();
    build_or_push_prep_modes();
    check_not_dirty();
    my $specsuite;
    if (@ARGV==0) {
    } elsif (@ARGV==1) {
	($specsuite) = (@ARGV);
    } else {
	badusage f_ "incorrect arguments to dgit %s", $subcommand;
    }
    if ($new_package) {
	local ($package) = $existing_package; # this is a hack
	canonicalise_suite();
    } else {
	canonicalise_suite();
    }
    if (defined $specsuite &&
	$specsuite ne $isuite &&
	$specsuite ne $csuite) {
	    fail f_ "dgit %s: changelog specifies %s (%s)".
	            " but command line specifies %s",
		    $subcommand, $isuite, $csuite, $specsuite;
    }
}

sub cmd_push_built {
    prep_push();
    if (do_split_brain()) {
	# We may need to make the split brain view now, bedcause if
	# the user built the package other than with dgit they may
	# have a correct .dsc, but not populated the cache.
	#
	# Do this only in split brain mode, since we don't actually
	# want to update HEAD!
	build_maybe_quilt_fixup();
    }
    dopush();
}

sub cmd_push {
    some_push_alias('push', \&cmd_push_source, \&cmd_push_built,
		    [qw(dgit.default.push-subcmd)], sub {
        my ($spec) = @_;
        f_ 'dgit push, but dgit.default.push-subcmd set to %s', $spec
    });
}
sub cmd_rpush { 
    some_push_alias('rpush', \&cmd_rpush_source, \&cmd_rpush_built,
		    [qw(dgit.default.rpush-subcmd
			dgit.default.push-subcmd)], sub {
        my ($spec) = @_;
        f_ 'dgit rpush, but dgit.default.[r]push-subcmd set to %s', $spec
    });
}
sub some_push_alias ($$@) {
    my ($verb, $if_source, $if_built, $cfgs, $badvalue_msg) = @_;
    my $spec = cfg @$cfgs;

    if ($spec eq 'source') {
	$if_source->();
    } elsif ($spec eq 'built') {
	$if_built->();
    } elsif ($spec eq 'warn,built') {
	print STDERR f_ <<'END', $verb,$verb,$verb;
warning: "dgit %s" currently means "dgit %s-built" (by default)
warning:   but is going to change to "dgit %s-source".   See dgit!(1).
END
	$if_built->();
    } else {
	fail $badvalue_msg->($spec);
    }
}

#---------- remote commands' implementation ----------

sub pre_remote_push_build_host        { core_pre_rpush_bh('push');        }
sub pre_remote_push_source_build_host { core_pre_rpush_bh('push-source'); }
sub core_pre_rpush_bh ($) {
    ($rpush_verb) = @_;
    my ($nrargs) = shift @ARGV;
    my (@rargs) = @ARGV[0..$nrargs-1];
    @ARGV = @ARGV[$nrargs..$#ARGV];
    die unless @rargs;
    my ($dir,$vsnwant) = @rargs;
    # vsnwant is a comma-separated list; we report which we have
    # chosen in our ready response (so other end can tell if they
    # offered several)
    $debugprefix = ' ';
    $we_are_responder = 1;
    $us .= " (build host)";

    open PI, "<&STDIN" or confess "$!";
    open STDIN, "/dev/null" or confess "$!";
    open PO, ">&STDOUT" or confess "$!";
    autoflush PO 1;
    open STDOUT, ">&STDERR" or confess "$!";
    autoflush STDOUT 1;
    $rparent_conn = Debian::Dgit::ProtoConn->new(\*PI, \*PO);

    $vsnwant //= 1;
    ($protovsn) = grep {
	$vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
    } @rpushprotovsn_support;

    fail f_ "build host has dgit rpush protocol versions %s".
            " but invocation host has %s",
	    (join ",", @rpushprotovsn_support), $vsnwant
	unless defined $protovsn;

    changedir $dir;

    responder_send_command("dgit-remote-$rpush_verb-ready $protovsn");
}

sub cmd_remote_push_build_host        { &cmd_push_built;  }
sub cmd_remote_push_source_build_host { &cmd_push_source; }

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)

sub rpush_handle_protovsn_bothends () {
}

our $i_tmp;

sub i_cleanup {
    local ($@, $?);
    my $report = i_child_report(WNOHANG);
    if (defined $report) {
	printdebug "($report)\n";
    } elsif ($i_child_pid) {
	printdebug "(killing build host child $i_child_pid)\n";
	kill 15, $i_child_pid;
    }
    if (defined $i_tmp && !defined $initiator_tempdir) {
	changedir "/";
	eval { rmdir_r $i_tmp; };
    }
}

END {
    return unless forkcheck_mainprocess();
    i_cleanup();
}

sub i_method {
    my ($base,$selector,@args) = @_;
    $selector =~ s/\-/_/g;
    { no strict qw(refs); &{"${base}_${selector}"}(@args); }
}

sub pre_rpush_source () { not_necessarily_a_tree(); }
sub pre_rpush_built ()  { not_necessarily_a_tree(); }
sub pre_rpush ()        { not_necessarily_a_tree(); }

sub cmd_rpush_source { rpush_core('push-source'); }
sub cmd_rpush_built  { rpush_core('push');        }

sub rpush_core ($) {
    ($rpush_verb) = @_;

    my $host = nextarg;
    my $dir;
    if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
	$host = $1;
	$dir = $'; #';
    } else {
	$dir = nextarg;
    }
    $dir =~ s{^-}{./-};
    my @rargs = ($dir);
    push @rargs, join ",", @rpushprotovsn_support;
    my @rdgit;
    push @rdgit, @dgit;
    push @rdgit, @ropts;
    push @rdgit, "remote-$rpush_verb-build-host", (scalar @rargs), @rargs;
    push @rdgit, @ARGV;
    my @cmd = (@ssh, $host, shellquote @rdgit);
    debugcmd "+",@cmd;
    @i_child_cmd = @cmd;

    $we_are_initiator=1;

    if (defined $initiator_tempdir) {
	rmdir_r $initiator_tempdir;
	mkdir $initiator_tempdir, 0700
	    or fail f_ "create %s: %s", $initiator_tempdir, $!;
	$i_tmp = $initiator_tempdir;
    } else {
	$i_tmp = tempdir();
    }
    $i_child_pid = open2(\*RO, \*RI, @cmd);
    $rpush_conn = Debian::Dgit::ProtoConn->new(\*RO, \*RI);
    $rpush_conn->set_eof_hook(sub {
        # The child has probably exited.  Ideally we would wait with WNOHANG,
        # but Linux has an annoying race: if you have a pipe on a child,
        # which dies, you can read EOF on the pipe, but get nothing from
        # wait WNOHANG.  So we must call waitpid *without* WNOHANG.
        # We send SIGTERM in case some even more bizarre thing is wrong.
        kill 15, $i_child_pid;
        i_child_report(0);
    });
    changedir $i_tmp;
    ($protovsn) = initiator_expect { m/^dgit-remote-$rpush_verb-ready (\S+)/ };
    die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;

    for (;;) {
	my ($icmd,$iargs) = initiator_expect {
	    m/^(\S+)(?: (.*))?$/;
	    ($1,$2);
	};
	i_method "i_resp", $icmd, $iargs;
    }
}

sub i_resp_progress ($) {
    my ($rhs) = @_;
    my $msg = $rpush_conn->read_bytes($rhs);
    progress $msg;
}

sub i_resp_supplementary_message ($) {
    my ($rhs) = @_;
    $supplementary_message = $rpush_conn->read_bytes($rhs);
}

sub i_resp_complete {
    my $pid = $i_child_pid;
    $i_child_pid = undef; # prevents killing some other process with same pid
    printdebug "waiting for build host child $pid...\n";
    my $got = waitpid $pid, 0;
    confess "$!" unless $got == $pid;
    fail f_ "build host child failed: %s", waitstatusmsg() if $?;

    i_cleanup();
    printdebug __ "all done\n";
    finish 0;
}

sub i_resp_file ($) {
    my ($keyword) = @_;
    my $localname = i_method "i_localname", $keyword;
    my $localpath = "$i_tmp/$localname";
    stat_exists $localpath and
	$rpush_conn->bad(f_ "file %s (%s) twice", $keyword, $localpath);
    $rpush_conn->receive_file($localpath);
    i_method "i_file", $keyword;
}

sub i_resp_param ($) {
    $_[0] =~ m/^(\S+) (.*)$/ or $rpush_conn->bad(__ "bad param spec");
    $i_param{$1} = $2;
}

sub i_resp_previously ($) {
    $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
	or $rpush_conn->bad(__ "bad previously spec");
    my $r = system qw(git check-ref-format), $1;
    confess "bad previously ref spec ($r)" if $r;
    $previously{$1} = $2;
}

our %i_wanted;
our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);

sub i_resp_want ($) {
    my ($keyword) = @_;
    die "$keyword ?" if $i_wanted{$keyword}++;
    
    defined $i_param{'csuite'} or $rpush_conn->bad(
        "premature desire, no csuite");
    $isuite = $i_param{'isuite'} // $i_param{'csuite'};
    die unless $isuite =~ m/^$suite_re$/;

    if (!defined $dsc) {
	pushing();
	rpush_handle_protovsn_bothends();
	push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
	if ($protovsn >= 6) {
	    determine_whether_split_brain getfield $dsc, 'Format';
	    $do_split_brain eq ($i_param{'splitbrain'} // '<unsent>')
		or $rpush_conn->bad(
 "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";
    foreach my $localpath (@localpaths) {
	$rpush_conn->send_file($localpath);
    }
    $rpush_conn->send("files-end");
}

sub i_localname_parsed_changelog {
    return "remote-changelog.822";
}
sub i_file_parsed_changelog {
    ($i_clogp, $i_version, $i_dscfn) =
	push_parse_changelog "$i_tmp/remote-changelog.822";
    die if $i_dscfn =~ m#/|^\W#;
}

sub i_localname_dsc {
    defined $i_dscfn or $rpush_conn->bad("dsc (before parsed-changelog)");
    return $i_dscfn;
}
sub i_file_dsc { }

sub i_localname_buildinfo ($) {
    my $bi = $i_param{'buildinfo-filename'};
    defined $bi or $rpush_conn->bad("buildinfo before filename");
    defined $i_changesfn or $rpush_conn->bad("buildinfo before changes");
    $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
	or $rpush_conn->bad("improper buildinfo filename");
    return $&;
}
sub i_file_buildinfo {
    $rpush_verb eq 'push' or $t2u_bmode
      or $rpush_conn->bad("buildinfo file but verb is $rpush_verb");

    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 f_ "buildinfo mismatch in field %s", $_
	    foreach qw(Source Version);
	!$t2u_bmode or (getfield $bd, 'Architecture') eq "source"
	  or fail __ "buildinfo mismatch in field Architecture";
	!defined $bd->{$_} or
	    fail f_ "buildinfo contains forbidden field %s", $_
	    foreach qw(Changes Changed-by Distribution);
    }
    push @i_buildinfos, $bi;
    delete $i_param{'buildinfo-filename'};
}

sub i_localname_changes {
    defined $i_dscfn or $rpush_conn->bad("dsc (before parsed-changelog)");
    $i_changesfn = $i_dscfn;
    $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
    return $i_changesfn;
}
sub i_file_changes {
    my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
    # TODO Here we check that *our* rpush verb is push-source.
    # We should confirm that the responder will always agree with us,
    # no matter its local configuration.  This is relevant because we
    # have this thing to allow users to configure the default rpush
    # verb, and at the same time we are in the process of changing the
    # meaning of plain 'push' to mean 'push-source'.
    unless ($rpush_verb eq 'push' || test_source_only_changes($ch)) {
	fail __ "build-host-supplied changes file is not source-only";
    }
}

sub i_want_signed_tag {
    printdebug Dumper(\%i_param, $i_dscfn);
    defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
	&& defined $i_param{'csuite'}
	or $rpush_conn->bad("premature desire for signed-tag");
    my $head = $i_param{'head'};
    die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;

    my $maintview = $i_param{'maint-view'};
    die if defined $maintview && $maintview =~ m/[^0-9a-f]/;

    if ($protovsn == 4) {
	my $p = $i_param{'tagformat'} // '<undef>';
	$p eq 'new'
	    or $rpush_conn->bad("tag format mismatch: $p vs. new");
    }

    die unless $i_param{'csuite'} =~ m/^$suite_re$/;
    $csuite = $&;
    defined $dsc or $rpush_conn->bad("dsc (before parsed-changelog)");

    my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
    @tagwants = grep { !$_->{ReuseExisting} } @tagwants;

    return
	push_mktags $i_clogp, $i_dscfn,
	    $i_changesfn, (__ 'remote changes file'),
	    \@tagwants;
}

sub i_want_signed_dsc_changes {
    rename "$_.tmp", $_ or die "$_ $!" for $i_dscfn, $i_changesfn;
    sign_changes $i_changesfn;
    return ($i_dscfn, $i_changesfn, @i_buildinfos);
}

#---------- building etc. ----------

our $version;
our $sourcechanges;
our $dscfn;

#----- `3.0 (quilt)' handling -----

our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';

sub quiltify_make_dpkg_patch ($$$$$;$) {
    my ($oldtreeish,$newtreeish, $patchname,$author,$msg, $xinfo) = @_;
    $xinfo //= '';

    mkpath '.git/dgit'; # we are in playtree
    my $patchfn = "debian/patches/$patchname";
    ensuredir dirname $patchfn;
    open O, '>', $patchfn or confess "$patchfn: $!";
    $msg =~ s/\n+/\n\n/;
    print O <<END or confess "$!";
From: $author
${xinfo}Subject: $msg
---

END
    close O or confess "$!";

    my @diffcmd = (git_diff_programmatic, $oldtreeish, $newtreeish,
		   '--', ':!/debian', ':!/.pc');
    runcmd qw(sh -ec), 'exec >>"$1"; shift; exec "$@"', 'x', $patchfn,
      @diffcmd;

    open S, ">> debian/patches/series" or confess "$!";
    print S "$patchname\n" or confess "$!";
    close S or confess "$!";
}

sub normalise_mode_strip_exec ($) {
    my ($m) = @_;
    return $m eq '100755' ? '100644' : $m;
}

sub quiltify_trees_differ ($$;$$$) {
    my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
    # returns true iff the two tree objects differ other than in debian/
    # with $finegrained,
    # returns bitmask 01 - differ in upstream files except .gitignore
    #                 02 - differ in .gitignore
    # if $ignorenamesr is defined, $ingorenamesr->{$fn}
    #  is set for each modified .gitignore filename $fn
    # if $unrepres is defined, array ref to which is appended
    #  a list of unrepresentable changes (changes that dpkg-source
    #  cannot apply even just during unpack).
    local $/=undef;
    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;
    my $diffs= cmdoutput @cmd;
    my $r = 0;
    my @lmodes;
    foreach my $f (split /\0/, $diffs) {
	if ($unrepres && !@lmodes) {
	    @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
	    next;
	}
	my ($oldmode,$newmode) = @lmodes;
	@lmodes = ();

	next if $f =~ m#^debian(?:/.*)?$#s;

	if ($unrepres) {
	    eval {
		die __ "not a plain file\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 in unsupported way\n" if
		      normalise_mode_strip_exec($oldmode) ne
		      normalise_mode_strip_exec($newmode);
		    die __ "modified symlink\n" unless $newmode =~ m/^10/;
		} elsif ($oldmode =~ m/[^0]/) {
		    # deletion
		    die __ "deletion of symlink\n"
			unless $oldmode =~ m/^10/;
		} else {
		    # creation
		    die __ "creation with non-default mode, or symlink\n"
			unless $newmode =~ m/^100644$/ or
			       $newmode =~ m/^100755$/;
		}
	    };
	    if ($@) {
		local $/="\n"; chomp $@;
		push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
	    }
	}

	my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
	$r |= $isignore ? 02 : 01;
	$ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
    }
    printdebug "quiltify_trees_differ $x $y => $r\n";
    return $r;
}

sub quiltify_check_unrepresentable ($) {
    my ($unrepres) = @_;
    return unless @$unrepres;
    if ($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.
	return;
    }
    print STDERR f_ "dgit:  cannot represent change: %s: %s\n",
                    $_->[1], $_->[0]
        foreach @$unrepres;

    forceable_fail [qw(unrepresentable)], __ <<END;
HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
END
}

sub quiltify_tree_sentinelfiles ($) {
    # lists the `sentinel' files present in the tree
    my ($x) = @_;
    my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
        qw(-- debian/rules debian/control);
    $r =~ s/\n/,/g;
    return $r;
}

sub quiltify_splitting ($$$$$$$) {
    my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
	$editedignores, $cachekey) = @_;
    my $gitignore_special = 1;
    if ($quilt_mode !~ m/gbp|dpm|baredebian/) {
	# treat .gitignore just like any other upstream file
	$diffbits = { %$diffbits };
	$_ = !!$_ foreach values %$diffbits;
	$gitignore_special = 0;
    }
    # We would like any commits we generate to be reproducible
    my @authline = clogp_authline($clogp);
    local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
    local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
    local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
    local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
    local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
    local $ENV{GIT_AUTHOR_DATE} =  $authline[2];

    confess unless do_split_brain();

    my $fulldiffhint = sub {
	my ($x,$y) = @_;
	my $cmd = "git diff $x $y -- :/ ':!debian'";
	$cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
	return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
	          $cmd;
    };

    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" and $quilt_mode !~ m/baredebian/) {
	    $msg .= __
 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
	}  
	fail $msg;
    }
    if ($quilt_mode =~ m/dpm/ &&
	($diffbits->{H2A} & 01)) {
	fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
--quilt=%s specified, implying patches-applied git tree
 but git tree differs from result of applying debian/patches to upstream
END
    }
    if ($quilt_mode =~ m/baredebian/) {
	# We need to construct a merge which has upstream files from
	# upstream and debian/ files from HEAD.

	read_tree_upstream $quilt_upstream_commitish, 1, $headref;
	my $version = getfield $clogp, 'Version';
	my $upsversion = upstreamversion $version;
	my $merge = make_commit
	    [ $headref, $quilt_upstream_commitish ],
 [ +(f_ <<ENDT, $upsversion), $quilt_upstream_commitish_message, <<ENDU ];
Combine debian/ with upstream source for %s
ENDT
[dgit ($our_version) baredebian-merge $version $quilt_upstream_commitish_used]
ENDU
	runcmd @git, qw(reset -q --hard), $merge;
    }
    if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
	($diffbits->{O2A} & 01)) { # some patches
	progress __ "dgit view: creating patches-applied version using gbp pq";
	gbp_pq_pc_aside(sub {
            runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
	});
	# gbp pq import creates a fresh branch; push back to dgit-view
	runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
	runcmd @git, qw(checkout -q dgit-view);
    }
    if ($quilt_mode =~ m/gbp|dpm/ &&
	($diffbits->{O2A} & 02)) {
	fail f_ <<END, $quilt_mode;
--quilt=%s specified, implying that HEAD is for use with a
 tool which does not create patches for changes to upstream
 .gitignores: but, such patches exist in debian/patches.
END
    }
    if (($diffbits->{O2H} & 02) && # user has modified .gitignore
	!($diffbits->{O2A} & 02)) { # patches do not change .gitignore
	progress __
	    "dgit view: creating patch to represent .gitignore changes";
        ensuredir "debian/patches";
	my $gipatch = "debian/patches/auto-gitignore";
	open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
	stat GIPATCH or confess "$gipatch: $!";
	fail f_ "%s already exists; but want to create it".
	        " to record .gitignore changes",
		$gipatch
	    if (stat _)[7];
	# TODO: The "Subject:" ought not to be translated
	print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
Subject: Update .gitignore from Debian packaging branch

The Debian packaging git branch contains these updates to the upstream
.gitignore file(s).  This patch is autogenerated, to provide these
updates to users of the official Debian archive view of the package.
END

[dgit ($our_version) update-gitignore]
---
ENDU
        close GIPATCH or die "$gipatch: $!";
        runcmd shell_cmd "exec >>$gipatch",
	    git_diff_programmatic $unapplied, $headref, "--",
	    sort keys %$editedignores;
        open SERIES, "+>>", "debian/patches/series" or confess "$!";
        defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
        my $newline;
        defined read SERIES, $newline, 1 or confess "$!";
	print SERIES "\n" or confess "$!" unless $newline eq "\n";
	print SERIES "auto-gitignore\n" or confess "$!";
	close SERIES or die  $!;
        runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
        commit_admin +(__ <<END).<<ENDU
Commit patch to update .gitignore
END

[dgit ($our_version) update-gitignore-quilt-fixup]
ENDU
    }
}

sub quiltify ($$$$) {
    my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;

    # Quilt patchification algorithm
    #
    # We search backwards through the history of the main tree's HEAD
    # (T) looking for a start commit S whose tree object is identical
    # to to the patch tip tree (ie the tree corresponding to the
    # current dpkg-committed patch series).  For these purposes
    # `identical' disregards anything in debian/ - this wrinkle is
    # necessary because dpkg-source treats debian/ specially.
    #
    # We can only traverse edges where at most one of the ancestors'
    # trees differs (in changes outside in debian/).  And we cannot
    # handle edges which change .pc/ or debian/patches.  To avoid
    # going down a rathole we avoid traversing edges which introduce
    # debian/rules or debian/control.  And we set a limit on the
    # number of edges we are willing to look at.
    #
    # If we succeed, we walk forwards again.  For each traversed edge
    # PC (with P parent, C child) (starting with P=S and ending with
    # C=T) to we do this:
    #  - git checkout C
    #  - dpkg-source --commit with a patch name and message derived from C
    # After traversing PT, we git commit the changes which
    # should be contained within debian/patches.

    # The search for the path S..T is breadth-first.  We maintain a
    # todo list containing search nodes.  A search node identifies a
    # commit, and looks something like this:
    #  $p = {
    #      Commit => $git_commit_id,
    #      Child => $c,                          # or undef if P=T
    #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
    #      Nontrivial => true iff $p..$c has relevant changes
    #  };

    my @todo;
    my @nots;
    my $sref_S;
    my $max_work=100;
    my %considered; # saves being exponential on some weird graphs

    my $t_sentinels = quiltify_tree_sentinelfiles $target;

    my $not = sub {
	my ($search,$whynot) = @_;
	printdebug " search NOT $search->{Commit} $whynot\n";
	$search->{Whynot} = $whynot;
	push @nots, $search;
	no warnings qw(exiting);
	next;
    };

    push @todo, {
	Commit => $target,
    };

    while (@todo) {
	my $c = shift @todo;
	next if $considered{$c->{Commit}}++;

	$not->($c, __ "maximum search space exceeded") if --$max_work <= 0;

	printdebug "quiltify investigate $c->{Commit}\n";

	# are we done?
	if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
	    printdebug " search finished hooray!\n";
	    $sref_S = $c;
	    last;
	}

	quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
	if ($quilt_mode eq 'smash') {
	    printdebug " search quitting smash\n";
	    last;
	}

	my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
	$not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
	    if $c_sentinels ne $t_sentinels;

	my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
	$commitdata =~ m/\n\n/;
	$commitdata =~ $`;
	my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
	@parents = map { { Commit => $_, Child => $c } } @parents;

	$not->($c, __ "root commit") if !@parents;

	foreach my $p (@parents) {
	    $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
	}
	my $ndiffers = grep { $_->{Nontrivial} } @parents;
	$not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
	    if $ndiffers > 1;

	foreach my $p (@parents) {
	    printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";

	    my @cmd= (@git, qw(diff-tree -r --name-only),
		      $p->{Commit},$c->{Commit},
		      qw(-- debian/patches .pc debian/source/format));
	    my $patchstackchange = cmdoutput @cmd;
	    if (length $patchstackchange) {
		$patchstackchange =~ s/\n/,/g;
		$not->($p, f_ "changed %s", $patchstackchange);
	    }

	    printdebug " search queue P=$p->{Commit} ",
	        ($p->{Nontrivial} ? "NT" : "triv"),"\n";
	    push @todo, $p;
	}
    }

    if (!$sref_S) {
	printdebug "quiltify want to smash\n";

	my $abbrev = sub {
	    my $x = $_[0]{Commit};
	    $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
	    return $x;
	};
	if ($quilt_mode eq 'linear') {
	    print STDERR f_
		"\n%s: error: quilt fixup cannot be linear.  Stopped at:\n",
		$us;
	    my $all_gdr = !!@nots;
	    foreach my $notp (@nots) {
		my $c = $notp->{Child};
		my $cprange = $abbrev->($notp);
		$cprange .= "..".$abbrev->($c) if $c;
		print STDERR f_ "%s:  %s: %s\n",
		    $us, $cprange, $notp->{Whynot};
		$all_gdr &&= $notp->{Child} &&
		    (git_cat_file $notp->{Child}{Commit}, 'commit')
		    =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
	    }
	    print STDERR "\n";
	    $failsuggestion =
		[ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
		if $all_gdr;
	    print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
	    fail __
 "quilt history linearisation failed.  Search \`quilt fixup' in dgit(7).\n";
	} elsif ($quilt_mode eq 'smash') {
	} elsif ($quilt_mode eq 'try-linear') {
	    progress __ "quilt fixup cannot be linear, smashing...";
	} else {
	    confess "$quilt_mode ?";
	}

	my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
	$time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
	my $ncommits = 3;
	my $msg = cmdoutput @git, qw(log), "-n$ncommits";

	quiltify_make_dpkg_patch
	    $oldtiptree, $target,
            "auto-$version-$target-$time",
	    (getfield $clogp, 'Maintainer'),
	    (f_ "Automatically generated patch (%s)\n".
	     "Last (up to) %s git changes, FYI:\n\n",
	     $clogp->{Version}, $ncommits).
	     $msg;
	return;
    }

    progress __ "quiltify linearisation planning successful, executing...";

    for (my $p = $sref_S;
	 my $c = $p->{Child};
	 $p = $p->{Child}) {
	printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
	next unless $p->{Nontrivial};

	my $cc = $c->{Commit};

	my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
	$commitdata =~ m/\n\n/ or die "$c ?";
	$commitdata = $`;
	my $msg = $'; #';
	$commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
	my $author = $1;

	my $commitdate = cmdoutput
	    @git, qw(log -n1 --pretty=format:%aD), $cc;

	$msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";

	my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
	$strip_nls->();

	my $title = $1;
	my $patchname;
	my $patchdir;

	my $gbp_check_suitable = sub {
	    $_ = shift;
	    my ($what) = @_;

	    eval {
		die __ "contains unexpected slashes\n" if m{//} || m{/$};
		die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
		die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
		die __ "is series file\n" if m{$series_filename_re}o;
		die __ "too long\n" if length > 200;
	    };
	    return $_ unless $@;
	    print STDERR f_
		"quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
		$cc, $what, $@;
	    return undef;
	};

	if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
			   gbp-pq-name: \s* )
		       (\S+) \s* \n //ixm) {
	    $patchname = $gbp_check_suitable->($1, 'Name');
	}
	if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
			   gbp-pq-topic: \s* )
		       (\S+) \s* \n //ixm) {
	    $patchdir = $gbp_check_suitable->($1, 'Topic');
	}

	$strip_nls->();

	if (!defined $patchname) {
	    $patchname = $title;
	    $patchname =~ s/[.:]$//;
            use Text::Iconv;
	    eval {
		my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
		my $translitname = $converter->convert($patchname);
		die unless defined $translitname;
		$patchname = $translitname;
	    };
	    print STDERR
		+(f_ "dgit: patch title transliteration error: %s", $@)
		if $@;
	    $patchname =~ y/ A-Z/-a-z/;
	    $patchname =~ y/-a-z0-9_.+=~//cd;
	    $patchname =~ s/^\W/x-$&/;
	    $patchname = substr($patchname,0,40);
	    $patchname .= ".patch";
	}
	if (!defined $patchdir) {
	    $patchdir = '';
	}
	if (length $patchdir) {
	    $patchname = "$patchdir/$patchname";
	}
	if ($patchname =~ m{^(.*)/}) {
	    mkpath "debian/patches/$1";
	}

	my $index;
	for ($index='';
	     stat "debian/patches/$patchname$index";
	     $index++) { }
	$!==ENOENT or confess "$patchname$index $!";

	quiltify_make_dpkg_patch
	    $p->{Commit} ,$cc,
            "$patchname$index", $author, $msg,
	    "Date: $commitdate\n".
	    "X-Dgit-Generated: $clogp->{Version} $cc\n";

    }
    runcmd @git, qw(checkout -q), $target;
}

sub build_maybe_quilt_fixup () {
    my ($format,$fopts) = get_source_format;
    return unless madformat_wantfixup $format;
    # sigh

    check_for_vendor_patches();

    my $clogp = parsechangelog();
    my $headref = git_rev_parse('HEAD');
    my $symref = git_get_symref();
    my $upstreamversion = upstreamversion $version;

    prep_ud();
    changedir $playground;

    my $splitbrain_cachekey;

    if (do_split_brain()) {
	my $cachehit;
	($cachehit, $splitbrain_cachekey) =
	    quilt_check_splitbrain_cache($headref, $upstreamversion);
	if ($cachehit) {
	    changedir $maindir;
	    return;
	}
    }

    unpack_playtree_need_cd_work($headref);
    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
	#  unpack_playtree_need_cd_work
	# will DTRT, resetting dgit-view.
	confess if $made_splitbrain_playtree;
	$made_splitbrain_playtree = 1;
    }
    chdir '..';

    if (grep m{^single-debian-patch$}, @$fopts) {
	fail f_
 "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
	    $quilt_mode
	    if quiltmode_splitting();

	# We always use dpkg-source --commit in this case, because
	# otherwise we can generate source packages that trigger horrible
	# bugs in dpkg-source.
	#   https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1018984
	quilt_fixup_dpkgsource_singlepatch($clogp, $headref, $upstreamversion);
    } elsif ($quilt_mode =~ m/single/) {
	quilt_fixup_git_singlepatch($clogp, $headref, $upstreamversion);
    } else {
	quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
			      $splitbrain_cachekey);
    }

    if (do_split_brain()) {
	my $dgitview = git_rev_parse 'HEAD';

	changedir $maindir;
	reflog_cache_insert "refs/$splitbraincache",
	    $splitbrain_cachekey, $dgitview;

	changedir "$playground/work";

	my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
	progress f_ "dgit view: created (%s)", $saved;
    }

    changedir $maindir;
    runcmd_ordryrun_local
        @git, qw(pull --ff-only -q), "$playground/work", qw(master);
}

sub build_check_quilt_splitbrain () {
    build_maybe_quilt_fixup();
}

sub unpack_playtree_need_cd_work ($) {
    my ($headref) = @_;

    # prep_ud() must have been called already.
    if (!chdir "work") {
	# Check in the filesystem because sometimes we run prep_ud
	# in between multiple calls to unpack_playtree_need_cd_work.
	confess "$!" unless $!==ENOENT;
	mkdir "work" or confess "$!";
	changedir "work";
	mktree_in_ud_here();
    }
    runcmd @git, qw(reset -q --hard), $headref;
}

sub unpack_playtree_linkorigs ($$) {
    my ($upstreamversion, $fn) = @_;
    # calls $fn->($leafname);

    my $bpd_abs = bpd_abs();

    dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };

    opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
    while ($!=0, defined(my $leaf = readdir QFD)) {
	my $f = bpd_abs()."/".$leaf;
	{
	    local ($debuglevel) = $debuglevel-1;
	    printdebug "QF linkorigs bpd $leaf, $f ?\n";
	}
	next unless is_orig_file_of_vsn $leaf, $upstreamversion;
	printdebug "QF linkorigs $leaf, $f Y\n";
	# link_ltarget contains a calls to realpath, and does its own
	# error handling, so do idempotency with an explicit stat.
	stat_exists $leaf or link_ltarget $f, $leaf;
        $fn->($leaf);
    }
    die "$buildproductsdir: $!" if $!;
    closedir QFD;
}

sub quilt_fixup_delete_pc () {
    runcmd @git, qw(rm -rqf .pc);
    commit_admin +(__ <<END).<<ENDU
Commit removal of .pc (quilt series tracking data)
END

[dgit ($our_version) upgrade quilt-remove-pc]
ENDU
}

sub quilt_fixup_dpkgsource_singlepatch ($$$) {
    my ($clogp, $headref, $upstreamversion) = @_;

    progress __ "starting quiltify (single-debian-patch)";

    # dpkg-source --commit generates new patches even if
    # single-debian-patch is in debian/source/options.  In order to
    # get it to generate debian/patches/debian-changes, it is
    # necessary to build the source package.

    # We "trust" dpkg-source to get this right, and in particular, to
    # complain about things it can't represent.  However, this is not
    # always the case.  See the test cases in tests/tests/unrepresentable
    # which have as outcome "LATE-EP:...".  When this happens, quilt fixup
    # succeeds and dgit push fails.  This is one of the reasons we
    # deprecate this in the docs.  In principle, we could do better by
    # rejecting these situations earlier, but we would need another
    # lot of recapitulation of dpkg-source behaviours.

    unpack_playtree_linkorigs($upstreamversion, sub { });
    unpack_playtree_need_cd_work($headref);

    rmdir_r("debian/patches");

    runcmd @dpkgsource, qw(--include-removal -b .);
    changedir "..";
    runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
    rename srcfn("$upstreamversion", "/debian/patches"), 
	"work/debian/patches"
	or $!==ENOENT
	or confess "install d/patches: $!";

    changedir "work";
    commit_quilty_patch();
}

sub quilt_fixup_git_singlepatch ($$$) {
    my ($clogp, $headref, $upstreamversion) = @_;

    progress f_ "regenerating patch using git diff (--quilt=%s)",
      $quilt_mode;

    my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
    changedir '..';

    my @unrepres;
    my $o2h = quiltify_trees_differ($unapplied,$headref, 1, undef,\@unrepres);
    unpack_playtree_need_cd_work($headref);

    quiltify_check_unrepresentable \@unrepres;

    rmdir_r("debian/patches");

    if ($o2h) {
	quiltify_make_dpkg_patch
	    $unapplied, $headref,
	    'dgit-changes', '', <<END, '';
Debian changes

The Debian packaging of $package is maintained in git, using a workflow
similar to the one described in dgit-maint-merge(7).
The Debian delta is represented by this one combined patch; there isn't a
patch queue that can be represented as a quilt series.

A detailed breakdown of the changes is available from their canonical
representation -- git commits in the packaging repository.
For example, to see the changes made by the Debian maintainer in the first
upload of upstream version 1.2.3, you could use:

    % git clone https://git.dgit.debian.org/$package
    % cd $package
    % git log --oneline 1.2.3..debian/1.2.3-1 -- . ':!debian'

(If you have dgit, use `dgit clone $package`, rather than plain `git clone`.)

We don't use debian/source/options single-debian-patch because it has bugs.
Therefore, NMUs etc. may nevertheless have made additional patches.
END
    }

    commit_quilty_patch();
}

sub quilt_need_fake_dsc ($) {
    # cwd should be playground
    my ($upstreamversion) = @_;

    return if stat_exists "fake.dsc";
    # ^ OK to test this as a sentinel because if we created it
    # we must either have done the rest too, or crashed.

    my $fakeversion="$upstreamversion-~~DGITFAKE";

    my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
    print $fakedsc <<END or confess "$!";
Format: 3.0 (quilt)
Source: $package
Version: $fakeversion
Files:
END

    my $dscaddfile=sub {
        my ($leaf) = @_;
        
	my $md = new Digest::MD5;

	my $fh = new IO::File $leaf, '<' or die "$leaf $!";
	stat $fh or confess "$!";
	my $size = -s _;

	$md->addfile($fh);
	print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
    };

    unpack_playtree_linkorigs($upstreamversion, $dscaddfile);

    my @files=qw(debian/source/format
                 debian/control debian/changelog);
    foreach my $maybe (qw(debian/patches debian/rules debian/source/options
			  debian/source/include-binaries
                          debian/tests/control)) {
        next unless stat_exists "$maindir/$maybe";
        push @files, $maybe;
    }
    if (open IB, "$maindir/debian/source/include-binaries") {
      BFILE: while (<IB>) {
	    s{^[ \t]*}{};
	    s{[ \t\n]*$}{};
	    next if m{^\#};
	    next unless length;
	    our $include_binaries_warning;
	    $include_binaries_warning++ or
	      print STDERR __
 "warning: package uses dpkg-source include-binaries feature - not all changes are visible in patches!\n";

	    my @bpath;
	    my $bfile_in = $_;
	    my $bpath_chk;
	    foreach my $ent (split m{/}, $bfile_in) {
		my $wrong = sub {
		    no warnings qw(exiting);
		    print STDERR f_
 "warning: ignoring bad include-binaries file %s: %s\n", $bfile_in, $_[0];
		    next BFILE;
		};
		$wrong->(f_ "forbidden path component '%s'", $ent)
		  if grep { $_ eq $ent } '', '.', '..';
		if (!@bpath) { # check first component
		  # dpkg-source doesn't like files in debian/ which it
		  # considers binary, so the user may have listed
		  # them.  We should silently ignore this.  #1026918.
		  if ($ent eq 'debian') {
		    no warnings qw(exiting);
		    next BFILE;
		  }
		  $wrong->(f_ "path starts with '%s'", $ent)
		    if grep { $_ eq $ent } qw(.git);
		}
		push @bpath, $ent;
		$bpath_chk = join '/', @bpath;
		if (!lstat "$maindir/$bpath_chk") {
		    confess "$maindir/$bpath_chk" unless $!==ENOENT;
		    next BFILE;
		} elsif (-f _ || -d _) {
		} else {
		    $wrong->(f_ "path to '%s' not a plain file or directory",
			     $bpath_chk);
		}
	    };
	    push @files, $bpath_chk;
	}
	IB->error and confess "$!";
	close IB;
    } else {
	$! == ENOENT || confess "$!";
    }

    my $debtar= srcfn $fakeversion,'.debian.tar';
    runcmd qw(tar -cf), "./$debtar", qw(-C), $maindir, @files;
    runcmd qw(gzip -1n), "./$debtar";

    $dscaddfile->("$debtar.gz");
    close $fakedsc or confess "$!";
}

sub quilt_fakedsc2unapplied ($$) {
    my ($headref, $upstreamversion) = @_;
    # must be run in the playground
    # quilt_need_fake_dsc must have been called

    quilt_need_fake_dsc($upstreamversion);
    runcmd qw(sh -ec),
        'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';

    my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
    rename $fakexdir, "fake" or die "$fakexdir $!";

    changedir 'fake';

    remove_stray_gits(__ "source package");
    mktree_in_ud_here();

    rmdir_r '.pc';

    rmdir_r '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";
    return $unapplied;
}    

sub quilt_check_splitbrain_cache ($$) {
    my ($headref, $upstreamversion) = @_;
    # Called only if we are in (potentially) split brain mode.
    # Called in playground.
    # Computes the cache key and looks in the cache.
    # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)

    quilt_need_fake_dsc($upstreamversion);

    my $splitbrain_cachekey;
    
    progress f_
 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
                $quilt_mode;
    # we look in the reflog of dgit-intern/quilt-cache
    # we look for an entry whose message is the key for the cache lookup
    my @cachekey = (qw(dgit), $our_version);
    push @cachekey, $upstreamversion;
    push @cachekey, $quilt_mode;
    push @cachekey, $headref;
    push @cachekey, $quilt_upstream_commitish // '-';

    push @cachekey, hashfile('fake.dsc');

    my $srcshash = Digest::SHA->new(256);
    my %sfs = ( %INC, '$0(dgit)' => $0 );
    foreach my $sfk (sort keys %sfs) {
	next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
	$srcshash->add($sfk,"  ");
	$srcshash->add(hashfile($sfs{$sfk}));
	$srcshash->add("\n");
    }
    push @cachekey, $srcshash->hexdigest();
    $splitbrain_cachekey = "@cachekey";

    printdebug "splitbrain cachekey $splitbrain_cachekey\n";

    my $cachehit = reflog_cache_lookup
	"refs/$splitbraincache", $splitbrain_cachekey;

    if ($cachehit) {
	unpack_playtree_need_cd_work($headref);
	my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
	if ($cachehit ne $headref) {
	    progress f_ "dgit view: found cached (%s)", $saved;
	    runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
	    $made_splitbrain_playtree = 1;
	    return ($cachehit, $splitbrain_cachekey);
	}
	progress __ "dgit view: found cached, no changes required";
	return ($headref, $splitbrain_cachekey);
    }

    printdebug "splitbrain cache miss\n";
    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) = @_;

    progress f_ "examining quilt state (multiple patches, %s mode)",
	        $quilt_mode;

    # Our objective is:
    #  - honour any existing .pc in case it has any strangeness
    #  - determine the git commit corresponding to the tip of
    #    the patch stack (if there is one)
    #  - if there is such a git commit, convert each subsequent
    #    git commit into a quilt patch, simulating dpkg-source --commit
    #  - otherwise convert all the differences in the tree into
    #    a single git commit
    #
    # To do this we:

    # So we need to find out what the tree for the tip of the patch
    # stack is.
    #     1. Collect all relevant .orig from parent directory
    #     2. Generate a debian.tar.gz out of
    #         debian/{patches,rules,source/format,source/options}
    #     3. Generate a fake .dsc containing just these fields:
    #          Format Source Version Files
    #     4. Extract the fake .dsc
    #
    # Then we can actually do the fake dpkg-source --commit.

    # Another situation we may have to cope with is gbp-style
    # patches-unapplied trees.
    #
    # We would want to detect these, so we know to escape into
    # quilt_fixup_gbp.  However, this is in general not possible.
    # Consider a package with a one patch which the dgit user reverts
    # (with git revert or the moral equivalent).
    #
    # That is indistinguishable in contents from a patches-unapplied
    # tree.  And looking at the history to distinguish them is not
    # useful because the user might have made a confusing-looking git
    # history structure (which ought to produce an error if dgit can't
    # cope, not a silent reintroduction of an unwanted patch).
    #
    # So gbp users will have to pass an option.  But we can usually
    # detect their failure to do so: if the tree is not a clean
    # patches-applied tree, quilt linearisation fails, but the tree
    # _is_ a clean patches-unapplied tree, we can suggest that maybe
    # they want --quilt=unapplied.
    #
    # To help detect this, when we are extracting the fake dsc, we
    # first extract it with --skip-patches, and then apply the patches
    # afterwards with dpkg-source --before-build.  That lets us save a
    # tree object corresponding to .origs.

    if ($quilt_mode eq 'linear'
	&& branch_is_gdr($headref)) {
	# This is much faster.  It also makes patches that gdr
	# likes better for future updates without laundering.
	#
	# However, it can fail in some casses where we would
	# succeed: if there are existing patches, which correspond
	# to a prefix of the branch, but are not in gbp/gdr
	# format, gdr will fail (exiting status 7), but we might
	# be able to figure out where to start linearising.  That
	# will be slower so hopefully there's not much to do.

	unpack_playtree_need_cd_work $headref;

	my @cmd = (@git_debrebase,
		   qw(--noop-ok -funclean-mixed -funclean-ordering
		      make-patches --quiet-would-amend));
	# We tolerate soe snags that gdr wouldn't, by default.
	if (act_local()) {
	    debugcmd "+",@cmd;
	    $!=0; $?=-1;
	    failedcmd @cmd
		if system @cmd
		and not ($? == 7*256 or
			 $? == -1 && $!==ENOENT);
	} else {
	    dryrun_report @cmd;
	}
	$headref = git_rev_parse('HEAD');

	changedir '..';
    }

    my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);

    ensuredir '.pc';

    my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
    $!=0; $?=-1;
    debugcmd "+",@bbcmd;
    if (system @bbcmd) {
	failedcmd @bbcmd if $? < 0;
	fail __ <<END;
failed to apply your git tree's patch stack (from debian/patches/) to
 the corresponding upstream tarball(s).  Your source tree and .orig
 are probably too inconsistent.  dgit can only fix up certain kinds of
 anomaly (depending on the quilt mode).  Please see --quilt= in dgit(1).
END
    }

    changedir '..';

    unpack_playtree_need_cd_work($headref);

    my $mustdeletepc=0;
    if (stat_exists ".pc") {
        -d _ or die;
	progress __ "Tree already contains .pc - will delete it.";
        $mustdeletepc=1;
    } else {
        rename '../fake/.pc','.pc' or confess "$!";
    }

    changedir '../fake';
    rmdir_r '.pc';
    my $oldtiptree=git_add_write_tree();
    printdebug "fake o+d/p tree object $unapplied\n";
    changedir '../work';


    # We calculate some guesswork now about what kind of tree this might
    # be.  This is mostly for error reporting.

    my $tentries = cmdoutput @git, qw(ls-tree --name-only -z), $headref;
    my $onlydebian = $tentries eq "debian\0";

    my $uheadref = $headref;
    my $uhead_whatshort = 'HEAD';

    if ($quilt_mode =~ m/baredebian\+tarball/) {
	# We need to make a tarball import.  Yuk.
	# We want to do this here so that we have a $uheadref value

	my @fakedfi;
	baredebian_origtarballs_scan \@fakedfi, $upstreamversion, bpd_abs();
	baredebian_origtarballs_scan \@fakedfi, $upstreamversion,
	    "$maindir/.." unless $buildproductsdir eq '..';
	changedir '..';

	my @tartrees = import_tarball_tartrees $upstreamversion, \@fakedfi;

	fail __ "baredebian quilt fixup: could not find any origs"
	    unless @tartrees;

	changedir 'work';
	my ($authline, $r1authline, $clogp,) =
	    import_tarball_commits \@tartrees, $upstreamversion;

	if (@tartrees == 1) {
	    $uheadref = $tartrees[0]{Commit};
	    # TRANSLATORS: this translation must fit in the ASCII art
	    # quilt differences display.  The untranslated display
	    # says %9.9s, so with that display it must be at most 9
	    # characters.
	    $uhead_whatshort = __ 'tarball';
	} else {
	    # on .dsc import we do not make a separate commit, but
	    # here we need to do so
	    rm_subdir_cached '.';
	    my $parents;
	    foreach my $ti (@tartrees) {
		my $c = $ti->{Commit};
		if ($ti->{OrigPart} eq 'orig') {
		    runcmd qw(git read-tree), $c;
		} elsif ($ti->{OrigPart} =~ m/orig-/) {
		    read_tree_subdir $', $c;
		} else {
		    confess "$ti->OrigPart} ?"
		}
		$parents .= "parent $c\n";
	    }
	    my $tree = git_write_tree();
	    my $mbody = f_ 'Combine orig tarballs for %s %s',
		$package, $upstreamversion;
	    $uheadref = hash_commit_text <<END;
tree $tree
${parents}author $r1authline
committer $r1authline

$mbody

[dgit import tarballs combine $package $upstreamversion]
END
	    # TRANSLATORS: this translation must fit in the ASCII art
	    # quilt differences display.  The untranslated display
	    # says %9.9s, so with that display it must be at most 9
	    # characters.  This fragmentt is referring to multiple
	    # orig tarballs in a source package.
	    $uhead_whatshort = __ 'tarballs';

	    runcmd @git, qw(reset -q);
	}
	$quilt_upstream_commitish = $uheadref;
	$quilt_upstream_commitish_used = '*orig*';
	$quilt_upstream_commitish_message = '';
    }
    if ($quilt_mode =~ m/baredebian$/) {
	$uheadref = $quilt_upstream_commitish;
	# TRANSLATORS: this translation must fit in the ASCII art
	# quilt differences display.  The untranslated display
	# says %9.9s, so with that display it must be at most 9
	# characters.
	$uhead_whatshort = __ 'upstream';
    }

    my %editedignores;
    my @unrepres;
    my $diffbits = {
        # H = user's HEAD
        # O = orig, without patches applied
        # A = "applied", ie orig with H's debian/patches applied
        O2H => quiltify_trees_differ($unapplied,$uheadref,   1,
				     \%editedignores, \@unrepres),
        H2A => quiltify_trees_differ($uheadref, $oldtiptree,1),
        O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
    };

    my @dl;
    foreach my $bits (qw(01 02)) {
        foreach my $v (qw(O2H O2A H2A)) {
            push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
        }
    }
    printdebug "differences \@dl @dl.\n";

    progress f_
"%s: base trees orig=%.20s o+d/p=%.20s",
              $us, $unapplied, $oldtiptree;
    # TRANSLATORS: Try to keep this ascii-art layout right.  The 0s in
    # %9.00009s will be ignored and are there to make the format the
    # same length (9 characters) as the output it generates.  If you
    # change the value 9, your translations of "upstream" and
    # 'tarball' must fit into the new length, and you should change
    # the number of 0s.  Do not reduce it below 4 as HEAD has to fit
    # too.
    progress f_
"%s: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
"%s: quilt differences: %9.00009s %s o+d/p          %9.00009s %s o+d/p",
  $us,                      $dl[0], $dl[1],              $dl[3], $dl[4],
  $us,        $uhead_whatshort, $dl[2],   $uhead_whatshort, $dl[5];

    quiltify_check_unrepresentable(\@unrepres);

    my @failsuggestion;
    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})) {
        push @failsuggestion, [ 'applied', __
 "This might be a patches-applied branch." ];
    }
    push @failsuggestion, [ 'quilt-mode', __
 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];

    push @failsuggestion, [ 'gitattrs', __
 "Warning: Tree has .gitattributes.  See GITATTRIBUTES in dgit(7)." ]
	if stat_exists '.gitattributes';

    push @failsuggestion, [ 'origs', __
 "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()]);

    if (!open P, '>>', ".pc/applied-patches") {
	$!==&ENOENT or confess "$!";
    } else {
	close P;
    }

    commit_quilty_patch();

    if ($mustdeletepc) {
        quilt_fixup_delete_pc();
    }
}

sub quilt_fixup_editor () {
    my $descfn = $ENV{$fakeeditorenv};
    my $editing = $ARGV[$#ARGV];
    open I1, '<', $descfn or confess "$descfn: $!";
    open I2, '<', $editing or confess "$editing: $!";
    unlink $editing or confess "$editing: $!";
    open O, '>', $editing or confess "$editing: $!";
    while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
    my $copying = 0;
    while (<I2>) {
	$copying ||= m/^\-\-\- /;
	next unless $copying;
	print O or confess "$!";
    }
    I2->error and confess "$!";
    close O or die $1;
    finish 0;
}

sub maybe_apply_patches_dirtily () {
    return unless $quilt_mode =~ m/gbp|unapplied|baredebian/;
    print STDERR __ <<END or confess "$!";

dgit: Building, or cleaning with rules target, in patches-unapplied tree.
dgit: Have to apply the patches - making the tree dirty.
dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)

END
    $patches_applied_dirtily = 01;
    $patches_applied_dirtily |= 02 unless stat_exists '.pc';
    runcmd qw(dpkg-source --before-build .);
}

sub maybe_unapply_patches_again () {
    progress __ "dgit: Unapplying patches again to tidy up the tree."
	if $patches_applied_dirtily;
    runcmd qw(dpkg-source --after-build .)
	if $patches_applied_dirtily & 01;
    rmdir_r '.pc'
	if $patches_applied_dirtily & 02;
    $patches_applied_dirtily = 0;
}

#----- other building -----

sub clean_tree_check_git ($$$) {
    my ($honour_ignores, $message, $ignmessage) = @_;
    my @cmd = (@git, qw(clean -dn));
    push @cmd, qw(-x) unless $honour_ignores;
    my $leftovers = cmdoutput @cmd;
    if (length $leftovers) {
	print STDERR $leftovers, "\n" or confess "$!";
	$message .= $ignmessage if $honour_ignores;
	fail $message;
    }
}

sub clean_tree_check_git_wd ($) {
    my ($message) = @_;
    return if $cleanmode =~ m{no-check};
    return if $patches_applied_dirtily; # yuk
    clean_tree_check_git +($cleanmode !~ m{all-check}),
	$message, "\n".__ <<END;
If this is just missing .gitignore entries, use a different clean
mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
or --clean=git (-wg/-wgf) to use \`git clean' instead.
END
}

sub clean_tree_check () {
    # This function needs to not care about modified but tracked files.
    # That was done by check_not_dirty, and by now we may have run
    # the rules clean target which might modify tracked files (!)
    if ($cleanmode =~ m{^check}) {
	clean_tree_check_git +($cleanmode =~ m{ignores}), __
 "tree contains uncommitted files and --clean=check specified", '';
    } elsif ($cleanmode =~ m{^dpkg-source}) {
	clean_tree_check_git_wd __
 "tree contains uncommitted files (NB dgit didn't run rules clean)";
    } elsif ($cleanmode =~ m{^git}) {
	clean_tree_check_git 1, __
 "tree contains uncommitted, untracked, unignored files\n".
 "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.\n".
 "To include them in the build, it is usually best to just commit them.", '';
    } elsif ($cleanmode eq 'none') {
    } else {
	confess "$cleanmode ?";
    }
}

sub clean_tree () {
    # We always clean the tree ourselves, rather than leave it to the
    # builder (dpkg-source, or something which calls dpkg-source).
    if ($quilt_mode =~ m/baredebian/ and $cleanmode =~ m/git/) {
	fail f_ <<END, $quilt_mode, $cleanmode;
quilt mode %s (generally needs untracked upstream files)
contradicts clean mode %s (which would delete them)
END
	# This is not 100% true: dgit build-source and push-source
	# (for example) could operate just fine with no upstream
	# source in the working tree.  But it doesn't seem likely that
	# the user wants dgit to proactively delete such things.
	# -wn, for example, would produce identical output without
	# deleting anything from the working tree.
    }
    if ($cleanmode =~ m{^dpkg-source}) {
	my @cmd = @dpkgbuildpackage;
	push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
	push @cmd, qw(-T clean);
	maybe_apply_patches_dirtily();
	runcmd_ordryrun_local @cmd;
	clean_tree_check_git_wd __
 "tree contains uncommitted files (after running rules clean)";
    } elsif ($cleanmode =~ m{^git(?!-)}) {
	runcmd_ordryrun_local @git, qw(clean -xdf);
    } elsif ($cleanmode =~ m{^git-ff}) {
	runcmd_ordryrun_local @git, qw(clean -xdff);
    } elsif ($cleanmode =~ m{^check}) {
	clean_tree_check();
    } elsif ($cleanmode eq 'none') {
    } else {
	confess "$cleanmode ?";
    }
}

sub cmd_clean () {
    badusage __ "clean takes no additional arguments" if @ARGV;
    notpushing();
    clean_tree();
    maybe_unapply_patches_again();
}

# return values from massage_dbp_args are one or both of these flags
sub WANTSRC_SOURCE  () { 01; } # caller should build source (separately)
sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage

sub build_or_push_prep_early () {
    our $build_or_push_prep_early_done //= 0;
    return if $build_or_push_prep_early_done++;
    my $clogp = parsechangelog();
    $isuite = getfield $clogp, 'Distribution';
    my $gotpackage = getfield $clogp, 'Source';
    $version = getfield $clogp, 'Version';
    $package //= $gotpackage;
    if ($package ne $gotpackage) {
	fail f_ "-p specified package %s, but changelog says %s",
	    $package, $gotpackage;
    }
    $dscfn = dscfn($version);
}

sub build_or_push_prep_modes () {
    my ($format, $fopts) = get_source_format();
    determine_whether_split_brain($format);

    fail __ "dgit: --include-dirty is not supported with split view".
            " (including with view-splitting quilt modes)"
	if do_split_brain() && $includedirty;

    if (grep m{^tar-ignore$}, @$fopts) {
      if ((cmdoutput qw(git ls-files :.gitignore :*/.gitignore)) ne '') {
	# The source package won't be faithful; bail with an explanation.
        fail __ <<'END';
tree has .gitignore(s) but debian/source/options has 'tar-ignore'
Try 'tar-ignore=.git' in d/s/options instead.  (See #908747.)
END
      } else {
	print STDERR f_ <<'END', $us;
%s: warning: debian/source/options contains bare 'tar-ignore'
This can cause .gitignore files to be improperly omitted.  See #908747.
END
      }
    }

    if (madformat_wantfixup $format and $quilt_mode =~ m/baredebian$/) {
	($quilt_upstream_commitish, $quilt_upstream_commitish_used,
	 $quilt_upstream_commitish_message)
	    = resolve_upstream_version
	    $quilt_upstream_commitish, upstreamversion $version;
	progress f_ "dgit: --quilt=%s, %s", $quilt_mode,
	    $quilt_upstream_commitish_message;
    } elsif (defined $quilt_upstream_commitish) {
	fail __
 "dgit: --upstream-commitish only makes sense with --quilt=baredebian"
    }
}

sub build_prep_early () {
    build_or_push_prep_early();
    notpushing();
    build_or_push_prep_modes();
    check_not_dirty();
}

sub build_prep ($) {
    my ($wantsrc) = @_;
    build_prep_early();
    check_bpd_exists();
    if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
	# Clean the tree because we're going to use the contents of
	# $maindir.  (We trying to include dirty changes in the source
	# package, or we are running the builder in $maindir.)
	|| $cleanmode =~ m{always}) {
	# Or because the user asked us to.
	clean_tree();
    } else {
	# We don't actually need to do anything in $maindir, but we
	# should do some kind of cleanliness check because (i) the
	# user may have forgotten a `git add', and (ii) if the user
	# said -wc we should still do the check.
	clean_tree_check();
    }
    build_check_quilt_splitbrain();
    if ($rmchanges) {
	my $pat = changespat $version;
	foreach my $f (glob "$buildproductsdir/$pat") {
	    if (act_local()) {
		unlink $f or
		    fail f_ "remove old changes file %s: %s", $f, $!;
	    } else {
		progress f_ "would remove %s", $f;
	    }
	}
    }
}

sub maybe_warn_opt_confusion ($$$) {
    my ($subcommand, $willrun, $optsref) = @_;
    foreach (@$optsref) {
	if (m/^(?: --dry-run  $
	         | --damp-run $
		 | --clean= | -w[gcnd]
		 | --(?:include|ignore)-dirty$
		 | --quilt= | --gbp$ | --dpm$ | --baredebian
		 | --split-view=
		 | --build-products-dir=
		 )/x) {
	    print STDERR f_ <<END, $&, $subcommand or die $!;
warning: dgit option %s must be passed before %s on dgit command line
END
	} elsif (m/^(?: -C
		      | --no-sign  $
		      | -k
		      )/x) {
	    print STDERR f_ <<END, $&, $subcommand, $willrun or die $!;
warning: option %s should probably be passed to dgit before %s sub-command on the dgit command line, so that it is seen by dgit and not simply passed to %s
END
	}
    }
}

sub changesopts_initial () {
    my @opts =@changesopts[1..$#changesopts];
}

sub changesopts_version () {
    if (!defined $changes_since_version) {
	my @vsns;
	unless (eval {
	    @vsns = archive_query('archive_query');
	    my @quirk = access_quirk();
	    if ($quirk[0] eq 'backports') {
		local $isuite = $quirk[2];
		local $csuite;
		canonicalise_suite();
		push @vsns, archive_query('archive_query');
	    }
	    1;
	}) {
	    print STDERR $@;
	    fail __
 "archive query failed (queried because --since-version not specified)";
	}
	if (@vsns) {
	    @vsns = map { $_->[0] } @vsns;
	    @vsns = sort { -version_compare($a, $b) } @vsns;
	    $changes_since_version = $vsns[0];
	    progress f_ "changelog will contain changes since %s", $vsns[0];
	} else {
	    $changes_since_version = '_';
	    progress __ "package seems new, not specifying -v<version>";
	}
    }
    if ($changes_since_version ne '_') {
	return ("-v$changes_since_version");
    } else {
	return ();
    }
}

sub changesopts () {
    return (changesopts_initial(), changesopts_version());
}

sub massage_dbp_args ($;$) {
    my ($cmd,$xargs) = @_;
    # Since we split the source build out so we can do strange things
    # to it, massage the arguments to dpkg-buildpackage so that the
    # main build doessn't build source (or add an argument to stop it
    # building source by default).
    debugcmd '#massaging#', @$cmd if $debuglevel>1;
    # -nc has the side effect of specifying -b if nothing else specified
    # and some combinations of -S, -b, et al, are errors, rather than
    # later simply overriding earlie.  So we need to:
    #  - search the command line for these options
    #  - pick the last one
    #  - perhaps add our own as a default
    #  - perhaps adjust it to the corresponding non-source-building version
    my $dmode = '-F';
    foreach my $l ($cmd, $xargs) {
	next unless $l;
	@$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
    }
    push @$cmd, '-nc';
#print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
    my $r = WANTSRC_BUILDER;
    printdebug "massage split $dmode.\n";
    if ($dmode =~ s/^--build=//) {
	$r = 0;
	my @d = split /,/, $dmode;
	$r |= WANTSRC_SOURCE  if grep { s/^full$/binary/ } @d;
	$r |= WANTSRC_SOURCE  if grep { s/^source$// } @d;
	$r |= WANTSRC_BUILDER if grep { m/./ } @d;
	fail __ "Wanted to build nothing!" unless $r;
	$dmode = '--build='. join ',', grep m/./, @d;
    } else {
	$r =
	  $dmode =~ m/[S]/     ?  WANTSRC_SOURCE :
	  $dmode =~ y/gGF/ABb/ ?  WANTSRC_SOURCE | WANTSRC_BUILDER :
	  $dmode =~ m/[ABb]/   ?                   WANTSRC_BUILDER :
	  confess "$dmode ?";
    }
    printdebug "massage done $r $dmode.\n";
    push @$cmd, $dmode;
#print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
    return $r;
}

sub in_bpd (&) {
    my ($fn) = @_;
    my $wasdir = must_getcwd();
    changedir $buildproductsdir;
    $fn->();
    changedir $wasdir;
}    

# this sub must run with CWD=$buildproductsdir (eg in in_bpd)
sub postbuild_mergechanges ($) {
    my ($msg_if_onlyone) = @_;
    # If there is only one .changes file, fail with $msg_if_onlyone,
    # or if that is undef, be a no-op.
    # Returns the changes file to report to the user.
    my $pat = changespat $version;
    my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
    @changesfiles = sort {
	($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
	    or $a cmp $b
    } @changesfiles;
    my $result;
    if (@changesfiles==1) {
	fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
only one changes file from build (%s)
END
	    if defined $msg_if_onlyone;
	$result = $changesfiles[0];
    } elsif (@changesfiles==2) {
	my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
	foreach my $l (split /\n/, getfield $binchanges, 'Files') {
	    fail f_ "%s found in binaries changes file %s", $l, $binchanges
		if $l =~ m/\.dsc$/;
	}
	runcmd_ordryrun_local @mergechanges, @changesfiles;
	my $multichanges = changespat $version,'multi';
	if (act_local()) {
	    stat_exists $multichanges or fail f_
		"%s unexpectedly not created by build", $multichanges;
	    foreach my $cf (glob $pat) {
		next if $cf eq $multichanges;
		rename "$cf", "$cf.inmulti" or fail f_
		    "install new changes %s\{,.inmulti}: %s", $cf, $!;
	    }
	}
	$result = $multichanges;
    } else {
	fail f_ "wrong number of different changes files (%s)",
	        "@changesfiles";
    }
    printdone f_ "build successful, results in %s\n", $result
	or confess "$!";
}

sub midbuild_checkchanges () {
    my $pat = changespat $version;
    return if $rmchanges;
    my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
    @unwanted = grep {
	$_ ne changespat $version,'source' and
	$_ ne changespat $version,'multi'
    } @unwanted;
    fail +(f_ <<END, $pat, "@unwanted")
changes files other than source matching %s already present; building would result in ambiguity about the intended results.
Suggest you delete %s.
END
	if @unwanted;
}

sub midbuild_checkchanges_vanilla ($) {
    my ($wantsrc) = @_;
    midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
}

sub postbuild_mergechanges_vanilla ($) {
    my ($wantsrc) = @_;
    if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
	in_bpd {
	    postbuild_mergechanges(undef);
	};
    } else {
	printdone __ "build successful\n";
    }
}

sub cmd_build {
    build_prep_early();
    maybe_warn_opt_confusion 'build', 'dpkg-buildpackage', \@ARGV;
    $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
%s: warning: build-products-dir set, but not supported by dpkg-buildpackage
%s: warning: build-products-dir will be ignored; files will go to ..
END
    $buildproductsdir = '..';
    my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
    my $wantsrc = massage_dbp_args \@dbp;
    build_prep($wantsrc);
    if ($wantsrc & WANTSRC_SOURCE) {
	build_source();
	midbuild_checkchanges_vanilla $wantsrc;
    }
    if ($wantsrc & WANTSRC_BUILDER) {
	push @dbp, changesopts_version();
	maybe_apply_patches_dirtily();
	runcmd_ordryrun_local @dbp;
    }
    maybe_unapply_patches_again();
    postbuild_mergechanges_vanilla $wantsrc;
}

sub pre_gbp_build {
    $quilt_mode //= 'gbp';
}

sub cmd_gbp_build {
    build_prep_early();
    maybe_warn_opt_confusion 'gbp-build', 'gbp buildpackage', \@ARGV;

    # gbp can make .origs out of thin air.  In my tests it does this
    # even for a 1.0 format package, with no origs present.  So I
    # guess it keys off just the version number.  We don't know
    # exactly what .origs ought to exist, but let's assume that we
    # should run gbp if: the version has an upstream part and the main
    # orig is absent.
    my $upstreamversion = upstreamversion $version;
    my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
    my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");

    if ($gbp_make_orig) {
	clean_tree();
	$cleanmode = 'none'; # don't do it again
    }

    my @dbp = @dpkgbuildpackage;

    my $wantsrc = massage_dbp_args \@dbp, \@ARGV;

    if (!length $gbp_build[0]) {
	if (length executable_on_path('git-buildpackage')) {
	    $gbp_build[0] = qw(git-buildpackage);
	} else {
	    $gbp_build[0] = 'gbp buildpackage';
	}
    }
    my @cmd = opts_opt_multi_cmd [], @gbp_build;

    push @cmd, (qw(-us -uc --git-no-sign-tags),
		"--git-builder=".(shellquote @dbp));

    if ($gbp_make_orig) {
	my $priv = dgit_privdir();
	my $ok = "$priv/origs-gen-ok";
	unlink $ok or $!==&ENOENT or confess "$!";
	my @origs_cmd = @cmd;
	push @origs_cmd, qw(--git-cleaner=true);
	push @origs_cmd, "--git-prebuild=".
            "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
	push @origs_cmd, @ARGV;
	if (act_local()) {
	    debugcmd @origs_cmd;
	    system @origs_cmd;
	    do { local $!; stat_exists $ok; }
		or failedcmd @origs_cmd;
	} else {
	    dryrun_report @origs_cmd;
	}
    }

    build_prep($wantsrc);
    if ($wantsrc & WANTSRC_SOURCE) {
	build_source();
	midbuild_checkchanges_vanilla $wantsrc;
    } else {
	push @cmd, '--git-cleaner=true';
    }
    maybe_unapply_patches_again();
    if ($wantsrc & WANTSRC_BUILDER) {
	push @cmd, changesopts();
	runcmd_ordryrun_local @cmd, @ARGV;
    }
    postbuild_mergechanges_vanilla $wantsrc;
}
sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0

sub building_source_in_playtree {
    # If $includedirty, we have to build the source package from the
    # working tree, not a playtree, so that uncommitted changes are
    # included (copying or hardlinking them into the playtree could
    # cause trouble).
    #
    # Note that if we are building a source package in split brain
    # mode we do not support including uncommitted changes, because
    # that makes quilt fixup too hard.  I.e. ($made_splitbrain_playtree && (dgit is
    # building a source package)) => !$includedirty
    return !$includedirty;
}

sub build_source {
    $sourcechanges = changespat $version,'source';
    if (act_local()) {
	unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
	    or fail f_ "remove %s: %s", $sourcechanges, $!;
    }

    my ($dtag, $dtag_t);
    if ($t2u_bmode) {
	# See if it's at all likely we'll find our debian/ tag.
	do_split_brain() or fail __
"--tag2upload-builder-mode needs split-brain mode";

	$dtag = debiantag_maintview $version, access_nomdistro;
	$dtag_t = git_get_ref "refs/tags/$dtag";

	fail __ "upstream tag and not commit, or vice-versa"
	  unless defined $t2u_upstream == defined $t2u_upstreamc;
    }

    my @cmd = (@dpkgsource, qw(-b --include-removal));
    my $leafdir;
    my $binfofn = srcfn($version, "_source.buildinfo");
    if (building_source_in_playtree()) {
	$leafdir = 'work';
        my $headref = git_rev_parse('HEAD');
        # If we are in split brain, there is already a playtree with
        # the thing we should package into a .dsc (thanks to quilt
        # fixup).  If not, make a playtree
        prep_ud() unless $made_splitbrain_playtree;
        changedir $playground;
        unless ($made_splitbrain_playtree) {
            my $upstreamversion = upstreamversion $version;
            unpack_playtree_linkorigs($upstreamversion, sub { });
            unpack_playtree_need_cd_work($headref);
            changedir '..';
        }

	# We are presenting dpkg-source with a tree with no .pc directory.
	# Without this option, dpkg-source tries to guess if it should
	# mess about (un)applying patches.  Depending on what precisely is
	# in the patches, it can guess wrong.
	push @cmd, qw(--no-preparation);

	if ($t2u_bmode) {
	    # We need to copy the maintainer & upstream tags into the
	    # playtree for mini-git-tag-fsck's consumption.
	    changedir $leafdir;
	    runcmd @git, qw(update-ref), "refs/tags/$dtag", $dtag_t;
	    runcmd @git, qw(update-ref), "refs/tags/$t2u_upstream",
	      $t2u_upstreamc if $t2u_upstream;
	    changedir '..';
	}

	runcmd @cmd, qw(--), $leafdir;
    } else {
        $leafdir = basename $maindir;

	if ($buildproductsdir ne '..') {
	    # Well, we are going to run dpkg-source -b which consumes
	    # origs from .. and generates output there.  To make this
	    # work when the bpd is not .. , we would have to (i) link
	    # origs from bpd to .. , (ii) check for files that
	    # dpkg-source -b would/might overwrite, and afterwards
	    # (iii) move all the outputs back to the bpd (iv) except
	    # for the origs which should be deleted from .. if they
	    # weren't there beforehand.  And if there is an error and
	    # we don't run to completion we would necessarily leave a
	    # mess.  This is too much.  The real way to fix this
	    # is for dpkg-source to have bpd support.
	    confess unless $includedirty;
	    fail __
 "--include-dirty not supported with --build-products-dir, sorry";
	}

        changedir '..';
	runcmd_ordryrun_local @cmd, qw(--), $leafdir;
    }
    $dsc = parsecontrol($dscfn, "source package");

    # We use dpkg-genchanges to generate the .changes.  We want to
    # pass -S.  However, that in that case, if there is a .git.tar.xz
    # in debian/files, dpkg-genchanges will ignore it.
    #
    # What we do is not pass -S in the case that we are adding a
    # .git.tar.xz.  This is safe because: we only need to add a
    # .git.tar.xz when in split brain mode because tag2upload is
    # always in that mode; if we are in split brain mode then we
    # always build in a playtree (see building_source_in_playtree());
    # and if we are indeed building in a playtree, then we will
    # certainly get a source-only changes, even if we don't pass -S.
    changedir $leafdir;
    my @gencmd = (qw(sh -ec),
		  'exec >../$1; shift; exec "$@"','x', $sourcechanges,
		  @dpkggenchanges, changesopts());
    if ($t2u_bmode) {
	building_source_in_playtree() or fail __
"--include-dirty not supported with --tag2upload-builder-mode";

	runcmd @dpkggenbuildinfo, qw(--build=source);

	# The aim of including a _source.buildinfo in tag2upload
	# uploads is to make it possible for a third party to
	# reproduce the .dsc (see #932802).  The most important
	# information for this not already likely to be have been
	# included in the _source.buildinfo is the versions of dgit
	# and dgit-infrastructure that were installed.  As the
	# tag2upload builder is already a system with only a minimal
	# set of packages installed, we just include everything.
	my $binfo = parsecontrol("../$binfofn",
				 __ "source-only buildinfo");
	chomp(my @all = split "\n", cmdoutput @dpkgquery,
	      qw(-W), '--showformat=${Package} (= ${Version})\n');
	$binfo->{"Installed-Build-Depends"} = "\n".join ",\n", @all;
	$binfo->save("../$binfofn") or confess "$!";

	my @cmd = (@mgtf, qw(--prepare --distro), access_nomdistro);
	push @cmd, "--upstream=$t2u_upstream",
	  "--upstream-commit=$t2u_upstreamc" if $t2u_upstream;
	runcmd @cmd;

	runcmd @gencmd;
    } else {
	push @gencmd, qw(-S);
	if (building_source_in_playtree()) {
	    runcmd @gencmd;
	} else {
	    runcmd_ordryrun_local @gencmd;
	}
    }
    changedir '..';

    printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";

    my $mv = sub {
	my ($why, $l) = @_;
        printdebug " renaming ($why) $l\n";
	return unless act_local();
        rename_link_xf 0, "$l", bpd_abs()."/$l"
	    or fail f_ "put in place new built file (%s): %s", $l, $@;
    };
    foreach my $l (split /\n/, getfield $dsc, 'Files') {
        $l =~ m/\S+$/ or next;
	$mv->('Files', $&);
    }
    $mv->('dsc', $dscfn);
    if ($t2u_bmode) {
	$mv->('buildinfo', $binfofn);
	$mv->('mgtf', srcfn($version,".git.tar.xz"));
    }
    $mv->('changes', $sourcechanges);

    changedir $maindir;
}

sub build_source_check_dsc_vs_git () {
    return if $includedirty; # well that's not going to work
    return unless access_cfg_bool(1, 'build-source-check-correspondence');

    my $dgithead = $dgitview_saved || git_rev_parse('HEAD');
    my $dscfn = dscfn $version;
    changedir $playground;
    check_dsc_vs_git $dscfn, $dgithead;
    changedir $maindir;
}

sub cmd_build_source {
    badusage __ "build-source takes no additional arguments" if @ARGV;
    build_prep(WANTSRC_SOURCE);
    build_source();
    maybe_unapply_patches_again();
    build_source_check_dsc_vs_git();
    printdone f_ "source built, results in %s and %s",
	         $dscfn, $sourcechanges;
}

sub cmd_push_source {
    prep_push();
    fail __
	"dgit push-source: --include-dirty/--ignore-dirty does not make".
	"sense with push-source!"
	if $includedirty;
    build_check_quilt_splitbrain();
    if ($changesfile) {
	fail __ "--tag2upload-builder-mode not supported with -C"
	  if $t2u_bmode;
        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();
	confess "er, patches are applied dirtily but shouldn't be.."
	    if $patches_applied_dirtily;
	$changesfile = $sourcechanges;
    }
    dopush();
}

sub binary_builder {
    my ($bbuilder, $pbmc_msg, @args) = @_;
    build_prep(WANTSRC_SOURCE);
    build_source();
    midbuild_checkchanges();
    in_bpd {
	if (act_local()) {
	    stat_exists $dscfn or fail f_
		"%s (in build products dir): %s", $dscfn, $!;
	    stat_exists $sourcechanges or fail f_
		"%s (in build products dir): %s", $sourcechanges, $!;
	}
	runcmd_ordryrun_local @$bbuilder, @args;
    };
    maybe_unapply_patches_again();
    in_bpd {
	postbuild_mergechanges($pbmc_msg);
    };
}

sub cmd_sbuild {
    build_prep_early();
    maybe_warn_opt_confusion 'sbuild', 'sbuild', \@ARGV;
    binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
perhaps you need to pass -A ?  (sbuild's default is to build only
arch-specific binaries; dgit 1.4 used to override that.)
END
}

sub pbuilder ($) {
    my ($pbuilder) = @_;
    build_prep_early();
    maybe_warn_opt_confusion 'pbuilder', 'pbuilder', \@ARGV;
    # @ARGV is allowed to contain only things that should be passed to
    # pbuilder under debbuildopts; just massage those
    my $wantsrc = massage_dbp_args \@ARGV;
    fail __
	"you asked for a builder but your debbuildopts didn't ask for".
	" any binaries -- is this really what you meant?"
	unless $wantsrc & WANTSRC_BUILDER;
    fail __
	"we must build a .dsc to pass to the builder but your debbuiltopts".
	" forbids the building of a source package; cannot continue"
      unless $wantsrc & WANTSRC_SOURCE;
    # We do not want to include the verb "build" in @pbuilder because
    # the user can customise @pbuilder and they shouldn't be required
    # to include "build" in their customised value.  However, if the
    # user passes any additional args to pbuilder using the dgit
    # option --pbuilder:foo, such args need to come after the "build"
    # verb.  opts_opt_multi_cmd does all of that.
    binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
                   qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
                   $dscfn);
}

sub cmd_pbuilder {
    pbuilder(\@pbuilder);
}

sub cmd_cowbuilder {
    pbuilder(\@cowbuilder);
}

sub cmd_quilt_fixup {
    badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
    build_prep_early();
    clean_tree();
    build_maybe_quilt_fixup();
}

sub cmd_print_unapplied_treeish {
    badusage __ "incorrect arguments to dgit print-unapplied-treeish"
	if @ARGV;
    my $headref = git_rev_parse('HEAD');
    my $clogp = commit_getclogp $headref;
    $package = getfield $clogp, 'Source';
    $version = getfield $clogp, 'Version';
    $isuite = getfield $clogp, 'Distribution';
    $csuite = $isuite; # we want this to be offline!
    notpushing();

    prep_ud();
    changedir $playground;
    my $uv = upstreamversion $version;
    my $u = quilt_fakedsc2unapplied($headref, $uv);
    print $u, "\n" or confess "$!";
}

sub import_dsc_result {
    my ($dstref, $newhash, $what_log, $what_msg) = @_;
    my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
    runcmd @cmd;
    check_gitattrs($newhash, __ "source tree");

    progress f_ "dgit: import-dsc: %s", $what_msg;
}

sub cmd_import_dsc {
    my $needsig = 0;

    while (@ARGV) {
	last unless $ARGV[0] =~ m/^-/;
	$_ = shift @ARGV;
	last if m/^--?$/;
	if (m/^--require-valid-signature$/) {
	    $needsig = 1;
	} else {
	    badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
	}
    }

    badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
	unless @ARGV==2;
    my ($dscfn, $dstbranch) = @ARGV;

    badusage __ "dry run makes no sense with import-dsc"
	unless act_local();

    my $force = $dstbranch =~ s/^\+//   ? +1 :
	        $dstbranch =~ s/^\.\.// ? -1 :
                                           0;
    my $info = $force ? " $&" : '';
    $info = "$dscfn$info";

    my $specbranch = $dstbranch;
    $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
    $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;

    my @symcmd = (@git, qw(symbolic-ref -q HEAD));
    my $chead = cmdoutput_errok @symcmd;
    defined $chead or $?==256 or failedcmd @symcmd;

    fail f_ "%s is checked out - will not update it", $dstbranch
	if defined $chead and $chead eq $dstbranch;

    my $oldhash = git_get_ref $dstbranch;

    open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
    $dscdata = do { local $/ = undef; <D>; };
    D->error and fail f_ "read %s: %s", $dscfn, $!;
    close C;

    # we don't normally need this so import it here
    use Dpkg::Source::Package;
    my $dp = new Dpkg::Source::Package filename => $dscfn,
      options => { require_valid_signature => $needsig };
    {
	local $SIG{__WARN__} = sub {
	    print STDERR $_[0];
	    return unless $needsig;
	    fail __ "import-dsc signature check failed";
	};
	if (!$dp->is_signed()) {
	    warn f_ "%s: warning: importing unsigned .dsc\n", $us;
	} else {
	    my $r = $dp->check_signature();
	    confess "->check_signature => $r" if $needsig && $r;
	}
    }

    parse_dscdata();

    $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 $dsc_hash | git cat-file --batch-check");
	my $objgot = cmdoutput @cmd;
	if ($objgot =~ m#^\w+ missing\b#) {
	    fail f_ <<END, $dsc_hash
.dsc contains Dgit field referring to object %s
Your git tree does not have that object.  Try `git fetch' from a
plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
END
	}
	if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
	    if ($force > 0) {
		progress __ "Not fast forward, forced update.";
	    } else {
		fail f_ "Not fast forward to %s", $dsc_hash;
	    }
	}
	import_dsc_result $dstbranch, $dsc_hash,
	    "dgit import-dsc (Dgit): $info",
	    f_ "updated git ref %s", $dstbranch;
	return 0;
    }

    fail f_ <<END, $dstbranch, $specbranch, $specbranch
Branch %s already exists
Specify ..%s for a pseudo-merge, binding in existing history
Specify  +%s to overwrite, discarding existing history
END
	if $oldhash && !$force;

    my @dfi = dsc_files_info();
    foreach my $fi (@dfi) {
	my $f = $fi->{Filename};
	# We transfer all the pieces of the dsc to the bpd, not just
	# origs.  This is by analogy with dgit fetch, which wants to
	# keep them somewhere to avoid downloading them again.
	# We make symlinks, though.  If the user wants copies, then
	# they can copy the parts of the dsc to the bpd using dcmd,
	# or something.
	my $here = "$buildproductsdir/$f";
	if (lstat $here) {
	    if (stat $here) {
		next;
	    }
	    fail f_ "lstat %s works but stat gives %s !", $here, $!;
	}
	fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
	printdebug "not in bpd, $f ...\n";
	# $f does not exist in bpd, we need to transfer it
	my $there = $dscfn;
	$there =~ s{[^/]+$}{$f} or confess "$there ?";
	# $there is file we want, relative to user's cwd, or abs
	printdebug "not in bpd, $f, test $there ...\n";
	stat $there or fail f_
	    "import %s requires %s, but: %s", $dscfn, $there, $!;
	if ($there =~ m#^(?:\./+)?\.\./+#) {
	    # $there is relative to user's cwd
	    my $there_from_parent = $';
	    if ($buildproductsdir !~ m{^/}) {
		# abs2rel, despite its name, can take two relative paths
		$there = File::Spec->abs2rel($there,$buildproductsdir);
		# now $there is relative to bpd, great
		printdebug "not in bpd, $f, abs2rel, $there ...\n";
	    } else {
		$there = (dirname $maindir)."/$there_from_parent";
		# now $there is absolute
		printdebug "not in bpd, $f, rel2rel, $there ...\n";
	    }
	} elsif ($there =~ m#^/#) {
	    # $there is absolute already
	    printdebug "not in bpd, $f, abs, $there ...\n";
	} else {
	    fail f_
		"cannot import %s which seems to be inside working tree!",
		$dscfn;
	}
	symlink $there, $here or fail f_
	    "symlink %s to %s: %s", $there, $here, $!;
	progress f_ "made symlink %s -> %s", $here, $there;
#	print STDERR Dumper($fi);
    }
    my @mergeinputs = generate_commits_from_dsc();
    die unless @mergeinputs == 1;

    my $newhash = $mergeinputs[0]{Commit};

    if ($oldhash) {
	if ($force > 0) {
	    progress __
		"Import, forced update - synthetic orphan git history.";
	} elsif ($force < 0) {
	    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 = hash_commit_text <<ENDU
tree $tree
parent $newhash
parent $oldhash
author $authline
committer $authline

ENDU
		.(f_ <<END, $package, $version, $dstbranch);
Merge %s (%s) import into %s
END
	} else {
	    die; # caught earlier
	}
    }

    import_dsc_result $dstbranch, $newhash,
	"dgit import-dsc: $info",
	f_ "results are in git ref %s", $dstbranch;
}

sub pre_archive_api_query () {
    not_necessarily_a_tree();
}
sub cmd_archive_api_query {
    badusage __ "need only 1 subpath argument" unless @ARGV==1;
    my ($subpath) = @ARGV;
    local $isuite = 'DGIT-API-QUERY-CMD';
    my $json = api_query_raw $subpath;
    print $json or die "$!";
}

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;
    my $url = repos_server_url();
    my @cmd = (@git, qw(clone), $url, $destdir);
    debugcmd ">",@cmd;
    exec @cmd or fail f_ "exec git clone: %s\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 confess "$!";
}

sub unfetched_origs_identify_by_suite ($) {
    my ($uversion) = @_;

    get_archive_dsc();
    if (!$dsc) {
	print STDERR __
	  "package does not exist in target suite, looking in whole archive\n";
	return undef;
    }

    my $dsc_uversion = upstreamversion getfield $dsc, 'Version';
    if ($dsc_uversion ne $uversion) {
	print STDERR f_
	  "package in target suite is different upstream version, %s\n",
	  $dsc_uversion;
	return undef;
    }

    my @dsc_files = dsc_files_info();
    my @origs = ();
    foreach my $fi (@dsc_files) {
	next unless is_orig_file_in_dsc $fi->{Filename}, \@dsc_files;
	push @origs, $fi;
    }
    if (!@origs) {
	print STDERR __ "suite has this upstream version, but no origs\n";
	finish 4;
    }

    print STDERR __ "suite has origs for this upstream version\n";
    return \@origs;
}

sub unfetched_origs_whole_archive_search ($) {
    my ($uversion) = @_;
    my $u_f_version = stripepoch $uversion;
    my $pat = source_file_leafname $package, $u_f_version, '.orig*.tar.*';
    my $info = archive_query('file_in_archive', $pat);

    printdebug "package $package, orig filename version $u_f_version\n";

    my %by_comp;
    foreach my $ent (@$info) {
	printdebug "considering $ent->{sha256sum} $ent->{filename} ";
	$ent->{filename} =~ m{
            ^ (?: .* / )?
            \Q$package\E _ \Q$u_f_version\E
            \. ($orig_f_comp_re) \. .* $
        }x or ((printdebug "irrelevant\n"), next);
	my $comp = $1;
	printdebug " ours, $comp\n";
	push @{ $by_comp{$1} }, $ent;
    }

    if (!%by_comp) {
	print STDERR f_ "no .origs for package %s upstream version %s\n",
	  $package, $uversion;
	finish 4;
    }
    my $mirror = access_cfg('mirror');

    # Convert from ftpmaster API schema to .dsc-ish dsc_files_info schema
    my @origs = ();
    # Also, check that each comp (FOO for orig_FOO) has only one .orig.
    # This ought to prevent us from accidentally mixing origs from
    # different uploads, since any upload which has a different set of
    # secondary origs ought to have a different primary orig too.
    my $ambiguous = 0;
    foreach my $comp (sort keys %by_comp) {
	my $ents = $by_comp{$comp};
	foreach my $ent (@$ents) {
	    my $leaf =  $ent->{filename}; $leaf =~ s{.*/}{};
	    my $rel_path = "pool/$ent->{component}/$ent->{filename}";
	    my $url = $mirror.$rel_path;
	    # We're hardcoding the hash as SHA-256, because that's
	    # what the fptmaster API currently provides.  If and when
	    # we want to change this, more complex code will be needed here.
	    push @origs, {
		Hash => $ent->{sha256sum},
		Digester => Digest::SHA->new(256),
		DigestName => 'sha256sum',
		Filename => $leaf,
		Url => $url,
            }
	}
	if (@$ents != 1) {
	    print STDERR f_
	      "multiple possibilities for orig component %s:\n",
	      $comp;
	    foreach my $ent (@$ents) {
		# Don't try to translate this, so no f_.
		print STDERR
		  "  $ent->{component}: $ent->{sha256sum} $ent->{filename}\n";
	    }
	    $ambiguous++;
	}
    }

    if ($ambiguous) {
	print STDERR __
	  "failed to resolve, unambiguously, which .origs are intended\n";
	finish 5;
    }

    return \@origs;
}

sub cmd_download_unfetched_origs {
    my $write_checksums = '/dev/null';

    while (@ARGV && $ARGV[0] =~ m/^-/) {
	$_ = shift @ARGV;
	if ($_ eq '--') {
	    last;
	} elsif (s/^--write-sha256sums=//) {
	    $write_checksums = $_;
	} else {
	    badusage f_
	      "unknown long option to download-unfetched-origs \`%s'", $_;
	}
    }
    badusage __ "download-unfetched-origs takes no non-option arguments"
      if @ARGV;

    open CHECKSUMS, ">", $write_checksums or die "open $write_checksums: $!";

    my $clogp = parsechangelog();
    $isuite = getfield $clogp, 'Distribution';
    my $uversion = upstreamversion getfield $clogp, 'Version';
    $package //= getfield $clogp, 'Source';

    notpushing();

    my $origs =
      unfetched_origs_identify_by_suite($uversion) //
      unfetched_origs_whole_archive_search($uversion);

    # Write out checksums for our caller (in case we don't obtain them!)
    foreach my $fi (@$origs) {
	confess $fi->{DigestName} unless $fi->{DigestName} eq 'sha256sum';
	printf CHECKSUMS "%s  %s\n", $fi->{Hash}, $fi->{Filename}
	  or die $!;
    }
    close CHECKSUMS or die $!;

    my $missing;
    foreach my $fi (@$origs) {
	my $found = complete_file_from_dsc $buildproductsdir, $fi, undef, 1;
	if ($found < 0) {
	    $missing++;
	    print f_
		  "orig file is missing (404) at archive mirror: %s\n",
		  $fi->{Url};
	    next;
	}
    }

    if ($missing) {
	print STDERR f_ "%d orig file(s) could not be obtained\n", $missing;
	finish 3;
    }
}

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 confess "$!";
}

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-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();
}

#---------- argument parsing and main program ----------

sub cmd_version {
    # We don't let DGIT_VERSION influence anything else
    # (eg commits we generate), just the --version output.
    my $v = $ENV{DGIT_VERSION} // $our_version;
    print "dgit version $v\n" or confess "$!";
    finish 0;
}

our (%valopts_long, %valopts_short);
our (%funcopts_long);
our @rvalopts;
our (@modeopt_cfgs);

sub defvalopt ($$$$) {
    my ($long,$short,$val_re,$how) = @_;
    my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
    $valopts_long{$long} = $oi;
    $valopts_short{$short} = $oi;
    # $how subref should:
    #   do whatever assignment or thing it likes with $_[0]
    #   if the option should not be passed on to remote, @rvalopts=()
    # or $how can be a scalar ref, meaning simply assign the value
}

defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
defvalopt '--distro',        '-d', '.+',      \$idistro;
defvalopt '',                '-k', '.+',      \$keyid;
defvalopt '--existing-package','', '.*',      \$existing_package;
defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
defvalopt '--package',   '-p',   $package_re, \$package;
defvalopt '--expect-suite','',     $suite_re, \$expected_suite;
defvalopt '--expect-version','',   '.+',      \$expected_version;
defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
# See comment next to --tag2upload-builder-mode option impl, below.
defvalopt '--t2u-upstream','','.+',           \$t2u_upstream;
defvalopt '--t2u-upstream-commit','','.+',    \$t2u_upstreamc;

defvalopt '', '-C', '.+', sub {
    ($changesfile) = (@_);
    if ($changesfile =~ s#^(.*)/##) {
	$buildproductsdir = $1;
    }
};

defvalopt '--initiator-tempdir','','.*', sub {
    ($initiator_tempdir) = (@_);
    $initiator_tempdir =~ m#^/# or
	badusage __ "--initiator-tempdir must be used specify an".
	            " absolute, not relative, directory."
};

# We leave validating the field names to Dpkg::Control::Hash.
#
# We abbreviate `t2u`, so the options are --t2u-*-add;
# see comment next to --tag2upload-builder-mode, below.
foreach my $abbrev (qw(dsc ch t2u)) {
    defvalopt "--$abbrev-control-add", '', '([^=]+)=(.+)',
      sub { $control_add{$abbrev}{$1} = $2 };
}

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;

    my $oi;
    my $val;
    my $valopt = sub {
	my ($what) = @_;
	@rvalopts = ($_);
	if (!defined $val) {
	    badusage f_ "%s needs a value", $what unless @ARGV;
	    $val = shift @ARGV;
	    push @rvalopts, $val;
	}
	badusage f_ "bad value \`%s' for %s", $val, $what unless
	    $val =~ m/^$oi->{Re}$(?!\n)/s;
	my $how = $oi->{How};
	if (ref($how) eq 'SCALAR') {
	    $$how = $val;
	} else {
	    $how->($val);
	}
	push @ropts, @rvalopts;
    };

    # Empty out each of the builtin commands-we-call.
    # This lets us capture ad-hoc settings of eg @dgit
    # in the option parser, and turn them into entries
    # in @cmd_opts_opts.  See parseopts_cmd_opts_resolve.
    @$_ = () foreach values %opts_opt_map;
    # Doing it like this means we can simply append to @somecmd here
    # in the option parser, without further fuss.  (Adjustments other
    # than appending won't work at all.)

    while (@ARGV) {
	last unless $ARGV[0] =~ m/^-/;
	$_ = shift @ARGV;
	last if m/^--?$/;
	if (m/^--/) {
	    if (m/^--dry-run$/) {
		push @ropts, $_;
		$dryrun_level=2;
	    } elsif (m/^--damp-run$/) {
		push @ropts, $_;
		$dryrun_level=1;
	    } elsif (m/^--no-sign$/) {
		push @ropts, $_;
		$sign=0;
	    } elsif (m/^--help$/) {
		cmd_help();
	    } elsif (m/^--version$/) {
		cmd_version();
	    } elsif (m/^--new$/) {
		push @ropts, $_;
		$new_package=1;
	    } elsif (m/^--([-0-9a-z]+)(=|:|!:)(.+)/s && $opts_opt_map{$1}) {
		push @ropts, $_;
		push @cmd_opts_opts, $_;
	    } elsif (m/^--($quilt_options_re)$/s) {
		push @ropts, "--quilt=$1";
		$quilt_mode = $1;
	    } elsif (m/^--(?:ignore|include)-dirty$/s) {
		push @ropts, $_;
		$includedirty = 1;
	    } elsif (m/^--no-quilt-fixup$/s) {
		push @ropts, $_;
		$quilt_mode = 'nocheck';
	    } 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/^--collab-non-dgit$/s) {
		push @ropts, $_;
		$overwrite_version = '';
		$splitview_mode = 'always';
	    } elsif (m/^(?:--trust-changelog|--overwrite)$/s) {
		push @ropts, '--overwrite'; # TODO, eventually, change this
		$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/^--dep14tag-reuse=($dep14tag_reuse_re)$/s) {
		push @ropts, $_;
		$dep14tag_reuse = $1;
	    } elsif (m/^--(no-)?dep14tag-verify$/s) {
		push @ropts, $_;
		$dep14tag_verify = !$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
		     ) {
		my ($k,$v) = ($1,$2);
		push @ropts, $_;
		$v =~ s#^(?!refs/)#refs/heads/#;
		$internal_object_save{$k} = $v;
	    } elsif (m/^--(no-)?keep-playground$/s) {
		push @ropts, $_;
		$keep_playground = !$1;
	    } elsif (m/^--(no-)?rm-old-changes$/s) {
		push @ropts, $_;
		$rmchanges = !$1;
	    } elsif (m/^--deliberately-($deliberately_re)$/s) {
		push @ropts, $_;
		push @deliberatelies, $&;
	    } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
		push @ropts, $&;
		$forceopts{$1} = 1;
		$_='';
	    } elsif (m/^--force-/) {
		print STDERR
		    f_ "%s: warning: ignoring unknown force option %s\n",
		       $us, $_;
		$_='';
	    } elsif (m/^--for-push$/s) {
		push @ropts, $_;
		$access_forpush = 1;
	    } elsif (/^--tag2upload-builder-mode$/) {
		# All tag2upload-specific private options are --t2u-*,
		# except this one, where we spell it out for clarity.
		#
		# --tag2upload-builder-mode (and therefore $t2u_bmode)
		# should not imply any options which change the behaviour
		# in a way that would be relevant for a local repro:
		#
		# That way the logs in tag2upload email reports are clear,
		# and useful for a local repro attempt
		# omitting t2u-specific private options.
		push @ropts, $_;
		$t2u_bmode = 1;
	    } elsif (/^--allow-unrelated-histories$/) {
		push @ropts, $_;
		$allow_unrelated_histories = 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 f_ "unknown long option \`%s'", $_;
	    }
	} else {
	    while (m/^-./s) {
		if (s/^-n/-/) {
		    push @ropts, $&;
		    $dryrun_level=2;
		} elsif (s/^-L/-/) {
		    push @ropts, $&;
		    $dryrun_level=1;
		} elsif (s/^-h/-/) {
		    cmd_help();
		} elsif (s/^-D/-/) {
		    push @ropts, $&;
		    $debuglevel++;
		    enabledebug();
		} elsif (s/^-N/-/) {
		    push @ropts, $&;
		    $new_package=1;
		} elsif (m/^-m/) {
		    push @ropts, $&;
		    push @changesopts, $_;
		    $_ = '';
		} elsif (s/^-wn$//s) {
		    push @ropts, $&;
		    $cleanmode = 'none';
		} elsif (s/^-wg(f?)(a?)$//s) {
		    push @ropts, $&;
		    $cleanmode = 'git';
		    $cleanmode .= '-ff' if $1;
		    $cleanmode .= ',always' if $2;
		} elsif (s/^-wd(d?)([na]?)$//s) {
		    push @ropts, $&;
		    $cleanmode = 'dpkg-source';
		    $cleanmode .= '-d' if $1;
		    $cleanmode .= ',no-check' if $2 eq 'n';
		    $cleanmode .= ',all-check' if $2 eq 'a';
		} elsif (s/^-wc$//s) {
		    push @ropts, $&;
		    $cleanmode = 'check';
		} elsif (s/^-wci$//s) {
		    push @ropts, $&;
		    $cleanmode = 'check,ignores';
		} elsif (s/^-c([^=]*)\=(.*)$//s) {
		    push @git, '-c', "$1=$2";
		    push @ropts, $&;
		    $gitcfgs{cmdline}{$1} = [ $2 ];
		} elsif (s/^-c([^=]+)$//s) {
		    push @git, '-c', $1;
		    push @ropts, $&;
		    $gitcfgs{cmdline}{$1} = [ 'true' ];
		} elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
		    $val = $'; #';
		    $val = undef unless length $val;
		    $valopt->($oi->{Short});
		    $_ = '';
		} else {
		    badusage f_ "unknown short option \`%s'", $_;
		}
	    }
	}
    }

    foreach my $cmd (keys %opts_opt_map) {
	foreach my $added (@{ $opts_opt_map{$cmd} }) {
	    push @cmd_opts_opts, "--${cmd}&${added}";
	}
    }

    parseopts_cmd_opts_resolve(sub {});
}

sub check_env_sanity () {
    my $blocked = new POSIX::SigSet;
    sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";

    eval {
	foreach my $name (qw(PIPE CHLD)) {
	    my $signame = "SIG$name";
	    my $signum = eval "POSIX::$signame" // die;
	    die f_ "%s is set to something other than SIG_DFL\n",
		$signame
		if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
	    $blocked->ismember($signum) and
		die f_ "%s is blocked\n", $signame;
	}
    };
    return unless $@;
    chomp $@;
    fail f_ <<END, $@;
On entry to dgit, %s
This is a bug produced by something in your execution environment.
Giving up.
END
}

sub parseopts_cmd_opts_resolve ($) {
    # Resolve cfg and options into the arrays referenced by %opts_opt_map
    #
    # We need to do this (at least) twice: once before we know our access cfg,
    # so that commands we run to *determine* the access cfg can be affected,
    # and once when we do (in parseopts_late_defaults).
    # (We mustn't call access_cfg too early.)
    # And, parseopts_late_defaults can be called more than once.
    #
    # So, we redo the calculation from the beginning, having saved
    # the built-in-defaults in $opts_opt_orig{$k};
    #
    # $from_config->($k, $om) should update @$om for command $k
    # (or be a no-op if we're not looking at access_cfg yet).
    my ($from_config) = @_;

    foreach my $k (keys %opts_opt_map) {
	my @om = @{ $opts_opt_orig{$k} };
	printcmd \*DEBUG, "COO RESET", $k, @om if $debuglevel >= 4;
	$from_config->($k, \@om);
	@{ $opts_opt_map{$k} } = @om;
    }

    if (defined $ENV{'DGIT_SSH'}) {
	@ssh = string_to_ssh $ENV{'DGIT_SSH'};
	printcmd \*DEBUG, "COO DGIT_SSH", @ssh if $debuglevel >= 3;
    } elsif (defined $ENV{'GIT_SSH'}) {
	@ssh = ($ENV{'GIT_SSH'});
	printcmd \*DEBUG, "COO GIT_SSH", @ssh if $debuglevel >= 3;
    }

    foreach (@cmd_opts_opts) {
	m/=|:|!:|\&/ or confess;
	my ($k, $mode, $v) = ($`, $&, $');
	$k =~ s/^\-\-// // confess "$k ?";
	my $om = $opts_opt_map{$k} // confess "$k ?";

	printcmd \*DEBUG, "COO OPT BEFORE", $k, @$om if $debuglevel >= 3;

	if ($mode eq '=') {
	    length $om->[0] or badusage f_
 "unsupported option \`%s', cannot set command for %s (can only provide options)",
                $_, $k;
	    $om->[0] = $v;
	} elsif ($mode eq ':') {
	    !$opts_opt_cmdonly{$k} or badusage f_
 "unsupported option \`%s', cannot provide additional options for %s (can only provide replacement command)",
                $_, $k;
	    push @$om, $v;
	} elsif ($mode eq '&') { # internal, set only at the end of parseopts
	    push @$om, $v;
	} elsif ($mode eq '!:') {
	    !$opts_opt_cmdonly{$k} or badusage f_
 "unsupported option \`%s', cannot adjust options for %s (can only provide replacement command)",
                $_, $k;
	    my $cmd = shift @$om;
	    @$om = ($cmd, grep { $_ ne $v } @$om);
	} else {
	    confess "$mode ?";
	}

	printcmd \*DEBUG, "COO OPT AFTER", $k, @$om if $debuglevel >= 3;
    }

    if ($debuglevel >= 4) {
	foreach my $k (keys %opts_opt_map) {
	    printcmd \*DEBUG, "COO FINAL", $k, @{ $opts_opt_map{$k} };
	}
    }
}

sub parseopts_late_defaults () {
    printdebug "parseopts_late_defaults()\n" if $debuglevel >= 3;

    $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
	if defined $idistro;
    $isuite //= cfg('dgit.default.default-suite');

    parseopts_cmd_opts_resolve(sub {
        my ($k, $om) = @_;

	my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
	if (defined $v) {
	    printcmd \*DEBUG, "COO CFG CMD", $k, $v if $debuglevel >= 3;
	    badcfg f_
	        "cannot set command for %s (can only provide options)",
	        $k
		unless length $om->[0];
	    $om->[0] = $v;
	}

	my %done;
	foreach my $c (access_cfg_cfgs("opts-$k")) {
	    # Look only once at each actual cfg.
	    # This scheme is not great for non-idempotent options,
	    # but we try to avoid making it break unnecessarily.
	    next if $done{$c}++;

	    my @vl =
		map { $_ ? @$_ : () }
		map { $gitcfgs{$_}{$c} }
		reverse @gitcfgsources;
	    printcmd \*DEBUG, "CL $c ", @vl if $debuglevel >= 4;
	    next unless @vl;
	    printcmd \*DEBUG, "COO CFG OPTS $c", @vl if $debuglevel >= 3;
	    badcfg f_
 "cannot configure options for %s (can only provide replacement command)",
                $k
		if $opts_opt_cmdonly{$k};

	    push @$om, @vl;
	}
    });

    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 f_ "unknown quilt-mode \`%s'", $quilt_mode;
	$quilt_mode = $1;
    }
    $quilt_mode =~ s/^(baredebian)\+git$/$1/;
    $quilt_mode =~ s/^auto$/try-linear/;

    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 f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
	    unless defined $v;
	$$vr = $v;
    }

    {
	local $access_forpush;
	default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
				$cleanmode_re);
    }

    if ($t2u_bmode && $dep14tag_reuse && $dep14tag_reuse ne 'must') {
	badusage __
	  "--tag2upload-builder-mode implies --dep14tag-reuse=must";
    } elsif ($t2u_bmode) {
	$dep14tag_reuse = 'must';
    } else {
	$dep14tag_reuse //= access_cfg('dep14tag-reuse', 'RETURN-UNDEF');
	$dep14tag_reuse //= 'if-exists';
	$dep14tag_reuse =~ m{^$dep14tag_reuse_re$} or badcfg f_
	  "unknown dep14tag-reuse mode \`%s'", $dep14tag_reuse;
    }

    $dep14tag_verify //= access_cfg_bool(0, 'dep14tag-verify');
    $dep14tag_verify //= 0;

    $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
    $buildproductsdir //= '..';
    $bpd_glob = $buildproductsdir;
    $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
}

setlocale(LC_MESSAGES, "");
textdomain("dgit");

if ($ENV{$fakeeditorenv}) {
    git_slurp_config();
    quilt_fixup_editor();
}

parseopts();
check_env_sanity();

print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
    if $dryrun_level == 1;
if (!@ARGV) {
    print STDERR __ $helpmsg or confess "$!";
    finish 8;
}
$cmd = $subcommand = shift @ARGV;
my $orig_cmd = $cmd;
$cmd =~ y/-/_/;

my $pre_fn = ${*::}{"pre_$cmd"};
$pre_fn->() if $pre_fn;

if ($invoked_in_git_tree) {
    changedir_git_toplevel();
    record_maindir();
}
git_slurp_config();

my $fn = ${*::}{"cmd_$cmd"};
$fn or badusage f_ "unknown operation %s", $orig_cmd;
$fn->();

changedir '/'; # rmdir_r complains if our cwd is inside what we remove
rmdir_r $playground if defined($playground) && !$keep_playground;

finish 0;
