Cope when an orig tarball is a tarbomb.

[dgit.git] / dgit

#!/usr/bin/perl -w
# dgit
# Integration between git and Debian-style archives
#
# Copyright (C)2013-2016 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 Text::Glob qw(match_glob);
use Fcntl qw(:DEFAULT :flock);
use Carp;

use Debian::Dgit;

our $our_version = 'UNRELEASED'; ###substituted###
our $absurdity = undef; ###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 $split_brain_save;
our $we_are_responder;
our $initiator_tempdir;
our $patches_applied_dirtily = 00;
our $tagformat_want;
our $tagformat;
our $tagformatfn;

our %forceopts = map { $_=>0 }
    qw(unrepresentable unsupported-source-format
       dsc-changes-mismatch changes-origs-exactly
       import-gitapply-absurd
       import-gitapply-no-absurd
       import-dsc-with-dgit-field);

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

our $suite_re = '[-+.0-9a-z]+';
our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";

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

our (@git) = qw(git);
our (@dget) = qw(dget);
our (@curl) = qw(curl);
our (@dput) = qw(dput);
our (@debsign) = qw(debsign);
our (@gpg) = qw(gpg);
our (@sbuild) = qw(sbuild);
our (@ssh) = 'ssh';
our (@dgit) = qw(dgit);
our (@aptget) = qw(apt-get);
our (@aptcache) = qw(apt-cache);
our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
our (@dpkggenchanges) = qw(dpkg-genchanges);
our (@mergechanges) = qw(mergechanges -f);
our (@gbp_build) = ('');
our (@gbp_pq) = ('gbp pq');
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,
                     'apt-get' => \@aptget,
                     'apt-cache' => \@aptcache,
                     'dpkg-source' => \@dpkgsource,
                     'dpkg-buildpackage' => \@dpkgbuildpackage,
                     'dpkg-genchanges' => \@dpkggenchanges,
                     'gbp-build' => \@gbp_build,
                     'gbp-pq' => \@gbp_pq,
                     '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;

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

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

sub upstreamversion ($) {
    my ($vsn) = @_;
    $vsn =~ s/-[^-]+$//;
    return $vsn;
}

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 forceable_fail ($$) {
    my ($forceoptsl, $msg) = @_;
    fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
    print STDERR "warning: overriding problem due to --force:\n". $msg;
}

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

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

sub opts_opt_multi_cmd {
    my @cmd;
    push @cmd, split /\s+/, shift @_;
    push @cmd, @_;
    @cmd;
}

sub gbp_pq {
    return opts_opt_multi_cmd @gbp_pq;
}

#---------- 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 "$us 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-suite.*-security.distro' => 'debian-security',
               'dgit.default.username' => '',
               'dgit.default.archive-query-default-component' => 'main',
               'dgit.default.ssh' => 'ssh',
               'dgit.default.archive-query' => 'madison:',
               'dgit.default.sshpsql-dbname' => 'service=projectb',
               'dgit.default.aptget-components' => 'main',
               'dgit.default.dgit-tag-format' => 'new,old,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/push.git-url' => '',
               'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
               'dgit-distro.debian/push.git-user-force' => 'dgit',
               'dgit-distro.debian/push.git-proto' => 'git+ssh://',
               'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
               'dgit-distro.debian/push.git-create' => 'true',
               'dgit-distro.debian/push.git-check' => 'ssh-cmd',
 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
