New import: Entirely new import algorithm

[dgit.git] / dgit

#!/usr/bin/perl -w
# dgit
# Integration between git and Debian-style archives
#
# Copyright (C)2013-2015 Ian Jackson
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# 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 <http://www.gnu.org/licenses/>.

use strict;

use Debian::Dgit;
setup_sigwarn();

use IO::Handle;
use Data::Dumper;
use LWP::UserAgent;
use Dpkg::Control::Hash;
use File::Path;
use File::Temp qw(tempdir);
use File::Basename;
use Dpkg::Version;
use POSIX;
use IPC::Open2;
use Digest::SHA;
use Digest::MD5;
use List::Util qw(any);
use List::MoreUtils qw(pairwise);
use Carp;

use Debian::Dgit;

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

our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
our $protovsn;

our $isuite = 'unstable';
our $idistro;
our $package;
our @ropts;

our $sign = 1;
our $dryrun_level = 0;
our $changesfile;
our $buildproductsdir = '..';
our $new_package = 0;
our $ignoredirty = 0;
our $rmonerror = 1;
our @deliberatelies;
our %previously;
our $existing_package = 'dpkg';
our $cleanmode;
our $changes_since_version;
our $rmchanges;
our $overwrite_version; # undef: not specified; '': check changelog
our $quilt_mode;
our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
our $we_are_responder;
our $initiator_tempdir;
our $patches_applied_dirtily = 00;
our $tagformat_want;
our $tagformat;
our $tagformatfn;

our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");

our $suite_re = '[-+.0-9a-z]+';
our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';

our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
our $splitbraincache = 'dgit-intern/quilt-cache';

our (@git) = qw(git);
our (@dget) = qw(dget);
our (@curl) = qw(curl -f);
our (@dput) = qw(dput);
our (@debsign) = qw(debsign);
our (@gpg) = qw(gpg);
our (@sbuild) = qw(sbuild);
our (@ssh) = 'ssh';
our (@dgit) = qw(dgit);
our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
our (@dpkggenchanges) = qw(dpkg-genchanges);
our (@mergechanges) = qw(mergechanges -f);
our (@gbp) = qw(gbp);
our (@changesopts) = ('');

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,
                     'dpkg-source' => \@dpkgsource,
                     'dpkg-buildpackage' => \@dpkgbuildpackage,
                     'dpkg-genchanges' => \@dpkggenchanges,
                     'gbp' => \@gbp,
                     'ch' => \@changesopts,
                     'mergechanges' => \@mergechanges);

our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
our %opts_cfg_insertpos = map {
    $_,
    scalar @{ $opts_opt_map{$_} }
} keys %opts_opt_map;

sub finalise_opts_opts();

our $keyid;

autoflush STDOUT 1;

our $supplementary_message = '';
our $need_split_build_invocation = 0;
our $split_brain = 0;

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

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

sub debiantag ($$) {
    my ($v,$distro) = @_;
    return $tagformatfn->($v, $distro);
}

sub debiantag_maintview ($$) { 
    my ($v,$distro) = @_;
    $v =~ y/~:/_%/;
    return "$distro/$v";
}

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

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

sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }

# We fetch some parts of lrfetchrefs/*.  Ideally we delete these
# locally fetched refs because they have unhelpful names and clutter
# up gitk etc.  So we track whether we have "used up" head ref (ie,
# whether we have made another local ref which refers to this object).
#
# (If we deleted them unconditionally, then we might end up
# re-fetching the same git objects each time dgit fetch was run.)
#
# So, leach use of lrfetchrefs needs to be accompanied by arrangements
# in git_fetch_us to fetch the refs in question, and possibly a call
# to lrfetchref_used.

our (%lrfetchrefs_f, %lrfetchrefs_d);
# $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid

sub lrfetchref_used ($) {
    my ($fullrefname) = @_;
    my $objid = $lrfetchrefs_f{$fullrefname};
    $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
}

sub stripepoch ($) {
    my ($vsn) = @_;
    $vsn =~ s/^\d+\://;
    return $vsn;
}

sub srcfn ($$) {
    my ($vsn,$sfx) = @_;
    return "${package}_".(stripepoch $vsn).$sfx
}

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 ($?);
    foreach my $f (@end) {
        eval { $f->(); };
        print STDERR "$us: cleanup: $@" if length $@;
    }
};

sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }

sub no_such_package () {
    print STDERR "$us: package $package does not exist in suite $isuite\n";
    exit 4;
}

sub changedir ($) {
    my ($newdir) = @_;
    printdebug "CD $newdir\n";
    chdir $newdir or confess "chdir: $newdir: $!";
}

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

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

sub quiltmode_splitbrain () {
    $quilt_mode =~ m/gbp|dpm|unapplied/;
}

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

# remote push initiator/responder protocol:
#  $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
#  where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
#  < dgit-remote-push-ready <actual-proto-vsn>
#
# occasionally:
#
#  > progress NBYTES
#  [NBYTES message]
#
#  > supplementary-message NBYTES          # $protovsn >= 3
#  [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 old|new
#  > param maint-view MAINT-VIEW-HEAD
#
#  > previously REFNAME=OBJNAME       # if --deliberately-not-fast-forward
#                                     # goes into tag, for replay prevention
#
#  > want signed-tag
#  [indicates that signed tag is wanted]
#  < data-block NBYTES
#  < [NBYTES bytes of data (no newline)]
#  [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]
#  < files-end
#
#  > complete

our $i_child_pid;

sub i_child_report () {
    # 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, WNOHANG;
    return undef if $got <= 0;
    die unless $got == $i_child_pid;
    $i_child_pid = undef;
    return undef unless $?;
    return "build host child ".waitstatusmsg();
}

sub badproto ($$) {
    my ($fh, $m) = @_;
    fail "connection lost: $!" if $fh->error;
    fail "protocol violation; $m not expected";
}

sub badproto_badread ($$) {
    my ($fh, $wh) = @_;
    fail "connection lost: $!" if $!;
    my $report = i_child_report();
    fail $report if defined $report;
    badproto $fh, "eof (reading $wh)";
}

sub protocol_expect (&$) {
    my ($match, $fh) = @_;
    local $_;
    $_ = <$fh>;
    defined && chomp or badproto_badread $fh, "protocol message";
    if (wantarray) {
        my @r = &$match;
        return @r if @r;
    } else {
        my $r = &$match;
        return $r if $r;
    }
    badproto $fh, "\`$_'";
}

sub protocol_send_file ($$) {
    my ($fh, $ourfn) = @_;
    open PF, "<", $ourfn or die "$ourfn: $!";
    for (;;) {
        my $d;
        my $got = read PF, $d, 65536;
        die "$ourfn: $!" unless defined $got;
        last if !$got;
        print $fh "data-block ".length($d)."\n" or die $!;
        print $fh $d or die $!;
    }
    PF->error and die "$ourfn $!";
    print $fh "data-end\n" or die $!;
    close PF;
}

sub protocol_read_bytes ($$) {
    my ($fh, $nbytes) = @_;
    $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
    my $d;
    my $got = read $fh, $d, $nbytes;
    $got==$nbytes or badproto_badread $fh, "data block";
    return $d;
}

sub protocol_receive_file ($$) {
    my ($fh, $ourfn) = @_;
    printdebug "() $ourfn\n";
    open PF, ">", $ourfn or die "$ourfn: $!";
    for (;;) {
        my ($y,$l) = protocol_expect {
            m/^data-block (.*)$/ ? (1,$1) :
            m/^data-end$/ ? (0,) :
            ();
        } $fh;
        last unless $y;
        my $d = protocol_read_bytes $fh, $l;
        print PF $d or die $!;
    }
    close PF or die $!;
}

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

sub responder_send_command ($) {
    my ($command) = @_;
    return unless $we_are_responder;
    # called even without $we_are_responder
    printdebug ">> $command\n";
    print PO $command, "\n" or die $!;
}    

sub responder_send_file ($$) {
    my ($keyword, $ourfn) = @_;
    return unless $we_are_responder;
    printdebug "]] $keyword $ourfn\n";
    responder_send_command "file $keyword";
    protocol_send_file \*PO, $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) {
        protocol_receive_file \*PI, $fn;
    }
    printdebug "[[\$\n";
    protocol_expect { m/^files-end$/ } \*PI;
}

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

sub initiator_expect (&) {
    my ($match) = @_;
    protocol_expect { &$match } \*RO;
}

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

sub progress {
    if ($we_are_responder) {
        my $m = join '', @_;
        responder_send_command "progress ".length($m) or die $!;
        print PO $m or die $!;
    } else {
        print @_, "\n";
    }
}

our $ua;

sub url_get {
    if (!$ua) {
        $ua = LWP::UserAgent->new();
        $ua->env_proxy;
    }
    my $what = $_[$#_];
    progress "downloading $what...";
    my $r = $ua->get(@_) or die $!;
    return undef if $r->code == 404;
    $r->is_success or fail "failed to fetch $what: ".$r->status_line;
    return $r->decoded_content(charset => 'none');
}

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

sub runcmd {
    debugcmd "+",@_;
    $!=0; $?=-1;
    failedcmd @_ if system @_;
}

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

sub printdone {
    if (!$dryrun_level) {
        progress "dgit ok: @_";
    } else {
        progress "would be ok: @_ (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 @_;
    }
}

sub shell_cmd {
    my ($first_shell, @cmd) = @_;
    return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
}

our $helpmsg = <<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] push [dgit-opts] [suite]
  dgit [dgit-opts] rpush 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 = <<END;
Perhaps the upload is stuck in incoming.  Using the version from git.
END

sub badusage {
    print STDERR "$us: @_\n", $helpmsg or die $!;
    exit 8;
}

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

sub cmd_help () {
    print $helpmsg or die $!;
    exit 0;
}

our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";

