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