dgit

   1 #!/usr/bin/perl -w
   2 # dgit
   3 # Integration between git and Debian-style archives
   4 #
   5 # Copyright (C)2013-2015 Ian Jackson
   6 #
   7 # This program is free software: you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation, either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 use strict;
  21
  22 use Debian::Dgit;
  23 setup_sigwarn();
  24
  25 use IO::Handle;
  26 use Data::Dumper;
  27 use LWP::UserAgent;
  28 use Dpkg::Control::Hash;
  29 use File::Path;
  30 use File::Temp qw(tempdir);
  31 use File::Basename;
  32 use Dpkg::Version;
  33 use POSIX;
  34 use IPC::Open2;
  35 use Digest::SHA;
  36 use Digest::MD5;
  37 use List::Util qw(any);
  38 use List::MoreUtils qw(pairwise);
  39
  40 use Debian::Dgit;
  41
  42 our $our_version = 'UNRELEASED'; ###substituted###
  43
  44 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
  45 our $protovsn;
  46
  47 our $isuite = 'unstable';
  48 our $idistro;
  49 our $package;
  50 our @ropts;
  51
  52 our $sign = 1;
  53 our $dryrun_level = 0;
  54 our $changesfile;
  55 our $buildproductsdir = '..';
  56 our $new_package = 0;
  57 our $ignoredirty = 0;
  58 our $rmonerror = 1;
  59 our @deliberatelies;
  60 our %previously;
  61 our $existing_package = 'dpkg';
  62 our $cleanmode;
  63 our $changes_since_version;
  64 our $rmchanges;
  65 our $quilt_mode;
  66 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|unapplied';
  67 our $we_are_responder;
  68 our $initiator_tempdir;
  69 our $patches_applied_dirtily = 00;
  70 our $tagformat_want;
  71 our $tagformat;
  72 our $tagformatfn;
  73
  74 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
  75
  76 our $suite_re = '[-+.0-9a-z]+';
  77 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
  78
  79 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
  80 our $splitbraincache = 'dgit-intern/quilt-cache';
  81
  82 our (@git) = qw(git);
  83 our (@dget) = qw(dget);
  84 our (@curl) = qw(curl -f);
  85 our (@dput) = qw(dput);
  86 our (@debsign) = qw(debsign);
  87 our (@gpg) = qw(gpg);
  88 our (@sbuild) = qw(sbuild);
  89 our (@ssh) = 'ssh';
  90 our (@dgit) = qw(dgit);
  91 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
  92 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
  93 our (@dpkggenchanges) = qw(dpkg-genchanges);
  94 our (@mergechanges) = qw(mergechanges -f);
  95 our (@gbp) = qw(gbp);
  96 our (@changesopts) = ('');
  97
  98 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
  99                      'curl' => \@curl,
 100                      'dput' => \@dput,
 101                      'debsign' => \@debsign,
 102                      'gpg' => \@gpg,
 103                      'sbuild' => \@sbuild,
 104                      'ssh' => \@ssh,
 105                      'dgit' => \@dgit,
 106                      'git' => \@git,
 107                      'dpkg-source' => \@dpkgsource,
 108                      'dpkg-buildpackage' => \@dpkgbuildpackage,
 109                      'dpkg-genchanges' => \@dpkggenchanges,
 110                      'gbp' => \@gbp,
 111                      'ch' => \@changesopts,
 112                      'mergechanges' => \@mergechanges);
 113
 114 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
 115 our %opts_cfg_insertpos = map {
 116     $_,
 117     scalar @{ $opts_opt_map{$_} }
 118 } keys %opts_opt_map;
 119
 120 sub finalise_opts_opts();
 121
 122 our $keyid;
 123
 124 autoflush STDOUT 1;
 125
 126 our $supplementary_message = '';
 127 our $need_split_build_invocation = 0;
 128 our $split_brain = 0;
 129
 130 END {
 131     local ($@, $?);
 132     print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
 133 }
 134
 135 our $remotename = 'dgit';
 136 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
 137 our $csuite;
 138 our $instead_distro;
 139
 140 sub debiantag ($$) {
 141     my ($v,$distro) = @_;
 142     return $tagformatfn->($v, $distro);
 143 }
 144
 145 sub debiantag_maintview ($$) {
 146     my ($v,$distro) = @_;
 147     $v =~ y/~:/_%/;
 148     return "$distro/$v";
 149 }
 150
 151 sub lbranch () { return "$branchprefix/$csuite"; }
 152 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
 153 sub lref () { return "refs/heads/".lbranch(); }
 154 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
 155 sub rrref () { return server_ref($csuite); }
 156
 157 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
 158 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
 159
 160 sub stripepoch ($) {
 161     my ($vsn) = @_;
 162     $vsn =~ s/^\d+\://;
 163     return $vsn;
 164 }
 165
 166 sub srcfn ($$) {
 167     my ($vsn,$sfx) = @_;
 168     return "${package}_".(stripepoch $vsn).$sfx
 169 }
 170
 171 sub dscfn ($) {
 172     my ($vsn) = @_;
 173     return srcfn($vsn,".dsc");
 174 }
 175
 176 sub changespat ($;$) {
 177     my ($vsn, $arch) = @_;
 178     return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
 179 }
 180
 181 our $us = 'dgit';
 182 initdebug('');
 183
 184 our @end;
 185 END {
 186     local ($?);
 187     foreach my $f (@end) {
 188         eval { $f->(); };
 189         print STDERR "$us: cleanup: $@" if length $@;
 190     }
 191 };
 192
 193 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
 194
 195 sub no_such_package () {
 196     print STDERR "$us: package $package does not exist in suite $isuite\n";
 197     exit 4;
 198 }
 199
 200 sub changedir ($) {
 201     my ($newdir) = @_;
 202     printdebug "CD $newdir\n";
 203     chdir $newdir or die "chdir: $newdir: $!";
 204 }
 205
 206 sub deliberately ($) {
 207     my ($enquiry) = @_;
 208     return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
 209 }
 210
 211 sub deliberately_not_fast_forward () {
 212     foreach (qw(not-fast-forward fresh-repo)) {
 213         return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
 214     }
 215 }
 216
 217 sub quiltmode_splitbrain () {
 218     $quilt_mode =~ m/gbp|dpm|unapplied/;
 219 }
 220
 221 #---------- remote protocol support, common ----------
 222
 223 # remote push initiator/responder protocol:
 224 #  $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
 225 #  where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
 226 #  < dgit-remote-push-ready <actual-proto-vsn>
 227 #
 228 # occasionally:
 229 #
 230 #  > progress NBYTES
 231 #  [NBYTES message]
 232 #
 233 #  > supplementary-message NBYTES          # $protovsn >= 3
 234 #  [NBYTES message]
 235 #
 236 # main sequence:
 237 #
 238 #  > file parsed-changelog
 239 #  [indicates that output of dpkg-parsechangelog follows]
 240 #  > data-block NBYTES
 241 #  > [NBYTES bytes of data (no newline)]
 242 #  [maybe some more blocks]
 243 #  > data-end
 244 #
 245 #  > file dsc
 246 #  [etc]
 247 #
 248 #  > file changes
 249 #  [etc]
 250 #
 251 #  > param head DGIT-VIEW-HEAD
 252 #  > param csuite SUITE
 253 #  > param tagformat old|new
 254 #  > param maint-view MAINT-VIEW-HEAD
 255 #
 256 #  > previously REFNAME=OBJNAME       # if --deliberately-not-fast-forward
 257 #                                     # goes into tag, for replay prevention
 258 #
 259 #  > want signed-tag
 260 #  [indicates that signed tag is wanted]
 261 #  < data-block NBYTES
 262 #  < [NBYTES bytes of data (no newline)]
 263 #  [maybe some more blocks]
 264 #  < data-end
 265 #  < files-end
 266 #
 267 #  > want signed-dsc-changes
 268 #  < data-block NBYTES    [transfer of signed dsc]
 269 #  [etc]
 270 #  < data-block NBYTES    [transfer of signed changes]
 271 #  [etc]
 272 #  < files-end
 273 #
 274 #  > complete
 275
 276 our $i_child_pid;
 277
 278 sub i_child_report () {
 279     # Sees if our child has died, and reap it if so.  Returns a string
 280     # describing how it died if it failed, or undef otherwise.
 281     return undef unless $i_child_pid;
 282     my $got = waitpid $i_child_pid, WNOHANG;
 283     return undef if $got <= 0;
 284     die unless $got == $i_child_pid;
 285     $i_child_pid = undef;
 286     return undef unless $?;
 287     return "build host child ".waitstatusmsg();
 288 }
 289
 290 sub badproto ($$) {
 291     my ($fh, $m) = @_;
 292     fail "connection lost: $!" if $fh->error;
 293     fail "protocol violation; $m not expected";
 294 }
 295
 296 sub badproto_badread ($$) {
 297     my ($fh, $wh) = @_;
 298     fail "connection lost: $!" if $!;
 299     my $report = i_child_report();
 300     fail $report if defined $report;
 301     badproto $fh, "eof (reading $wh)";
 302 }
 303
 304 sub protocol_expect (&$) {
 305     my ($match, $fh) = @_;
 306     local $_;
 307     $_ = <$fh>;
 308     defined && chomp or badproto_badread $fh, "protocol message";
 309     if (wantarray) {
 310         my @r = &$match;
 311         return @r if @r;
 312     } else {
 313         my $r = &$match;
 314         return $r if $r;
 315     }
 316     badproto $fh, "\`$_'";
 317 }
 318
 319 sub protocol_send_file ($$) {
 320     my ($fh, $ourfn) = @_;
 321     open PF, "<", $ourfn or die "$ourfn: $!";
 322     for (;;) {
 323         my $d;
 324         my $got = read PF, $d, 65536;
 325         die "$ourfn: $!" unless defined $got;
 326         last if !$got;
 327         print $fh "data-block ".length($d)."\n" or die $!;
 328         print $fh $d or die $!;
 329     }
 330     PF->error and die "$ourfn $!";
 331     print $fh "data-end\n" or die $!;
 332     close PF;
 333 }
 334
 335 sub protocol_read_bytes ($$) {
 336     my ($fh, $nbytes) = @_;
 337     $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
 338     my $d;
 339     my $got = read $fh, $d, $nbytes;
 340     $got==$nbytes or badproto_badread $fh, "data block";
 341     return $d;
 342 }
 343
 344 sub protocol_receive_file ($$) {
 345     my ($fh, $ourfn) = @_;
 346     printdebug "() $ourfn\n";
 347     open PF, ">", $ourfn or die "$ourfn: $!";
 348     for (;;) {
 349         my ($y,$l) = protocol_expect {
 350             m/^data-block (.*)$/ ? (1,$1) :
 351             m/^data-end$/ ? (0,) :
 352             ();
 353         } $fh;
 354         last unless $y;
 355         my $d = protocol_read_bytes $fh, $l;
 356         print PF $d or die $!;
 357     }
 358     close PF or die $!;
 359 }
 360
 361 #---------- remote protocol support, responder ----------
 362
 363 sub responder_send_command ($) {
 364     my ($command) = @_;
 365     return unless $we_are_responder;
 366     # called even without $we_are_responder
 367     printdebug ">> $command\n";
 368     print PO $command, "\n" or die $!;
 369 }
 370
 371 sub responder_send_file ($$) {
 372     my ($keyword, $ourfn) = @_;
 373     return unless $we_are_responder;
 374     printdebug "]] $keyword $ourfn\n";
 375     responder_send_command "file $keyword";
 376     protocol_send_file \*PO, $ourfn;
 377 }
 378
 379 sub responder_receive_files ($@) {
 380     my ($keyword, @ourfns) = @_;
 381     die unless $we_are_responder;
 382     printdebug "[[ $keyword @ourfns\n";
 383     responder_send_command "want $keyword";
 384     foreach my $fn (@ourfns) {
 385         protocol_receive_file \*PI, $fn;
 386     }
 387     printdebug "[[\$\n";
 388     protocol_expect { m/^files-end$/ } \*PI;
 389 }
 390
 391 #---------- remote protocol support, initiator ----------
 392
 393 sub initiator_expect (&) {
 394     my ($match) = @_;
 395     protocol_expect { &$match } \*RO;
 396 }
 397
 398 #---------- end remote code ----------
 399
 400 sub progress {
 401     if ($we_are_responder) {
 402         my $m = join '', @_;
 403         responder_send_command "progress ".length($m) or die $!;
 404         print PO $m or die $!;
 405     } else {
 406         print @_, "\n";
 407     }
 408 }
 409
 410 our $ua;
 411
 412 sub url_get {
 413     if (!$ua) {
 414         $ua = LWP::UserAgent->new();
 415         $ua->env_proxy;
 416     }
 417     my $what = $_[$#_];
 418     progress "downloading $what...";
 419     my $r = $ua->get(@_) or die $!;
 420     return undef if $r->code == 404;
 421     $r->is_success or fail "failed to fetch $what: ".$r->status_line;
 422     return $r->decoded_content(charset => 'none');
 423 }
 424
 425 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
 426
 427 sub runcmd {
 428     debugcmd "+",@_;
 429     $!=0; $?=-1;
 430     failedcmd @_ if system @_;
 431 }
 432
 433 sub act_local () { return $dryrun_level <= 1; }
 434 sub act_scary () { return !$dryrun_level; }
 435
 436 sub printdone {
 437     if (!$dryrun_level) {
 438         progress "dgit ok: @_";
 439     } else {
 440         progress "would be ok: @_ (but dry run only)";
 441     }
 442 }
 443
 444 sub dryrun_report {
 445     printcmd(\*STDERR,$debugprefix."#",@_);
 446 }
 447
 448 sub runcmd_ordryrun {
 449     if (act_scary()) {
 450         runcmd @_;
 451     } else {
 452         dryrun_report @_;
 453     }
 454 }
 455
 456 sub runcmd_ordryrun_local {
 457     if (act_local()) {
 458         runcmd @_;
 459     } else {
 460         dryrun_report @_;
 461     }
 462 }
 463
 464 sub shell_cmd {
 465     my ($first_shell, @cmd) = @_;
 466     return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
 467 }
 468
 469 our $helpmsg = <<END;
 470 main usages:
 471   dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
 472   dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
 473   dgit [dgit-opts] build [dpkg-buildpackage-opts]
 474   dgit [dgit-opts] sbuild [sbuild-opts]
 475   dgit [dgit-opts] push [dgit-opts] [suite]
 476   dgit [dgit-opts] rpush build-host:build-dir ...
 477 important dgit options:
 478   -k<keyid>           sign tag and package with <keyid> instead of default
 479   --dry-run -n        do not change anything, but go through the motions
 480   --damp-run -L       like --dry-run but make local changes, without signing
 481   --new -N            allow introducing a new package
 482   --debug -D          increase debug level
 483   -c<name>=<value>    set git config option (used directly by dgit too)
 484 END
 485
 486 our $later_warning_msg = <<END;
 487 Perhaps the upload is stuck in incoming.  Using the version from git.
 488 END
 489
 490 sub badusage {
 491     print STDERR "$us: @_\n", $helpmsg or die $!;
 492     exit 8;
 493 }
 494
 495 sub nextarg {
 496     @ARGV or badusage "too few arguments";
 497     return scalar shift @ARGV;
 498 }
 499
 500 sub cmd_help () {
 501     print $helpmsg or die $!;
 502     exit 0;
 503 }
 504
 505 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
 506
 507 our %defcfg = ('dgit.default.distro' => 'debian',
 508                'dgit.default.username' => '',
 509                'dgit.default.archive-query-default-component' => 'main',
 510                'dgit.default.ssh' => 'ssh',
 511                'dgit.default.archive-query' => 'madison:',
 512                'dgit.default.sshpsql-dbname' => 'service=projectb',
 513                'dgit.default.dgit-tag-format' => 'old,new,maint',
 514                'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
 515                'dgit-distro.debian.git-check' => 'url',
 516                'dgit-distro.debian.git-check-suffix' => '/info/refs',
 517                'dgit-distro.debian.new-private-pushers' => 't',
 518                'dgit-distro.debian.dgit-tag-format' => 'old',
 519                'dgit-distro.debian/push.git-url' => '',
 520                'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
 521                'dgit-distro.debian/push.git-user-force' => 'dgit',
 522                'dgit-distro.debian/push.git-proto' => 'git+ssh://',
 523                'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
 524                'dgit-distro.debian/push.git-create' => 'true',
 525                'dgit-distro.debian/push.git-check' => 'ssh-cmd',
 526  'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
 527 # 'dgit-distro.debian.archive-query-tls-key',
 528 #    '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
 529 # ^ this does not work because curl is broken nowadays
 530 # Fixing #790093 properly will involve providing providing the key
 531 # in some pacagke and maybe updating these paths.
 532 #
 533 # 'dgit-distro.debian.archive-query-tls-curl-args',
 534 #   '--ca-path=/etc/ssl/ca-debian',
 535 # ^ this is a workaround but works (only) on DSA-administered machines
 536                'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
 537                'dgit-distro.debian.git-url-suffix' => '',
 538                'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
 539                'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
 540  'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
 541  'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
 542                'dgit-distro.ubuntu.git-check' => 'false',
 543  'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
 544                'dgit-distro.test-dummy.ssh' => "$td/ssh",
 545                'dgit-distro.test-dummy.username' => "alice",
 546                'dgit-distro.test-dummy.git-check' => "ssh-cmd",
 547                'dgit-distro.test-dummy.git-create' => "ssh-cmd",
 548                'dgit-distro.test-dummy.git-url' => "$td/git",
 549                'dgit-distro.test-dummy.git-host' => "git",
 550                'dgit-distro.test-dummy.git-path' => "$td/git",
 551                'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
 552                'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
 553                'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
 554                'dgit-distro.test-dummy.upload-host' => 'test-dummy',
 555                );
 556
 557 our %gitcfg;
 558
 559 sub git_slurp_config () {
 560     local ($debuglevel) = $debuglevel-2;
 561     local $/="\0";
 562
 563     my @cmd = (@git, qw(config -z --get-regexp .*));
 564     debugcmd "|",@cmd;
 565
 566     open GITS, "-|", @cmd or die $!;
 567     while (<GITS>) {
 568         chomp or die;
 569         printdebug "=> ", (messagequote $_), "\n";
 570         m/\n/ or die "$_ ?";
 571         push @{ $gitcfg{$`} }, $'; #';
 572     }
 573     $!=0; $?=0;
 574     close GITS
 575         or ($!==0 && $?==256)
 576         or failedcmd @cmd;
 577 }
 578
 579 sub git_get_config ($) {
 580     my ($c) = @_;
 581     my $l = $gitcfg{$c};
 582     printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
 583         if $debuglevel >= 4;
 584     $l or return undef;
 585     @$l==1 or badcfg "multiple values for $c" if @$l > 1;
 586     return $l->[0];
 587 }
 588
 589 sub cfg {
 590     foreach my $c (@_) {
 591         return undef if $c =~ /RETURN-UNDEF/;
 592         my $v = git_get_config($c);
 593         return $v if defined $v;
 594         my $dv = $defcfg{$c};
 595         return $dv if defined $dv;
 596     }
 597     badcfg "need value for one of: @_\n".
 598         "$us: distro or suite appears not to be (properly) supported";
 599 }
 600
 601 sub access_basedistro () {
 602     if (defined $idistro) {
 603         return $idistro;
 604     } else {
 605         return cfg("dgit-suite.$isuite.distro",
 606                    "dgit.default.distro");
 607     }
 608 }
 609
 610 sub access_quirk () {
 611     # returns (quirk name, distro to use instead or undef, quirk-specific info)
 612     my $basedistro = access_basedistro();
 613     my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
 614                               'RETURN-UNDEF');
 615     if (defined $backports_quirk) {
 616         my $re = $backports_quirk;
 617         $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
 618         $re =~ s/\*/.*/g;
 619         $re =~ s/\%/([-0-9a-z_]+)/
 620             or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
 621         if ($isuite =~ m/^$re$/) {
 622             return ('backports',"$basedistro-backports",$1);
 623         }
 624     }
 625     return ('none',undef);
 626 }
 627
 628 our $access_forpush;
 629
 630 sub parse_cfg_bool ($$$) {
 631     my ($what,$def,$v) = @_;
 632     $v //= $def;
 633     return
 634         $v =~ m/^[ty1]/ ? 1 :
 635         $v =~ m/^[fn0]/ ? 0 :
 636         badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
 637 }
 638
 639 sub access_forpush_config () {
 640     my $d = access_basedistro();
 641
 642     return 1 if
 643         $new_package &&
 644         parse_cfg_bool('new-private-pushers', 0,
 645                        cfg("dgit-distro.$d.new-private-pushers",
 646                            'RETURN-UNDEF'));
 647
 648     my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
 649     $v //= 'a';
 650     return
 651         $v =~ m/^[ty1]/ ? 0 : # force readonly,    forpush = 0
 652         $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
 653         $v =~ m/^[a]/  ? '' : # auto,              forpush = ''
 654         badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
 655 }
 656
 657 sub access_forpush () {
 658     $access_forpush //= access_forpush_config();
 659     return $access_forpush;
 660 }
 661
 662 sub pushing () {
 663     die "$access_forpush ?" if ($access_forpush // 1) ne 1;
 664     badcfg "pushing but distro is configured readonly"
 665         if access_forpush_config() eq '0';
 666     $access_forpush = 1;
 667     $supplementary_message = <<'END' unless $we_are_responder;
 668 Push failed, before we got started.
 669 You can retry the push, after fixing the problem, if you like.
 670 END
 671     finalise_opts_opts();
 672 }
 673
 674 sub notpushing () {
 675     finalise_opts_opts();
 676 }
 677
 678 sub supplementary_message ($) {
 679     my ($msg) = @_;
 680     if (!$we_are_responder) {
 681         $supplementary_message = $msg;
 682         return;
 683     } elsif ($protovsn >= 3) {
 684         responder_send_command "supplementary-message ".length($msg)
 685             or die $!;
 686         print PO $msg or die $!;
 687     }
 688 }
 689
 690 sub access_distros () {
 691     # Returns list of distros to try, in order
 692     #
 693     # We want to try:
 694     #    0. `instead of' distro name(s) we have been pointed to
 695     #    1. the access_quirk distro, if any
 696     #    2a. the user's specified distro, or failing that  } basedistro
 697     #    2b. the distro calculated from the suite          }
 698     my @l = access_basedistro();
 699
 700     my (undef,$quirkdistro) = access_quirk();
 701     unshift @l, $quirkdistro;
 702     unshift @l, $instead_distro;
 703     @l = grep { defined } @l;
 704
 705     if (access_forpush()) {
 706         @l = map { ("$_/push", $_) } @l;
 707     }
 708     @l;
 709 }
 710
 711 sub access_cfg_cfgs (@) {
 712     my (@keys) = @_;
 713     my @cfgs;
 714     # The nesting of these loops determines the search order.  We put
 715     # the key loop on the outside so that we search all the distros
 716     # for each key, before going on to the next key.  That means that
 717     # if access_cfg is called with a more specific, and then a less
 718     # specific, key, an earlier distro can override the less specific
 719     # without necessarily overriding any more specific keys.  (If the
 720     # distro wants to override the more specific keys it can simply do
 721     # so; whereas if we did the loop the other way around, it would be
 722     # impossible to for an earlier distro to override a less specific
 723     # key but not the more specific ones without restating the unknown
 724     # values of the more specific keys.
 725     my @realkeys;
 726     my @rundef;
 727     # We have to deal with RETURN-UNDEF specially, so that we don't
 728     # terminate the search prematurely.
 729     foreach (@keys) {
 730         if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
 731         push @realkeys, $_
 732     }
 733     foreach my $d (access_distros()) {
 734         push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
 735     }
 736     push @cfgs, map { "dgit.default.$_" } @realkeys;
 737     push @cfgs, @rundef;
 738     return @cfgs;
 739 }
 740
 741 sub access_cfg (@) {
 742     my (@keys) = @_;
 743     my (@cfgs) = access_cfg_cfgs(@keys);
 744     my $value = cfg(@cfgs);
 745     return $value;
 746 }
 747
 748 sub access_cfg_bool ($$) {
 749     my ($def, @keys) = @_;
 750     parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
 751 }
 752
 753 sub string_to_ssh ($) {
 754     my ($spec) = @_;
 755     if ($spec =~ m/\s/) {
 756         return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
 757     } else {
 758         return ($spec);
 759     }
 760 }
 761
 762 sub access_cfg_ssh () {
 763     my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
 764     if (!defined $gitssh) {
 765         return @ssh;
 766     } else {
 767         return string_to_ssh $gitssh;
 768     }
 769 }
 770
 771 sub access_runeinfo ($) {
 772     my ($info) = @_;
 773     return ": dgit ".access_basedistro()." $info ;";
 774 }
 775
 776 sub access_someuserhost ($) {
 777     my ($some) = @_;
 778     my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
 779     defined($user) && length($user) or
 780         $user = access_cfg("$some-user",'username');
 781     my $host = access_cfg("$some-host");
 782     return length($user) ? "$user\@$host" : $host;
 783 }
 784
 785 sub access_gituserhost () {
 786     return access_someuserhost('git');
 787 }
 788
 789 sub access_giturl (;$) {
 790     my ($optional) = @_;
 791     my $url = access_cfg('git-url','RETURN-UNDEF');
 792     my $suffix;
 793     if (!length $url) {
 794         my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
 795         return undef unless defined $proto;
 796         $url =
 797             $proto.
 798             access_gituserhost().
 799             access_cfg('git-path');
 800     } else {
 801         $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
 802     }
 803     $suffix //= '.git';
 804     return "$url/$package$suffix";
 805 }
 806
 807 sub parsecontrolfh ($$;$) {
 808     my ($fh, $desc, $allowsigned) = @_;
 809     our $dpkgcontrolhash_noissigned;
 810     my $c;
 811     for (;;) {
 812         my %opts = ('name' => $desc);
 813         $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
 814         $c = Dpkg::Control::Hash->new(%opts);
 815         $c->parse($fh,$desc) or die "parsing of $desc failed";
 816         last if $allowsigned;
 817         last if $dpkgcontrolhash_noissigned;
 818         my $issigned= $c->get_option('is_pgp_signed');
 819         if (!defined $issigned) {
 820             $dpkgcontrolhash_noissigned= 1;
 821             seek $fh, 0,0 or die "seek $desc: $!";
 822         } elsif ($issigned) {
 823             fail "control file $desc is (already) PGP-signed. ".
 824                 " Note that dgit push needs to modify the .dsc and then".
 825                 " do the signature itself";
 826         } else {
 827             last;
 828         }
 829     }
 830     return $c;
 831 }
 832
 833 sub parsecontrol {
 834     my ($file, $desc) = @_;
 835     my $fh = new IO::Handle;
 836     open $fh, '<', $file or die "$file: $!";
 837     my $c = parsecontrolfh($fh,$desc);
 838     $fh->error and die $!;
 839     close $fh;
 840     return $c;
 841 }
 842
 843 sub getfield ($$) {
 844     my ($dctrl,$field) = @_;
 845     my $v = $dctrl->{$field};
 846     return $v if defined $v;
 847     fail "missing field $field in ".$v->get_option('name');
 848 }
 849
 850 sub parsechangelog {
 851     my $c = Dpkg::Control::Hash->new();
 852     my $p = new IO::Handle;
 853     my @cmd = (qw(dpkg-parsechangelog), @_);
 854     open $p, '-|', @cmd or die $!;
 855     $c->parse($p);
 856     $?=0; $!=0; close $p or failedcmd @cmd;
 857     return $c;
 858 }
 859
 860 sub must_getcwd () {
 861     my $d = getcwd();
 862     defined $d or fail "getcwd failed: $!";
 863     return $d;
 864 }
 865
 866 our %rmad;
 867
 868 sub archive_query ($) {
 869     my ($method) = @_;
 870     my $query = access_cfg('archive-query','RETURN-UNDEF');
 871     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
 872     my $proto = $1;
 873     my $data = $'; #';
 874     { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
 875 }
 876
 877 sub pool_dsc_subpath ($$) {
 878     my ($vsn,$component) = @_; # $package is implict arg
 879     my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
 880     return "/pool/$component/$prefix/$package/".dscfn($vsn);
 881 }
 882
 883 #---------- `ftpmasterapi' archive query method (nascent) ----------
 884
 885 sub archive_api_query_cmd ($) {
 886     my ($subpath) = @_;
 887     my @cmd = qw(curl -sS);
 888     my $url = access_cfg('archive-query-url');
 889     if ($url =~ m#^https://([-.0-9a-z]+)/#) {
 890         my $host = $1;
 891         my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
 892         foreach my $key (split /\:/, $keys) {
 893             $key =~ s/\%HOST\%/$host/g;
 894             if (!stat $key) {
 895                 fail "for $url: stat $key: $!" unless $!==ENOENT;
 896                 next;
 897             }
 898             fail "config requested specific TLS key but do not know".
 899                 " how to get curl to use exactly that EE key ($key)";
 900 #           push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
 901 #           # Sadly the above line does not work because of changes
 902 #           # to gnutls.   The real fix for #790093 may involve
 903 #           # new curl options.
 904             last;
 905         }
 906         # Fixing #790093 properly will involve providing a value
 907         # for this on clients.
 908         my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
 909         push @cmd, split / /, $kargs if defined $kargs;
 910     }
 911     push @cmd, $url.$subpath;
 912     return @cmd;
 913 }
 914
 915 sub api_query ($$) {
 916     use JSON;
 917     my ($data, $subpath) = @_;
 918     badcfg "ftpmasterapi archive query method takes no data part"
 919         if length $data;
 920     my @cmd = archive_api_query_cmd($subpath);
 921     my $json = cmdoutput @cmd;
 922     return decode_json($json);
 923 }
 924
 925 sub canonicalise_suite_ftpmasterapi () {
 926     my ($proto,$data) = @_;
 927     my $suites = api_query($data, 'suites');
 928     my @matched;
 929     foreach my $entry (@$suites) {
 930         next unless grep {
 931             my $v = $entry->{$_};
 932             defined $v && $v eq $isuite;
 933         } qw(codename name);
 934         push @matched, $entry;
 935     }
 936     fail "unknown suite $isuite" unless @matched;
 937     my $cn;
 938     eval {
 939         @matched==1 or die "multiple matches for suite $isuite\n";
 940         $cn = "$matched[0]{codename}";
 941         defined $cn or die "suite $isuite info has no codename\n";
 942         $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
 943     };
 944     die "bad ftpmaster api response: $@\n".Dumper(\@matched)
 945         if length $@;
 946     return $cn;
 947 }
 948
 949 sub archive_query_ftpmasterapi () {
 950     my ($proto,$data) = @_;
 951     my $info = api_query($data, "dsc_in_suite/$isuite/$package");
 952     my @rows;
 953     my $digester = Digest::SHA->new(256);
 954     foreach my $entry (@$info) {
 955         eval {
 956             my $vsn = "$entry->{version}";
 957             my ($ok,$msg) = version_check $vsn;
 958             die "bad version: $msg\n" unless $ok;
 959             my $component = "$entry->{component}";
 960             $component =~ m/^$component_re$/ or die "bad component";
 961             my $filename = "$entry->{filename}";
 962             $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
 963                 or die "bad filename";
 964             my $sha256sum = "$entry->{sha256sum}";
 965             $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
 966             push @rows, [ $vsn, "/pool/$component/$filename",
 967                           $digester, $sha256sum ];
 968         };
 969         die "bad ftpmaster api response: $@\n".Dumper($entry)
 970             if length $@;
 971     }
 972     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
 973     return @rows;
 974 }
 975
 976 #---------- `madison' archive query method ----------
 977
 978 sub archive_query_madison {
 979     return map { [ @$_[0..1] ] } madison_get_parse(@_);
 980 }
 981
 982 sub madison_get_parse {
 983     my ($proto,$data) = @_;
 984     die unless $proto eq 'madison';
 985     if (!length $data) {
 986         $data= access_cfg('madison-distro','RETURN-UNDEF');
 987         $data //= access_basedistro();
 988     }
 989     $rmad{$proto,$data,$package} ||= cmdoutput
 990         qw(rmadison -asource),"-s$isuite","-u$data",$package;
 991     my $rmad = $rmad{$proto,$data,$package};
 992
 993     my @out;
 994     foreach my $l (split /\n/, $rmad) {
 995         $l =~ m{^ \s*( [^ \t|]+ )\s* \|
 996                   \s*( [^ \t|]+ )\s* \|
 997                   \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
 998                   \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
 999         $1 eq $package or die "$rmad $package ?";
1000         my $vsn = $2;
1001         my $newsuite = $3;
1002         my $component;
1003         if (defined $4) {
1004             $component = $4;
1005         } else {
1006             $component = access_cfg('archive-query-default-component');
1007         }
1008         $5 eq 'source' or die "$rmad ?";
1009         push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1010     }
1011     return sort { -version_compare($a->[0],$b->[0]); } @out;
1012 }
1013
1014 sub canonicalise_suite_madison {
1015     # madison canonicalises for us
1016     my @r = madison_get_parse(@_);
1017     @r or fail
1018         "unable to canonicalise suite using package $package".
1019         " which does not appear to exist in suite $isuite;".
1020         " --existing-package may help";
1021     return $r[0][2];
1022 }
1023
1024 #---------- `sshpsql' archive query method ----------
1025
1026 sub sshpsql ($$$) {
1027     my ($data,$runeinfo,$sql) = @_;
1028     if (!length $data) {
1029         $data= access_someuserhost('sshpsql').':'.
1030             access_cfg('sshpsql-dbname');
1031     }
1032     $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1033     my ($userhost,$dbname) = ($`,$'); #';
1034     my @rows;
1035     my @cmd = (access_cfg_ssh, $userhost,
1036                access_runeinfo("ssh-psql $runeinfo").
1037                " export LC_MESSAGES=C; export LC_CTYPE=C;".
1038                " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1039     debugcmd "|",@cmd;
1040     open P, "-|", @cmd or die $!;
1041     while (<P>) {
1042         chomp or die;
1043         printdebug(">|$_|\n");
1044         push @rows, $_;
1045     }
1046     $!=0; $?=0; close P or failedcmd @cmd;
1047     @rows or die;
1048     my $nrows = pop @rows;
1049     $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1050     @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1051     @rows = map { [ split /\|/, $_ ] } @rows;
1052     my $ncols = scalar @{ shift @rows };
1053     die if grep { scalar @$_ != $ncols } @rows;
1054     return @rows;
1055 }
1056
1057 sub sql_injection_check {
1058     foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1059 }
1060
1061 sub archive_query_sshpsql ($$) {
1062     my ($proto,$data) = @_;
1063     sql_injection_check $isuite, $package;
1064     my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1065         SELECT source.version, component.name, files.filename, files.sha256sum
1066           FROM source
1067           JOIN src_associations ON source.id = src_associations.source
1068           JOIN suite ON suite.id = src_associations.suite
1069           JOIN dsc_files ON dsc_files.source = source.id
1070           JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1071           JOIN component ON component.id = files_archive_map.component_id
1072           JOIN files ON files.id = dsc_files.file
1073          WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1074            AND source.source='$package'
1075            AND files.filename LIKE '%.dsc';
1076 END
1077     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1078     my $digester = Digest::SHA->new(256);
1079     @rows = map {
1080         my ($vsn,$component,$filename,$sha256sum) = @$_;
1081         [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1082     } @rows;
1083     return @rows;
1084 }
1085
1086 sub canonicalise_suite_sshpsql ($$) {
1087     my ($proto,$data) = @_;
1088     sql_injection_check $isuite;
1089     my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1090         SELECT suite.codename
1091           FROM suite where suite_name='$isuite' or codename='$isuite';
1092 END
1093     @rows = map { $_->[0] } @rows;
1094     fail "unknown suite $isuite" unless @rows;
1095     die "ambiguous $isuite: @rows ?" if @rows>1;
1096     return $rows[0];
1097 }
1098
1099 #---------- `dummycat' archive query method ----------
1100
1101 sub canonicalise_suite_dummycat ($$) {
1102     my ($proto,$data) = @_;
1103     my $dpath = "$data/suite.$isuite";
1104     if (!open C, "<", $dpath) {
1105         $!==ENOENT or die "$dpath: $!";
1106         printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1107         return $isuite;
1108     }
1109     $!=0; $_ = <C>;
1110     chomp or die "$dpath: $!";
1111     close C;
1112     printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1113     return $_;
1114 }
1115
1116 sub archive_query_dummycat ($$) {
1117     my ($proto,$data) = @_;
1118     canonicalise_suite();
1119     my $dpath = "$data/package.$csuite.$package";
1120     if (!open C, "<", $dpath) {
1121         $!==ENOENT or die "$dpath: $!";
1122         printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1123         return ();
1124     }
1125     my @rows;
1126     while (<C>) {
1127         next if m/^\#/;
1128         next unless m/\S/;
1129         die unless chomp;
1130         printdebug "dummycat query $csuite $package $dpath | $_\n";
1131         my @row = split /\s+/, $_;
1132         @row==2 or die "$dpath: $_ ?";
1133         push @rows, \@row;
1134     }
1135     C->error and die "$dpath: $!";
1136     close C;
1137     return sort { -version_compare($a->[0],$b->[0]); } @rows;
1138 }
1139
1140 #---------- tag format handling ----------
1141
1142 sub access_cfg_tagformats () {
1143     split /\,/, access_cfg('dgit-tag-format');
1144 }
1145
1146 sub need_tagformat ($$) {
1147     my ($fmt, $why) = @_;
1148     fail "need to use tag format $fmt ($why) but also need".
1149         " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1150         " - no way to proceed"
1151         if $tagformat_want && $tagformat_want->[0] ne $fmt;
1152     $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1153 }
1154
1155 sub select_tagformat () {
1156     # sets $tagformatfn
1157     return if $tagformatfn && !$tagformat_want;
1158     die 'bug' if $tagformatfn && $tagformat_want;
1159     # ... $tagformat_want assigned after previous select_tagformat
1160
1161     my (@supported) = grep { $_ ne 'maint' } access_cfg_tagformats();
1162     printdebug "select_tagformat supported @supported\n";
1163
1164     $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1165     printdebug "select_tagformat specified @$tagformat_want\n";
1166
1167     my ($fmt,$why,$override) = @$tagformat_want;
1168
1169     fail "target distro supports tag formats @supported".
1170         " but have to use $fmt ($why)"
1171         unless $override
1172             or grep { $_ eq $fmt } @supported;
1173
1174     $tagformat_want = undef;
1175     $tagformat = $fmt;
1176     $tagformatfn = ${*::}{"debiantag_$fmt"};
1177
1178     fail "trying to use unknown tag format \`$fmt' ($why) !"
1179         unless $tagformatfn;
1180 }
1181
1182 #---------- archive query entrypoints and rest of program ----------
1183
1184 sub canonicalise_suite () {
1185     return if defined $csuite;
1186     fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1187     $csuite = archive_query('canonicalise_suite');
1188     if ($isuite ne $csuite) {
1189         progress "canonical suite name for $isuite is $csuite";
1190     }
1191 }
1192
1193 sub get_archive_dsc () {
1194     canonicalise_suite();
1195     my @vsns = archive_query('archive_query');
1196     foreach my $vinfo (@vsns) {
1197         my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1198         $dscurl = access_cfg('mirror').$subpath;
1199         $dscdata = url_get($dscurl);
1200         if (!$dscdata) {
1201             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1202             next;
1203         }
1204         if ($digester) {
1205             $digester->reset();
1206             $digester->add($dscdata);
1207             my $got = $digester->hexdigest();
1208             $got eq $digest or
1209                 fail "$dscurl has hash $got but".
1210                     " archive told us to expect $digest";
1211         }
1212         my $dscfh = new IO::File \$dscdata, '<' or die $!;
1213         printdebug Dumper($dscdata) if $debuglevel>1;
1214         $dsc = parsecontrolfh($dscfh,$dscurl,1);
1215         printdebug Dumper($dsc) if $debuglevel>1;
1216         my $fmt = getfield $dsc, 'Format';
1217         fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1218         $dsc_checked = !!$digester;
1219         printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1220         return;
1221     }
1222     $dsc = undef;
1223     printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1224 }
1225
1226 sub check_for_git ();
1227 sub check_for_git () {
1228     # returns 0 or 1
1229     my $how = access_cfg('git-check');
1230     if ($how eq 'ssh-cmd') {
1231         my @cmd =
1232             (access_cfg_ssh, access_gituserhost(),
1233              access_runeinfo("git-check $package").
1234              " set -e; cd ".access_cfg('git-path').";".
1235              " if test -d $package.git; then echo 1; else echo 0; fi");
1236         my $r= cmdoutput @cmd;
1237         if (defined $r and $r =~ m/^divert (\w+)$/) {
1238             my $divert=$1;
1239             my ($usedistro,) = access_distros();
1240             # NB that if we are pushing, $usedistro will be $distro/push
1241             $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1242             $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1243             progress "diverting to $divert (using config for $instead_distro)";
1244             return check_for_git();
1245         }
1246         failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1247         return $r+0;
1248     } elsif ($how eq 'url') {
1249         my $prefix = access_cfg('git-check-url','git-url');
1250         my $suffix = access_cfg('git-check-suffix','git-suffix',
1251                                 'RETURN-UNDEF') // '.git';
1252         my $url = "$prefix/$package$suffix";
1253         my @cmd = (qw(curl -sS -I), $url);
1254         my $result = cmdoutput @cmd;
1255         $result =~ s/^\S+ 200 .*\n\r?\n//;
1256         # curl -sS -I with https_proxy prints
1257         # HTTP/1.0 200 Connection established
1258         $result =~ m/^\S+ (404|200) /s or
1259             fail "unexpected results from git check query - ".
1260                 Dumper($prefix, $result);
1261         my $code = $1;
1262         if ($code eq '404') {
1263             return 0;
1264         } elsif ($code eq '200') {
1265             return 1;
1266         } else {
1267             die;
1268         }
1269     } elsif ($how eq 'true') {
1270         return 1;
1271     } elsif ($how eq 'false') {
1272         return 0;
1273     } else {
1274         badcfg "unknown git-check \`$how'";
1275     }
1276 }
1277
1278 sub create_remote_git_repo () {
1279     my $how = access_cfg('git-create');
1280     if ($how eq 'ssh-cmd') {
1281         runcmd_ordryrun
1282             (access_cfg_ssh, access_gituserhost(),
1283              access_runeinfo("git-create $package").
1284              "set -e; cd ".access_cfg('git-path').";".
1285              " cp -a _template $package.git");
1286     } elsif ($how eq 'true') {
1287         # nothing to do
1288     } else {
1289         badcfg "unknown git-create \`$how'";
1290     }
1291 }
1292
1293 our ($dsc_hash,$lastpush_mergeinput);
1294
1295 our $ud = '.git/dgit/unpack';
1296
1297 sub prep_ud (;$) {
1298     my ($d) = @_;
1299     $d //= $ud;
1300     rmtree($d);
1301     mkpath '.git/dgit';
1302     mkdir $d or die $!;
1303 }
1304
1305 sub mktree_in_ud_here () {
1306     runcmd qw(git init -q);
1307     rmtree('.git/objects');
1308     symlink '../../../../objects','.git/objects' or die $!;
1309 }
1310
1311 sub git_write_tree () {
1312     my $tree = cmdoutput @git, qw(write-tree);
1313     $tree =~ m/^\w+$/ or die "$tree ?";
1314     return $tree;
1315 }
1316
1317 sub remove_stray_gits () {
1318     my @gitscmd = qw(find -name .git -prune -print0);
1319     debugcmd "|",@gitscmd;
1320     open GITS, "-|", @gitscmd or die $!;
1321     {
1322         local $/="\0";
1323         while (<GITS>) {
1324             chomp or die;
1325             print STDERR "$us: warning: removing from source package: ",
1326                 (messagequote $_), "\n";
1327             rmtree $_;
1328         }
1329     }
1330     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1331 }
1332
1333 sub mktree_in_ud_from_only_subdir () {
1334     # changes into the subdir
1335     my (@dirs) = <*/.>;
1336     die "@dirs ?" unless @dirs==1;
1337     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1338     my $dir = $1;
1339     changedir $dir;
1340
1341     remove_stray_gits();
1342     mktree_in_ud_here();
1343     my ($format, $fopts) = get_source_format();
1344     if (madformat($format)) {
1345         rmtree '.pc';
1346     }
1347     runcmd @git, qw(add -Af);
1348     my $tree=git_write_tree();
1349     return ($tree,$dir);
1350 }
1351
1352 sub dsc_files_info () {
1353     foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1354                        ['Checksums-Sha1',  'Digest::SHA', 'new(1)'],
1355                        ['Files',           'Digest::MD5', 'new()']) {
1356         my ($fname, $module, $method) = @$csumi;
1357         my $field = $dsc->{$fname};
1358         next unless defined $field;
1359         eval "use $module; 1;" or die $@;
1360         my @out;
1361         foreach (split /\n/, $field) {
1362             next unless m/\S/;
1363             m/^(\w+) (\d+) (\S+)$/ or
1364                 fail "could not parse .dsc $fname line \`$_'";
1365             my $digester = eval "$module"."->$method;" or die $@;
1366             push @out, {
1367                 Hash => $1,
1368                 Bytes => $2,
1369                 Filename => $3,
1370                 Digester => $digester,
1371             };
1372         }
1373         return @out;
1374     }
1375     fail "missing any supported Checksums-* or Files field in ".
1376         $dsc->get_option('name');
1377 }
1378
1379 sub dsc_files () {
1380     map { $_->{Filename} } dsc_files_info();
1381 }
1382
1383 sub is_orig_file ($;$) {
1384     local ($_) = $_[0];
1385     my $base = $_[1];
1386     m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1387     defined $base or return 1;
1388     return $` eq $base;
1389 }
1390
1391 sub make_commit ($) {
1392     my ($file) = @_;
1393     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1394 }
1395
1396 sub clogp_authline ($) {
1397     my ($clogp) = @_;
1398     my $author = getfield $clogp, 'Maintainer';
1399     $author =~ s#,.*##ms;
1400     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1401     my $authline = "$author $date";
1402     $authline =~ m/$git_authline_re/o or
1403         fail "unexpected commit author line format \`$authline'".
1404         " (was generated from changelog Maintainer field)";
1405     return ($1,$2,$3) if wantarray;
1406     return $authline;
1407 }
1408
1409 sub vendor_patches_distro ($$) {
1410     my ($checkdistro, $what) = @_;
1411     return unless defined $checkdistro;
1412
1413     my $series = "debian/patches/\L$checkdistro\E.series";
1414     printdebug "checking for vendor-specific $series ($what)\n";
1415
1416     if (!open SERIES, "<", $series) {
1417         die "$series $!" unless $!==ENOENT;
1418         return;
1419     }
1420     while (<SERIES>) {
1421         next unless m/\S/;
1422         next if m/^\s+\#/;
1423
1424         print STDERR <<END;
1425
1426 Unfortunately, this source package uses a feature of dpkg-source where
1427 the same source package unpacks to different source code on different
1428 distros.  dgit cannot safely operate on such packages on affected
1429 distros, because the meaning of source packages is not stable.
1430
1431 Please ask the distro/maintainer to remove the distro-specific series
1432 files and use a different technique (if necessary, uploading actually
1433 different packages, if different distros are supposed to have
1434 different code).
1435
1436 END
1437         fail "Found active distro-specific series file for".
1438             " $checkdistro ($what): $series, cannot continue";
1439     }
1440     die "$series $!" if SERIES->error;
1441     close SERIES;
1442 }
1443
1444 sub check_for_vendor_patches () {
1445     # This dpkg-source feature doesn't seem to be documented anywhere!
1446     # But it can be found in the changelog (reformatted):
1447
1448     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
1449     #   Author: Raphael Hertzog <hertzog@debian.org>
1450     #   Date: Sun  Oct  3  09:36:48  2010 +0200
1451
1452     #   dpkg-source: correctly create .pc/.quilt_series with alternate
1453     #   series files
1454     #
1455     #   If you have debian/patches/ubuntu.series and you were
1456     #   unpacking the source package on ubuntu, quilt was still
1457     #   directed to debian/patches/series instead of
1458     #   debian/patches/ubuntu.series.
1459     #
1460     #   debian/changelog                        |    3 +++
1461     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
1462     #   2 files changed, 6 insertions(+), 1 deletion(-)
1463
1464     use Dpkg::Vendor;
1465     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1466     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1467                          "Dpkg::Vendor \`current vendor'");
1468     vendor_patches_distro(access_basedistro(),
1469                           "distro being accessed");
1470 }
1471
1472 sub generate_commits_from_dsc () {
1473     # See big comment in fetch_from_archive, below.
1474     prep_ud();
1475     changedir $ud;
1476
1477     foreach my $fi (dsc_files_info()) {
1478         my $f = $fi->{Filename};
1479         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1480
1481         link_ltarget "../../../$f", $f
1482             or $!==&ENOENT
1483             or die "$f $!";
1484
1485         complete_file_from_dsc('.', $fi)
1486             or next;
1487
1488         if (is_orig_file($f)) {
1489             link $f, "../../../../$f"
1490                 or $!==&EEXIST
1491                 or die "$f $!";
1492         }
1493     }
1494
1495     my $dscfn = "$package.dsc";
1496
1497     open D, ">", $dscfn or die "$dscfn: $!";
1498     print D $dscdata or die "$dscfn: $!";
1499     close D or die "$dscfn: $!";
1500     my @cmd = qw(dpkg-source);
1501     push @cmd, '--no-check' if $dsc_checked;
1502     push @cmd, qw(-x --), $dscfn;
1503     runcmd @cmd;
1504
1505     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1506     check_for_vendor_patches() if madformat($dsc->{format});
1507     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1508     my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1509     my $authline = clogp_authline $clogp;
1510     my $changes = getfield $clogp, 'Changes';
1511     open C, ">../commit.tmp" or die $!;
1512     print C <<END or die $!;
1513 tree $tree
1514 author $authline
1515 committer $authline
1516
1517 $changes
1518
1519 # imported from the archive
1520 END
1521     close C or die $!;
1522     my $rawimport_hash = make_commit qw(../commit.tmp);
1523     my $cversion = getfield $clogp, 'Version';
1524     my $rawimport_mergeinput = {
1525         Commit => $rawimport_hash,
1526         Info => "Import of source package",
1527     };
1528     my @output = ($rawimport_mergeinput);
1529     progress "synthesised git commit from .dsc $cversion";
1530     if ($lastpush_mergeinput) {
1531         my $lastpush_hash = $lastpush_mergeinput->{Commit};
1532         runcmd @git, qw(reset -q --hard), $lastpush_hash;
1533         runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1534         my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1535         my $oversion = getfield $oldclogp, 'Version';
1536         my $vcmp =
1537             version_compare($oversion, $cversion);
1538         if ($vcmp < 0) {
1539             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1540                 { Message => <<END, ReverseParents => 1 });
1541 Record $package ($cversion) in archive suite $csuite
1542 END
1543         } elsif ($vcmp > 0) {
1544             print STDERR <<END or die $!;
1545
1546 Version actually in archive:   $cversion (older)
1547 Last version pushed with dgit: $oversion (newer or same)
1548 $later_warning_msg
1549 END
1550             @output = $lastpush_mergeinput;
1551         } else {
1552             # Same version.  Use what's in the server git branch,
1553             # discarding our own import.  (This could happen if the
1554             # server automatically imports all packages into git.)
1555             @output = $lastpush_mergeinput;
1556         }
1557     }
1558     changedir '../../../..';
1559     rmtree($ud);
1560     return @output;
1561 }
1562
1563 sub complete_file_from_dsc ($$) {
1564     our ($dstdir, $fi) = @_;
1565     # Ensures that we have, in $dir, the file $fi, with the correct
1566     # contents.  (Downloading it from alongside $dscurl if necessary.)
1567
1568     my $f = $fi->{Filename};
1569     my $tf = "$dstdir/$f";
1570     my $downloaded = 0;
1571
1572     if (stat_exists $tf) {
1573         progress "using existing $f";
1574     } else {
1575         my $furl = $dscurl;
1576         $furl =~ s{/[^/]+$}{};
1577         $furl .= "/$f";
1578         die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1579         die "$f ?" if $f =~ m#/#;
1580         runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1581         return 0 if !act_local();
1582         $downloaded = 1;
1583     }
1584
1585     open F, "<", "$tf" or die "$tf: $!";
1586     $fi->{Digester}->reset();
1587     $fi->{Digester}->addfile(*F);
1588     F->error and die $!;
1589     my $got = $fi->{Digester}->hexdigest();
1590     $got eq $fi->{Hash} or
1591         fail "file $f has hash $got but .dsc".
1592             " demands hash $fi->{Hash} ".
1593             ($downloaded ? "(got wrong file from archive!)"
1594              : "(perhaps you should delete this file?)");
1595
1596     return 1;
1597 }
1598
1599 sub ensure_we_have_orig () {
1600     foreach my $fi (dsc_files_info()) {
1601         my $f = $fi->{Filename};
1602         next unless is_orig_file($f);
1603         complete_file_from_dsc('..', $fi)
1604             or next;
1605     }
1606 }
1607
1608 sub git_fetch_us () {
1609     my @specs =
1610         map { "$_/*" }
1611         qw(tags heads), $branchprefix;
1612
1613     # This is rather miserable:
1614     # When git-fetch --prune is passed a fetchspec ending with a *,
1615     # it does a plausible thing.  If there is no * then:
1616     # - it matches subpaths too, even if the supplied refspec
1617     #   starts refs, and behaves completely madly if the source
1618     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
1619     # - if there is no matching remote ref, it bombs out the whole
1620     #   fetch.
1621     # We want to fetch a fixed ref, and we don't know in advance
1622     # if it exists, so this is not suitable.
1623     #
1624     # Our workaround is to use git-ls-remote.  git-ls-remote has its
1625     # own qairks.  Notably, it has the absurd multi-tail-matching
1626     # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1627     # refs/refs/foo etc.
1628     #
1629     # Also, we want an idempotent snapshot, but we have to make two
1630     # calls to the remote: one to git-ls-remote and to git-fetch.  The
1631     # solution is use git-ls-remote to obtain a target state, and
1632     # git-fetch to try to generate it.  If we don't manage to generate
1633     # the target state, we try again.
1634
1635     my $specre = join '|', map {
1636         my $x = $_;
1637         $x =~ s/\W/\\$&/g;
1638         $x =~ s/\\\*$/.*/;
1639         "(?:refs/$x)";
1640     } @specs;
1641     printdebug "git_fetch_us specre=$specre\n";
1642     my $wanted_rref = sub {
1643         local ($_) = @_;
1644         return m/^(?:$specre)$/o;
1645     };
1646
1647     my %lrfetchrefs_f;
1648
1649     my $fetch_iteration = 0;
1650     FETCH_ITERATION:
1651     for (;;) {
1652         if (++$fetch_iteration > 10) {
1653             fail "too many iterations trying to get sane fetch!";
1654         }
1655
1656         my @look = map { "refs/$_" } @specs;
1657         my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1658         debugcmd "|",@lcmd;
1659
1660         my %wantr;
1661         open GITLS, "-|", @lcmd or die $!;
1662         while (<GITLS>) {
1663             printdebug "=> ", $_;
1664             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1665             my ($objid,$rrefname) = ($1,$2);
1666             if (!$wanted_rref->($rrefname)) {
1667                 print STDERR <<END;
1668 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1669 END
1670                 next;
1671             }
1672             $wantr{$rrefname} = $objid;
1673         }
1674         $!=0; $?=0;
1675         close GITLS or failedcmd @lcmd;
1676
1677         # OK, now %want is exactly what we want for refs in @specs
1678         my @fspecs = map {
1679             return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1680             "+refs/$_:".lrfetchrefs."/$_";
1681         } @specs;
1682
1683         my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1684         runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1685             @fspecs;
1686
1687         %lrfetchrefs_f = ();
1688         my %objgot;
1689
1690         git_for_each_ref(lrfetchrefs, sub {
1691             my ($objid,$objtype,$lrefname,$reftail) = @_;
1692             $lrfetchrefs_f{$lrefname} = $objid;
1693             $objgot{$objid} = 1;
1694         });
1695
1696         foreach my $lrefname (sort keys %lrfetchrefs_f) {
1697             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
1698             if (!exists $wantr{$rrefname}) {
1699                 if ($wanted_rref->($rrefname)) {
1700                     printdebug <<END;
1701 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
1702 END
1703                 } else {
1704                     print STDERR <<END
1705 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
1706 END
1707                 }
1708                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
1709                 delete $lrfetchrefs_f{$lrefname};
1710                 next;
1711             }
1712         }
1713         foreach my $rrefname (sort keys %wantr) {
1714             my $lrefname = lrfetchrefs.substr($rrefname, 4);
1715             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
1716             my $want = $wantr{$rrefname};
1717             next if $got eq $want;
1718             if (!defined $objgot{$want}) {
1719                 print STDERR <<END;
1720 warning: git-ls-remote suggests we want $lrefname
1721 warning:  and it should refer to $want
1722 warning:  but git-fetch didn't fetch that object to any relevant ref.
1723 warning:  This may be due to a race with someone updating the server.
1724 warning:  Will try again...
1725 END
1726                 next FETCH_ITERATION;
1727             }
1728             printdebug <<END;
1729 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
1730 END
1731             runcmd_ordryrun_local @git, qw(update-ref -m),
1732                 "dgit fetch git-fetch fixup", $lrefname, $want;
1733             $lrfetchrefs_f{$lrefname} = $want;
1734         }
1735         last;
1736     }
1737     printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
1738         Dumper(\%lrfetchrefs_f);
1739
1740     my %here;
1741     my @tagpats = debiantags('*',access_basedistro);
1742
1743     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1744         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1745         printdebug "currently $fullrefname=$objid\n";
1746         $here{$fullrefname} = $objid;
1747     });
1748     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1749         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1750         my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1751         printdebug "offered $lref=$objid\n";
1752         if (!defined $here{$lref}) {
1753             my @upd = (@git, qw(update-ref), $lref, $objid, '');
1754             runcmd_ordryrun_local @upd;
1755         } elsif ($here{$lref} eq $objid) {
1756         } else {
1757             print STDERR \
1758                 "Not updateting $lref from $here{$lref} to $objid.\n";
1759         }
1760     });
1761 }
1762
1763 sub mergeinfo_getclogp ($) {
1764     my ($mi) = @_;
1765     # Ensures thit $mi->{Clogp} exists and returns it
1766     return $mi->{Clogp} if $mi->{Clogp};
1767     my $mclog = ".git/dgit/clog-$mi->{Commit}";
1768     mkpath '.git/dgit';
1769     runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1770         "$mi->{Commit}:debian/changelog";
1771     $mi->{Clogp} = parsechangelog("-l$mclog");
1772 }
1773
1774 sub mergeinfo_version ($) {
1775     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1776 }
1777
1778 sub fetch_from_archive () {
1779     # ensures that lrref() is what is actually in the archive,
1780     #  one way or another
1781     get_archive_dsc();
1782
1783     if ($dsc) {
1784         foreach my $field (@ourdscfield) {
1785             $dsc_hash = $dsc->{$field};
1786             last if defined $dsc_hash;
1787         }
1788         if (defined $dsc_hash) {
1789             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1790             $dsc_hash = $&;
1791             progress "last upload to archive specified git hash";
1792         } else {
1793             progress "last upload to archive has NO git hash";
1794         }
1795     } else {
1796         progress "no version available from the archive";
1797     }
1798
1799     # If the archive's .dsc has a Dgit field, there are three
1800     # relevant git commitids we need to choose between and/or merge
1801     # together:
1802     #   1. $dsc_hash: the Dgit field from the archive
1803     #   2. $lastpush_hash: the suite branch on the dgit git server
1804     #   3. $lastfetch_hash: our local tracking brach for the suite
1805     #
1806     # These may all be distinct and need not be in any fast forward
1807     # relationship:
1808     #
1809     # If the dsc was pushed to this suite, then the server suite
1810     # branch will have been updated; but it might have been pushed to
1811     # a different suite and copied by the archive.  Conversely a more
1812     # recent version may have been pushed with dgit but not appeared
1813     # in the archive (yet).
1814     #
1815     # $lastfetch_hash may be awkward because archive imports
1816     # (particularly, imports of Dgit-less .dscs) are performed only as
1817     # needed on individual clients, so different clients may perform a
1818     # different subset of them - and these imports are only made
1819     # public during push.  So $lastfetch_hash may represent a set of
1820     # imports different to a subsequent upload by a different dgit
1821     # client.
1822     #
1823     # Our approach is as follows:
1824     #
1825     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1826     # descendant of $dsc_hash, then it was pushed by a dgit user who
1827     # had based their work on $dsc_hash, so we should prefer it.
1828     # Otherwise, $dsc_hash was installed into this suite in the
1829     # archive other than by a dgit push, and (necessarily) after the
1830     # last dgit push into that suite (since a dgit push would have
1831     # been descended from the dgit server git branch); thus, in that
1832     # case, we prefer the archive's version (and produce a
1833     # pseudo-merge to overwrite the dgit server git branch).
1834     #
1835     # (If there is no Dgit field in the archive's .dsc then
1836     # generate_commit_from_dsc uses the version numbers to decide
1837     # whether the suite branch or the archive is newer.  If the suite
1838     # branch is newer it ignores the archive's .dsc; otherwise it
1839     # generates an import of the .dsc, and produces a pseudo-merge to
1840     # overwrite the suite branch with the archive contents.)
1841     #
1842     # The outcome of that part of the algorithm is the `public view',
1843     # and is same for all dgit clients: it does not depend on any
1844     # unpublished history in the local tracking branch.
1845     #
1846     # As between the public view and the local tracking branch: The
1847     # local tracking branch is only updated by dgit fetch, and
1848     # whenever dgit fetch runs it includes the public view in the
1849     # local tracking branch.  Therefore if the public view is not
1850     # descended from the local tracking branch, the local tracking
1851     # branch must contain history which was imported from the archive
1852     # but never pushed; and, its tip is now out of date.  So, we make
1853     # a pseudo-merge to overwrite the old imports and stitch the old
1854     # history in.
1855     #
1856     # Finally: we do not necessarily reify the public view (as
1857     # described above).  This is so that we do not end up stacking two
1858     # pseudo-merges.  So what we actually do is figure out the inputs
1859     # to any public view psuedo-merge and put them in @mergeinputs.
1860
1861     my @mergeinputs;
1862     # $mergeinputs[]{Commit}
1863     # $mergeinputs[]{Info}
1864     # $mergeinputs[0] is the one whose tree we use
1865     # @mergeinputs is in the order we use in the actual commit)
1866     #
1867     # Also:
1868     # $mergeinputs[]{Message} is a commit message to use
1869     # $mergeinputs[]{ReverseParents} if def specifies that parent
1870     #                                list should be in opposite order
1871     # Such an entry has no Commit or Info.  It applies only when found
1872     # in the last entry.  (This ugliness is to support making
1873     # identical imports to previous dgit versions.)
1874
1875     my $lastpush_hash = git_get_ref(lrfetchref());
1876     printdebug "previous reference hash=$lastpush_hash\n";
1877     $lastpush_mergeinput = $lastpush_hash && {
1878         Commit => $lastpush_hash,
1879         Info => "dgit suite branch on dgit git server",
1880     };
1881
1882     my $lastfetch_hash = git_get_ref(lrref());
1883     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1884     my $lastfetch_mergeinput = $lastfetch_hash && {
1885         Commit => $lastfetch_hash,
1886         Info => "dgit client's archive history view",
1887     };
1888
1889     my $dsc_mergeinput = $dsc_hash && {
1890         Commit => $dsc_hash,
1891         Info => "Dgit field in .dsc from archive",
1892     };
1893
1894     if (defined $dsc_hash) {
1895         fail "missing remote git history even though dsc has hash -".
1896             " could not find ref ".rref()." at ".access_giturl()
1897             unless $lastpush_hash;
1898         ensure_we_have_orig();
1899         if ($dsc_hash eq $lastpush_hash) {
1900             @mergeinputs = $dsc_mergeinput
1901         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1902             print STDERR <<END or die $!;
1903
1904 Git commit in archive is behind the last version allegedly pushed/uploaded.
1905 Commit referred to by archive: $dsc_hash
1906 Last version pushed with dgit: $lastpush_hash
1907 $later_warning_msg
1908 END
1909             @mergeinputs = ($lastpush_mergeinput);
1910         } else {
1911             # Archive has .dsc which is not a descendant of the last dgit
1912             # push.  This can happen if the archive moves .dscs about.
1913             # Just follow its lead.
1914             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
1915                 progress "archive .dsc names newer git commit";
1916                 @mergeinputs = ($dsc_mergeinput);
1917             } else {
1918                 progress "archive .dsc names other git commit, fixing up";
1919                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
1920             }
1921         }
1922     } elsif ($dsc) {
1923         @mergeinputs = generate_commits_from_dsc();
1924         # We have just done an import.  Now, our import algorithm might
1925         # have been improved.  But even so we do not want to generate
1926         # a new different import of the same package.  So if the
1927         # version numbers are the same, just use our existing version.
1928         # If the version numbers are different, the archive has changed
1929         # (perhaps, rewound).
1930         if ($lastfetch_mergeinput &&
1931             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
1932                               (mergeinfo_version $mergeinputs[0]) )) {
1933             @mergeinputs = ($lastfetch_mergeinput);
1934         }
1935     } elsif ($lastpush_hash) {
1936         # only in git, not in the archive yet
1937         @mergeinputs = ($lastpush_mergeinput);
1938         print STDERR <<END or die $!;
1939
1940 Package not found in the archive, but has allegedly been pushed using dgit.
1941 $later_warning_msg
1942 END
1943     } else {
1944         printdebug "nothing found!\n";
1945         if (defined $skew_warning_vsn) {
1946             print STDERR <<END or die $!;
1947
1948 Warning: relevant archive skew detected.
1949 Archive allegedly contains $skew_warning_vsn
1950 But we were not able to obtain any version from the archive or git.
1951
1952 END
1953         }
1954         return 0;
1955     }
1956
1957     if ($lastfetch_hash &&
1958         !grep {
1959             my $h = $_->{Commit};
1960             $h and is_fast_fwd($lastfetch_hash, $h);
1961             # If true, one of the existing parents of this commit
1962             # is a descendant of the $lastfetch_hash, so we'll
1963             # be ff from that automatically.
1964         } @mergeinputs
1965         ) {
1966         # Otherwise:
1967         push @mergeinputs, $lastfetch_mergeinput;
1968     }
1969
1970     printdebug "fetch mergeinfos:\n";
1971     foreach my $mi (@mergeinputs) {
1972         if ($mi->{Info}) {
1973             printdebug " commit $mi->{Commit} $mi->{Info}\n";
1974         } else {
1975             printdebug sprintf " ReverseParents=%d Message=%s",
1976                 $mi->{ReverseParents}, $mi->{Message};
1977         }
1978     }
1979
1980     my $compat_info= pop @mergeinputs
1981         if $mergeinputs[$#mergeinputs]{Message};
1982
1983     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
1984
1985     my $hash;
1986     if (@mergeinputs > 1) {
1987         # here we go, then:
1988         my $tree_commit = $mergeinputs[0]{Commit};
1989
1990         my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
1991         $tree =~ m/\n\n/;  $tree = $`;
1992         $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
1993         $tree = $1;
1994
1995         # We use the changelog author of the package in question the
1996         # author of this pseudo-merge.  This is (roughly) correct if
1997         # this commit is simply representing aa non-dgit upload.
1998         # (Roughly because it does not record sponsorship - but we
1999         # don't have sponsorship info because that's in the .changes,
2000         # which isn't in the archivw.)
2001         #
2002         # But, it might be that we are representing archive history
2003         # updates (including in-archive copies).  These are not really
2004         # the responsibility of the person who created the .dsc, but
2005         # there is no-one whose name we should better use.  (The
2006         # author of the .dsc-named commit is clearly worse.)
2007
2008         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2009         my $author = clogp_authline $useclogp;
2010         my $cversion = getfield $useclogp, 'Version';
2011
2012         my $mcf = ".git/dgit/mergecommit";
2013         open MC, ">", $mcf or die "$mcf $!";
2014         print MC <<END or die $!;
2015 tree $tree
2016 END
2017
2018         my @parents = grep { $_->{Commit} } @mergeinputs;
2019         @parents = reverse @parents if $compat_info->{ReverseParents};
2020         print MC <<END or die $! foreach @parents;
2021 parent $_->{Commit}
2022 END
2023
2024         print MC <<END or die $!;
2025 author $author
2026 committer $author
2027
2028 END
2029
2030         if (defined $compat_info->{Message}) {
2031             print MC $compat_info->{Message} or die $!;
2032         } else {
2033             print MC <<END or die $!;
2034 Record $package ($cversion) in archive suite $csuite
2035
2036 Record that
2037 END
2038             my $message_add_info = sub {
2039                 my ($mi) = (@_);
2040                 my $mversion = mergeinfo_version $mi;
2041                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
2042                     or die $!;
2043             };
2044
2045             $message_add_info->($mergeinputs[0]);
2046             print MC <<END or die $!;
2047 should be treated as descended from
2048 END
2049             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2050         }
2051
2052         close MC or die $!;
2053         $hash = make_commit $mcf;
2054     } else {
2055         $hash = $mergeinputs[0]{Commit};
2056     }
2057     progress "fetch hash=$hash\n";
2058
2059     my $chkff = sub {
2060         my ($lasth, $what) = @_;
2061         return unless $lasth;
2062         die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2063     };
2064
2065     $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2066     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2067
2068     runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2069             'DGIT_ARCHIVE', $hash;
2070     cmdoutput @git, qw(log -n2), $hash;
2071     # ... gives git a chance to complain if our commit is malformed
2072
2073     if (defined $skew_warning_vsn) {
2074         mkpath '.git/dgit';
2075         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2076         my $clogf = ".git/dgit/changelog.tmp";
2077         runcmd shell_cmd "exec >$clogf",
2078             @git, qw(cat-file blob), "$hash:debian/changelog";
2079         my $gotclogp = parsechangelog("-l$clogf");
2080         my $got_vsn = getfield $gotclogp, 'Version';
2081         printdebug "SKEW CHECK GOT $got_vsn\n";
2082         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2083             print STDERR <<END or die $!;
2084
2085 Warning: archive skew detected.  Using the available version:
2086 Archive allegedly contains    $skew_warning_vsn
2087 We were able to obtain only   $got_vsn
2088
2089 END
2090         }
2091     }
2092
2093     if ($lastfetch_hash ne $hash) {
2094         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2095         if (act_local()) {
2096             cmdoutput @upd_cmd;
2097         } else {
2098             dryrun_report @upd_cmd;
2099         }
2100     }
2101     return 1;
2102 }
2103
2104 sub set_local_git_config ($$) {
2105     my ($k, $v) = @_;
2106     runcmd @git, qw(config), $k, $v;
2107 }
2108
2109 sub setup_mergechangelogs (;$) {
2110     my ($always) = @_;
2111     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2112
2113     my $driver = 'dpkg-mergechangelogs';
2114     my $cb = "merge.$driver";
2115     my $attrs = '.git/info/attributes';
2116     ensuredir '.git/info';
2117
2118     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2119     if (!open ATTRS, "<", $attrs) {
2120         $!==ENOENT or die "$attrs: $!";
2121     } else {
2122         while (<ATTRS>) {
2123             chomp;
2124             next if m{^debian/changelog\s};
2125             print NATTRS $_, "\n" or die $!;
2126         }
2127         ATTRS->error and die $!;
2128         close ATTRS;
2129     }
2130     print NATTRS "debian/changelog merge=$driver\n" or die $!;
2131     close NATTRS;
2132
2133     set_local_git_config "$cb.name", 'debian/changelog merge driver';
2134     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2135
2136     rename "$attrs.new", "$attrs" or die "$attrs: $!";
2137 }
2138
2139 sub setup_useremail (;$) {
2140     my ($always) = @_;
2141     return unless $always || access_cfg_bool(1, 'setup-useremail');
2142
2143     my $setup = sub {
2144         my ($k, $envvar) = @_;
2145         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2146         return unless defined $v;
2147         set_local_git_config "user.$k", $v;
2148     };
2149
2150     $setup->('email', 'DEBEMAIL');
2151     $setup->('name', 'DEBFULLNAME');
2152 }
2153
2154 sub setup_new_tree () {
2155     setup_mergechangelogs();
2156     setup_useremail();
2157 }
2158
2159 sub clone ($) {
2160     my ($dstdir) = @_;
2161     canonicalise_suite();
2162     badusage "dry run makes no sense with clone" unless act_local();
2163     my $hasgit = check_for_git();
2164     mkdir $dstdir or fail "create \`$dstdir': $!";
2165     changedir $dstdir;
2166     runcmd @git, qw(init -q);
2167     my $giturl = access_giturl(1);
2168     if (defined $giturl) {
2169         open H, "> .git/HEAD" or die $!;
2170         print H "ref: ".lref()."\n" or die $!;
2171         close H or die $!;
2172         runcmd @git, qw(remote add), 'origin', $giturl;
2173     }
2174     if ($hasgit) {
2175         progress "fetching existing git history";
2176         git_fetch_us();
2177         runcmd_ordryrun_local @git, qw(fetch origin);
2178     } else {
2179         progress "starting new git history";
2180     }
2181     fetch_from_archive() or no_such_package;
2182     my $vcsgiturl = $dsc->{'Vcs-Git'};
2183     if (length $vcsgiturl) {
2184         $vcsgiturl =~ s/\s+-b\s+\S+//g;
2185         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2186     }
2187     setup_new_tree();
2188     runcmd @git, qw(reset --hard), lrref();
2189     printdone "ready for work in $dstdir";
2190 }
2191
2192 sub fetch () {
2193     if (check_for_git()) {
2194         git_fetch_us();
2195     }
2196     fetch_from_archive() or no_such_package();
2197     printdone "fetched into ".lrref();
2198 }
2199
2200 sub pull () {
2201     fetch();
2202     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2203         lrref();
2204     printdone "fetched to ".lrref()." and merged into HEAD";
2205 }
2206
2207 sub check_not_dirty () {
2208     foreach my $f (qw(local-options local-patch-header)) {
2209         if (stat_exists "debian/source/$f") {
2210             fail "git tree contains debian/source/$f";
2211         }
2212     }
2213
2214     return if $ignoredirty;
2215
2216     my @cmd = (@git, qw(diff --quiet HEAD));
2217     debugcmd "+",@cmd;
2218     $!=0; $?=-1; system @cmd;
2219     return if !$?;
2220     if ($?==256) {
2221         fail "working tree is dirty (does not match HEAD)";
2222     } else {
2223         failedcmd @cmd;
2224     }
2225 }
2226
2227 sub commit_admin ($) {
2228     my ($m) = @_;
2229     progress "$m";
2230     runcmd_ordryrun_local @git, qw(commit -m), $m;
2231 }
2232
2233 sub commit_quilty_patch () {
2234     my $output = cmdoutput @git, qw(status --porcelain);
2235     my %adds;
2236     foreach my $l (split /\n/, $output) {
2237         next unless $l =~ m/\S/;
2238         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2239             $adds{$1}++;
2240         }
2241     }
2242     delete $adds{'.pc'}; # if there wasn't one before, don't add it
2243     if (!%adds) {
2244         progress "nothing quilty to commit, ok.";
2245         return;
2246     }
2247     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2248     runcmd_ordryrun_local @git, qw(add -f), @adds;
2249     commit_admin "Commit Debian 3.0 (quilt) metadata";
2250 }
2251
2252 sub get_source_format () {
2253     my %options;
2254     if (open F, "debian/source/options") {
2255         while (<F>) {
2256             next if m/^\s*\#/;
2257             next unless m/\S/;
2258             s/\s+$//; # ignore missing final newline
2259             if (m/\s*\#\s*/) {
2260                 my ($k, $v) = ($`, $'); #');
2261                 $v =~ s/^"(.*)"$/$1/;
2262                 $options{$k} = $v;
2263             } else {
2264                 $options{$_} = 1;
2265             }
2266         }
2267         F->error and die $!;
2268         close F;
2269     } else {
2270         die $! unless $!==&ENOENT;
2271     }
2272
2273     if (!open F, "debian/source/format") {
2274         die $! unless $!==&ENOENT;
2275         return '';
2276     }
2277     $_ = <F>;
2278     F->error and die $!;
2279     chomp;
2280     return ($_, \%options);
2281 }
2282
2283 sub madformat ($) {
2284     my ($format) = @_;
2285     return 0 unless $format eq '3.0 (quilt)';
2286     our $quilt_mode_warned;
2287     if ($quilt_mode eq 'nocheck') {
2288         progress "Not doing any fixup of \`$format' due to".
2289             " ----no-quilt-fixup or --quilt=nocheck"
2290             unless $quilt_mode_warned++;
2291         return 0;
2292     }
2293     progress "Format \`$format', need to check/update patch stack"
2294         unless $quilt_mode_warned++;
2295     return 1;
2296 }
2297
2298 sub push_parse_changelog ($) {
2299     my ($clogpfn) = @_;
2300
2301     my $clogp = Dpkg::Control::Hash->new();
2302     $clogp->load($clogpfn) or die;
2303
2304     $package = getfield $clogp, 'Source';
2305     my $cversion = getfield $clogp, 'Version';
2306     my $tag = debiantag($cversion, access_basedistro);
2307     runcmd @git, qw(check-ref-format), $tag;
2308
2309     my $dscfn = dscfn($cversion);
2310
2311     return ($clogp, $cversion, $dscfn);
2312 }
2313
2314 sub push_parse_dsc ($$$) {
2315     my ($dscfn,$dscfnwhat, $cversion) = @_;
2316     $dsc = parsecontrol($dscfn,$dscfnwhat);
2317     my $dversion = getfield $dsc, 'Version';
2318     my $dscpackage = getfield $dsc, 'Source';
2319     ($dscpackage eq $package && $dversion eq $cversion) or
2320         fail "$dscfn is for $dscpackage $dversion".
2321             " but debian/changelog is for $package $cversion";
2322 }
2323
2324 sub push_tagwants ($$$$) {
2325     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2326     my @tagwants;
2327     push @tagwants, {
2328         TagFn => \&debiantag,
2329         Objid => $dgithead,
2330         TfSuffix => '',
2331         View => 'dgit',
2332     };
2333     if (defined $maintviewhead) {
2334         push @tagwants, {
2335             TagFn => \&debiantag_maintview,
2336             Objid => $maintviewhead,
2337             TfSuffix => '-maintview',
2338             View => 'maint',
2339         };
2340     }
2341     foreach my $tw (@tagwants) {
2342         $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2343         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2344     }
2345     return @tagwants;
2346 }
2347
2348 sub push_mktags ($$ $$ $) {
2349     my ($clogp,$dscfn,
2350         $changesfile,$changesfilewhat,
2351         $tagwants) = @_;
2352
2353     die unless $tagwants->[0]{View} eq 'dgit';
2354
2355     $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2356     $dsc->save("$dscfn.tmp") or die $!;
2357
2358     my $changes = parsecontrol($changesfile,$changesfilewhat);
2359     foreach my $field (qw(Source Distribution Version)) {
2360         $changes->{$field} eq $clogp->{$field} or
2361             fail "changes field $field \`$changes->{$field}'".
2362                 " does not match changelog \`$clogp->{$field}'";
2363     }
2364
2365     my $cversion = getfield $clogp, 'Version';
2366     my $clogsuite = getfield $clogp, 'Distribution';
2367
2368     # We make the git tag by hand because (a) that makes it easier
2369     # to control the "tagger" (b) we can do remote signing
2370     my $authline = clogp_authline $clogp;
2371     my $delibs = join(" ", "",@deliberatelies);
2372     my $declaredistro = access_basedistro();
2373
2374     my $mktag = sub {
2375         my ($tw) = @_;
2376         my $tfn = $tw->{Tfn};
2377         my $head = $tw->{Objid};
2378         my $tag = $tw->{Tag};
2379
2380         open TO, '>', $tfn->('.tmp') or die $!;
2381         print TO <<END or die $!;
2382 object $head
2383 type commit
2384 tag $tag
2385 tagger $authline
2386
2387 END
2388         if ($tw->{View} eq 'dgit') {
2389             print TO <<END or die $!;
2390 $package release $cversion for $clogsuite ($csuite) [dgit]
2391 [dgit distro=$declaredistro$delibs]
2392 END
2393             foreach my $ref (sort keys %previously) {
2394                 print TO <<END or die $!;
2395 [dgit previously:$ref=$previously{$ref}]
2396 END
2397             }
2398         } elsif ($tw->{View} eq 'maint') {
2399             print TO <<END or die $!;
2400 $package release $cversion for $clogsuite ($csuite)
2401 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2402 END
2403         } else {
2404             die Dumper($tw)."?";
2405         }
2406
2407         close TO or die $!;
2408
2409         my $tagobjfn = $tfn->('.tmp');
2410         if ($sign) {
2411             if (!defined $keyid) {
2412                 $keyid = access_cfg('keyid','RETURN-UNDEF');
2413             }
2414             if (!defined $keyid) {
2415                 $keyid = getfield $clogp, 'Maintainer';
2416             }
2417             unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2418             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2419             push @sign_cmd, qw(-u),$keyid if defined $keyid;
2420             push @sign_cmd, $tfn->('.tmp');
2421             runcmd_ordryrun @sign_cmd;
2422             if (act_scary()) {
2423                 $tagobjfn = $tfn->('.signed.tmp');
2424                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2425                     $tfn->('.tmp'), $tfn->('.tmp.asc');
2426             }
2427         }
2428         return $tagobjfn;
2429     };
2430
2431     my @r = map { $mktag->($_); } @$tagwants;
2432     return @r;
2433 }
2434
2435 sub sign_changes ($) {
2436     my ($changesfile) = @_;
2437     if ($sign) {
2438         my @debsign_cmd = @debsign;
2439         push @debsign_cmd, "-k$keyid" if defined $keyid;
2440         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2441         push @debsign_cmd, $changesfile;
2442         runcmd_ordryrun @debsign_cmd;
2443     }
2444 }
2445
2446 sub dopush ($) {
2447     my ($forceflag) = @_;
2448     printdebug "actually entering push\n";
2449     supplementary_message(<<'END');
2450 Push failed, while preparing your push.
2451 You can retry the push, after fixing the problem, if you like.
2452 END
2453
2454     need_tagformat 'new', "quilt mode $quilt_mode"
2455         if quiltmode_splitbrain;
2456
2457     prep_ud();
2458
2459     access_giturl(); # check that success is vaguely likely
2460     select_tagformat();
2461
2462     my $clogpfn = ".git/dgit/changelog.822.tmp";
2463     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2464
2465     responder_send_file('parsed-changelog', $clogpfn);
2466
2467     my ($clogp, $cversion, $dscfn) =
2468         push_parse_changelog("$clogpfn");
2469
2470     my $dscpath = "$buildproductsdir/$dscfn";
2471     stat_exists $dscpath or
2472         fail "looked for .dsc $dscfn, but $!;".
2473             " maybe you forgot to build";
2474
2475     responder_send_file('dsc', $dscpath);
2476
2477     push_parse_dsc($dscpath, $dscfn, $cversion);
2478
2479     my $format = getfield $dsc, 'Format';
2480     printdebug "format $format\n";
2481
2482     my $actualhead = git_rev_parse('HEAD');
2483     my $dgithead = $actualhead;
2484     my $maintviewhead = undef;
2485
2486     if (madformat($format)) {
2487         # user might have not used dgit build, so maybe do this now:
2488         if (quiltmode_splitbrain()) {
2489             my $upstreamversion = $clogp->{Version};
2490             $upstreamversion =~ s/-[^-]*$//;
2491             changedir $ud;
2492             quilt_make_fake_dsc($upstreamversion);
2493             my ($dgitview, $cachekey) =
2494                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2495             $dgitview or fail
2496  "--quilt=$quilt_mode but no cached dgit view:
2497  perhaps tree changed since dgit build[-source] ?";
2498             $split_brain = 1;
2499             $dgithead = $dgitview;
2500             $maintviewhead = $actualhead;
2501             changedir '../../../..';
2502             prep_ud(); # so _only_subdir() works, below
2503         } else {
2504             commit_quilty_patch();
2505         }
2506     }
2507
2508     check_not_dirty();
2509     changedir $ud;
2510     progress "checking that $dscfn corresponds to HEAD";
2511     runcmd qw(dpkg-source -x --),
2512         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2513     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2514     check_for_vendor_patches() if madformat($dsc->{format});
2515     changedir '../../../..';
2516     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2517     my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2518     debugcmd "+",@diffcmd;
2519     $!=0; $?=-1;
2520     my $r = system @diffcmd;
2521     if ($r) {
2522         if ($r==256) {
2523             fail "$dscfn specifies a different tree to your HEAD commit;".
2524                 " perhaps you forgot to build".
2525                 ($diffopt eq '--exit-code' ? "" :
2526                  " (run with -D to see full diff output)");
2527         } else {
2528             failedcmd @diffcmd;
2529         }
2530     }
2531     if (!$changesfile) {
2532         my $pat = changespat $cversion;
2533         my @cs = glob "$buildproductsdir/$pat";
2534         fail "failed to find unique changes file".
2535             " (looked for $pat in $buildproductsdir);".
2536             " perhaps you need to use dgit -C"
2537             unless @cs==1;
2538         ($changesfile) = @cs;
2539     } else {
2540         $changesfile = "$buildproductsdir/$changesfile";
2541     }
2542
2543     responder_send_file('changes',$changesfile);
2544     responder_send_command("param head $dgithead");
2545     responder_send_command("param csuite $csuite");
2546     responder_send_command("param tagformat $tagformat");
2547     if (quiltmode_splitbrain) {
2548         die unless ($protovsn//4) >= 4;
2549         responder_send_command("param maint-view $maintviewhead");
2550     }
2551
2552     if (deliberately_not_fast_forward) {
2553         git_for_each_ref(lrfetchrefs, sub {
2554             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2555             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2556             responder_send_command("previously $rrefname=$objid");
2557             $previously{$rrefname} = $objid;
2558         });
2559     }
2560
2561     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2562                                  ".git/dgit/tag");
2563     my @tagobjfns;
2564
2565     supplementary_message(<<'END');
2566 Push failed, while signing the tag.
2567 You can retry the push, after fixing the problem, if you like.
2568 END
2569     # If we manage to sign but fail to record it anywhere, it's fine.
2570     if ($we_are_responder) {
2571         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2572         responder_receive_files('signed-tag', @tagobjfns);
2573     } else {
2574         @tagobjfns = push_mktags($clogp,$dscpath,
2575                               $changesfile,$changesfile,
2576                               \@tagwants);
2577     }
2578     supplementary_message(<<'END');
2579 Push failed, *after* signing the tag.
2580 If you want to try again, you should use a new version number.
2581 END
2582
2583     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2584
2585     foreach my $tw (@tagwants) {
2586         my $tag = $tw->{Tag};
2587         my $tagobjfn = $tw->{TagObjFn};
2588         my $tag_obj_hash =
2589             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2590         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2591         runcmd_ordryrun_local
2592             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2593     }
2594
2595     supplementary_message(<<'END');
2596 Push failed, while updating the remote git repository - see messages above.
2597 If you want to try again, you should use a new version number.
2598 END
2599     if (!check_for_git()) {
2600         create_remote_git_repo();
2601     }
2602
2603     my @pushrefs = $forceflag."HEAD:".rrref();
2604     foreach my $tw (@tagwants) {
2605         my $view = $tw->{View};
2606         next unless $view eq 'dgit'
2607             or any { $_ eq $view } access_cfg_tagformats();
2608         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2609     }
2610
2611     runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2612     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2613
2614     supplementary_message(<<'END');
2615 Push failed, after updating the remote git repository.
2616 If you want to try again, you must use a new version number.
2617 END
2618     if ($we_are_responder) {
2619         my $dryrunsuffix = act_local() ? "" : ".tmp";
2620         responder_receive_files('signed-dsc-changes',
2621                                 "$dscpath$dryrunsuffix",
2622                                 "$changesfile$dryrunsuffix");
2623     } else {
2624         if (act_local()) {
2625             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2626         } else {
2627             progress "[new .dsc left in $dscpath.tmp]";
2628         }
2629         sign_changes $changesfile;
2630     }
2631
2632     supplementary_message(<<END);
2633 Push failed, while uploading package(s) to the archive server.
2634 You can retry the upload of exactly these same files with dput of:
2635   $changesfile
2636 If that .changes file is broken, you will need to use a new version
2637 number for your next attempt at the upload.
2638 END
2639     my $host = access_cfg('upload-host','RETURN-UNDEF');
2640     my @hostarg = defined($host) ? ($host,) : ();
2641     runcmd_ordryrun @dput, @hostarg, $changesfile;
2642     printdone "pushed and uploaded $cversion";
2643
2644     supplementary_message('');
2645     responder_send_command("complete");
2646 }
2647
2648 sub cmd_clone {
2649     parseopts();
2650     notpushing();
2651     my $dstdir;
2652     badusage "-p is not allowed with clone; specify as argument instead"
2653         if defined $package;
2654     if (@ARGV==1) {
2655         ($package) = @ARGV;
2656     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2657         ($package,$isuite) = @ARGV;
2658     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2659         ($package,$dstdir) = @ARGV;
2660     } elsif (@ARGV==3) {
2661         ($package,$isuite,$dstdir) = @ARGV;
2662     } else {
2663         badusage "incorrect arguments to dgit clone";
2664     }
2665     $dstdir ||= "$package";
2666
2667     if (stat_exists $dstdir) {
2668         fail "$dstdir already exists";
2669     }
2670
2671     my $cwd_remove;
2672     if ($rmonerror && !$dryrun_level) {
2673         $cwd_remove= getcwd();
2674         unshift @end, sub {
2675             return unless defined $cwd_remove;
2676             if (!chdir "$cwd_remove") {
2677                 return if $!==&ENOENT;
2678                 die "chdir $cwd_remove: $!";
2679             }
2680             if (stat $dstdir) {
2681                 rmtree($dstdir) or die "remove $dstdir: $!\n";
2682             } elsif (!grep { $! == $_ }
2683                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2684             } else {
2685                 print STDERR "check whether to remove $dstdir: $!\n";
2686             }
2687         };
2688     }
2689
2690     clone($dstdir);
2691     $cwd_remove = undef;
2692 }
2693
2694 sub branchsuite () {
2695     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2696     if ($branch =~ m#$lbranch_re#o) {
2697         return $1;
2698     } else {
2699         return undef;
2700     }
2701 }
2702
2703 sub fetchpullargs () {
2704     notpushing();
2705     if (!defined $package) {
2706         my $sourcep = parsecontrol('debian/control','debian/control');
2707         $package = getfield $sourcep, 'Source';
2708     }
2709     if (@ARGV==0) {
2710 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
2711         if (!$isuite) {
2712             my $clogp = parsechangelog();
2713             $isuite = getfield $clogp, 'Distribution';
2714         }
2715         canonicalise_suite();
2716         progress "fetching from suite $csuite";
2717     } elsif (@ARGV==1) {
2718         ($isuite) = @ARGV;
2719         canonicalise_suite();
2720     } else {
2721         badusage "incorrect arguments to dgit fetch or dgit pull";
2722     }
2723 }
2724
2725 sub cmd_fetch {
2726     parseopts();
2727     fetchpullargs();
2728     fetch();
2729 }
2730
2731 sub cmd_pull {
2732     parseopts();
2733     fetchpullargs();
2734     pull();
2735 }
2736
2737 sub cmd_push {
2738     parseopts();
2739     pushing();
2740     badusage "-p is not allowed with dgit push" if defined $package;
2741     check_not_dirty();
2742     my $clogp = parsechangelog();
2743     $package = getfield $clogp, 'Source';
2744     my $specsuite;
2745     if (@ARGV==0) {
2746     } elsif (@ARGV==1) {
2747         ($specsuite) = (@ARGV);
2748     } else {
2749         badusage "incorrect arguments to dgit push";
2750     }
2751     $isuite = getfield $clogp, 'Distribution';
2752     if ($new_package) {
2753         local ($package) = $existing_package; # this is a hack
2754         canonicalise_suite();
2755     } else {
2756         canonicalise_suite();
2757     }
2758     if (defined $specsuite &&
2759         $specsuite ne $isuite &&
2760         $specsuite ne $csuite) {
2761             fail "dgit push: changelog specifies $isuite ($csuite)".
2762                 " but command line specifies $specsuite";
2763     }
2764     supplementary_message(<<'END');
2765 Push failed, while checking state of the archive.
2766 You can retry the push, after fixing the problem, if you like.
2767 END
2768     if (check_for_git()) {
2769         git_fetch_us();
2770     }
2771     my $forceflag = '';
2772     if (fetch_from_archive()) {
2773         if (is_fast_fwd(lrref(), 'HEAD')) {
2774             # ok
2775         } elsif (deliberately_not_fast_forward) {
2776             $forceflag = '+';
2777         } else {
2778             fail "dgit push: HEAD is not a descendant".
2779                 " of the archive's version.\n".
2780                 "dgit: To overwrite its contents,".
2781                 " use git merge -s ours ".lrref().".\n".
2782                 "dgit: To rewind history, if permitted by the archive,".
2783                 " use --deliberately-not-fast-forward";
2784         }
2785     } else {
2786         $new_package or
2787             fail "package appears to be new in this suite;".
2788                 " if this is intentional, use --new";
2789     }
2790     dopush($forceflag);
2791 }
2792
2793 #---------- remote commands' implementation ----------
2794
2795 sub cmd_remote_push_build_host {
2796     my ($nrargs) = shift @ARGV;
2797     my (@rargs) = @ARGV[0..$nrargs-1];
2798     @ARGV = @ARGV[$nrargs..$#ARGV];
2799     die unless @rargs;
2800     my ($dir,$vsnwant) = @rargs;
2801     # vsnwant is a comma-separated list; we report which we have
2802     # chosen in our ready response (so other end can tell if they
2803     # offered several)
2804     $debugprefix = ' ';
2805     $we_are_responder = 1;
2806     $us .= " (build host)";
2807
2808     pushing();
2809
2810     open PI, "<&STDIN" or die $!;
2811     open STDIN, "/dev/null" or die $!;
2812     open PO, ">&STDOUT" or die $!;
2813     autoflush PO 1;
2814     open STDOUT, ">&STDERR" or die $!;
2815     autoflush STDOUT 1;
2816
2817     $vsnwant //= 1;
2818     ($protovsn) = grep {
2819         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2820     } @rpushprotovsn_support;
2821
2822     fail "build host has dgit rpush protocol versions ".
2823         (join ",", @rpushprotovsn_support).
2824         " but invocation host has $vsnwant"
2825         unless defined $protovsn;
2826
2827     responder_send_command("dgit-remote-push-ready $protovsn");
2828     rpush_handle_protovsn_bothends();
2829     changedir $dir;
2830     &cmd_push;
2831 }
2832
2833 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2834 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2835 #     a good error message)
2836
2837 sub rpush_handle_protovsn_bothends () {
2838     if ($protovsn < 4) {
2839         need_tagformat 'old', "rpush negotiated protocol $protovsn";
2840     }
2841     select_tagformat();
2842 }
2843
2844 our $i_tmp;
2845
2846 sub i_cleanup {
2847     local ($@, $?);
2848     my $report = i_child_report();
2849     if (defined $report) {
2850         printdebug "($report)\n";
2851     } elsif ($i_child_pid) {
2852         printdebug "(killing build host child $i_child_pid)\n";
2853         kill 15, $i_child_pid;
2854     }
2855     if (defined $i_tmp && !defined $initiator_tempdir) {
2856         changedir "/";
2857         eval { rmtree $i_tmp; };
2858     }
2859 }
2860
2861 END { i_cleanup(); }
2862
2863 sub i_method {
2864     my ($base,$selector,@args) = @_;
2865     $selector =~ s/\-/_/g;
2866     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2867 }
2868
2869 sub cmd_rpush {
2870     pushing();
2871     my $host = nextarg;
2872     my $dir;
2873     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2874         $host = $1;
2875         $dir = $'; #';
2876     } else {
2877         $dir = nextarg;
2878     }
2879     $dir =~ s{^-}{./-};
2880     my @rargs = ($dir);
2881     push @rargs, join ",", @rpushprotovsn_support;
2882     my @rdgit;
2883     push @rdgit, @dgit;
2884     push @rdgit, @ropts;
2885     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2886     push @rdgit, @ARGV;
2887     my @cmd = (@ssh, $host, shellquote @rdgit);
2888     debugcmd "+",@cmd;
2889
2890     if (defined $initiator_tempdir) {
2891         rmtree $initiator_tempdir;
2892         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2893         $i_tmp = $initiator_tempdir;
2894     } else {
2895         $i_tmp = tempdir();
2896     }
2897     $i_child_pid = open2(\*RO, \*RI, @cmd);
2898     changedir $i_tmp;
2899     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2900     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2901     $supplementary_message = '' unless $protovsn >= 3;
2902
2903     fail "rpush negotiated protocol version $protovsn".
2904         " which does not support quilt mode $quilt_mode"
2905         if quiltmode_splitbrain;
2906
2907     rpush_handle_protovsn_bothends();
2908     for (;;) {
2909         my ($icmd,$iargs) = initiator_expect {
2910             m/^(\S+)(?: (.*))?$/;
2911             ($1,$2);
2912         };
2913         i_method "i_resp", $icmd, $iargs;
2914     }
2915 }
2916
2917 sub i_resp_progress ($) {
2918     my ($rhs) = @_;
2919     my $msg = protocol_read_bytes \*RO, $rhs;
2920     progress $msg;
2921 }
2922
2923 sub i_resp_supplementary_message ($) {
2924     my ($rhs) = @_;
2925     $supplementary_message = protocol_read_bytes \*RO, $rhs;
2926 }
2927
2928 sub i_resp_complete {
2929     my $pid = $i_child_pid;
2930     $i_child_pid = undef; # prevents killing some other process with same pid
2931     printdebug "waiting for build host child $pid...\n";
2932     my $got = waitpid $pid, 0;
2933     die $! unless $got == $pid;
2934     die "build host child failed $?" if $?;
2935
2936     i_cleanup();
2937     printdebug "all done\n";
2938     exit 0;
2939 }
2940
2941 sub i_resp_file ($) {
2942     my ($keyword) = @_;
2943     my $localname = i_method "i_localname", $keyword;
2944     my $localpath = "$i_tmp/$localname";
2945     stat_exists $localpath and
2946         badproto \*RO, "file $keyword ($localpath) twice";
2947     protocol_receive_file \*RO, $localpath;
2948     i_method "i_file", $keyword;
2949 }
2950
2951 our %i_param;
2952
2953 sub i_resp_param ($) {
2954     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2955     $i_param{$1} = $2;
2956 }
2957
2958 sub i_resp_previously ($) {
2959     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2960         or badproto \*RO, "bad previously spec";
2961     my $r = system qw(git check-ref-format), $1;
2962     die "bad previously ref spec ($r)" if $r;
2963     $previously{$1} = $2;
2964 }
2965
2966 our %i_wanted;
2967
2968 sub i_resp_want ($) {
2969     my ($keyword) = @_;
2970     die "$keyword ?" if $i_wanted{$keyword}++;
2971     my @localpaths = i_method "i_want", $keyword;
2972     printdebug "[[  $keyword @localpaths\n";
2973     foreach my $localpath (@localpaths) {
2974         protocol_send_file \*RI, $localpath;
2975     }
2976     print RI "files-end\n" or die $!;
2977 }
2978
2979 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
2980
2981 sub i_localname_parsed_changelog {
2982     return "remote-changelog.822";
2983 }
2984 sub i_file_parsed_changelog {
2985     ($i_clogp, $i_version, $i_dscfn) =
2986         push_parse_changelog "$i_tmp/remote-changelog.822";
2987     die if $i_dscfn =~ m#/|^\W#;
2988 }
2989
2990 sub i_localname_dsc {
2991     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2992     return $i_dscfn;
2993 }
2994 sub i_file_dsc { }
2995
2996 sub i_localname_changes {
2997     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2998     $i_changesfn = $i_dscfn;
2999     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3000     return $i_changesfn;
3001 }
3002 sub i_file_changes { }
3003
3004 sub i_want_signed_tag {
3005     printdebug Dumper(\%i_param, $i_dscfn);
3006     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3007         && defined $i_param{'csuite'}
3008         or badproto \*RO, "premature desire for signed-tag";
3009     my $head = $i_param{'head'};
3010     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3011
3012     my $maintview = $i_param{'maint-view'};
3013     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3014
3015     select_tagformat();
3016     if ($protovsn >= 4) {
3017         my $p = $i_param{'tagformat'} // '<undef>';
3018         $p eq $tagformat
3019             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3020     }
3021
3022     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3023     $csuite = $&;
3024     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3025
3026     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3027
3028     return
3029         push_mktags $i_clogp, $i_dscfn,
3030             $i_changesfn, 'remote changes',
3031             \@tagwants;
3032 }
3033
3034 sub i_want_signed_dsc_changes {
3035     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3036     sign_changes $i_changesfn;
3037     return ($i_dscfn, $i_changesfn);
3038 }
3039
3040 #---------- building etc. ----------
3041
3042 our $version;
3043 our $sourcechanges;
3044 our $dscfn;
3045
3046 #----- `3.0 (quilt)' handling -----
3047
3048 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3049
3050 sub quiltify_dpkg_commit ($$$;$) {
3051     my ($patchname,$author,$msg, $xinfo) = @_;
3052     $xinfo //= '';
3053
3054     mkpath '.git/dgit';
3055     my $descfn = ".git/dgit/quilt-description.tmp";
3056     open O, '>', $descfn or die "$descfn: $!";
3057     $msg =~ s/\s+$//g;
3058     $msg =~ s/\n/\n /g;
3059     $msg =~ s/^\s+$/ ./mg;
3060     print O <<END or die $!;
3061 Description: $msg
3062 Author: $author
3063 $xinfo
3064 ---
3065
3066 END
3067     close O or die $!;
3068
3069     {
3070         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3071         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3072         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3073         runcmd @dpkgsource, qw(--commit .), $patchname;
3074     }
3075 }
3076
3077 sub quiltify_trees_differ ($$;$$) {
3078     my ($x,$y,$finegrained,$ignorenamesr) = @_;
3079     # returns true iff the two tree objects differ other than in debian/
3080     # with $finegrained,
3081     # returns bitmask 01 - differ in upstream files except .gitignore
3082     #                 02 - differ in .gitignore
3083     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3084     #  is set for each modified .gitignore filename $fn
3085     local $/=undef;
3086     my @cmd = (@git, qw(diff-tree --name-only -z));
3087     push @cmd, qw(-r) if $finegrained;
3088     push @cmd, $x, $y;
3089     my $diffs= cmdoutput @cmd;
3090     my $r = 0;
3091     foreach my $f (split /\0/, $diffs) {
3092         next if $f =~ m#^debian(?:/.*)?$#s;
3093         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3094         $r |= $isignore ? 02 : 01;
3095         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3096     }
3097     printdebug "quiltify_trees_differ $x $y => $r\n";
3098     return $r;
3099 }
3100
3101 sub quiltify_tree_sentinelfiles ($) {
3102     # lists the `sentinel' files present in the tree
3103     my ($x) = @_;
3104     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3105         qw(-- debian/rules debian/control);
3106     $r =~ s/\n/,/g;
3107     return $r;
3108 }
3109
3110 sub quiltify_splitbrain_needed () {
3111     if (!$split_brain) {
3112         progress "dgit view: changes are required...";
3113         runcmd @git, qw(checkout -q -b dgit-view);
3114         $split_brain = 1;
3115     }
3116 }
3117
3118 sub quiltify_splitbrain ($$$$$$) {
3119     my ($clogp, $unapplied, $headref, $diffbits,
3120         $editedignores, $cachekey) = @_;
3121     if ($quilt_mode !~ m/gbp|dpm/) {
3122         # treat .gitignore just like any other upstream file
3123         $diffbits = { %$diffbits };
3124         $_ = !!$_ foreach values %$diffbits;
3125     }
3126     # We would like any commits we generate to be reproducible
3127     my @authline = clogp_authline($clogp);
3128     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
3129     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3130     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
3131
3132     if ($quilt_mode =~ m/gbp|unapplied/ &&
3133         ($diffbits->{H2O} & 01)) {
3134         my $msg =
3135  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3136  " but git tree differs from orig in upstream files.";
3137         if (!stat_exists "debian/patches") {
3138             $msg .=
3139  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3140         }
3141         fail $msg;
3142     }
3143     if ($quilt_mode =~ m/gbp|unapplied/ &&
3144         ($diffbits->{O2A} & 01)) { # some patches
3145         quiltify_splitbrain_needed();
3146         progress "dgit view: creating patches-applied version using gbp pq";
3147         runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3148         # gbp pq import creates a fresh branch; push back to dgit-view
3149         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3150         runcmd @git, qw(checkout -q dgit-view);
3151     }
3152     if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3153         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3154         quiltify_splitbrain_needed();
3155         progress "dgit view: creating patch to represent .gitignore changes";
3156         ensuredir "debian/patches";
3157         my $gipatch = "debian/patches/auto-gitignore";
3158         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3159         stat GIPATCH or die "$gipatch: $!";
3160         fail "$gipatch already exists; but want to create it".
3161             " to record .gitignore changes" if (stat _)[7];
3162         print GIPATCH <<END or die "$gipatch: $!";
3163 Subject: Update .gitignore from Debian packaging branch
3164
3165 The Debian packaging git branch contains these updates to the upstream
3166 .gitignore file(s).  This patch is autogenerated, to provide these
3167 updates to users of the official Debian archive view of the package.
3168
3169 [dgit version $our_version]
3170 ---
3171 END
3172         close GIPATCH or die "$gipatch: $!";
3173         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3174             $unapplied, $headref, "--", sort keys %$editedignores;
3175         open SERIES, "+>>", "debian/patches/series" or die $!;
3176         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3177         my $newline;
3178         defined read SERIES, $newline, 1 or die $!;
3179         print SERIES "\n" or die $! unless $newline eq "\n";
3180         print SERIES "auto-gitignore\n" or die $!;
3181         close SERIES or die  $!;
3182         runcmd @git, qw(add -- debian/patches/series), $gipatch;
3183         commit_admin "Commit patch to update .gitignore";
3184     }
3185
3186     my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3187
3188     changedir '../../../..';
3189     ensuredir ".git/logs/refs/dgit-intern";
3190     my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3191       or die $!;
3192     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3193         $dgitview;
3194
3195     progress "dgit view: created (commit id $dgitview)";
3196
3197     changedir '.git/dgit/unpack/work';
3198 }
3199
3200 sub quiltify ($$$$) {
3201     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3202
3203     # Quilt patchification algorithm
3204     #
3205     # We search backwards through the history of the main tree's HEAD
3206     # (T) looking for a start commit S whose tree object is identical
3207     # to to the patch tip tree (ie the tree corresponding to the
3208     # current dpkg-committed patch series).  For these purposes
3209     # `identical' disregards anything in debian/ - this wrinkle is
3210     # necessary because dpkg-source treates debian/ specially.
3211     #
3212     # We can only traverse edges where at most one of the ancestors'
3213     # trees differs (in changes outside in debian/).  And we cannot
3214     # handle edges which change .pc/ or debian/patches.  To avoid
3215     # going down a rathole we avoid traversing edges which introduce
3216     # debian/rules or debian/control.  And we set a limit on the
3217     # number of edges we are willing to look at.
3218     #
3219     # If we succeed, we walk forwards again.  For each traversed edge
3220     # PC (with P parent, C child) (starting with P=S and ending with
3221     # C=T) to we do this:
3222     #  - git checkout C
3223     #  - dpkg-source --commit with a patch name and message derived from C
3224     # After traversing PT, we git commit the changes which
3225     # should be contained within debian/patches.
3226
3227     # The search for the path S..T is breadth-first.  We maintain a
3228     # todo list containing search nodes.  A search node identifies a
3229     # commit, and looks something like this:
3230     #  $p = {
3231     #      Commit => $git_commit_id,
3232     #      Child => $c,                          # or undef if P=T
3233     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
3234     #      Nontrivial => true iff $p..$c has relevant changes
3235     #  };
3236
3237     my @todo;
3238     my @nots;
3239     my $sref_S;
3240     my $max_work=100;
3241     my %considered; # saves being exponential on some weird graphs
3242
3243     my $t_sentinels = quiltify_tree_sentinelfiles $target;
3244
3245     my $not = sub {
3246         my ($search,$whynot) = @_;
3247         printdebug " search NOT $search->{Commit} $whynot\n";
3248         $search->{Whynot} = $whynot;
3249         push @nots, $search;
3250         no warnings qw(exiting);
3251         next;
3252     };
3253
3254     push @todo, {
3255         Commit => $target,
3256     };
3257
3258     while (@todo) {
3259         my $c = shift @todo;
3260         next if $considered{$c->{Commit}}++;
3261
3262         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3263
3264         printdebug "quiltify investigate $c->{Commit}\n";
3265
3266         # are we done?
3267         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3268             printdebug " search finished hooray!\n";
3269             $sref_S = $c;
3270             last;
3271         }
3272
3273         if ($quilt_mode eq 'nofix') {
3274             fail "quilt fixup required but quilt mode is \`nofix'\n".
3275                 "HEAD commit $c->{Commit} differs from tree implied by ".
3276                 " debian/patches (tree object $oldtiptree)";
3277         }
3278         if ($quilt_mode eq 'smash') {
3279             printdebug " search quitting smash\n";
3280             last;
3281         }
3282
3283         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3284         $not->($c, "has $c_sentinels not $t_sentinels")
3285             if $c_sentinels ne $t_sentinels;
3286
3287         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3288         $commitdata =~ m/\n\n/;
3289         $commitdata =~ $`;
3290         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3291         @parents = map { { Commit => $_, Child => $c } } @parents;
3292
3293         $not->($c, "root commit") if !@parents;
3294
3295         foreach my $p (@parents) {
3296             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3297         }
3298         my $ndiffers = grep { $_->{Nontrivial} } @parents;
3299         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3300
3301         foreach my $p (@parents) {
3302             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3303
3304             my @cmd= (@git, qw(diff-tree -r --name-only),
3305                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3306             my $patchstackchange = cmdoutput @cmd;
3307             if (length $patchstackchange) {
3308                 $patchstackchange =~ s/\n/,/g;
3309                 $not->($p, "changed $patchstackchange");
3310             }
3311
3312             printdebug " search queue P=$p->{Commit} ",
3313                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3314             push @todo, $p;
3315         }
3316     }
3317
3318     if (!$sref_S) {
3319         printdebug "quiltify want to smash\n";
3320
3321         my $abbrev = sub {
3322             my $x = $_[0]{Commit};
3323             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3324             return $x;
3325         };
3326         my $reportnot = sub {
3327             my ($notp) = @_;
3328             my $s = $abbrev->($notp);
3329             my $c = $notp->{Child};
3330             $s .= "..".$abbrev->($c) if $c;
3331             $s .= ": ".$notp->{Whynot};
3332             return $s;
3333         };
3334         if ($quilt_mode eq 'linear') {
3335             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
3336             foreach my $notp (@nots) {
3337                 print STDERR "$us:  ", $reportnot->($notp), "\n";
3338             }
3339             print STDERR "$us: $_\n" foreach @$failsuggestion;
3340             fail "quilt fixup naive history linearisation failed.\n".
3341  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3342         } elsif ($quilt_mode eq 'smash') {
3343         } elsif ($quilt_mode eq 'auto') {
3344             progress "quilt fixup cannot be linear, smashing...";
3345         } else {
3346             die "$quilt_mode ?";
3347         }
3348
3349         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3350         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3351         my $ncommits = 3;
3352         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3353
3354         quiltify_dpkg_commit "auto-$version-$target-$time",
3355             (getfield $clogp, 'Maintainer'),
3356             "Automatically generated patch ($clogp->{Version})\n".
3357             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3358         return;
3359     }
3360
3361     progress "quiltify linearisation planning successful, executing...";
3362
3363     for (my $p = $sref_S;
3364          my $c = $p->{Child};
3365          $p = $p->{Child}) {
3366         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3367         next unless $p->{Nontrivial};
3368
3369         my $cc = $c->{Commit};
3370
3371         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3372         $commitdata =~ m/\n\n/ or die "$c ?";
3373         $commitdata = $`;
3374         my $msg = $'; #';
3375         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3376         my $author = $1;
3377
3378         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3379
3380         my $title = $1;
3381         my $patchname = $title;
3382         $patchname =~ s/[.:]$//;
3383         $patchname =~ y/ A-Z/-a-z/;
3384         $patchname =~ y/-a-z0-9_.+=~//cd;
3385         $patchname =~ s/^\W/x-$&/;
3386         $patchname = substr($patchname,0,40);
3387         my $index;
3388         for ($index='';
3389              stat "debian/patches/$patchname$index";
3390              $index++) { }
3391         $!==ENOENT or die "$patchname$index $!";
3392
3393         runcmd @git, qw(checkout -q), $cc;
3394
3395         # We use the tip's changelog so that dpkg-source doesn't
3396         # produce complaining messages from dpkg-parsechangelog.  None
3397         # of the information dpkg-source gets from the changelog is
3398         # actually relevant - it gets put into the original message
3399         # which dpkg-source provides our stunt editor, and then
3400         # overwritten.
3401         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3402
3403         quiltify_dpkg_commit "$patchname$index", $author, $msg,
3404             "X-Dgit-Generated: $clogp->{Version} $cc\n";
3405
3406         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3407     }
3408
3409     runcmd @git, qw(checkout -q master);
3410 }
3411
3412 sub build_maybe_quilt_fixup () {
3413     my ($format,$fopts) = get_source_format;
3414     return unless madformat $format;
3415     # sigh
3416
3417     check_for_vendor_patches();
3418
3419     my $clogp = parsechangelog();
3420     my $headref = git_rev_parse('HEAD');
3421
3422     prep_ud();
3423     changedir $ud;
3424
3425     my $upstreamversion=$version;
3426     $upstreamversion =~ s/-[^-]*$//;
3427
3428     if ($fopts->{'single-debian-patch'}) {
3429         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3430     } else {
3431         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3432     }
3433
3434     die 'bug' if $split_brain && !$need_split_build_invocation;
3435
3436     changedir '../../../..';
3437     runcmd_ordryrun_local
3438         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3439 }
3440
3441 sub quilt_fixup_mkwork ($) {
3442     my ($headref) = @_;
3443
3444     mkdir "work" or die $!;
3445     changedir "work";
3446     mktree_in_ud_here();
3447     runcmd @git, qw(reset -q --hard), $headref;
3448 }
3449
3450 sub quilt_fixup_linkorigs ($$) {
3451     my ($upstreamversion, $fn) = @_;
3452     # calls $fn->($leafname);
3453
3454     foreach my $f (<../../../../*>) { #/){
3455         my $b=$f; $b =~ s{.*/}{};
3456         {
3457             local ($debuglevel) = $debuglevel-1;
3458             printdebug "QF linkorigs $b, $f ?\n";
3459         }
3460         next unless is_orig_file $b, srcfn $upstreamversion,'';
3461         printdebug "QF linkorigs $b, $f Y\n";
3462         link_ltarget $f, $b or die "$b $!";
3463         $fn->($b);
3464     }
3465 }
3466
3467 sub quilt_fixup_delete_pc () {
3468     runcmd @git, qw(rm -rqf .pc);
3469     commit_admin "Commit removal of .pc (quilt series tracking data)";
3470 }
3471
3472 sub quilt_fixup_singlepatch ($$$) {
3473     my ($clogp, $headref, $upstreamversion) = @_;
3474
3475     progress "starting quiltify (single-debian-patch)";
3476
3477     # dpkg-source --commit generates new patches even if
3478     # single-debian-patch is in debian/source/options.  In order to
3479     # get it to generate debian/patches/debian-changes, it is
3480     # necessary to build the source package.
3481
3482     quilt_fixup_linkorigs($upstreamversion, sub { });
3483     quilt_fixup_mkwork($headref);
3484
3485     rmtree("debian/patches");
3486
3487     runcmd @dpkgsource, qw(-b .);
3488     chdir "..";
3489     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3490     rename srcfn("$upstreamversion", "/debian/patches"),
3491            "work/debian/patches";
3492
3493     chdir "work";
3494     commit_quilty_patch();
3495 }
3496
3497 sub quilt_make_fake_dsc ($) {
3498     my ($upstreamversion) = @_;
3499
3500     my $fakeversion="$upstreamversion-~~DGITFAKE";
3501
3502     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3503     print $fakedsc <<END or die $!;
3504 Format: 3.0 (quilt)
3505 Source: $package
3506 Version: $fakeversion
3507 Files:
3508 END
3509
3510     my $dscaddfile=sub {
3511         my ($b) = @_;
3512
3513         my $md = new Digest::MD5;
3514
3515         my $fh = new IO::File $b, '<' or die "$b $!";
3516         stat $fh or die $!;
3517         my $size = -s _;
3518
3519         $md->addfile($fh);
3520         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3521     };
3522
3523     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3524
3525     my @files=qw(debian/source/format debian/rules
3526                  debian/control debian/changelog);
3527     foreach my $maybe (qw(debian/patches debian/source/options
3528                           debian/tests/control)) {
3529         next unless stat_exists "../../../$maybe";
3530         push @files, $maybe;
3531     }
3532
3533     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3534     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3535
3536     $dscaddfile->($debtar);
3537     close $fakedsc or die $!;
3538 }
3539
3540 sub quilt_check_splitbrain_cache ($$) {
3541     my ($headref, $upstreamversion) = @_;
3542     # Called only if we are in (potentially) split brain mode.
3543     # Called in $ud.
3544     # Computes the cache key and looks in the cache.
3545     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3546
3547     my $splitbrain_cachekey;
3548
3549     progress
3550  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3551     # we look in the reflog of dgit-intern/quilt-cache
3552     # we look for an entry whose message is the key for the cache lookup
3553     my @cachekey = (qw(dgit), $our_version);
3554     push @cachekey, $upstreamversion;
3555     push @cachekey, $quilt_mode;
3556     push @cachekey, $headref;
3557
3558     push @cachekey, hashfile('fake.dsc');
3559
3560     my $srcshash = Digest::SHA->new(256);
3561     my %sfs = ( %INC, '$0(dgit)' => $0 );
3562     foreach my $sfk (sort keys %sfs) {
3563         next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3564         $srcshash->add($sfk,"  ");
3565         $srcshash->add(hashfile($sfs{$sfk}));
3566         $srcshash->add("\n");
3567     }
3568     push @cachekey, $srcshash->hexdigest();
3569     $splitbrain_cachekey = "@cachekey";
3570
3571     my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3572                $splitbraincache);
3573     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3574     debugcmd "|(probably)",@cmd;
3575     my $child = open GC, "-|";  defined $child or die $!;
3576     if (!$child) {
3577         chdir '../../..' or die $!;
3578         if (!stat ".git/logs/refs/$splitbraincache") {
3579             $! == ENOENT or die $!;
3580             printdebug ">(no reflog)\n";
3581             exit 0;
3582         }
3583         exec @cmd; die $!;
3584     }
3585     while (<GC>) {
3586         chomp;
3587         printdebug ">| ", $_, "\n" if $debuglevel > 1;
3588         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3589
3590         my $cachehit = $1;
3591         quilt_fixup_mkwork($headref);
3592         if ($cachehit ne $headref) {
3593             progress "dgit view: found cached (commit id $cachehit)";
3594             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3595             $split_brain = 1;
3596             return ($cachehit, $splitbrain_cachekey);
3597         }
3598         progress "dgit view: found cached, no changes required";
3599         return ($headref, $splitbrain_cachekey);
3600     }
3601     die $! if GC->error;
3602     failedcmd unless close GC;
3603
3604     printdebug "splitbrain cache miss\n";
3605     return (undef, $splitbrain_cachekey);
3606 }
3607
3608 sub quilt_fixup_multipatch ($$$) {
3609     my ($clogp, $headref, $upstreamversion) = @_;
3610
3611     progress "examining quilt state (multiple patches, $quilt_mode mode)";
3612
3613     # Our objective is:
3614     #  - honour any existing .pc in case it has any strangeness
3615     #  - determine the git commit corresponding to the tip of
3616     #    the patch stack (if there is one)
3617     #  - if there is such a git commit, convert each subsequent
3618     #    git commit into a quilt patch with dpkg-source --commit
3619     #  - otherwise convert all the differences in the tree into
3620     #    a single git commit
3621     #
3622     # To do this we:
3623
3624     # Our git tree doesn't necessarily contain .pc.  (Some versions of
3625     # dgit would include the .pc in the git tree.)  If there isn't
3626     # one, we need to generate one by unpacking the patches that we
3627     # have.
3628     #
3629     # We first look for a .pc in the git tree.  If there is one, we
3630     # will use it.  (This is not the normal case.)
3631     #
3632     # Otherwise need to regenerate .pc so that dpkg-source --commit
3633     # can work.  We do this as follows:
3634     #     1. Collect all relevant .orig from parent directory
3635     #     2. Generate a debian.tar.gz out of
3636     #         debian/{patches,rules,source/format,source/options}
3637     #     3. Generate a fake .dsc containing just these fields:
3638     #          Format Source Version Files
3639     #     4. Extract the fake .dsc
3640     #        Now the fake .dsc has a .pc directory.
3641     # (In fact we do this in every case, because in future we will
3642     # want to search for a good base commit for generating patches.)
3643     #
3644     # Then we can actually do the dpkg-source --commit
3645     #     1. Make a new working tree with the same object
3646     #        store as our main tree and check out the main
3647     #        tree's HEAD.
3648     #     2. Copy .pc from the fake's extraction, if necessary
3649     #     3. Run dpkg-source --commit
3650     #     4. If the result has changes to debian/, then
3651     #          - git-add them them
3652     #          - git-add .pc if we had a .pc in-tree
3653     #          - git-commit
3654     #     5. If we had a .pc in-tree, delete it, and git-commit
3655     #     6. Back in the main tree, fast forward to the new HEAD
3656
3657     # Another situation we may have to cope with is gbp-style
3658     # patches-unapplied trees.
3659     #
3660     # We would want to detect these, so we know to escape into
3661     # quilt_fixup_gbp.  However, this is in general not possible.
3662     # Consider a package with a one patch which the dgit user reverts
3663     # (with git-revert or the moral equivalent).
3664     #
3665     # That is indistinguishable in contents from a patches-unapplied
3666     # tree.  And looking at the history to distinguish them is not
3667     # useful because the user might have made a confusing-looking git
3668     # history structure (which ought to produce an error if dgit can't
3669     # cope, not a silent reintroduction of an unwanted patch).
3670     #
3671     # So gbp users will have to pass an option.  But we can usually
3672     # detect their failure to do so: if the tree is not a clean
3673     # patches-applied tree, quilt linearisation fails, but the tree
3674     # _is_ a clean patches-unapplied tree, we can suggest that maybe
3675     # they want --quilt=unapplied.
3676     #
3677     # To help detect this, when we are extracting the fake dsc, we
3678     # first extract it with --skip-patches, and then apply the patches
3679     # afterwards with dpkg-source --before-build.  That lets us save a
3680     # tree object corresponding to .origs.
3681
3682     my $splitbrain_cachekey;
3683
3684     quilt_make_fake_dsc($upstreamversion);
3685
3686     if (quiltmode_splitbrain()) {
3687         my $cachehit;
3688         ($cachehit, $splitbrain_cachekey) =
3689             quilt_check_splitbrain_cache($headref, $upstreamversion);
3690         return if $cachehit;
3691     }
3692
3693     runcmd qw(sh -ec),
3694         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3695
3696     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3697     rename $fakexdir, "fake" or die "$fakexdir $!";
3698
3699     changedir 'fake';
3700
3701     remove_stray_gits();
3702     mktree_in_ud_here();
3703
3704     rmtree '.pc';
3705
3706     runcmd @git, qw(add -Af .);
3707     my $unapplied=git_write_tree();
3708     printdebug "fake orig tree object $unapplied\n";
3709
3710     ensuredir '.pc';
3711
3712     runcmd qw(sh -ec),
3713         'exec dpkg-source --before-build . >/dev/null';
3714
3715     changedir '..';
3716
3717     quilt_fixup_mkwork($headref);
3718
3719     my $mustdeletepc=0;
3720     if (stat_exists ".pc") {
3721         -d _ or die;
3722         progress "Tree already contains .pc - will use it then delete it.";
3723         $mustdeletepc=1;
3724     } else {
3725         rename '../fake/.pc','.pc' or die $!;
3726     }
3727
3728     changedir '../fake';
3729     rmtree '.pc';
3730     runcmd @git, qw(add -Af .);
3731     my $oldtiptree=git_write_tree();
3732     printdebug "fake o+d/p tree object $unapplied\n";
3733     changedir '../work';
3734
3735
3736     # We calculate some guesswork now about what kind of tree this might
3737     # be.  This is mostly for error reporting.
3738
3739     my %editedignores;
3740     my $diffbits = {
3741         # H = user's HEAD
3742         # O = orig, without patches applied
3743         # A = "applied", ie orig with H's debian/patches applied
3744         H2O => quiltify_trees_differ($headref,  $unapplied, 1,\%editedignores),
3745         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
3746         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3747     };
3748
3749     my @dl;
3750     foreach my $b (qw(01 02)) {
3751         foreach my $v (qw(H2O O2A H2A)) {
3752             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3753         }
3754     }
3755     printdebug "differences \@dl @dl.\n";
3756
3757     progress sprintf
3758 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
3759 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
3760                              $dl[0], $dl[1],              $dl[3], $dl[4],
3761                                  $dl[2],                     $dl[5];
3762
3763     my @failsuggestion;
3764     if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3765         push @failsuggestion, "This might be a patches-unapplied branch.";
3766     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3767         push @failsuggestion, "This might be a patches-applied branch.";
3768     }
3769     push @failsuggestion, "Maybe you need to specify one of".
3770         " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3771
3772     if (quiltmode_splitbrain()) {
3773         quiltify_splitbrain($clogp, $unapplied, $headref,
3774                             $diffbits, \%editedignores,
3775                             $splitbrain_cachekey);
3776         return;
3777     }
3778
3779     progress "starting quiltify (multiple patches, $quilt_mode mode)";
3780     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3781
3782     if (!open P, '>>', ".pc/applied-patches") {
3783         $!==&ENOENT or die $!;
3784     } else {
3785         close P;
3786     }
3787
3788     commit_quilty_patch();
3789
3790     if ($mustdeletepc) {
3791         quilt_fixup_delete_pc();
3792     }
3793 }
3794
3795 sub quilt_fixup_editor () {
3796     my $descfn = $ENV{$fakeeditorenv};
3797     my $editing = $ARGV[$#ARGV];
3798     open I1, '<', $descfn or die "$descfn: $!";
3799     open I2, '<', $editing or die "$editing: $!";
3800     unlink $editing or die "$editing: $!";
3801     open O, '>', $editing or die "$editing: $!";
3802     while (<I1>) { print O or die $!; } I1->error and die $!;
3803     my $copying = 0;
3804     while (<I2>) {
3805         $copying ||= m/^\-\-\- /;
3806         next unless $copying;
3807         print O or die $!;
3808     }
3809     I2->error and die $!;
3810     close O or die $1;
3811     exit 0;
3812 }
3813
3814 sub maybe_apply_patches_dirtily () {
3815     return unless $quilt_mode =~ m/gbp|unapplied/;
3816     print STDERR <<END or die $!;
3817
3818 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3819 dgit: Have to apply the patches - making the tree dirty.
3820 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3821
3822 END
3823     $patches_applied_dirtily = 01;
3824     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3825     runcmd qw(dpkg-source --before-build .);
3826 }
3827
3828 sub maybe_unapply_patches_again () {
3829     progress "dgit: Unapplying patches again to tidy up the tree."
3830         if $patches_applied_dirtily;
3831     runcmd qw(dpkg-source --after-build .)
3832         if $patches_applied_dirtily & 01;
3833     rmtree '.pc'
3834         if $patches_applied_dirtily & 02;
3835 }
3836
3837 #----- other building -----
3838
3839 our $clean_using_builder;
3840 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3841 #   clean the tree before building (perhaps invoked indirectly by
3842 #   whatever we are using to run the build), rather than separately
3843 #   and explicitly by us.
3844
3845 sub clean_tree () {
3846     return if $clean_using_builder;
3847     if ($cleanmode eq 'dpkg-source') {
3848         maybe_apply_patches_dirtily();
3849         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3850     } elsif ($cleanmode eq 'dpkg-source-d') {
3851         maybe_apply_patches_dirtily();
3852         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3853     } elsif ($cleanmode eq 'git') {
3854         runcmd_ordryrun_local @git, qw(clean -xdf);
3855     } elsif ($cleanmode eq 'git-ff') {
3856         runcmd_ordryrun_local @git, qw(clean -xdff);
3857     } elsif ($cleanmode eq 'check') {
3858         my $leftovers = cmdoutput @git, qw(clean -xdn);
3859         if (length $leftovers) {
3860             print STDERR $leftovers, "\n" or die $!;
3861             fail "tree contains uncommitted files and --clean=check specified";
3862         }
3863     } elsif ($cleanmode eq 'none') {
3864     } else {
3865         die "$cleanmode ?";
3866     }
3867 }
3868
3869 sub cmd_clean () {
3870     badusage "clean takes no additional arguments" if @ARGV;
3871     notpushing();
3872     clean_tree();
3873     maybe_unapply_patches_again();
3874 }
3875
3876 sub build_prep () {
3877     notpushing();
3878     badusage "-p is not allowed when building" if defined $package;
3879     check_not_dirty();
3880     clean_tree();
3881     my $clogp = parsechangelog();
3882     $isuite = getfield $clogp, 'Distribution';
3883     $package = getfield $clogp, 'Source';
3884     $version = getfield $clogp, 'Version';
3885     build_maybe_quilt_fixup();
3886     if ($rmchanges) {
3887         my $pat = changespat $version;
3888         foreach my $f (glob "$buildproductsdir/$pat") {
3889             if (act_local()) {
3890                 unlink $f or fail "remove old changes file $f: $!";
3891             } else {
3892                 progress "would remove $f";
3893             }
3894         }
3895     }
3896 }
3897
3898 sub changesopts_initial () {
3899     my @opts =@changesopts[1..$#changesopts];
3900 }
3901
3902 sub changesopts_version () {
3903     if (!defined $changes_since_version) {
3904         my @vsns = archive_query('archive_query');
3905         my @quirk = access_quirk();
3906         if ($quirk[0] eq 'backports') {
3907             local $isuite = $quirk[2];
3908             local $csuite;
3909             canonicalise_suite();
3910             push @vsns, archive_query('archive_query');
3911         }
3912         if (@vsns) {
3913             @vsns = map { $_->[0] } @vsns;
3914             @vsns = sort { -version_compare($a, $b) } @vsns;
3915             $changes_since_version = $vsns[0];
3916             progress "changelog will contain changes since $vsns[0]";
3917         } else {
3918             $changes_since_version = '_';
3919             progress "package seems new, not specifying -v<version>";
3920         }
3921     }
3922     if ($changes_since_version ne '_') {
3923         return ("-v$changes_since_version");
3924     } else {
3925         return ();
3926     }
3927 }
3928
3929 sub changesopts () {
3930     return (changesopts_initial(), changesopts_version());
3931 }
3932
3933 sub massage_dbp_args ($;$) {
3934     my ($cmd,$xargs) = @_;
3935     # We need to:
3936     #
3937     #  - if we're going to split the source build out so we can
3938     #    do strange things to it, massage the arguments to dpkg-buildpackage
3939     #    so that the main build doessn't build source (or add an argument
3940     #    to stop it building source by default).
3941     #
3942     #  - add -nc to stop dpkg-source cleaning the source tree,
3943     #    unless we're not doing a split build and want dpkg-source
3944     #    as cleanmode, in which case we can do nothing
3945     #
3946     # return values:
3947     #    0 - source will NOT need to be built separately by caller
3948     #   +1 - source will need to be built separately by caller
3949     #   +2 - source will need to be built separately by caller AND
3950     #        dpkg-buildpackage should not in fact be run at all!
3951     debugcmd '#massaging#', @$cmd if $debuglevel>1;
3952 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3953     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3954         $clean_using_builder = 1;
3955         return 0;
3956     }
3957     # -nc has the side effect of specifying -b if nothing else specified
3958     # and some combinations of -S, -b, et al, are errors, rather than
3959     # later simply overriding earlie.  So we need to:
3960     #  - search the command line for these options
3961     #  - pick the last one
3962     #  - perhaps add our own as a default
3963     #  - perhaps adjust it to the corresponding non-source-building version
3964     my $dmode = '-F';
3965     foreach my $l ($cmd, $xargs) {
3966         next unless $l;
3967         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3968     }
3969     push @$cmd, '-nc';
3970 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3971     my $r = 0;
3972     if ($need_split_build_invocation) {
3973         printdebug "massage split $dmode.\n";
3974         $r = $dmode =~ m/[S]/     ? +2 :
3975              $dmode =~ y/gGF/ABb/ ? +1 :
3976              $dmode =~ m/[ABb]/   ?  0 :
3977              die "$dmode ?";
3978     }
3979     printdebug "massage done $r $dmode.\n";
3980     push @$cmd, $dmode;
3981 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3982     return $r;
3983 }
3984
3985 sub cmd_build {
3986     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3987     my $wantsrc = massage_dbp_args \@dbp;
3988     if ($wantsrc > 0) {
3989         build_source();
3990     } else {
3991         build_prep();
3992     }
3993     if ($wantsrc < 2) {
3994         push @dbp, changesopts_version();
3995         maybe_apply_patches_dirtily();
3996         runcmd_ordryrun_local @dbp;
3997     }
3998     maybe_unapply_patches_again();
3999     printdone "build successful\n";
4000 }
4001
4002 sub cmd_gbp_build {
4003     my @dbp = @dpkgbuildpackage;
4004
4005     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4006
4007     my @cmd;
4008     if (length executable_on_path('git-buildpackage')) {
4009         @cmd = qw(git-buildpackage);
4010     } else {
4011         @cmd = qw(gbp buildpackage);
4012     }
4013     push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4014
4015     if ($wantsrc > 0) {
4016         build_source();
4017     } else {
4018         if (!$clean_using_builder) {
4019             push @cmd, '--git-cleaner=true';
4020         }
4021         build_prep();
4022     }
4023     if ($wantsrc < 2) {
4024         unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4025             canonicalise_suite();
4026             push @cmd, "--git-debian-branch=".lbranch();
4027         }
4028         push @cmd, changesopts();
4029         maybe_apply_patches_dirtily();
4030         runcmd_ordryrun_local @cmd, @ARGV;
4031     }
4032     maybe_unapply_patches_again();
4033     printdone "build successful\n";
4034 }
4035 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4036
4037 sub build_source {
4038     my $our_cleanmode = $cleanmode;
4039     if ($need_split_build_invocation) {
4040         # Pretend that clean is being done some other way.  This
4041         # forces us not to try to use dpkg-buildpackage to clean and
4042         # build source all in one go; and instead we run dpkg-source
4043         # (and build_prep() will do the clean since $clean_using_builder
4044         # is false).
4045         $our_cleanmode = 'ELSEWHERE';
4046     }
4047     if ($our_cleanmode =~ m/^dpkg-source/) {
4048         # dpkg-source invocation (below) will clean, so build_prep shouldn't
4049         $clean_using_builder = 1;
4050     }
4051     build_prep();
4052     $sourcechanges = changespat $version,'source';
4053     if (act_local()) {
4054         unlink "../$sourcechanges" or $!==ENOENT
4055             or fail "remove $sourcechanges: $!";
4056     }
4057     $dscfn = dscfn($version);
4058     if ($our_cleanmode eq 'dpkg-source') {
4059         maybe_apply_patches_dirtily();
4060         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4061             changesopts();
4062     } elsif ($our_cleanmode eq 'dpkg-source-d') {
4063         maybe_apply_patches_dirtily();
4064         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4065             changesopts();
4066     } else {
4067         my @cmd = (@dpkgsource, qw(-b --));
4068         if ($split_brain) {
4069             changedir $ud;
4070             runcmd_ordryrun_local @cmd, "work";
4071             my @udfiles = <${package}_*>;
4072             changedir "../../..";
4073             foreach my $f (@udfiles) {
4074                 printdebug "source copy, found $f\n";
4075                 next unless
4076                     $f eq $dscfn or
4077                     ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4078                      $f eq srcfn($version, $&));
4079                 printdebug "source copy, found $f - renaming\n";
4080                 rename "$ud/$f", "../$f" or $!==ENOENT
4081                     or fail "put in place new source file ($f): $!";
4082             }
4083         } else {
4084             my $pwd = must_getcwd();
4085             my $leafdir = basename $pwd;
4086             changedir "..";
4087             runcmd_ordryrun_local @cmd, $leafdir;
4088             changedir $pwd;
4089         }
4090         runcmd_ordryrun_local qw(sh -ec),
4091             'exec >$1; shift; exec "$@"','x',
4092             "../$sourcechanges",
4093             @dpkggenchanges, qw(-S), changesopts();
4094     }
4095 }
4096
4097 sub cmd_build_source {
4098     badusage "build-source takes no additional arguments" if @ARGV;
4099     build_source();
4100     maybe_unapply_patches_again();
4101     printdone "source built, results in $dscfn and $sourcechanges";
4102 }
4103
4104 sub cmd_sbuild {
4105     build_source();
4106     my $pat = changespat $version;
4107     if (!$rmchanges) {
4108         my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4109         @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4110         fail "changes files other than source matching $pat".
4111             " already present (@unwanted);".
4112             " building would result in ambiguity about the intended results"
4113             if @unwanted;
4114     }
4115     changedir "..";
4116     if (act_local()) {
4117         stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4118         stat_exists $sourcechanges
4119             or fail "$sourcechanges (in parent directory): $!";
4120     }
4121     runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4122     my @changesfiles = glob $pat;
4123     @changesfiles = sort {
4124         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4125             or $a cmp $b
4126     } @changesfiles;
4127     fail "wrong number of different changes files (@changesfiles)"
4128         unless @changesfiles==2;
4129     my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4130     foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4131         fail "$l found in binaries changes file $binchanges"
4132             if $l =~ m/\.dsc$/;
4133     }
4134     runcmd_ordryrun_local @mergechanges, @changesfiles;
4135     my $multichanges = changespat $version,'multi';
4136     if (act_local()) {
4137         stat_exists $multichanges or fail "$multichanges: $!";
4138         foreach my $cf (glob $pat) {
4139             next if $cf eq $multichanges;
4140             rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4141         }
4142     }
4143     maybe_unapply_patches_again();
4144     printdone "build successful, results in $multichanges\n" or die $!;
4145 }
4146
4147 sub cmd_quilt_fixup {
4148     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4149     my $clogp = parsechangelog();
4150     $version = getfield $clogp, 'Version';
4151     $package = getfield $clogp, 'Source';
4152     check_not_dirty();
4153     clean_tree();
4154     build_maybe_quilt_fixup();
4155 }
4156
4157 sub cmd_archive_api_query {
4158     badusage "need only 1 subpath argument" unless @ARGV==1;
4159     my ($subpath) = @ARGV;
4160     my @cmd = archive_api_query_cmd($subpath);
4161     debugcmd ">",@cmd;
4162     exec @cmd or fail "exec curl: $!\n";
4163 }
4164
4165 sub cmd_clone_dgit_repos_server {
4166     badusage "need destination argument" unless @ARGV==1;
4167     my ($destdir) = @ARGV;
4168     $package = '_dgit-repos-server';
4169     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4170     debugcmd ">",@cmd;
4171     exec @cmd or fail "exec git clone: $!\n";
4172 }
4173
4174 sub cmd_setup_mergechangelogs {
4175     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4176     setup_mergechangelogs(1);
4177 }
4178
4179 sub cmd_setup_useremail {
4180     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4181     setup_useremail(1);
4182 }
4183
4184 sub cmd_setup_new_tree {
4185     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4186     setup_new_tree();
4187 }
4188
4189 #---------- argument parsing and main program ----------
4190
4191 sub cmd_version {
4192     print "dgit version $our_version\n" or die $!;
4193     exit 0;
4194 }
4195
4196 our (%valopts_long, %valopts_short);
4197 our @rvalopts;
4198
4199 sub defvalopt ($$$$) {
4200     my ($long,$short,$val_re,$how) = @_;
4201     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4202     $valopts_long{$long} = $oi;
4203     $valopts_short{$short} = $oi;
4204     # $how subref should:
4205     #   do whatever assignemnt or thing it likes with $_[0]
4206     #   if the option should not be passed on to remote, @rvalopts=()
4207     # or $how can be a scalar ref, meaning simply assign the value
4208 }
4209
4210 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4211 defvalopt '--distro',        '-d', '.+',      \$idistro;
4212 defvalopt '',                '-k', '.+',      \$keyid;
4213 defvalopt '--existing-package','', '.*',      \$existing_package;
4214 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
4215 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
4216 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
4217
4218 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4219
4220 defvalopt '', '-C', '.+', sub {
4221     ($changesfile) = (@_);
4222     if ($changesfile =~ s#^(.*)/##) {
4223         $buildproductsdir = $1;
4224     }
4225 };
4226
4227 defvalopt '--initiator-tempdir','','.*', sub {
4228     ($initiator_tempdir) = (@_);
4229     $initiator_tempdir =~ m#^/# or
4230         badusage "--initiator-tempdir must be used specify an".
4231         " absolute, not relative, directory."
4232 };
4233
4234 sub parseopts () {
4235     my $om;
4236
4237     if (defined $ENV{'DGIT_SSH'}) {
4238         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4239     } elsif (defined $ENV{'GIT_SSH'}) {
4240         @ssh = ($ENV{'GIT_SSH'});
4241     }
4242
4243     my $oi;
4244     my $val;
4245     my $valopt = sub {
4246         my ($what) = @_;
4247         @rvalopts = ($_);
4248         if (!defined $val) {
4249             badusage "$what needs a value" unless @ARGV;
4250             $val = shift @ARGV;
4251             push @rvalopts, $val;
4252         }
4253         badusage "bad value \`$val' for $what" unless
4254             $val =~ m/^$oi->{Re}$(?!\n)/s;
4255         my $how = $oi->{How};
4256         if (ref($how) eq 'SCALAR') {
4257             $$how = $val;
4258         } else {
4259             $how->($val);
4260         }
4261         push @ropts, @rvalopts;
4262     };
4263
4264     while (@ARGV) {
4265         last unless $ARGV[0] =~ m/^-/;
4266         $_ = shift @ARGV;
4267         last if m/^--?$/;
4268         if (m/^--/) {
4269             if (m/^--dry-run$/) {
4270                 push @ropts, $_;
4271                 $dryrun_level=2;
4272             } elsif (m/^--damp-run$/) {
4273                 push @ropts, $_;
4274                 $dryrun_level=1;
4275             } elsif (m/^--no-sign$/) {
4276                 push @ropts, $_;
4277                 $sign=0;
4278             } elsif (m/^--help$/) {
4279                 cmd_help();
4280             } elsif (m/^--version$/) {
4281                 cmd_version();
4282             } elsif (m/^--new$/) {
4283                 push @ropts, $_;
4284                 $new_package=1;
4285             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4286                      ($om = $opts_opt_map{$1}) &&
4287                      length $om->[0]) {
4288                 push @ropts, $_;
4289                 $om->[0] = $2;
4290             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4291                      !$opts_opt_cmdonly{$1} &&
4292                      ($om = $opts_opt_map{$1})) {
4293                 push @ropts, $_;
4294                 push @$om, $2;
4295             } elsif (m/^--ignore-dirty$/s) {
4296                 push @ropts, $_;
4297                 $ignoredirty = 1;
4298             } elsif (m/^--no-quilt-fixup$/s) {
4299                 push @ropts, $_;
4300                 $quilt_mode = 'nocheck';
4301             } elsif (m/^--no-rm-on-error$/s) {
4302                 push @ropts, $_;
4303                 $rmonerror = 0;
4304             } elsif (m/^--(no-)?rm-old-changes$/s) {
4305                 push @ropts, $_;
4306                 $rmchanges = !$1;
4307             } elsif (m/^--deliberately-($deliberately_re)$/s) {
4308                 push @ropts, $_;
4309                 push @deliberatelies, $&;
4310             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4311                 # undocumented, for testing
4312                 push @ropts, $_;
4313                 $tagformat_want = [ $1, 'command line', 1 ];
4314                 # 1 menas overrides distro configuration
4315             } elsif (m/^--always-split-source-build$/s) {
4316                 # undocumented, for testing
4317                 push @ropts, $_;
4318                 $need_split_build_invocation = 1;
4319             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4320                 $val = $2 ? $' : undef; #';
4321                 $valopt->($oi->{Long});
4322             } else {
4323                 badusage "unknown long option \`$_'";
4324             }
4325         } else {
4326             while (m/^-./s) {
4327                 if (s/^-n/-/) {
4328                     push @ropts, $&;
4329                     $dryrun_level=2;
4330                 } elsif (s/^-L/-/) {
4331                     push @ropts, $&;
4332                     $dryrun_level=1;
4333                 } elsif (s/^-h/-/) {
4334                     cmd_help();
4335                 } elsif (s/^-D/-/) {
4336                     push @ropts, $&;
4337                     $debuglevel++;
4338                     enabledebug();
4339                 } elsif (s/^-N/-/) {
4340                     push @ropts, $&;
4341                     $new_package=1;
4342                 } elsif (m/^-m/) {
4343                     push @ropts, $&;
4344                     push @changesopts, $_;
4345                     $_ = '';
4346                 } elsif (s/^-wn$//s) {
4347                     push @ropts, $&;
4348                     $cleanmode = 'none';
4349                 } elsif (s/^-wg$//s) {
4350                     push @ropts, $&;
4351                     $cleanmode = 'git';
4352                 } elsif (s/^-wgf$//s) {
4353                     push @ropts, $&;
4354                     $cleanmode = 'git-ff';
4355                 } elsif (s/^-wd$//s) {
4356                     push @ropts, $&;
4357                     $cleanmode = 'dpkg-source';
4358                 } elsif (s/^-wdd$//s) {
4359                     push @ropts, $&;
4360                     $cleanmode = 'dpkg-source-d';
4361                 } elsif (s/^-wc$//s) {
4362                     push @ropts, $&;
4363                     $cleanmode = 'check';
4364                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4365                     $val = $'; #';
4366                     $val = undef unless length $val;
4367                     $valopt->($oi->{Short});
4368                     $_ = '';
4369                 } else {
4370                     badusage "unknown short option \`$_'";
4371                 }
4372             }
4373         }
4374     }
4375 }
4376
4377 sub finalise_opts_opts () {
4378     foreach my $k (keys %opts_opt_map) {
4379         my $om = $opts_opt_map{$k};
4380
4381         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4382         if (defined $v) {
4383             badcfg "cannot set command for $k"
4384                 unless length $om->[0];
4385             $om->[0] = $v;
4386         }
4387
4388         foreach my $c (access_cfg_cfgs("opts-$k")) {
4389             my $vl = $gitcfg{$c};
4390             printdebug "CL $c ",
4391                 ($vl ? join " ", map { shellquote } @$vl : ""),
4392                 "\n" if $debuglevel >= 4;
4393             next unless $vl;
4394             badcfg "cannot configure options for $k"
4395                 if $opts_opt_cmdonly{$k};
4396             my $insertpos = $opts_cfg_insertpos{$k};
4397             @$om = ( @$om[0..$insertpos-1],
4398                      @$vl,
4399                      @$om[$insertpos..$#$om] );
4400         }
4401     }
4402 }
4403
4404 if ($ENV{$fakeeditorenv}) {
4405     git_slurp_config();
4406     quilt_fixup_editor();
4407 }
4408
4409 parseopts();
4410 git_slurp_config();
4411
4412 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4413 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4414     if $dryrun_level == 1;
4415 if (!@ARGV) {
4416     print STDERR $helpmsg or die $!;
4417     exit 8;
4418 }
4419 my $cmd = shift @ARGV;
4420 $cmd =~ y/-/_/;
4421
4422 if (!defined $rmchanges) {
4423     local $access_forpush;
4424     $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4425 }
4426
4427 if (!defined $quilt_mode) {
4428     local $access_forpush;
4429     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4430         // access_cfg('quilt-mode', 'RETURN-UNDEF')
4431         // 'linear';
4432     $quilt_mode =~ m/^($quilt_modes_re)$/
4433         or badcfg "unknown quilt-mode \`$quilt_mode'";
4434     $quilt_mode = $1;
4435 }
4436
4437 $need_split_build_invocation ||= quiltmode_splitbrain();
4438
4439 if (!defined $cleanmode) {
4440     local $access_forpush;
4441     $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4442     $cleanmode //= 'dpkg-source';
4443
4444     badcfg "unknown clean-mode \`$cleanmode'" unless
4445         $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4446 }
4447
4448 my $fn = ${*::}{"cmd_$cmd"};
4449 $fn or badusage "unknown operation $cmd";
4450 $fn->();