our %defcfg = ('dgit.default.distro' => 'debian',
               '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.dgit-tag-format' => 'old,new,maint',
               # old means "repo server accepts pushes with old dgit tags"
               # new means "repo server accepts pushes with new dgit tags"
               # maint means "repo server accepts split brain pushes"
               # hist means "repo server may have old pushes without new tag"
               #   ("hist" is implied by "old")
               '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.dgit-tag-format' => 'new',
               'dgit-distro.debian/push.git-url' => '',
               'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
               'dgit-distro.debian/push.git-user-force' => 'dgit',
               'dgit-distro.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.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.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' => "ftpmasterapi:",
               '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 %gitcfg;

sub git_slurp_config () {
    local ($debuglevel) = $debuglevel-2;
    local $/="\0";

    my @cmd = (@git, qw(config -z --get-regexp .*));
    debugcmd "|",@cmd;

    open GITS, "-|", @cmd or die $!;
    while (<GITS>) {
        chomp or die;
        printdebug "=> ", (messagequote $_), "\n";
        m/\n/ or die "$_ ?";
        push @{ $gitcfg{$`} }, $'; #';
    }
    $!=0; $?=0;
    close GITS
        or ($!==0 && $?==256)
        or failedcmd @cmd;
}

sub git_get_config ($) {
    my ($c) = @_;
    my $l = $gitcfg{$c};
    printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
        if $debuglevel >= 4;
    $l or return undef;
    @$l==1 or badcfg "multiple values for $c" if @$l > 1;
    return $l->[0];
}

sub cfg {
    foreach my $c (@_) {
        return undef if $c =~ /RETURN-UNDEF/;
        my $v = git_get_config($c);
        return $v if defined $v;
        my $dv = $defcfg{$c};
        return $dv if defined $dv;
    }
    badcfg "need value for one of: @_\n".
        "$us: distro or suite appears not to be (properly) supported";
}

sub access_basedistro () {
    if (defined $idistro) {
        return $idistro;
    } else {    
        return cfg("dgit-suite.$isuite.distro",
                   "dgit.default.distro");
    }
}

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 "$what needs t (true, y, 1) or f (false, n, 0) not \`$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 pushing () {
    die "$access_forpush ?" if ($access_forpush // 1) ne 1;
    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
    finalise_opts_opts();
}

sub notpushing () {
    finalise_opts_opts();
}

sub supplementary_message ($) {
    my ($msg) = @_;
    if (!$we_are_responder) {
        $supplementary_message = $msg;
        return;
    } elsif ($protovsn >= 3) {
        responder_send_command "supplementary-message ".length($msg)
            or die $!;
        print PO $msg or die $!;
    }
}

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;

    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 parsecontrolfh ($$;$) {
    my ($fh, $desc, $allowsigned) = @_;
    our $dpkgcontrolhash_noissigned;
    my $c;
    for (;;) {
        my %opts = ('name' => $desc);
        $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
        $c = Dpkg::Control::Hash->new(%opts);
        $c->parse($fh,$desc) or die "parsing of $desc failed";
        last if $allowsigned;
        last if $dpkgcontrolhash_noissigned;
        my $issigned= $c->get_option('is_pgp_signed');
        if (!defined $issigned) {
            $dpkgcontrolhash_noissigned= 1;
            seek $fh, 0,0 or die "seek $desc: $!";
        } elsif ($issigned) {
            fail "control file $desc is (already) PGP-signed. ".
                " Note that dgit push needs to modify the .dsc and then".
                " do the signature itself";
        } else {
            last;
        }
    }
    return $c;
}

sub parsecontrol {
    my ($file, $desc) = @_;
    my $fh = new IO::Handle;
    open $fh, '<', $file or die "$file: $!";
    my $c = parsecontrolfh($fh,$desc);
    $fh->error and die $!;
    close $fh;
    return $c;
}

sub getfield ($$) {
    my ($dctrl,$field) = @_;
    my $v = $dctrl->{$field};
    return $v if defined $v;
    fail "missing field $field in ".$dctrl->get_option('name');
}

sub parsechangelog {
    my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
    my $p = new IO::Handle;
    my @cmd = (qw(dpkg-parsechangelog), @_);
    open $p, '-|', @cmd or die $!;
    $c->parse($p);
    $?=0; $!=0; close $p or failedcmd @cmd;
    return $c;
}

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;
    mkpath '.git/dgit';
    my $mclog = ".git/dgit/clog-$objid";
    runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
        "$objid:debian/changelog";
    $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
}

sub must_getcwd () {
    my $d = getcwd();
    defined $d or fail "getcwd failed: $!";
    return $d;
}

our %rmad;

sub archive_query ($) {
    my ($method) = @_;
    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 pool_dsc_subpath ($$) {
    my ($vsn,$component) = @_; # $package is implict arg
    my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
    return "/pool/$component/$prefix/$package/".dscfn($vsn);
}

#---------- `ftpmasterapi' archive query method (nascent) ----------

sub archive_api_query_cmd ($) {
    my ($subpath) = @_;
    my @cmd = qw(curl -sS);
    my $url = access_cfg('archive-query-url');
    if ($url =~ m#^https://([-.0-9a-z]+)/#) {
        my $host = $1;
        my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
        foreach my $key (split /\:/, $keys) {
            $key =~ s/\%HOST\%/$host/g;
            if (!stat $key) {
                fail "for $url: stat $key: $!" unless $!==ENOENT;
                next;
            }
            fail "config requested specific TLS key but do not know".
                " how to get curl to use exactly that EE key ($key)";
#           push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
#           # Sadly the above line does not work because of changes
#           # to gnutls.   The real fix for #790093 may involve
#           # new curl options.
            last;
        }
        # Fixing #790093 properly will involve providing a value
        # for this on clients.
        my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
        push @cmd, split / /, $kargs if defined $kargs;
    }
    push @cmd, $url.$subpath;
    return @cmd;
}

sub api_query ($$) {
    use JSON;
    my ($data, $subpath) = @_;
    badcfg "ftpmasterapi archive query method takes no data part"
        if length $data;
    my @cmd = archive_api_query_cmd($subpath);
    my $json = cmdoutput @cmd;
    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 "unknown suite $isuite" unless @matched;
    my $cn;
    eval {
        @matched==1 or die "multiple matches for suite $isuite\n";
        $cn = "$matched[0]{codename}";
        defined $cn or die "suite $isuite info has no codename\n";
        $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
    };
    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 "bad version: $msg\n" 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 @rows;
}

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

sub archive_query_madison {
    return 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
        "unable to canonicalise suite using package $package".
        " which does not appear to exist in suite $isuite;".
        " --existing-package may help";
    return $r[0][2];
}

#---------- `sshpsql' archive query method ----------

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 die $!;
    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 @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];
}

#---------- `dummycat' archive query method ----------

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 sort { -version_compare($a->[0],$b->[0]); } @rows;
}

#---------- tag format handling ----------

sub access_cfg_tagformats () {
    split /\,/, access_cfg('dgit-tag-format');
}

sub need_tagformat ($$) {
    my ($fmt, $why) = @_;
    fail "need to use tag format $fmt ($why) but also need".
        " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
        " - no way to proceed"
        if $tagformat_want && $tagformat_want->[0] ne $fmt;
    $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
}

sub select_tagformat () {
    # sets $tagformatfn
    return if $tagformatfn && !$tagformat_want;
    die 'bug' if $tagformatfn && $tagformat_want;
    # ... $tagformat_want assigned after previous select_tagformat

    my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
    printdebug "select_tagformat supported @supported\n";

    $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
    printdebug "select_tagformat specified @$tagformat_want\n";

    my ($fmt,$why,$override) = @$tagformat_want;

    fail "target distro supports tag formats @supported".
        " but have to use $fmt ($why)"
        unless $override
            or grep { $_ eq $fmt } @supported;

    $tagformat_want = undef;
    $tagformat = $fmt;
    $tagformatfn = ${*::}{"debiantag_$fmt"};

    fail "trying to use unknown tag format \`$fmt' ($why) !"
        unless $tagformatfn;
}

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

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

sub get_archive_dsc () {
    canonicalise_suite();
    my @vsns = archive_query('archive_query');
    foreach my $vinfo (@vsns) {
        my ($vsn,$subpath,$digester,$digest) = @$vinfo;
        $dscurl = access_cfg('mirror').$subpath;
        $dscdata = url_get($dscurl);
        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 "$dscurl has hash $got but".
                    " archive told us to expect $digest";
        }
        my $dscfh = new IO::File \$dscdata, '<' or die $!;
        printdebug Dumper($dscdata) if $debuglevel>1;
        $dsc = parsecontrolfh($dscfh,$dscurl,1);
        printdebug Dumper($dsc) if $debuglevel>1;
        my $fmt = getfield $dsc, 'Format';
        fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
        $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 "diverting to $divert (using config for $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 @cmd = (qw(curl -sS -I), $url);
        my $result = cmdoutput @cmd;
        $result =~ s/^\S+ 200 .*\n\r?\n//;
        # curl -sS -I with https_proxy prints
        # HTTP/1.0 200 Connection established
        $result =~ m/^\S+ (404|200) /s or
            fail "unexpected results from git check query - ".
                Dumper($prefix, $result);
        my $code = $1;
        if ($code eq '404') {
            return 0;
        } elsif ($code eq '200') {
            return 1;
        } else {
            die;
        }
    } elsif ($how eq 'true') {
        return 1;
    } elsif ($how eq 'false') {
        return 0;
    } else {
        badcfg "unknown git-check \`$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 "unknown git-create \`$how'";
    }
}

our ($dsc_hash,$lastpush_mergeinput);

our $ud = '.git/dgit/unpack';

sub prep_ud (;$) {
    my ($d) = @_;
    $d //= $ud;
    rmtree($d);
    mkpath '.git/dgit';
    mkdir $d or die $!;
}

sub mktree_in_ud_here () {
    runcmd qw(git init -q);
    runcmd qw(git config gc.auto 0);
    rmtree('.git/objects');
    symlink '../../../../objects','.git/objects' or die $!;
}

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

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

sub mktree_in_ud_from_only_subdir (;$) {
    my ($raw) = @_;

    # changes into the subdir
    my (@dirs) = <*/.>;
    die "expected one subdir but found @dirs ?" unless @dirs==1;
    $dirs[0] =~ m#^([^/]+)/\.$# or die;
    my $dir = $1;
    changedir $dir;

    remove_stray_gits();
    mktree_in_ud_here();
    if (!$raw) {
        my ($format, $fopts) = get_source_format();
        if (madformat($format)) {
            rmtree '.pc';
        }
    }

    runcmd @git, qw(add -Af);
    my $tree=git_write_tree();
    return ($tree,$dir);
}

sub dsc_files_info () {
    foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
                       ['Checksums-Sha1',  'Digest::SHA', 'new(1)'],
                       ['Files',           'Digest::MD5', 'new()']) {
        my ($fname, $module, $method) = @$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 "could not parse .dsc $fname line \`$_'";
            my $digester = eval "$module"."->$method;" or die $@;
            push @out, {
                Hash => $1,
                Bytes => $2,
                Filename => $3,
                Digester => $digester,
            };
        }
        return @out;
    }
    fail "missing any supported Checksums-* or Files field in ".
        $dsc->get_option('name');
}

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

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(?:-\w+)?\.tar(?:\.\w+)?$/;
    return 1;
}

sub is_orig_file_of_vsn ($$) {
    my ($f, $upstreamvsn) = @_;
    my $base = srcfn $upstreamvsn, '';
    return 0 unless $f =~ m/^\Q$base\E\.orig(?:-\w+)?\.tar(?:\.\w+)?$/;
    return 1;
}

sub make_commit ($) {
    my ($file) = @_;
    return cmdoutput @git, qw(hash-object -w -t commit), $file;
}

sub make_commit_text ($) {
    my ($text) = @_;
    my ($out, $in);
    my @cmd = (@git, qw(hash-object -w -t commit --stdin));
    debugcmd "|",@cmd;
    print Dumper($text) if $debuglevel > 1;
    my $child = open2($out, $in, @cmd) or die $!;
    my $h;
    eval {
        print $in $text or die $!;
        close $in or die $!;
        $h = <$out>;
        $h =~ m/^\w+$/ or die;
        $h = $&;
        printdebug "=> $h\n";
    };
    close $out;
    waitpid $child, 0 == $child or die "$child $!";
    $? and failedcmd @cmd;
    return $h;
}

sub clogp_authline ($) {
    my ($clogp) = @_;
    my $author = getfield $clogp, 'Maintainer';
    $author =~ s#,.*##ms;
    my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
    my $authline = "$author $date";
    $authline =~ m/$git_authline_re/o or
        fail "unexpected commit author line format \`$authline'".
        " (was generated from changelog Maintainer field)";
    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) {
        die "$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 "Found active distro-specific series file for".
            " $checkdistro ($what): $series, cannot continue";
    }
    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(),
                          "distro being accessed");
}

sub generate_commits_from_dsc () {
    # See big comment in fetch_from_archive, below.
    prep_ud();
    changedir $ud;

    my @dfi = dsc_files_info();
    foreach my $fi (@dfi) {
        my $f = $fi->{Filename};
        die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;

        link_ltarget "../../../$f", $f
            or $!==&ENOENT
            or die "$f $!";

        complete_file_from_dsc('.', $fi)
            or next;

        if (is_orig_file_in_dsc($f, \@dfi)) {
            link $f, "../../../../$f"
                or $!==&EEXIST
                or die "$f $!";
        }
    }

    # We unpack and record the orig tarballs first, so that we only
    # need disk space for one private copy of the unpacked source.
    # But we can't make them into commits until we have the metadata
    # from the debian/changelog, so we record the tree objects now and
    # make them into commits later.
    my @tartrees;
    my $upstreamv = $dsc->{version};
    $upstreamv =~ s/-[^-]+$//;
    my $orig_f_base = srcfn $upstreamv, '';

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

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

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

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

        my $input = new IO::File $f, '<' or die "$f $!";
        my $compr_pid;
        my @compr_cmd;

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

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

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

        runcmd qw(chmod -R +rwX ../unpack-tar);
        changedir "../unpack-tar";
        my ($tree) = mktree_in_ud_from_only_subdir(1);
        changedir "../../unpack";
        rmtree "../unpack-tar";

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

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

    my $any_orig = grep { $_->{Orig} } @tartrees;

    my $dscfn = "$package.dsc";

    my $treeimporthow = 'package';

    open D, ">", $dscfn or die "$dscfn: $!";
    print D $dscdata or die "$dscfn: $!";
    close D or die "$dscfn: $!";
    my @cmd = qw(dpkg-source);
    push @cmd, '--no-check' if $dsc_checked;
    if (madformat $dsc->{format}) {
        push @cmd, '--skip-patches';
        $treeimporthow = 'unpatched';
    }
    push @cmd, qw(-x --), $dscfn;
    runcmd @cmd;

    my ($tree,$dir) = mktree_in_ud_from_only_subdir();
    if (madformat $dsc->{format}) { 
        check_for_vendor_patches();
    }

    my $dappliedtree;
    if (madformat $dsc->{format}) {
        my @pcmd = qw(dpkg-source --before-build .);
        runcmd shell_cmd 'exec >/dev/null', @pcmd;
        rmtree '.pc';
        runcmd @git, qw(add -Af);
        $dappliedtree = git_write_tree();
    }

    my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
    debugcmd "|",@clogcmd;
    open CLOGS, "-|", @clogcmd or die $!;

    my $clogp;
    my $r1clogp;

    for (;;) {
        my $stanzatext = do { local $/=""; <CLOGS>; };
        last if !defined $stanzatext;

        my $desc = "package changelog, entry no.$.";
        open my $stanzafh, "<", \$stanzatext or die;
        my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
        $clogp //= $thisstanza;

        last if !$any_orig; # we don't need $r1clogp

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

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

        last if version_compare($thisstanza->{version}, $upstreamv) < 0;
        $r1clogp = $thisstanza;
    }
    die $! if CLOGS->error;
    close CLOGS or $?==(SIGPIPE<<8) or failedcmd @clogcmd;

    $clogp or fail "package changelog has no entries!";

    my $authline = clogp_authline $clogp;
    my $changes = getfield $clogp, 'Changes';
    my $cversion = getfield $clogp, 'Version';

    if (@tartrees) {
        $r1clogp //= $clogp; # maybe there's only one entry;
        my $r1authline = clogp_authline $r1clogp;
        # Strictly, r1authline might now be wrong if it's going to be
        # unused because !$any_orig.  Whatever.

        foreach my $tt (@tartrees) {
            $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
tree $tt->{Tree}
author $r1authline
committer $r1authline

Import $tt->{F}

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

Import $tt->{F}

[dgit import tarball $package $cversion $tt->{F}]
END_T
        }
    }

    open C, ">../commit.tmp" or die $!;
    print C <<END or die $!;
tree $tree
END
    print C <<END or die $! foreach @tartrees;
parent $_->{Commit}
END
    print C <<END or die $!;
author $authline
committer $authline

$changes

[dgit import $treeimporthow $package $cversion]
END

    close C or die $!;
    my $rawimport_hash = make_commit qw(../commit.tmp);

    if (madformat $dsc->{format}) {
        # regularise the state of the working tree so that
        # the checkout of $rawimport_hash works nicely.
        my $dappliedcommit = make_commit_text(<<END);
tree $dappliedtree
author $authline
committer $authline

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

        runcmd @git, qw(checkout -b unpa), $rawimport_hash;
        runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
        my $gapplied = git_rev_parse('HEAD');
        my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
        $gappliedtree eq $dappliedtree or
            fail <<END;
gbp-pq import and dpkg-source disagree!
 gbp-pq import gave commit $gapplied
 gbp-pq import gave tree $gappliedtree
 dpkg-source --before-build gave tree $dappliedtree
END
        $rawimport_hash = $gapplied;
    }

    progress "synthesised git commit from .dsc $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,
                { Message => <<END, ReverseParents => 1 });
Record $package ($cversion) in archive suite $csuite
END
        } elsif ($vcmp > 0) {
            print STDERR <<END or die $!;

Version actually in archive:   $cversion (older)
Last version pushed with dgit: $oversion (newer or same)
$later_warning_msg
END
            @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 '../../../..';
    rmtree($ud);
    return @output;
}

sub complete_file_from_dsc ($$) {
    our ($dstdir, $fi) = @_;
    # Ensures that we have, in $dir, the file $fi, with the correct
    # contents.  (Downloading it from alongside $dscurl if necessary.)

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

    if (stat_exists $tf) {
        progress "using existing $f";
    } else {
        my $furl = $dscurl;
        $furl =~ s{/[^/]+$}{};
        $furl .= "/$f";
        die "$f ?" unless $f =~ m/^\Q${package}\E_/;
        die "$f ?" if $f =~ m#/#;
        runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
        return 0 if !act_local();
        $downloaded = 1;
    }

    open F, "<", "$tf" or die "$tf: $!";
    $fi->{Digester}->reset();
    $fi->{Digester}->addfile(*F);
    F->error and die $!;
    my $got = $fi->{Digester}->hexdigest();
    $got eq $fi->{Hash} or
        fail "file $f has hash $got but .dsc".
            " demands hash $fi->{Hash} ".
            ($downloaded ? "(got wrong file from archive!)"
             : "(perhaps you should delete this file?)");

    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('..', $fi)
            or next;
    }
}

sub git_fetch_us () {
    # Want to fetch only what we are going to use, unless
    # deliberately-not-ff, in which case we must fetch everything.

    my @specs = deliberately_not_fast_forward ? qw(tags/*) :
        map { "tags/$_" }
        (quiltmode_splitbrain
         ? (map { $_->('*',access_basedistro) }
            \&debiantag_new, \&debiantag_maintview)
         : debiantags('*',access_basedistro));
    push @specs, server_branch($csuite);
    push @specs, qw(heads/*) if deliberately_not_fast_forward;

    # 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.

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

    my $fetch_iteration = 0;
    FETCH_ITERATION:
    for (;;) {
        if (++$fetch_iteration > 10) {
            fail "too many iterations trying to get sane fetch!";
        }

        my @look = map { "refs/$_" } @specs;
        my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
        debugcmd "|",@lcmd;

        my %wantr;
        open GITLS, "-|", @lcmd or die $!;
        while (<GITLS>) {
            printdebug "=> ", $_;
            m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
            my ($objid,$rrefname) = ($1,$2);
            if (!$wanted_rref->($rrefname)) {
                print STDERR <<END;
warning: git-ls-remote @look reported $rrefname; 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 {
            return () if !m/\*$/ && !exists $wantr{"refs/$_"};
            "+refs/$_:".lrfetchrefs."/$_";
        } @specs;

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

        %lrfetchrefs_f = ();
        my %objgot;

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

        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 <<END
warning: git-fetch @fspecs created $lrefname; 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}) {
                print STDERR <<END;
warning: git-ls-remote suggests we want $lrefname
warning:  and it should refer to $want
warning:  but git-fetch didn't fetch that object to any relevant ref.
warning:  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;
    }
    printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
        Dumper(\%lrfetchrefs_f);

    my %here;
    my @tagpats = debiantags('*',access_basedistro);

    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 \
                "Not updateting $lref from $here{$lref} to $objid.\n";
        }
    });
}

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 () {
    # 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) {
        foreach my $field (@ourdscfield) {
            $dsc_hash = $dsc->{$field};
            last if defined $dsc_hash;
        }
        if (defined $dsc_hash) {
            $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
            $dsc_hash = $&;
            progress "last upload to archive specified git hash";
        } else {
            progress "last upload to archive has NO git hash";
        }
    } 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 brach 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 die $!;
            }
            printf $gur "delete %s %s\n", $fullrefname, $objid;
        }
        if ($gur) {
            close $gur or failedcmd "git update-ref delete lrfetchrefs";
        }
    };

    if (defined $dsc_hash) {
        fail "missing remote git history even though dsc has hash -".
            " could not find ref ".rref()." at ".access_giturl()
            unless $lastpush_hash;
        ensure_we_have_orig();
        if ($dsc_hash eq $lastpush_hash) {
            @mergeinputs = $dsc_mergeinput
        } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
            print STDERR <<END or die $!;

Git commit in archive is behind the last version allegedly pushed/uploaded.
Commit referred to by archive: $dsc_hash
Last version pushed with dgit: $lastpush_hash
$later_warning_msg
END
            @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 <<END or die $!;

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

Warning: relevant archive skew detected.
Archive allegedly contains $skew_warning_vsn
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 = cmdoutput @git, qw(cat-file commit), $tree_commit;
        $tree =~ m/\n\n/;  $tree = $`;
        $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
        $tree = $1;

        # 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 = ".git/dgit/mergecommit";
        open MC, ">", $mcf or die "$mcf $!";
        print MC <<END or die $!;
tree $tree
END

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

        print MC <<END or die $!;
author $author
committer $author

END

        if (defined $compat_info->{Message}) {
            print MC $compat_info->{Message} or die $!;
        } else {
            print MC <<END or die $!;
Record $package ($cversion) in archive suite $csuite

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

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

        close MC or die $!;
        $hash = make_commit $mcf;
    } else {
        $hash = $mergeinputs[0]{Commit};
    }
    progress "fetch hash=$hash\n";

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

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

    runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
            'DGIT_ARCHIVE', $hash;
    cmdoutput @git, qw(log -n2), $hash;
    # ... gives git a chance to complain if our commit is malformed

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

Warning: archive skew detected.  Using the available version:
Archive allegedly contains    $skew_warning_vsn
We were able to obtain only   $got_vsn

END
        }
    }

    if ($lastfetch_hash ne $hash) {
        my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
        if (act_local()) {
            cmdoutput @upd_cmd;
        } else {
            dryrun_report @upd_cmd;
        }
    }

    lrfetchref_used lrfetchref();

    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";
    my $attrs = '.git/info/attributes';
    ensuredir '.git/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 die $!;
        }
        ATTRS->error and die $!;
        close ATTRS;
    }
    print NATTRS "debian/changelog merge=$driver\n" or die $!;
    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 setup_new_tree () {
    setup_mergechangelogs();
    setup_useremail();
}