# 'dgit-distro.debian.archive-query-tls-key',
#    '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
# ^ this does not work because curl is broken nowadays
# Fixing #790093 properly will involve providing providing the key
# in some pacagke and maybe updating these paths.
#
# 'dgit-distro.debian.archive-query-tls-curl-args',
#   '--ca-path=/etc/ssl/ca-debian',
# ^ this is a workaround but works (only) on DSA-administered machines
               'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
               'dgit-distro.debian.git-url-suffix' => '',
               'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
               'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
 'dgit-distro.debian-security.archive-query' => 'aptget:',
 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
 'dgit-distro.debian-security.nominal-distro' => 'debian',
 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
               'dgit-distro.ubuntu.git-check' => 'false',
 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
               'dgit-distro.test-dummy.ssh' => "$td/ssh",
               'dgit-distro.test-dummy.username' => "alice",
               'dgit-distro.test-dummy.git-check' => "ssh-cmd",
               'dgit-distro.test-dummy.git-create' => "ssh-cmd",
               'dgit-distro.test-dummy.git-url' => "$td/git",
               'dgit-distro.test-dummy.git-host' => "git",
               'dgit-distro.test-dummy.git-path' => "$td/git",
               'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
               'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
               'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
               'dgit-distro.test-dummy.upload-host' => 'test-dummy',
               );

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

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

    # This algoritm is a bit subtle, but this is needed so that for
    # options which we want to be single-valued, we allow the
    # different config sources to override properly.  See #835858.
    foreach my $src (@gitcfgsources) {
        next if $src eq 'cmdline';
        # we do this ourselves since git doesn't handle it
        
        my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
        debugcmd "|",@cmd;

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

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

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

sub access_nomdistro () {
    my $base = access_basedistro();
    return cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
}

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;

    push @l, access_nomdistro();

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

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

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

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

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

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

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

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

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

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

sub 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, $allowsigned) = @_;
    my $fh = new IO::Handle;
    open $fh, '<', $file or die "$file: $!";
    my $c = parsecontrolfh($fh,$desc,$allowsigned);
    $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;
}

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

our %rmad;

