dgit

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