sub clone ($) {
    my ($dstdir) = @_;
    canonicalise_suite();
    badusage "dry run makes no sense with clone" unless act_local();
    my $hasgit = check_for_git();
    mkdir $dstdir or fail "create \`$dstdir': $!";
    changedir $dstdir;
    runcmd @git, qw(init -q);
    my $giturl = access_giturl(1);
    if (defined $giturl) {
        open H, "> .git/HEAD" or die $!;
        print H "ref: ".lref()."\n" or die $!;
        close H or die $!;
        runcmd @git, qw(remote add), 'origin', $giturl;
    }
    if ($hasgit) {
        progress "fetching existing git history";
        git_fetch_us();
        runcmd_ordryrun_local @git, qw(fetch origin);
    } else {
        progress "starting new git history";
    }
    fetch_from_archive() or no_such_package;
    my $vcsgiturl = $dsc->{'Vcs-Git'};
    if (length $vcsgiturl) {
        $vcsgiturl =~ s/\s+-b\s+\S+//g;
        runcmd @git, qw(remote add vcs-git), $vcsgiturl;
    }
    setup_new_tree();
    runcmd @git, qw(reset --hard), lrref();
    printdone "ready for work in $dstdir";
}

sub fetch () {
    if (check_for_git()) {
        git_fetch_us();
    }
    fetch_from_archive() or no_such_package();
    printdone "fetched into ".lrref();
}