sub archive_query ($;@) {
    my ($method) = shift @_;
    fail "this operation does not support multiple comma-separated suites"
        if $isuite =~ m/,/;
    my $query = access_cfg('archive-query','RETURN-UNDEF');
    $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
    my $proto = $1;
    my $data = $'; #';
    { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
}

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

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

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

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

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

sub archive_api_query_cmd ($) {
    my ($subpath) = @_;
    my @cmd = (@curl, qw(-sS));
    my $url = access_cfg('archive-query-url');
    if ($url =~ m#^https://([-.0-9a-z]+)/#) {
        my $host = $1;
        my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
        foreach my $key (split /\:/, $keys) {
            $key =~ s/\%HOST\%/$host/g;
            if (!stat $key) {
                fail "for $url: stat $key: $!" unless $!==ENOENT;
                next;
            }
            fail "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, $ok404) = @_;
    badcfg "ftpmasterapi archive query method takes no data part"
        if length $data;
    my @cmd = archive_api_query_cmd($subpath);
    my $url = $cmd[$#cmd];
    push @cmd, qw(-w %{http_code});
    my $json = cmdoutput @cmd;
    unless ($json =~ s/\d+\d+\d$//) {
        failedcmd_report_cmd undef, @cmd;
        fail "curl failed to print 3-digit HTTP code";
    }
    my $code = $&;
    return undef if $code eq '404' && $ok404;
    fail "fetch of $url gave HTTP code $code"
        unless $url =~ m#^file://# or $code =~ m/^2/;
    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 archive_query_prepend_mirror @rows;
}

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

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

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

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

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

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

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

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

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

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

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

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

    ensuredir $aptget_base;

    aptget_lock_acquire();

    aptget_cache_clean();

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

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

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

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

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

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

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

    runcmd_ordryrun_local aptget_aptget(), qw(update);

    my @releasefiles;
    foreach my $oldlist (<$aptget_base/lists/*Release>) {
        next unless stat_exists $oldlist;
        my ($atime) = (stat _)[8];
        next if $atime == $oldatime;
        push @releasefiles, $oldlist;
    }
    my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
    @releasefiles = @inreleasefiles if @inreleasefiles;
    die "apt updated wrong number of Release files (@releasefiles), erk"
        unless @releasefiles == 1;

    ($aptget_releasefile) = @releasefiles;
}

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

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

    foreach my $name (qw(Codename Suite)) {
        my $val = $release->{$name};
        if (defined $val) {
            printdebug "release file $name: $val\n";
            $val =~ m/^$suite_re$/o or fail
 "Release file ($aptget_releasefile) specifies intolerable $name";
            cfg_apply_map(\$val, 'suite rmap',
                          access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
            return $val
        }
    }
    return $isuite;
}

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

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

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

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

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

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

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

#---------- `dummyapicat' archive query method ----------

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

sub file_in_archive_dummycatapi ($$$) {
    my ($proto,$data,$filename) = @_;
    my $mirror = access_cfg('mirror');
    $mirror =~ s#^file://#/# or die "$mirror ?";
    my @out;
    my @cmd = (qw(sh -ec), '
            cd "$1"
            find -name "$2" -print0 |
            xargs -0r sha256sum
        ', qw(x), $mirror, $filename);
    debugcmd "-|", @cmd;
    open FIA, "-|", @cmd or die $!;
    while (<FIA>) {
        chomp or die;
        printdebug "| $_\n";
        m/^(\w+)  (\S+)$/ or die "$_ ?";
        push @out, { sha256sum => $1, filename => $2 };
    }
    close FIA or die failedcmd @cmd;
    return \@out;
}

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

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

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

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

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

sub file_in_archive_madison { return undef; }

#---------- `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 archive_query_prepend_mirror @rows;
}

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

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

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

sub file_in_archive_dummycat () { return undef; }

#---------- 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";
    } else {
        progress "canonical suite name is $csuite";
    }
}

sub get_archive_dsc () {
    canonicalise_suite();
    my @vsns = archive_query('archive_query');
    foreach my $vinfo (@vsns) {
        my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
        $dscurl = $vsn_dscurl;
        $dscdata = url_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";
        }
        parse_dscdata();
        my $fmt = getfield $dsc, 'Format';
        $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
            "unsupported source format $fmt, sorry";
            
        $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 = (@curl, qw(-sS -I), $url);
        my $result = cmdoutput @cmd;
        $result =~ s/^\S+ 200 .*\n\r?\n//;
        # curl -sS -I with https_proxy prints
        # HTTP/1.0 200 Connection established
        $result =~ m/^\S+ (404|200) /s or
            fail "unexpected results from git check query - ".
                Dumper($prefix, $result);
        my $code = $1;
        if ($code eq '404') {
            return 0;
        } elsif ($code eq '200') {
            return 1;
        } else {
            die;
        }
    } 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 git_add_write_tree () {
    runcmd @git, qw(add -Af .);
    return git_write_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);
}

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

sub dsc_files_info () {
    foreach my $csumi (@files_csum_info_fields) {
        my ($fname, $module, $method) = @$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 files_compare_inputs (@) {
    my $inputs = \@_;
    my %record;
    my %fchecked;

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

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

        printdebug "files_compare_inputs $in_name\n";

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

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

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

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

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

                push @files, $f;

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

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

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

sub is_orig_file_of_vsn ($$) {
    my ($f, $upstreamvsn) = @_;
    my $base = srcfn $upstreamvsn, '';
    return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
    return 1;
}

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

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(),
                          "(base) distro being accessed");
    vendor_patches_distro(access_nomdistro(),
                          "(nominal) distro being accessed");
}

sub generate_commits_from_dsc () {
    # See big comment in fetch_from_archive, below.
    # See also README.dsc-import.
    prep_ud();
    changedir $ud;

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

        printdebug "considering linking $f: ";

        link_ltarget "../../../../$f", $f
            or ((printdebug "($!) "), 0)
            or $!==&ENOENT
            or die "$f $!";

        printdebug "linked.\n";

        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 = upstreamversion $dsc->{version};
    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+)?$/;
        (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
        my $compr_ext = $1;

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

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

        my $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";
        remove_stray_gits();
        mktree_in_ud_here();
        
        my ($tree) = git_add_write_tree();
        my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
        if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
            $tree = $1;
            printdebug "one subtree $1\n";
        } else {
            printdebug "multiple subtrees\n";
        }
        changedir "..";
        rmtree "_unpack-tar";

        my $ent = [ $f, $tree ];
        push @tartrees, {
            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;

    printdebug "import clog search...\n";

    for (;;) {
        my $stanzatext = do { local $/=""; <CLOGS>; };
        printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
        last if !defined $stanzatext;

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

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

        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.

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

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

        printdebug "import clog $r1clogp->{version} becomes r1\n";
    }
    die $! if CLOGS->error;
    close CLOGS or $?==SIGPIPE 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.

        printdebug "import tartrees authline   $authline\n";
        printdebug "import tartrees r1authline $r1authline\n";

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

            $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
        }
    }

    printdebug "import main commit\n";

    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}) {
        printdebug "import apply patches...\n";

        # regularise the state of the working tree so that
        # the checkout of $rawimport_hash works nicely.
        my $dappliedcommit = make_commit_text(<<END);
tree $dappliedtree
author $authline
committer $authline

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

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

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

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

        foreach my $use_absurd (qw(0 1)) {
            local $ENV{PATH} = $path;
            if ($use_absurd) {
                chomp $@;
                progress "warning: $@";
                $path = "$absurdity:$path";
                progress "$us: trying slow absurd-git-apply...";
                rename "../../gbp-pq-output","../../gbp-pq-output.0"
                    or $!==ENOENT
                    or die $!;
            }
            eval {
                die "forbid absurd git-apply\n" if $use_absurd
                    && forceing [qw(import-gitapply-no-absurd)];
                die "only absurd git-apply!\n" if !$use_absurd
                    && forceing [qw(import-gitapply-absurd)];

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

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

                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;
            };
            last unless $@;
        }
        if ($@) {
            { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
            die $@;
        }
    }

    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 {
        printdebug "$tf does not exist, need to fetch\n";
        my $furl = $dscurl;
        $furl =~ s{/[^/]+$}{};
        $furl .= "/$f";
        die "$f ?" unless $f =~ m/^\Q${package}\E_/;
        die "$f ?" if $f =~ m#/#;
        runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
        return 0 if !act_local();
        $downloaded = 1;
    }

    open F, "<", "$tf" or die "$tf: $!";
    $fi->{Digester}->reset();
    $fi->{Digester}->addfile(*F);
    F->error and die $!;
    my $got = $fi->{Digester}->hexdigest();
    $got eq $fi->{Hash} or
        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_nomdistro) }
            \&debiantag_new, \&debiantag_maintview)
         : debiantags('*',access_nomdistro));
    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.

    printdebug "git_fetch_us specs @specs\n";

    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 (;;) {
        printdebug "git_fetch_us iteration $fetch_iteration\n";
        if (++$fetch_iteration > 10) {
            fail "too many iterations trying to get sane fetch!";
        }

        my @look = map { "refs/$_" } @specs;
        my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
        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 {
            !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
            "+refs/$_:".lrfetchrefs."/$_";
        } @specs;

        printdebug "git_fetch_us fspecs @fspecs\n";

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

        %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_nomdistro);

    git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
        my ($objid,$objtype,$fullrefname,$reftail) = @_;
        printdebug "currently $fullrefname=$objid\n";
        $here{$fullrefname} = $objid;
    });
    git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
        my ($objid,$objtype,$fullrefname,$reftail) = @_;
        my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
        printdebug "offered $lref=$objid\n";
        if (!defined $here{$lref}) {
            my @upd = (@git, qw(update-ref), $lref, $objid, '');
            runcmd_ordryrun_local @upd;
            lrfetchref_used $fullrefname;
        } elsif ($here{$lref} eq $objid) {
            lrfetchref_used $fullrefname;
        } else {
            print STDERR \
                "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_record_1 ($) {
    my ($hash) = @_;
    runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
            'DGIT_ARCHIVE', $hash;
    cmdoutput @git, qw(log -n2), $hash;
    # ... gives git a chance to complain if our commit is malformed
}

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

sub fetch_from_archive () {
    ensure_setup_existing_tree();

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

    if ($dsc) {
        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) {
        ensure_we_have_orig();
        if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
            @mergeinputs = $dsc_mergeinput
        } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
            print STDERR <<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};
    }
    printdebug "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)')
        if $lastpush_hash;
    $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');

    fetch_from_archive_record_1($hash);

    if (defined $skew_warning_vsn) {
        mkpath '.git/dgit';
        printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
        my $gotclogp = commit_getclogp($hash);
        my $got_vsn = getfield $gotclogp, 'Version';
        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) {
        fetch_from_archive_record_2($hash);
    }

    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 ensure_setup_existing_tree () {
    my $k = "remote.$remotename.skipdefaultupdate";
    my $c = git_get_config $k;
    return if defined $c;
    set_local_git_config $k, 'true';
}

sub setup_new_tree () {
    setup_mergechangelogs();
    setup_useremail();
}

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

sub fork_for_multisuite ($) {
    my ($before_fetch_merge) = @_;
    # if nothing unusual, just returns ''
    #
    # if multisuite:
    # returns 0 to caller in child, to do first of the specified suites
    # in child, $csuite is not yet set
    #
    # returns 1 to caller in parent, to finish up anything needed after
    # in parent, $csuite is set to canonicalised portmanteau

    my $org_isuite = $isuite;
    my @suites = split /\,/, $isuite;
    return '' unless @suites > 1;
    printdebug "fork_for_multisuite: @suites\n";

    my @mergeinputs;

    my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
                                            sub { });
    return 0 unless defined $cbasesuite;

    fail "package $package missing in (base suite) $cbasesuite"
        unless @mergeinputs;

    my @csuites = ($cbasesuite);

    $before_fetch_merge->();

    foreach my $tsuite (@suites[1..$#suites]) {
        my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
                                               sub {
            @end = ();
            fetch();
            exit 0;
        });
        # xxx collecte the ref here

        $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
        push @csuites, $csubsuite;
    }

    foreach my $mi (@mergeinputs) {
        my $ref = git_get_ref $mi->{Ref};
        die "$mi->{Ref} ?" unless length $ref;
        $mi->{Commit} = $ref;
    }

    $csuite = join ",", @csuites;

    my $previous = git_get_ref lrref;
    if ($previous) {
        unshift @mergeinputs, {
            Commit => $previous,
            Info => "local combined tracking branch",
            Warning =>
 "archive seems to have rewound: local tracking branch is ahead!",
        };
    }

    foreach my $ix (0..$#mergeinputs) {
        $mergeinputs[$ix]{Index} = $ix;
    }

    @mergeinputs = sort {
        -version_compare(mergeinfo_version $a,
                         mergeinfo_version $b) # highest version first
            or
        $a->{Index} <=> $b->{Index}; # earliest in spec first
    } @mergeinputs;

    my @needed;

  NEEDED:
    foreach my $mi (@mergeinputs) {
        printdebug "multisuite merge check $mi->{Info}\n";
        foreach my $previous (@needed) {
            next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
            printdebug "multisuite merge un-needed $previous->{Info}\n";
            next NEEDED;
        }
        push @needed, $mi;
        printdebug "multisuite merge this-needed\n";
        $mi->{Character} = '+';
    }

    $needed[0]{Character} = '*';

    my $output = $needed[0]{Commit};

    if (@needed > 1) {
        printdebug "multisuite merge nontrivial\n";
        my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';

        my $commit = "tree $tree\n";
        my $msg = "Combine archive branches $csuite [dgit]\n\n".
            "Input branches:\n";

        foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
            printdebug "multisuite merge include $mi->{Info}\n";
            $mi->{Character} //= ' ';
            $commit .= "parent $mi->{Commit}\n";
            $msg .= sprintf " %s  %-25s %s\n",
                $mi->{Character},
                (mergeinfo_version $mi),
                $mi->{Info};
        }
        my $authline = clogp_authline mergeinfo_getclogp $needed[0];
        $msg .= "\nKey\n".
            " * marks the highest version branch, which choose to use\n".
            " + marks each branch which was not already an ancestor\n\n".
            "[dgit multi-suite $csuite]\n";
        $commit .=
            "author $authline\n".
            "committer $authline\n\n";
        $output = make_commit_text $commit.$msg;
        printdebug "multisuite merge generated $output\n";
    }

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

    progress "calculated combined tracking suite $csuite";

    return 1;
}

sub clone_set_head () {
    open H, "> .git/HEAD" or die $!;
    print H "ref: ".lref()."\n" or die $!;
    close H or die $!;
}
sub clone_finish ($) {
    my ($dstdir) = @_;
    runcmd @git, qw(reset --hard), lrref();
    runcmd qw(bash -ec), <<'END';
        set -o pipefail
        git ls-tree -r --name-only -z HEAD | \
        xargs -0r touch -r . --
END
    printdone "ready for work in $dstdir";
}

sub clone ($) {
    my ($dstdir) = @_;
    badusage "dry run makes no sense with clone" unless act_local();

    my $multi_fetched = fork_for_multisuite(sub {
        printdebug "multi clone before fetch merge\n";
        changedir $dstdir;
    });
    if ($multi_fetched) {
        printdebug "multi clone after fetch merge\n";
        clone_set_head();
        clone_finish($dstdir);
        exit 0;
    }
    printdebug "clone main body\n";

    canonicalise_suite();
    my $hasgit = check_for_git();
    mkdir $dstdir or fail "create \`$dstdir': $!";
    changedir $dstdir;
    runcmd @git, qw(init -q);
    clone_set_head();
    my $giturl = access_giturl(1);
    if (defined $giturl) {
        runcmd @git, qw(remote add), 'origin', $giturl;
    }
    if ($hasgit) {
        progress "fetching existing git history";
        git_fetch_us();
        runcmd_ordryrun_local @git, qw(fetch origin);
    } else {
        progress "starting new git history";
    }
    fetch_from_archive() or no_such_package;
    my $vcsgiturl = $dsc->{'Vcs-Git'};
    if (length $vcsgiturl) {
        $vcsgiturl =~ s/\s+-b\s+\S+//g;
        runcmd @git, qw(remote add vcs-git), $vcsgiturl;
    }
    setup_new_tree();
    clone_finish($dstdir);
}

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

sub pull () {
    my $multi_fetched = fork_for_multisuite(sub { });
    fetch() unless $multi_fetched; # parent
    return if $multi_fetched eq '0'; # child
    runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
        lrref();
    printdone "fetched to ".lrref()." and merged into HEAD";
}

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 <<END
Commit Debian 3.0 (quilt) metadata

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

sub get_source_format () {
    my %options;
    if (open F, "debian/source/options") {
        while (<F>) {
            next if m/^\s*\#/;
            next unless m/\S/;
            s/\s+$//; # ignore missing final newline
            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;
}

sub maybe_split_brain_save ($$$) {
    my ($headref, $dgitview, $msg) = @_;
    # => message fragment "$saved" describing disposition of $dgitview
    return "commit id $dgitview" unless defined $split_brain_save;
    my @cmd = (shell_cmd "cd ../../../..",
               @git, qw(update-ref -m),
               "dgit --dgit-view-save $msg HEAD=$headref",
               $split_brain_save, $dgitview);
    runcmd @cmd;
    return "and left in $split_brain_save";
}

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

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

sub infopair_lrf_tag_lookup ($$) {
    my ($tagnames, $what) = @_;
    # $tagname may be an array ref
    my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
    printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
    foreach my $tagname (@tagnames) {
        my $lrefname = lrfetchrefs."/tags/$tagname";
        my $tagobj = $lrfetchrefs_f{$lrefname};
        next unless defined $tagobj;
        printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
        return [ git_rev_parse($tagobj), $what ];
    }
    fail @tagnames==1 ? <<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'
    #

    return $dgitview unless defined $archive_hash;

    printdebug "splitbrain_pseudomerge...\n";

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

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

    return $dgitview if is_fast_fwd $archive_hash, $dgitview;

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

        printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";

        infopair_cond_equal($i_dgit, $i_archive);
        infopair_cond_ff($i_dep14, $i_dgit);
        infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
        1;
    }) {
        print STDERR <<END;
$us: check failed (maybe --overwrite is needed, consult documentation)
END
        die "$@";
    }

    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 $i_arch_v->[0]
END_OVERWR
Make fast forward from $i_arch_v->[0]
END_MAKEFF

    maybe_split_brain_save $maintview, $r, "pseudomerge";

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

    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;

    my $clogpackage = getfield $clogp, 'Source';
    $package //= $clogpackage;
    fail "-p specified $package but changelog specified $clogpackage"
        unless $package eq $clogpackage;
    my $cversion = getfield $clogp, 'Version';
    my $tag = debiantag($cversion, access_nomdistro);
    runcmd @git, qw(check-ref-format), $tag;

    my $dscfn = dscfn($cversion);

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

sub push_parse_dsc ($$$) {
    my ($dscfn,$dscfnwhat, $cversion) = @_;
    $dsc = parsecontrol($dscfn,$dscfnwhat);
    my $dversion = getfield $dsc, 'Version';
    my $dscpackage = getfield $dsc, 'Source';
    ($dscpackage eq $package && $dversion eq $cversion) or
        fail "$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_nomdistro);
        $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_nomdistro();

    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;

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

    if (madformat_wantfixup($format)) {
        # user might have not used dgit build, so maybe do this now:
        if (quiltmode_splitbrain()) {
            changedir $ud;
            quilt_make_fake_dsc($upstreamversion);
            my $cachekey;
            ($dgithead, $cachekey) =
                quilt_check_splitbrain_cache($actualhead, $upstreamversion);
            $dgithead or fail
 "--quilt=$quilt_mode but no cached dgit view:
 perhaps tree changed since dgit build[-source] ?";
            $split_brain = 1;
            $dgithead = splitbrain_pseudomerge($clogp,
                                               $actualhead, $dgithead,
                                               $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 @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
    debugcmd "+",@diffcmd;
    $!=0; $?=-1;
    my $r = system @diffcmd;
    if ($r) {
        if ($r==256) {
            my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
            fail <<END
HEAD specifies a different tree to $dscfn:
$diffs
Perhaps you forgot to build.  Or perhaps there is a problem with your
 source tree (see dgit(7) for some hints).  To see a full diff, run
   git diff $tree HEAD
END
        } 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";
    }

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

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

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

    responder_send_file('changes',$changesfile);
    responder_send_command("param head $dgithead");
    responder_send_command("param csuite $csuite");
    responder_send_command("param 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(-c push.followTags=false 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: $!";
            }
            printdebug "clone rmonerror removing $dstdir\n";
            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();
        if (!$isuite) {
            my $clogp = parsechangelog();
            $isuite = getfield $clogp, 'Distribution';
        }
    } elsif (@ARGV==1) {
        ($isuite) = @ARGV;
    } else {
        badusage "incorrect arguments to dgit fetch or dgit pull";
    }
}

sub cmd_fetch {
    parseopts();
    fetchpullargs();
    my $multi_fetched = fork_for_multisuite(sub { });
    exit 0 if $multi_fetched;
    fetch();
}

sub cmd_pull {
    parseopts();
    fetchpullargs();
    if (quiltmode_splitbrain()) {
        my ($format, $fopts) = get_source_format();
        madformat($format) and fail <<END
dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
END
    }
    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) = @_;