sub pull () {
    fetch();
    runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
        lrref();
    printdone "fetched to ".lrref()." and merged into HEAD";
}

sub check_not_dirty () {
    foreach my $f (qw(local-options local-patch-header)) {
        if (stat_exists "debian/source/$f") {
            fail "git tree contains debian/source/$f";
        }
    }

    return if $ignoredirty;

    my @cmd = (@git, qw(diff --quiet HEAD));
    debugcmd "+",@cmd;
    $!=0; $?=-1; system @cmd;
    return if !$?;
    if ($?==256) {
        fail "working tree is dirty (does not match HEAD)";
    } else {
        failedcmd @cmd;
    }
}

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

sub commit_quilty_patch () {
    my $output = cmdoutput @git, qw(status --porcelain);
    my %adds;
    foreach my $l (split /\n/, $output) {
        next unless $l =~ m/\S/;
        if ($l =~ m{^(?:\?\?| M) (.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;
    }
    my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
    runcmd_ordryrun_local @git, qw(add -f), @adds;
    commit_admin "Commit Debian 3.0 (quilt) metadata";
}

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
            if (m/\s*\#\s*/) {
                my ($k, $v) = ($`, $'); #');
                $v =~ s/^"(.*)"$/$1/;
                $options{$k} = $v;
            } else {
                $options{$_} = 1;
            }
        }
        F->error and die $!;
        close F;
    } else {
        die $! unless $!==&ENOENT;
    }

    if (!open F, "debian/source/format") {
        die $! unless $!==&ENOENT;
        return '';
    }
    $_ = <F>;
    F->error and die $!;
    chomp;
    return ($_, \%options);
}

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

# 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 ? <<END : <<END;
Wanted tag $what (@tagnames) on dgit server, but not found
END
Wanted tag $what (one of: @tagnames) on dgit server, but not found
END
}

sub infopair_cond_ff ($$) {
    my ($anc,$desc) = @_;
    is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
$anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) 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 "Checking package changelog for archive version $v ...";
            eval {
                my @xa = ("-f$v", "-t$v");
                my $vclogp = parsechangelog @xa;
                my $cv = [ (getfield $vclogp, 'Version'),
                           "Version field from dpkg-parsechangelog @xa" ];
                infopair_cond_equal($i_arch_v, $cv);
            };
            if ($@) {
                $@ =~ s/^dgit: //gm;
                fail "$@".
                    "Perhaps debian/changelog does not mention $v ?";
            }
        }
    }
    
    printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
    return $i_arch_v;
}

sub pseudomerge_make_commit ($$$$ $$) {
    my ($clogp, $dgitview, $archive_hash, $i_arch_v,
        $msg_cmd, $msg_msg) = @_;
    progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";

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

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

    mkpath '.git/dgit';
    my $pmf = ".git/dgit/pseudomerge";
    open MC, ">", $pmf or die "$pmf $!";
    print MC <<END or die $!;
tree $tree
parent $dgitview
parent $archive_hash
author $authline
commiter $authline

$msg_msg

[$msg_cmd]
END
    close MC or die $!;

    return make_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'
    #

    printdebug "splitbrain_pseudomerge...\n";

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

    return $dgitview unless defined $archive_hash;

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

    return $dgitview if is_fast_fwd $archive_hash, $dgitview;

    my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
    my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
    my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
    my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
    my $i_archive = [ $archive_hash, "current archive contents" ];

    printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";

    infopair_cond_equal($i_dgit, $i_archive);
    infopair_cond_ff($i_dep14, $i_dgit);
    $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);

    my $r = pseudomerge_make_commit
        $clogp, $dgitview, $archive_hash, $i_arch_v,
        "dgit --quilt=$quilt_mode",
        (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
Declare fast forward from $overwrite_version
END_OVERWR
Make fast forward from $i_arch_v->[0]
END_MAKEFF

    progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
    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);

    my @tagformats = access_cfg_tagformats();
    my @t_overwr =
        map { $_->($i_arch_v->[0], access_basedistro) }
        (grep { m/^(?:old|hist)$/ } @tagformats)
        ? \&debiantags : \&debiantag_new;
    my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
    my $i_archive = [ $archive_hash, "current archive contents" ];

    infopair_cond_equal($i_overwr, $i_archive);

    return $head if is_fast_fwd $archive_hash, $head;

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

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

    runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;

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

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

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

    $package = getfield $clogp, 'Source';
    my $cversion = getfield $clogp, 'Version';
    my $tag = debiantag($cversion, access_basedistro);
    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 "$dscfn is for $dscpackage $dversion".
            " but debian/changelog is for $package $cversion";
}

sub push_tagwants ($$$$) {
    my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
    my @tagwants;
    push @tagwants, {
        TagFn => \&debiantag,
        Objid => $dgithead,
        TfSuffix => '',
        View => 'dgit',
    };
    if (defined $maintviewhead) {
        push @tagwants, {
            TagFn => \&debiantag_maintview,
            Objid => $maintviewhead,
            TfSuffix => '-maintview',
            View => 'maint',
        };
    }
    foreach my $tw (@tagwants) {
        $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
        $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
    }
    printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
    return @tagwants;
}

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

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

    $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
    $dsc->save("$dscfn.tmp") or die $!;

    my $changes = parsecontrol($changesfile,$changesfilewhat);
    foreach my $field (qw(Source Distribution Version)) {
        $changes->{$field} eq $clogp->{$field} or
            fail "changes field $field \`$changes->{$field}'".
                " does not match changelog \`$clogp->{$field}'";
    }

    my $cversion = getfield $clogp, 'Version';
    my $clogsuite = getfield $clogp, 'Distribution';

    # We make the git tag by hand because (a) that makes it easier
    # to control the "tagger" (b) we can do remote signing
    my $authline = clogp_authline $clogp;
    my $delibs = join(" ", "",@deliberatelies);
    my $declaredistro = access_basedistro();

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

        open TO, '>', $tfn->('.tmp') or die $!;
        print TO <<END or die $!;
object $head
type commit
tag $tag
tagger $authline

END
        if ($tw->{View} eq 'dgit') {
            print TO <<END or die $!;
$package release $cversion for $clogsuite ($csuite) [dgit]
[dgit distro=$declaredistro$delibs]
END
            foreach my $ref (sort keys %previously) {
                print TO <<END or die $!;
[dgit previously:$ref=$previously{$ref}]
END
            }
        } elsif ($tw->{View} eq 'maint') {
            print TO <<END or die $!;
$package release $cversion for $clogsuite ($csuite)
(maintainer view tag generated by dgit --quilt=$quilt_mode)
END
        } else {
            die Dumper($tw)."?";
        }

        close TO or die $!;

        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 die $!;
            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');
            }
        }
        return $tagobjfn;
    };

    my @r = map { $mktag->($_); } @$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 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();
    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

    need_tagformat 'new', "quilt mode $quilt_mode"
        if quiltmode_splitbrain;

    prep_ud();

    access_giturl(); # check that success is vaguely likely
    select_tagformat();

    my $clogpfn = ".git/dgit/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 "looked for .dsc $dscfn, but $!;".
            " maybe you forgot to build";

    responder_send_file('dsc', $dscpath);

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

    my $format = getfield $dsc, 'Format';
    printdebug "format $format\n";

    my $actualhead = git_rev_parse('HEAD');
    my $dgithead = $actualhead;
    my $maintviewhead = undef;

    if (madformat_wantfixup($format)) {
        # user might have not used dgit build, so maybe do this now:
        if (quiltmode_splitbrain()) {
            my $upstreamversion = $clogp->{Version};
            $upstreamversion =~ s/-[^-]*$//;
            changedir $ud;
            quilt_make_fake_dsc($upstreamversion);
            my ($dgitview, $cachekey) =
                quilt_check_splitbrain_cache($actualhead, $upstreamversion);
            $dgitview or fail
 "--quilt=$quilt_mode but no cached dgit view:
 perhaps tree changed since dgit build[-source] ?";
            $split_brain = 1;
            $dgithead = splitbrain_pseudomerge($clogp,
                                               $actualhead, $dgitview,
                                               $archive_hash);
            $maintviewhead = $actualhead;
            changedir '../../../..';
            prep_ud(); # so _only_subdir() works, below
        } else {
            commit_quilty_patch();
        }
    }

    if (defined $overwrite_version && !defined $maintviewhead) {
        $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 --overwrite[=VERSION].\n".
                "To rewind history, if permitted by the archive,".
                " use --deliberately-not-fast-forward.";
        }
    }

    changedir $ud;
    progress "checking that $dscfn corresponds to HEAD";
    runcmd qw(dpkg-source -x --),
        $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
    my ($tree,$dir) = mktree_in_ud_from_only_subdir();
    check_for_vendor_patches() if madformat($dsc->{format});
    changedir '../../../..';
    my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
    my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
    debugcmd "+",@diffcmd;
    $!=0; $?=-1;
    my $r = system @diffcmd;
    if ($r) {
        if ($r==256) {
            fail "$dscfn specifies a different tree to your HEAD commit;".
                " perhaps you forgot to build".
                ($diffopt eq '--exit-code' ? "" :
                 " (run with -D to see full diff output)");
        } else {
            failedcmd @diffcmd;
        }
    }
    if (!$changesfile) {
        my $pat = changespat $cversion;
        my @cs = glob "$buildproductsdir/$pat";
        fail "failed to find unique changes file".
            " (looked for $pat in $buildproductsdir);".
            " perhaps you need to use dgit -C"
            unless @cs==1;
        ($changesfile) = @cs;
    } else {
        $changesfile = "$buildproductsdir/$changesfile";
    }

    # 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 tagformat $tagformat");
    if (defined $maintviewhead) {
        die unless ($protovsn//4) >= 4;
        responder_send_command("param maint-view $maintviewhead");
    }

    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 = push_tagwants($cversion, $dgithead, $maintviewhead,
                                 ".git/dgit/tag");
    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 = map { $_->{Tfn}('.signed-tmp') } @tagwants;
        responder_receive_files('signed-tag', @tagobjfns);
    } else {
        @tagobjfns = push_mktags($clogp,$dscpath,
                              $changesfile,$changesfile,
                              \@tagwants);
    }
    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, @tagobjfns;

    foreach my $tw (@tagwants) {
        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;
        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) {
        push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
    }

    runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
    runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;

    supplementary_message(<<'END');
Push failed, after updating the remote git repository.
If you want to try again, you must use a new version number.
END
    if ($we_are_responder) {
        my $dryrunsuffix = act_local() ? "" : ".tmp";
        responder_receive_files('signed-dsc-changes',
                                "$dscpath$dryrunsuffix",
                                "$changesfile$dryrunsuffix");
    } else {
        if (act_local()) {
            rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
        } else {
            progress "[new .dsc left in $dscpath.tmp]";
        }
        sign_changes $changesfile;
    }

    supplementary_message(<<END);
Push failed, while uploading package(s) to the archive server.
You can retry the upload of exactly these same files with dput of:
  $changesfile
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 "pushed and uploaded $cversion";

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

sub cmd_clone {
    parseopts();
    notpushing();
    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";
    }
    $dstdir ||= "$package";

    if (stat_exists $dstdir) {
        fail "$dstdir already exists";
    }

    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;
                die "chdir $cwd_remove: $!";
            }
            if (stat $dstdir) {
                rmtree($dstdir) or die "remove $dstdir: $!\n";
            } elsif (!grep { $! == $_ }
                     (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
            } else {
                print STDERR "check whether to remove $dstdir: $!\n";
            }
        };
    }

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

sub branchsuite () {
    my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
    if ($branch =~ m#$lbranch_re#o) {
        return $1;
    } else {
        return undef;
    }
}

sub fetchpullargs () {
    notpushing();
    if (!defined $package) {
        my $sourcep = parsecontrol('debian/control','debian/control');
        $package = getfield $sourcep, 'Source';
    }
    if (@ARGV==0) {
#       $isuite = branchsuite();  # this doesn't work because dak hates canons
        if (!$isuite) {
            my $clogp = parsechangelog();
            $isuite = getfield $clogp, 'Distribution';
        }
        canonicalise_suite();
        progress "fetching from suite $csuite";
    } elsif (@ARGV==1) {
        ($isuite) = @ARGV;
        canonicalise_suite();
    } else {
        badusage "incorrect arguments to dgit fetch or dgit pull";
    }
}

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

sub cmd_pull {
    parseopts();
    fetchpullargs();
    pull();
}

sub cmd_push {
    parseopts();
    pushing();
    badusage "-p is not allowed with dgit push" if defined $package;
    check_not_dirty();
    my $clogp = parsechangelog();
    $package = getfield $clogp, 'Source';
    my $specsuite;
    if (@ARGV==0) {
    } elsif (@ARGV==1) {
        ($specsuite) = (@ARGV);
    } else {
        badusage "incorrect arguments to dgit push";
    }
    $isuite = getfield $clogp, 'Distribution';
    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 "dgit push: changelog specifies $isuite ($csuite)".
                " but command line specifies $specsuite";
    }
    dopush();
}

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

sub cmd_remote_push_build_host {
    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)";

    pushing();

    open PI, "<&STDIN" or die $!;
    open STDIN, "/dev/null" or die $!;
    open PO, ">&STDOUT" or die $!;
    autoflush PO 1;
    open STDOUT, ">&STDERR" or die $!;
    autoflush STDOUT 1;

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

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

    responder_send_command("dgit-remote-push-ready $protovsn");
    rpush_handle_protovsn_bothends();
    changedir $dir;
    &cmd_push;
}

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 () {
    if ($protovsn < 4) {
        need_tagformat 'old', "rpush negotiated protocol $protovsn";
    }
    select_tagformat();
}

our $i_tmp;

sub i_cleanup {
    local ($@, $?);
    my $report = i_child_report();
    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 { rmtree $i_tmp; };
    }
}

END { i_cleanup(); }

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

sub cmd_rpush {
    pushing();
    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, qw(remote-push-build-host), (scalar @rargs), @rargs;
    push @rdgit, @ARGV;
    my @cmd = (@ssh, $host, shellquote @rdgit);
    debugcmd "+",@cmd;

    if (defined $initiator_tempdir) {
        rmtree $initiator_tempdir;
        mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
        $i_tmp = $initiator_tempdir;
    } else {
        $i_tmp = tempdir();
    }
    $i_child_pid = open2(\*RO, \*RI, @cmd);
    changedir $i_tmp;
    ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
    die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
    $supplementary_message = '' unless $protovsn >= 3;

    fail "rpush negotiated protocol version $protovsn".
        " which does not support quilt mode $quilt_mode"
        if quiltmode_splitbrain;

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

sub i_resp_progress ($) {
    my ($rhs) = @_;
    my $msg = protocol_read_bytes \*RO, $rhs;
    progress $msg;
}

sub i_resp_supplementary_message ($) {
    my ($rhs) = @_;
    $supplementary_message = protocol_read_bytes \*RO, $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;
    die $! unless $got == $pid;
    die "build host child failed $?" if $?;

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

sub i_resp_file ($) {
    my ($keyword) = @_;
    my $localname = i_method "i_localname", $keyword;
    my $localpath = "$i_tmp/$localname";
    stat_exists $localpath and
        badproto \*RO, "file $keyword ($localpath) twice";
    protocol_receive_file \*RO, $localpath;
    i_method "i_file", $keyword;
}

our %i_param;

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

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

our %i_wanted;

sub i_resp_want ($) {
    my ($keyword) = @_;
    die "$keyword ?" if $i_wanted{$keyword}++;
    my @localpaths = i_method "i_want", $keyword;
    printdebug "[[  $keyword @localpaths\n";
    foreach my $localpath (@localpaths) {
        protocol_send_file \*RI, $localpath;
    }
    print RI "files-end\n" or die $!;
}

our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);

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 badproto \*RO, "dsc (before parsed-changelog)";
    return $i_dscfn;
}
sub i_file_dsc { }

sub i_localname_changes {
    defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
    $i_changesfn = $i_dscfn;
    $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
    return $i_changesfn;
}
sub i_file_changes { }

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 badproto \*RO, "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]/;

    select_tagformat();
    if ($protovsn >= 4) {
        my $p = $i_param{'tagformat'} // '<undef>';
        $p eq $tagformat
            or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
    }

    die unless $i_param{'csuite'} =~ m/^$suite_re$/;
    $csuite = $&;
    push_parse_dsc $i_dscfn, 'remote dsc', $i_version;

    my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";

    return
        push_mktags $i_clogp, $i_dscfn,
            $i_changesfn, 'remote changes',
            \@tagwants;
}

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

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

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

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

our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';

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

    mkpath '.git/dgit';
    my $descfn = ".git/dgit/quilt-description.tmp";
    open O, '>', $descfn or die "$descfn: $!";
    $msg =~ s/\s+$//g;
    $msg =~ s/\n/\n /g;
    $msg =~ s/^\s+$/ ./mg;
    print O <<END or die $!;
Description: $msg
Author: $author
$xinfo
---

END
    close O or die $!;

    {
        local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
        local $ENV{'VISUAL'} = $ENV{'EDITOR'};
        local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
        runcmd @dpkgsource, qw(--commit .), $patchname;
    }
}

sub quiltify_trees_differ ($$;$$) {
    my ($x,$y,$finegrained,$ignorenamesr) = @_;
    # 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
    local $/=undef;
    my @cmd = (@git, qw(diff-tree --name-only -z));
    push @cmd, qw(-r) if $finegrained;
    push @cmd, $x, $y;
    my $diffs= cmdoutput @cmd;
    my $r = 0;
    foreach my $f (split /\0/, $diffs) {
        next if $f =~ m#^debian(?:/.*)?$#s;
        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_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_splitbrain_needed () {
    if (!$split_brain) {
        progress "dgit view: changes are required...";
        runcmd @git, qw(checkout -q -b dgit-view);
        $split_brain = 1;
    }
}

sub quiltify_splitbrain ($$$$$$) {
    my ($clogp, $unapplied, $headref, $diffbits,
        $editedignores, $cachekey) = @_;
    if ($quilt_mode !~ m/gbp|dpm/) {
        # treat .gitignore just like any other upstream file
        $diffbits = { %$diffbits };
        $_ = !!$_ foreach values %$diffbits;
    }
    # 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];
        
    if ($quilt_mode =~ m/gbp|unapplied/ &&
        ($diffbits->{H2O} & 01)) {
        my $msg =
 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
 " but git tree differs from orig in upstream files.";
        if (!stat_exists "debian/patches") {
            $msg .=
 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
        }  
        fail $msg;
    }
    if ($quilt_mode =~ m/dpm/ &&
        ($diffbits->{H2A} & 01)) {
        fail <<END;
--quilt=$quilt_mode specified, implying patches-applied git tree
 but git tree differs from result of applying debian/patches to upstream
END
    }
    if ($quilt_mode =~ m/gbp|unapplied/ &&
        ($diffbits->{O2A} & 01)) { # some patches
        quiltify_splitbrain_needed();
        progress "dgit view: creating patches-applied version using gbp pq";
        runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
        # 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 <<END
--quilt=$quilt_mode 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->{H2O} & 02) && # user has modified .gitignore
        !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
        quiltify_splitbrain_needed();
        progress "dgit view: creating patch to represent .gitignore changes";
        ensuredir "debian/patches";
        my $gipatch = "debian/patches/auto-gitignore";
        open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
        stat GIPATCH or die "$gipatch: $!";
        fail "$gipatch already exists; but want to create it".
            " to record .gitignore changes" if (stat _)[7];
        print GIPATCH <<END 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.

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

    my $dgitview = git_rev_parse 'refs/heads/dgit-view';

    changedir '../../../..';
    ensuredir ".git/logs/refs/dgit-intern";
    my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
      or die $!;
    runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
        $dgitview;

    progress "dgit view: created (commit id $dgitview)";

    changedir '.git/dgit/unpack/work';
}

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

        if ($quilt_mode eq 'nofix') {
            fail "quilt fixup required but quilt mode is \`nofix'\n".
                "HEAD commit $c->{Commit} differs from tree implied by ".
                " debian/patches (tree object $oldtiptree)";
        }
        if ($quilt_mode eq 'smash') {
            printdebug " search quitting smash\n";
            last;
        }

        my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
        $not->($c, "has $c_sentinels not $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, "merge ($ndiffers nontrivial parents)") 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));
            my $patchstackchange = cmdoutput @cmd;
            if (length $patchstackchange) {
                $patchstackchange =~ s/\n/,/g;
                $not->($p, "changed $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;
        };
        my $reportnot = sub {
            my ($notp) = @_;
            my $s = $abbrev->($notp);
            my $c = $notp->{Child};
            $s .= "..".$abbrev->($c) if $c;
            $s .= ": ".$notp->{Whynot};
            return $s;
        };
        if ($quilt_mode eq 'linear') {
            print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
            foreach my $notp (@nots) {
                print STDERR "$us:  ", $reportnot->($notp), "\n";
            }
            print STDERR "$us: $_\n" foreach @$failsuggestion;
            fail "quilt fixup naive history linearisation failed.\n".
 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
        } elsif ($quilt_mode eq 'smash') {
        } elsif ($quilt_mode eq 'auto') {
            progress "quilt fixup cannot be linear, smashing...";
        } else {
            die "$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_dpkg_commit "auto-$version-$target-$time",
            (getfield $clogp, 'Maintainer'),
            "Automatically generated patch ($clogp->{Version})\n".
            "Last (up to) $ncommits git changes, FYI:\n\n". $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;

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

        my $title = $1;
        my $patchname = $title;
        $patchname =~ s/[.:]$//;
        $patchname =~ y/ A-Z/-a-z/;
        $patchname =~ y/-a-z0-9_.+=~//cd;
        $patchname =~ s/^\W/x-$&/;
        $patchname = substr($patchname,0,40);
        my $index;
        for ($index='';
             stat "debian/patches/$patchname$index";
             $index++) { }
        $!==ENOENT or die "$patchname$index $!";

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

        # We use the tip's changelog so that dpkg-source doesn't
        # produce complaining messages from dpkg-parsechangelog.  None
        # of the information dpkg-source gets from the changelog is
        # actually relevant - it gets put into the original message
        # which dpkg-source provides our stunt editor, and then
        # overwritten.
        runcmd @git, qw(checkout -q), $target, qw(debian/changelog);

        quiltify_dpkg_commit "$patchname$index", $author, $msg,
            "X-Dgit-Generated: $clogp->{Version} $cc\n";

        runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
    }

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

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

    check_for_vendor_patches();

    if (quiltmode_splitbrain) {
        foreach my $needtf (qw(new maint)) {
            next if grep { $_ eq $needtf } access_cfg_tagformats;
            fail <<END
quilt mode $quilt_mode requires split view so server needs to support
 both "new" and "maint" tag formats, but config says it doesn't.
END
        }
    }

    my $clogp = parsechangelog();
    my $headref = git_rev_parse('HEAD');

    prep_ud();
    changedir $ud;

    my $upstreamversion=$version;
    $upstreamversion =~ s/-[^-]*$//;

    if ($fopts->{'single-debian-patch'}) {
        quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
    } else {
        quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
    }

    die 'bug' if $split_brain && !$need_split_build_invocation;

    changedir '../../../..';
    runcmd_ordryrun_local
        @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
}

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

    mkdir "work" or die $!;
    changedir "work";
    mktree_in_ud_here();
    runcmd @git, qw(reset -q --hard), $headref;
}

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

    foreach my $f (<../../../../*>) { #/){
        my $b=$f; $b =~ s{.*/}{};
        {
            local ($debuglevel) = $debuglevel-1;
            printdebug "QF linkorigs $b, $f ?\n";
        }
        next unless is_orig_file_of_vsn $b, $upstreamversion;
        printdebug "QF linkorigs $b, $f Y\n";
        link_ltarget $f, $b or die "$b $!";
        $fn->($b);
    }
}

sub quilt_fixup_delete_pc () {
    runcmd @git, qw(rm -rqf .pc);
    commit_admin "Commit removal of .pc (quilt series tracking data)";
}

sub quilt_fixup_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.

    quilt_fixup_linkorigs($upstreamversion, sub { });
    quilt_fixup_mkwork($headref);

    rmtree("debian/patches");

    runcmd @dpkgsource, qw(-b .);
    changedir "..";
    runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
    rename srcfn("$upstreamversion", "/debian/patches"), 
           "work/debian/patches";

    changedir "work";
    commit_quilty_patch();
}

sub quilt_make_fake_dsc ($) {
    my ($upstreamversion) = @_;

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

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

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

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

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

    quilt_fixup_linkorigs($upstreamversion, $dscaddfile);

    my @files=qw(debian/source/format debian/rules
                 debian/control debian/changelog);
    foreach my $maybe (qw(debian/patches debian/source/options
                          debian/tests/control)) {
        next unless stat_exists "../../../$maybe";
        push @files, $maybe;
    }

    my $debtar= srcfn $fakeversion,'.debian.tar.gz';
    runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;

    $dscaddfile->($debtar);
    close $fakedsc or die $!;
}

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

    my $splitbrain_cachekey;
    
    progress
 "dgit: split brain (separate dgit view) may be needed (--quilt=$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, hashfile('fake.dsc');

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

    my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
               $splitbraincache);
    printdebug "splitbrain cachekey $splitbrain_cachekey\n";
    debugcmd "|(probably)",@cmd;
    my $child = open GC, "-|";  defined $child or die $!;
    if (!$child) {
        chdir '../../..' or die $!;
        if (!stat ".git/logs/refs/$splitbraincache") {
            $! == ENOENT or die $!;
            printdebug ">(no reflog)\n";
            exit 0;
        }
        exec @cmd; die $!;
    }
    while (<GC>) {
        chomp;
        printdebug ">| ", $_, "\n" if $debuglevel > 1;
        next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
            
        my $cachehit = $1;
        quilt_fixup_mkwork($headref);
        if ($cachehit ne $headref) {
            progress "dgit view: found cached (commit id $cachehit)";
            runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
            $split_brain = 1;
            return ($cachehit, $splitbrain_cachekey);
        }
        progress "dgit view: found cached, no changes required";
        return ($headref, $splitbrain_cachekey);
    }
    die $! if GC->error;
    failedcmd unless close GC;

    printdebug "splitbrain cache miss\n";
    return (undef, $splitbrain_cachekey);
}

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

    progress "examining quilt state (multiple patches, $quilt_mode 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 with dpkg-source --commit
    #  - otherwise convert all the differences in the tree into
    #    a single git commit
    #
    # To do this we:

    # Our git tree doesn't necessarily contain .pc.  (Some versions of
    # dgit would include the .pc in the git tree.)  If there isn't
    # one, we need to generate one by unpacking the patches that we
    # have.
    #
    # We first look for a .pc in the git tree.  If there is one, we
    # will use it.  (This is not the normal case.)
    #
    # Otherwise need to regenerate .pc so that dpkg-source --commit
    # can work.  We do this as follows:
    #     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
    #        Now the fake .dsc has a .pc directory.
    # (In fact we do this in every case, because in future we will
    # want to search for a good base commit for generating patches.)
    #
    # Then we can actually do the dpkg-source --commit
    #     1. Make a new working tree with the same object
    #        store as our main tree and check out the main
    #        tree's HEAD.
    #     2. Copy .pc from the fake's extraction, if necessary
    #     3. Run dpkg-source --commit
    #     4. If the result has changes to debian/, then
    #          - git-add them them
    #          - git-add .pc if we had a .pc in-tree
    #          - git-commit
    #     5. If we had a .pc in-tree, delete it, and git-commit
    #     6. Back in the main tree, fast forward to the new HEAD

    # 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.

    my $splitbrain_cachekey;

    quilt_make_fake_dsc($upstreamversion);

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

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

    rmtree '.pc';

    runcmd @git, qw(add -Af .);
    my $unapplied=git_write_tree();
    printdebug "fake orig tree object $unapplied\n";

    ensuredir '.pc';

    runcmd qw(sh -ec),
        'exec dpkg-source --before-build . >/dev/null';

    changedir '..';

    quilt_fixup_mkwork($headref);

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

    changedir '../fake';
    rmtree '.pc';
    runcmd @git, qw(add -Af .);
    my $oldtiptree=git_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 %editedignores;
    my $diffbits = {
        # H = user's HEAD
        # O = orig, without patches applied
        # A = "applied", ie orig with H's debian/patches applied
        H2O => quiltify_trees_differ($headref,  $unapplied, 1,\%editedignores),
        H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
        O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
    };

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

    progress sprintf
"$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
"$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
                             $dl[0], $dl[1],              $dl[3], $dl[4],
                                 $dl[2],                     $dl[5];

    my @failsuggestion;
    if (!($diffbits->{H2O} & $diffbits->{O2A})) {
        push @failsuggestion, "This might be a patches-unapplied branch.";
    }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
        push @failsuggestion, "This might be a patches-applied branch.";
    }
    push @failsuggestion, "Maybe you need to specify one of".
        " --quilt=gbp --quilt=dpm --quilt=unapplied ?";

    if (quiltmode_splitbrain()) {
        quiltify_splitbrain($clogp, $unapplied, $headref,
                            $diffbits, \%editedignores,
                            $splitbrain_cachekey);
        return;
    }

    progress "starting quiltify (multiple patches, $quilt_mode mode)";
    quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);

    if (!open P, '>>', ".pc/applied-patches") {
        $!==&ENOENT or die $!;
    } 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 die "$descfn: $!";
    open I2, '<', $editing or die "$editing: $!";
    unlink $editing or die "$editing: $!";
    open O, '>', $editing or die "$editing: $!";
    while (<I1>) { print O or die $!; } I1->error and die $!;
    my $copying = 0;
    while (<I2>) {
        $copying ||= m/^\-\-\- /;
        next unless $copying;
        print O or die $!;
    }
    I2->error and die $!;
    close O or die $1;
    exit 0;
}

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

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;
    rmtree '.pc'
        if $patches_applied_dirtily & 02;
    $patches_applied_dirtily = 0;
}

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

our $clean_using_builder;
# ^ tree is to be cleaned by dpkg-source's builtin idea that it should
#   clean the tree before building (perhaps invoked indirectly by
#   whatever we are using to run the build), rather than separately
#   and explicitly by us.

sub clean_tree () {
    return if $clean_using_builder;
    if ($cleanmode eq 'dpkg-source') {
        maybe_apply_patches_dirtily();
        runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
    } elsif ($cleanmode eq 'dpkg-source-d') {
        maybe_apply_patches_dirtily();
        runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
    } elsif ($cleanmode eq 'git') {
        runcmd_ordryrun_local @git, qw(clean -xdf);
    } elsif ($cleanmode eq 'git-ff') {
        runcmd_ordryrun_local @git, qw(clean -xdff);
    } elsif ($cleanmode eq 'check') {
        my $leftovers = cmdoutput @git, qw(clean -xdn);
        if (length $leftovers) {
            print STDERR $leftovers, "\n" or die $!;
            fail "tree contains uncommitted files and --clean=check specified";
        }
    } elsif ($cleanmode eq 'none') {
    } else {
        die "$cleanmode ?";
    }
}

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

sub build_prep () {
    notpushing();
    badusage "-p is not allowed when building" if defined $package;
    check_not_dirty();
    clean_tree();
    my $clogp = parsechangelog();
    $isuite = getfield $clogp, 'Distribution';
    $package = getfield $clogp, 'Source';
    $version = getfield $clogp, 'Version';
    build_maybe_quilt_fixup();
    if ($rmchanges) {
        my $pat = changespat $version;
        foreach my $f (glob "$buildproductsdir/$pat") {
            if (act_local()) {
                unlink $f or fail "remove old changes file $f: $!";
            } else {
                progress "would remove $f";
            }
        }
    }
}

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

sub changesopts_version () {
    if (!defined $changes_since_version) {
        my @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');
        }
        if (@vsns) {
            @vsns = map { $_->[0] } @vsns;
            @vsns = sort { -version_compare($a, $b) } @vsns;
            $changes_since_version = $vsns[0];
            progress "changelog will contain changes since $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) = @_;
    # We need to:
    #
    #  - if we're going to 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).
    #
    #  - add -nc to stop dpkg-source cleaning the source tree,
    #    unless we're not doing a split build and want dpkg-source
    #    as cleanmode, in which case we can do nothing
    #
    # return values:
    #    0 - source will NOT need to be built separately by caller
    #   +1 - source will need to be built separately by caller
    #   +2 - source will need to be built separately by caller AND
    #        dpkg-buildpackage should not in fact be run at all!
    debugcmd '#massaging#', @$cmd if $debuglevel>1;
#print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
    if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
        $clean_using_builder = 1;
        return 0;
    }
    # -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]$/s and $dmode=$_) } @$l;
    }
    push @$cmd, '-nc';
#print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
    my $r = 0;
    if ($need_split_build_invocation) {
        printdebug "massage split $dmode.\n";
        $r = $dmode =~ m/[S]/     ? +2 :
             $dmode =~ y/gGF/ABb/ ? +1 :
             $dmode =~ m/[ABb]/   ?  0 :
             die "$dmode ?";
    }
    printdebug "massage done $r $dmode.\n";
    push @$cmd, $dmode;
#print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
    return $r;
}

sub cmd_build {
    my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
    my $wantsrc = massage_dbp_args \@dbp;
    if ($wantsrc > 0) {
        build_source();
    } else {
        build_prep();
    }
    if ($wantsrc < 2) {
        push @dbp, changesopts_version();
        maybe_apply_patches_dirtily();
        runcmd_ordryrun_local @dbp;
    }
    maybe_unapply_patches_again();
    printdone "build successful\n";
}

sub cmd_gbp_build {
    my @dbp = @dpkgbuildpackage;

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

    my @cmd;
    if (length executable_on_path('git-buildpackage')) {
        @cmd = qw(git-buildpackage);
    } else {
        @cmd = qw(gbp buildpackage);
    }
    push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");

    if ($wantsrc > 0) {
        build_source();
    } else {
        if (!$clean_using_builder) {
            push @cmd, '--git-cleaner=true';
        }
        build_prep();
    }
    maybe_unapply_patches_again();
    if ($wantsrc < 2) {
        unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
            canonicalise_suite();
            push @cmd, "--git-debian-branch=".lbranch();
        }
        push @cmd, changesopts();
        runcmd_ordryrun_local @cmd, @ARGV;
    }
    printdone "build successful\n";
}
sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0

sub build_source {
    my $our_cleanmode = $cleanmode;
    if ($need_split_build_invocation) {
        # Pretend that clean is being done some other way.  This
        # forces us not to try to use dpkg-buildpackage to clean and
        # build source all in one go; and instead we run dpkg-source
        # (and build_prep() will do the clean since $clean_using_builder
        # is false).
        $our_cleanmode = 'ELSEWHERE';
    }
    if ($our_cleanmode =~ m/^dpkg-source/) {
        # dpkg-source invocation (below) will clean, so build_prep shouldn't
        $clean_using_builder = 1;
    }
    build_prep();
    $sourcechanges = changespat $version,'source';
    if (act_local()) {
        unlink "../$sourcechanges" or $!==ENOENT
            or fail "remove $sourcechanges: $!";
    }
    $dscfn = dscfn($version);
    if ($our_cleanmode eq 'dpkg-source') {
        maybe_apply_patches_dirtily();
        runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
            changesopts();
    } elsif ($our_cleanmode eq 'dpkg-source-d') {
        maybe_apply_patches_dirtily();
        runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
            changesopts();
    } else {
        my @cmd = (@dpkgsource, qw(-b --));
        if ($split_brain) {
            changedir $ud;
            runcmd_ordryrun_local @cmd, "work";
            my @udfiles = <${package}_*>;
            changedir "../../..";
            foreach my $f (@udfiles) {
                printdebug "source copy, found $f\n";
                next unless
                    $f eq $dscfn or
                    ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
                     $f eq srcfn($version, $&));
                printdebug "source copy, found $f - renaming\n";
                rename "$ud/$f", "../$f" or $!==ENOENT
                    or fail "put in place new source file ($f): $!";
            }
        } else {
            my $pwd = must_getcwd();
            my $leafdir = basename $pwd;
            changedir "..";
            runcmd_ordryrun_local @cmd, $leafdir;
            changedir $pwd;
        }
        runcmd_ordryrun_local qw(sh -ec),
            'exec >$1; shift; exec "$@"','x',
            "../$sourcechanges",
            @dpkggenchanges, qw(-S), changesopts();
    }
}

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

sub cmd_sbuild {
    build_source();
    my $pat = changespat $version;
    if (!$rmchanges) {
        my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
        @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
        fail "changes files other than source matching $pat".
            " already present (@unwanted);".
            " building would result in ambiguity about the intended results"
            if @unwanted;
    }
    my $wasdir = must_getcwd();
    changedir "..";
    if (act_local()) {
        stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
        stat_exists $sourcechanges
            or fail "$sourcechanges (in parent directory): $!";
    }
    runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
    my @changesfiles = glob $pat;
    @changesfiles = sort {
        ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
            or $a cmp $b
    } @changesfiles;
    fail "wrong number of different changes files (@changesfiles)"
        unless @changesfiles==2;
    my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
    foreach my $l (split /\n/, getfield $binchanges, 'Files') {
        fail "$l found in binaries changes file $binchanges"
            if $l =~ m/\.dsc$/;
    }
    runcmd_ordryrun_local @mergechanges, @changesfiles;
    my $multichanges = changespat $version,'multi';
    if (act_local()) {
        stat_exists $multichanges or fail "$multichanges: $!";
        foreach my $cf (glob $pat) {
            next if $cf eq $multichanges;
            rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
        }
    }
    changedir $wasdir;
    maybe_unapply_patches_again();
    printdone "build successful, results in $multichanges\n" or die $!;
}    

sub cmd_quilt_fixup {
    badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
    my $clogp = parsechangelog();
    $version = getfield $clogp, 'Version';
    $package = getfield $clogp, 'Source';
    check_not_dirty();
    clean_tree();
    build_maybe_quilt_fixup();
}

sub cmd_archive_api_query {
    badusage "need only 1 subpath argument" unless @ARGV==1;
    my ($subpath) = @ARGV;
    my @cmd = archive_api_query_cmd($subpath);
    debugcmd ">",@cmd;
    exec @cmd or fail "exec curl: $!\n";
}

sub cmd_clone_dgit_repos_server {
    badusage "need destination argument" unless @ARGV==1;
    my ($destdir) = @ARGV;
    $package = '_dgit-repos-server';
    my @cmd = (@git, qw(clone), access_giturl(), $destdir);
    debugcmd ">",@cmd;
    exec @cmd or fail "exec git clone: $!\n";
}

sub cmd_setup_mergechangelogs {
    badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
    setup_mergechangelogs(1);
}

sub cmd_setup_useremail {
    badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
    setup_useremail(1);
}

sub cmd_setup_new_tree {
    badusage "no arguments allowed to dgit setup-tree" if @ARGV;
    setup_new_tree();
}

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

sub cmd_version {
    print "dgit version $our_version\n" or die $!;
    exit 0;
}

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

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 assignemnt 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 '--quilt',     '', $quilt_modes_re, \$quilt_mode;

defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };

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."
};

sub parseopts () {
    my $om;

    if (defined $ENV{'DGIT_SSH'}) {
        @ssh = string_to_ssh $ENV{'DGIT_SSH'};
    } elsif (defined $ENV{'GIT_SSH'}) {
        @ssh = ($ENV{'GIT_SSH'});
    }

    my $oi;
    my $val;
    my $valopt = sub {
        my ($what) = @_;
        @rvalopts = ($_);
        if (!defined $val) {
            badusage "$what needs a value" unless @ARGV;
            $val = shift @ARGV;
            push @rvalopts, $val;
        }
        badusage "bad value \`$val' for $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;
    };

    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 &&
                     ($om = $opts_opt_map{$1}) &&
                     length $om->[0]) {
                push @ropts, $_;
                $om->[0] = $2;
            } elsif (m/^--([-0-9a-z]+):(.*)/s &&
                     !$opts_opt_cmdonly{$1} &&
                     ($om = $opts_opt_map{$1})) {
                push @ropts, $_;
                push @$om, $2;
            } elsif (m/^--ignore-dirty$/s) {
                push @ropts, $_;
                $ignoredirty = 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/^--overwrite$/s) {
                push @ropts, $_;
                $overwrite_version = '';
            } elsif (m/^--overwrite=(.+)$/s) {
                push @ropts, $_;
                $overwrite_version = $1;
            } elsif (m/^--(no-)?rm-old-changes$/s) {
                push @ropts, $_;
                $rmchanges = !$1;
            } elsif (m/^--deliberately-($deliberately_re)$/s) {
                push @ropts, $_;
                push @deliberatelies, $&;
            } elsif (m/^--dgit-tag-format=(old|new)$/s) {
                # undocumented, for testing
                push @ropts, $_;
                $tagformat_want = [ $1, 'command line', 1 ];
                # 1 menas overrides distro configuration
            } elsif (m/^--always-split-source-build$/s) {
                # undocumented, for testing
                push @ropts, $_;
                $need_split_build_invocation = 1;
            } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
                $val = $2 ? $' : undef; #';
                $valopt->($oi->{Long});
            } else {
                badusage "unknown long option \`$_'";
            }
        } 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$//s) {
                    push @ropts, $&;
                    $cleanmode = 'git';
                } elsif (s/^-wgf$//s) {
                    push @ropts, $&;
                    $cleanmode = 'git-ff';
                } elsif (s/^-wd$//s) {
                    push @ropts, $&;
                    $cleanmode = 'dpkg-source';
                } elsif (s/^-wdd$//s) {
                    push @ropts, $&;
                    $cleanmode = 'dpkg-source-d';
                } elsif (s/^-wc$//s) {
                    push @ropts, $&;
                    $cleanmode = 'check';
                } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
                    $val = $'; #';
                    $val = undef unless length $val;
                    $valopt->($oi->{Short});
                    $_ = '';
                } else {
                    badusage "unknown short option \`$_'";
                }
            }
        }
    }
}

sub finalise_opts_opts () {
    foreach my $k (keys %opts_opt_map) {
        my $om = $opts_opt_map{$k};

        my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
        if (defined $v) {
            badcfg "cannot set command for $k"
                unless length $om->[0];
            $om->[0] = $v;
        }

        foreach my $c (access_cfg_cfgs("opts-$k")) {
            my $vl = $gitcfg{$c};
            printdebug "CL $c ",
                ($vl ? join " ", map { shellquote } @$vl : ""),
                "\n" if $debuglevel >= 4;
            next unless $vl;
            badcfg "cannot configure options for $k"
                if $opts_opt_cmdonly{$k};
            my $insertpos = $opts_cfg_insertpos{$k};
            @$om = ( @$om[0..$insertpos-1],
                     @$vl,
                     @$om[$insertpos..$#$om] );
        }
    }
}

if ($ENV{$fakeeditorenv}) {
    git_slurp_config();
    quilt_fixup_editor();
}

parseopts();
git_slurp_config();

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 die $!;
    exit 8;
}
my $cmd = shift @ARGV;
$cmd =~ y/-/_/;

if (!defined $rmchanges) {
    local $access_forpush;
    $rmchanges = access_cfg_bool(0, 'rm-old-changes');
}

if (!defined $quilt_mode) {
    local $access_forpush;
    $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
        // access_cfg('quilt-mode', 'RETURN-UNDEF')
        // 'linear';
    $quilt_mode =~ m/^($quilt_modes_re)$/ 
        or badcfg "unknown quilt-mode \`$quilt_mode'";
    $quilt_mode = $1;
}

$need_split_build_invocation ||= quiltmode_splitbrain();

if (!defined $cleanmode) {
    local $access_forpush;
    $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
    $cleanmode //= 'dpkg-source';

    badcfg "unknown clean-mode \`$cleanmode'" unless
        $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
}

my $fn = ${*::}{"cmd_$cmd"};
$fn or badusage "unknown operation $cmd";
$fn->();