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 $overwrite_version
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 ($dgitview, $cachekey) =
3156                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3157             $dgitview or fail
3158  "--quilt=$quilt_mode but no cached dgit view:
3159  perhaps tree changed since dgit build[-source] ?";
3160             $split_brain = 1;
3161             $dgithead = splitbrain_pseudomerge($clogp,
3162                                                $actualhead, $dgitview,
3163                                                $archive_hash);
3164             $maintviewhead = $actualhead;
3165             changedir '../../../..';
3166             prep_ud(); # so _only_subdir() works, below
3167         } else {
3168             commit_quilty_patch();
3169         }
3170     }
3171
3172     if (defined $overwrite_version && !defined $maintviewhead) {
3173         $dgithead = plain_overwrite_pseudomerge($clogp,
3174                                                 $dgithead,
3175                                                 $archive_hash);
3176     }
3177
3178     check_not_dirty();
3179
3180     my $forceflag = '';
3181     if ($archive_hash) {
3182         if (is_fast_fwd($archive_hash, $dgithead)) {
3183             # ok
3184         } elsif (deliberately_not_fast_forward) {
3185             $forceflag = '+';
3186         } else {
3187             fail "dgit push: HEAD is not a descendant".
3188                 " of the archive's version.\n".
3189                 "To overwrite the archive's contents,".
3190                 " pass --overwrite[=VERSION].\n".
3191                 "To rewind history, if permitted by the archive,".
3192                 " use --deliberately-not-fast-forward.";
3193         }
3194     }
3195
3196     changedir $ud;
3197     progress "checking that $dscfn corresponds to HEAD";
3198     runcmd qw(dpkg-source -x --),
3199         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3200     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3201     check_for_vendor_patches() if madformat($dsc->{format});
3202     changedir '../../../..';
3203     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3204     debugcmd "+",@diffcmd;
3205     $!=0; $?=-1;
3206     my $r = system @diffcmd;
3207     if ($r) {
3208         if ($r==256) {
3209             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3210             fail <<END
3211 HEAD specifies a different tree to $dscfn:
3212 $diffs
3213 Perhaps you forgot to build.  Or perhaps there is a problem with your
3214  source tree (see dgit(7) for some hints).  To see a full diff, run
3215    git diff $tree HEAD
3216 END
3217         } else {
3218             failedcmd @diffcmd;
3219         }
3220     }
3221     if (!$changesfile) {
3222         my $pat = changespat $cversion;
3223         my @cs = glob "$buildproductsdir/$pat";
3224         fail "failed to find unique changes file".
3225             " (looked for $pat in $buildproductsdir);".
3226             " perhaps you need to use dgit -C"
3227             unless @cs==1;
3228         ($changesfile) = @cs;
3229     } else {
3230         $changesfile = "$buildproductsdir/$changesfile";
3231     }
3232
3233     # Check that changes and .dsc agree enough
3234     $changesfile =~ m{[^/]*$};
3235     files_compare_inputs($dsc, parsecontrol($changesfile,$&));
3236
3237     # Checks complete, we're going to try and go ahead:
3238
3239     responder_send_file('changes',$changesfile);
3240     responder_send_command("param head $dgithead");
3241     responder_send_command("param csuite $csuite");
3242     responder_send_command("param tagformat $tagformat");
3243     if (defined $maintviewhead) {
3244         die unless ($protovsn//4) >= 4;
3245         responder_send_command("param maint-view $maintviewhead");
3246     }
3247
3248     if (deliberately_not_fast_forward) {
3249         git_for_each_ref(lrfetchrefs, sub {
3250             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3251             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3252             responder_send_command("previously $rrefname=$objid");
3253             $previously{$rrefname} = $objid;
3254         });
3255     }
3256
3257     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3258                                  ".git/dgit/tag");
3259     my @tagobjfns;
3260
3261     supplementary_message(<<'END');
3262 Push failed, while signing the tag.
3263 You can retry the push, after fixing the problem, if you like.
3264 END
3265     # If we manage to sign but fail to record it anywhere, it's fine.
3266     if ($we_are_responder) {
3267         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3268         responder_receive_files('signed-tag', @tagobjfns);
3269     } else {
3270         @tagobjfns = push_mktags($clogp,$dscpath,
3271                               $changesfile,$changesfile,
3272                               \@tagwants);
3273     }
3274     supplementary_message(<<'END');
3275 Push failed, *after* signing the tag.
3276 If you want to try again, you should use a new version number.
3277 END
3278
3279     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3280
3281     foreach my $tw (@tagwants) {
3282         my $tag = $tw->{Tag};
3283         my $tagobjfn = $tw->{TagObjFn};
3284         my $tag_obj_hash =
3285             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3286         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3287         runcmd_ordryrun_local
3288             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3289     }
3290
3291     supplementary_message(<<'END');
3292 Push failed, while updating the remote git repository - see messages above.
3293 If you want to try again, you should use a new version number.
3294 END
3295     if (!check_for_git()) {
3296         create_remote_git_repo();
3297     }
3298
3299     my @pushrefs = $forceflag.$dgithead.":".rrref();
3300     foreach my $tw (@tagwants) {
3301         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3302     }
3303
3304     runcmd_ordryrun @git,
3305         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3306     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3307
3308     supplementary_message(<<'END');
3309 Push failed, after updating the remote git repository.
3310 If you want to try again, you must use a new version number.
3311 END
3312     if ($we_are_responder) {
3313         my $dryrunsuffix = act_local() ? "" : ".tmp";
3314         responder_receive_files('signed-dsc-changes',
3315                                 "$dscpath$dryrunsuffix",
3316                                 "$changesfile$dryrunsuffix");
3317     } else {
3318         if (act_local()) {
3319             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3320         } else {
3321             progress "[new .dsc left in $dscpath.tmp]";
3322         }
3323         sign_changes $changesfile;
3324     }
3325
3326     supplementary_message(<<END);
3327 Push failed, while uploading package(s) to the archive server.
3328 You can retry the upload of exactly these same files with dput of:
3329   $changesfile
3330 If that .changes file is broken, you will need to use a new version
3331 number for your next attempt at the upload.
3332 END
3333     my $host = access_cfg('upload-host','RETURN-UNDEF');
3334     my @hostarg = defined($host) ? ($host,) : ();
3335     runcmd_ordryrun @dput, @hostarg, $changesfile;
3336     printdone "pushed and uploaded $cversion";
3337
3338     supplementary_message('');
3339     responder_send_command("complete");
3340 }
3341
3342 sub cmd_clone {
3343     parseopts();
3344     notpushing();
3345     my $dstdir;
3346     badusage "-p is not allowed with clone; specify as argument instead"
3347         if defined $package;
3348     if (@ARGV==1) {
3349         ($package) = @ARGV;
3350     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3351         ($package,$isuite) = @ARGV;
3352     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3353         ($package,$dstdir) = @ARGV;
3354     } elsif (@ARGV==3) {
3355         ($package,$isuite,$dstdir) = @ARGV;
3356     } else {
3357         badusage "incorrect arguments to dgit clone";
3358     }
3359     $dstdir ||= "$package";
3360
3361     if (stat_exists $dstdir) {
3362         fail "$dstdir already exists";
3363     }
3364
3365     my $cwd_remove;
3366     if ($rmonerror && !$dryrun_level) {
3367         $cwd_remove= getcwd();
3368         unshift @end, sub {
3369             return unless defined $cwd_remove;
3370             if (!chdir "$cwd_remove") {
3371                 return if $!==&ENOENT;
3372                 die "chdir $cwd_remove: $!";
3373             }
3374             if (stat $dstdir) {
3375                 rmtree($dstdir) or die "remove $dstdir: $!\n";
3376             } elsif (grep { $! == $_ }
3377                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3378             } else {
3379                 print STDERR "check whether to remove $dstdir: $!\n";
3380             }
3381         };
3382     }
3383
3384     clone($dstdir);
3385     $cwd_remove = undef;
3386 }
3387
3388 sub branchsuite () {
3389     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3390     if ($branch =~ m#$lbranch_re#o) {
3391         return $1;
3392     } else {
3393         return undef;
3394     }
3395 }
3396
3397 sub fetchpullargs () {
3398     notpushing();
3399     if (!defined $package) {
3400         my $sourcep = parsecontrol('debian/control','debian/control');
3401         $package = getfield $sourcep, 'Source';
3402     }
3403     if (@ARGV==0) {
3404 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
3405         if (!$isuite) {
3406             my $clogp = parsechangelog();
3407             $isuite = getfield $clogp, 'Distribution';
3408         }
3409         canonicalise_suite();
3410         progress "fetching from suite $csuite";
3411     } elsif (@ARGV==1) {
3412         ($isuite) = @ARGV;
3413         canonicalise_suite();
3414     } else {
3415         badusage "incorrect arguments to dgit fetch or dgit pull";
3416     }
3417 }
3418
3419 sub cmd_fetch {
3420     parseopts();
3421     fetchpullargs();
3422     fetch();
3423 }
3424
3425 sub cmd_pull {
3426     parseopts();
3427     fetchpullargs();
3428     pull();
3429 }
3430
3431 sub cmd_push {
3432     parseopts();
3433     pushing();
3434     badusage "-p is not allowed with dgit push" if defined $package;
3435     check_not_dirty();
3436     my $clogp = parsechangelog();
3437     $package = getfield $clogp, 'Source';
3438     my $specsuite;
3439     if (@ARGV==0) {
3440     } elsif (@ARGV==1) {
3441         ($specsuite) = (@ARGV);
3442     } else {
3443         badusage "incorrect arguments to dgit push";
3444     }
3445     $isuite = getfield $clogp, 'Distribution';
3446     if ($new_package) {
3447         local ($package) = $existing_package; # this is a hack
3448         canonicalise_suite();
3449     } else {
3450         canonicalise_suite();
3451     }
3452     if (defined $specsuite &&
3453         $specsuite ne $isuite &&
3454         $specsuite ne $csuite) {
3455             fail "dgit push: changelog specifies $isuite ($csuite)".
3456                 " but command line specifies $specsuite";
3457     }
3458     dopush();
3459 }
3460
3461 #---------- remote commands' implementation ----------
3462
3463 sub cmd_remote_push_build_host {
3464     my ($nrargs) = shift @ARGV;
3465     my (@rargs) = @ARGV[0..$nrargs-1];
3466     @ARGV = @ARGV[$nrargs..$#ARGV];
3467     die unless @rargs;
3468     my ($dir,$vsnwant) = @rargs;
3469     # vsnwant is a comma-separated list; we report which we have
3470     # chosen in our ready response (so other end can tell if they
3471     # offered several)
3472     $debugprefix = ' ';
3473     $we_are_responder = 1;
3474     $us .= " (build host)";
3475
3476     pushing();
3477
3478     open PI, "<&STDIN" or die $!;
3479     open STDIN, "/dev/null" or die $!;
3480     open PO, ">&STDOUT" or die $!;
3481     autoflush PO 1;
3482     open STDOUT, ">&STDERR" or die $!;
3483     autoflush STDOUT 1;
3484
3485     $vsnwant //= 1;
3486     ($protovsn) = grep {
3487         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3488     } @rpushprotovsn_support;
3489
3490     fail "build host has dgit rpush protocol versions ".
3491         (join ",", @rpushprotovsn_support).
3492         " but invocation host has $vsnwant"
3493         unless defined $protovsn;
3494
3495     responder_send_command("dgit-remote-push-ready $protovsn");
3496     rpush_handle_protovsn_bothends();
3497     changedir $dir;
3498     &cmd_push;
3499 }
3500
3501 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3502 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3503 #     a good error message)
3504
3505 sub rpush_handle_protovsn_bothends () {
3506     if ($protovsn < 4) {
3507         need_tagformat 'old', "rpush negotiated protocol $protovsn";
3508     }
3509     select_tagformat();
3510 }
3511
3512 our $i_tmp;
3513
3514 sub i_cleanup {
3515     local ($@, $?);
3516     my $report = i_child_report();
3517     if (defined $report) {
3518         printdebug "($report)\n";
3519     } elsif ($i_child_pid) {
3520         printdebug "(killing build host child $i_child_pid)\n";
3521         kill 15, $i_child_pid;
3522     }
3523     if (defined $i_tmp && !defined $initiator_tempdir) {
3524         changedir "/";
3525         eval { rmtree $i_tmp; };
3526     }
3527 }
3528
3529 END { i_cleanup(); }
3530
3531 sub i_method {
3532     my ($base,$selector,@args) = @_;
3533     $selector =~ s/\-/_/g;
3534     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3535 }
3536
3537 sub cmd_rpush {
3538     pushing();
3539     my $host = nextarg;
3540     my $dir;
3541     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3542         $host = $1;
3543         $dir = $'; #';
3544     } else {
3545         $dir = nextarg;
3546     }
3547     $dir =~ s{^-}{./-};
3548     my @rargs = ($dir);
3549     push @rargs, join ",", @rpushprotovsn_support;
3550     my @rdgit;
3551     push @rdgit, @dgit;
3552     push @rdgit, @ropts;
3553     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3554     push @rdgit, @ARGV;
3555     my @cmd = (@ssh, $host, shellquote @rdgit);
3556     debugcmd "+",@cmd;
3557
3558     if (defined $initiator_tempdir) {
3559         rmtree $initiator_tempdir;
3560         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3561         $i_tmp = $initiator_tempdir;
3562     } else {
3563         $i_tmp = tempdir();
3564     }
3565     $i_child_pid = open2(\*RO, \*RI, @cmd);
3566     changedir $i_tmp;
3567     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3568     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3569     $supplementary_message = '' unless $protovsn >= 3;
3570
3571     fail "rpush negotiated protocol version $protovsn".
3572         " which does not support quilt mode $quilt_mode"
3573         if quiltmode_splitbrain;
3574
3575     rpush_handle_protovsn_bothends();
3576     for (;;) {
3577         my ($icmd,$iargs) = initiator_expect {
3578             m/^(\S+)(?: (.*))?$/;
3579             ($1,$2);
3580         };
3581         i_method "i_resp", $icmd, $iargs;
3582     }
3583 }
3584
3585 sub i_resp_progress ($) {
3586     my ($rhs) = @_;
3587     my $msg = protocol_read_bytes \*RO, $rhs;
3588     progress $msg;
3589 }
3590
3591 sub i_resp_supplementary_message ($) {
3592     my ($rhs) = @_;
3593     $supplementary_message = protocol_read_bytes \*RO, $rhs;
3594 }
3595
3596 sub i_resp_complete {
3597     my $pid = $i_child_pid;
3598     $i_child_pid = undef; # prevents killing some other process with same pid
3599     printdebug "waiting for build host child $pid...\n";
3600     my $got = waitpid $pid, 0;
3601     die $! unless $got == $pid;
3602     die "build host child failed $?" if $?;
3603
3604     i_cleanup();
3605     printdebug "all done\n";
3606     exit 0;
3607 }
3608
3609 sub i_resp_file ($) {
3610     my ($keyword) = @_;
3611     my $localname = i_method "i_localname", $keyword;
3612     my $localpath = "$i_tmp/$localname";
3613     stat_exists $localpath and
3614         badproto \*RO, "file $keyword ($localpath) twice";
3615     protocol_receive_file \*RO, $localpath;
3616     i_method "i_file", $keyword;
3617 }
3618
3619 our %i_param;
3620
3621 sub i_resp_param ($) {
3622     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3623     $i_param{$1} = $2;
3624 }
3625
3626 sub i_resp_previously ($) {
3627     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3628         or badproto \*RO, "bad previously spec";
3629     my $r = system qw(git check-ref-format), $1;
3630     die "bad previously ref spec ($r)" if $r;
3631     $previously{$1} = $2;
3632 }
3633
3634 our %i_wanted;
3635
3636 sub i_resp_want ($) {
3637     my ($keyword) = @_;
3638     die "$keyword ?" if $i_wanted{$keyword}++;
3639     my @localpaths = i_method "i_want", $keyword;
3640     printdebug "[[  $keyword @localpaths\n";
3641     foreach my $localpath (@localpaths) {
3642         protocol_send_file \*RI, $localpath;
3643     }
3644     print RI "files-end\n" or die $!;
3645 }
3646
3647 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3648
3649 sub i_localname_parsed_changelog {
3650     return "remote-changelog.822";
3651 }
3652 sub i_file_parsed_changelog {
3653     ($i_clogp, $i_version, $i_dscfn) =
3654         push_parse_changelog "$i_tmp/remote-changelog.822";
3655     die if $i_dscfn =~ m#/|^\W#;
3656 }
3657
3658 sub i_localname_dsc {
3659     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3660     return $i_dscfn;
3661 }
3662 sub i_file_dsc { }
3663
3664 sub i_localname_changes {
3665     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3666     $i_changesfn = $i_dscfn;
3667     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3668     return $i_changesfn;
3669 }
3670 sub i_file_changes { }
3671
3672 sub i_want_signed_tag {
3673     printdebug Dumper(\%i_param, $i_dscfn);
3674     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3675         && defined $i_param{'csuite'}
3676         or badproto \*RO, "premature desire for signed-tag";
3677     my $head = $i_param{'head'};
3678     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3679
3680     my $maintview = $i_param{'maint-view'};
3681     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3682
3683     select_tagformat();
3684     if ($protovsn >= 4) {
3685         my $p = $i_param{'tagformat'} // '<undef>';
3686         $p eq $tagformat
3687             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3688     }
3689
3690     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3691     $csuite = $&;
3692     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3693
3694     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3695
3696     return
3697         push_mktags $i_clogp, $i_dscfn,
3698             $i_changesfn, 'remote changes',
3699             \@tagwants;
3700 }
3701
3702 sub i_want_signed_dsc_changes {
3703     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3704     sign_changes $i_changesfn;
3705     return ($i_dscfn, $i_changesfn);
3706 }
3707
3708 #---------- building etc. ----------
3709
3710 our $version;
3711 our $sourcechanges;
3712 our $dscfn;
3713
3714 #----- `3.0 (quilt)' handling -----
3715
3716 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3717
3718 sub quiltify_dpkg_commit ($$$;$) {
3719     my ($patchname,$author,$msg, $xinfo) = @_;
3720     $xinfo //= '';
3721
3722     mkpath '.git/dgit';
3723     my $descfn = ".git/dgit/quilt-description.tmp";
3724     open O, '>', $descfn or die "$descfn: $!";
3725     $msg =~ s/\n+/\n\n/;
3726     print O <<END or die $!;
3727 From: $author
3728 ${xinfo}Subject: $msg
3729 ---
3730
3731 END
3732     close O or die $!;
3733
3734     {
3735         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3736         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3737         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3738         runcmd @dpkgsource, qw(--commit .), $patchname;
3739     }
3740 }
3741
3742 sub quiltify_trees_differ ($$;$$$) {
3743     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
3744     # returns true iff the two tree objects differ other than in debian/
3745     # with $finegrained,
3746     # returns bitmask 01 - differ in upstream files except .gitignore
3747     #                 02 - differ in .gitignore
3748     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3749     #  is set for each modified .gitignore filename $fn
3750     # if $unrepres is defined, array ref to which is appeneded
3751     #  a list of unrepresentable changes (removals of upstream files
3752     #  (as messages)
3753     local $/=undef;
3754     my @cmd = (@git, qw(diff-tree -z));
3755     push @cmd, qw(--name-only) unless $unrepres;
3756     push @cmd, qw(-r) if $finegrained || $unrepres;
3757     push @cmd, $x, $y;
3758     my $diffs= cmdoutput @cmd;
3759     my $r = 0;
3760     my @lmodes;
3761     foreach my $f (split /\0/, $diffs) {
3762         if ($unrepres && !@lmodes) {
3763             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
3764             next;
3765         }
3766         my ($oldmode,$newmode) = @lmodes;
3767         @lmodes = ();
3768
3769         next if $f =~ m#^debian(?:/.*)?$#s;
3770
3771         if ($unrepres) {
3772             eval {
3773                 die "deleted\n" unless $newmode =~ m/[^0]/;
3774                 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
3775                 if ($oldmode =~ m/[^0]/) {
3776                     die "mode changed\n" if $oldmode ne $newmode;
3777                 } else {
3778                     die "non-default mode\n" unless $newmode =~ m/^100644$/;
3779                 }
3780             };
3781             if ($@) {
3782                 local $/="\n"; chomp $@;
3783                 push @$unrepres, [ $f, $@ ];
3784             }
3785         }
3786
3787         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3788         $r |= $isignore ? 02 : 01;
3789         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3790     }
3791     printdebug "quiltify_trees_differ $x $y => $r\n";
3792     return $r;
3793 }
3794
3795 sub quiltify_tree_sentinelfiles ($) {
3796     # lists the `sentinel' files present in the tree
3797     my ($x) = @_;
3798     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3799         qw(-- debian/rules debian/control);
3800     $r =~ s/\n/,/g;
3801     return $r;
3802 }
3803
3804 sub quiltify_splitbrain_needed () {
3805     if (!$split_brain) {
3806         progress "dgit view: changes are required...";
3807         runcmd @git, qw(checkout -q -b dgit-view);
3808         $split_brain = 1;
3809     }
3810 }
3811
3812 sub quiltify_splitbrain ($$$$$$) {
3813     my ($clogp, $unapplied, $headref, $diffbits,
3814         $editedignores, $cachekey) = @_;
3815     if ($quilt_mode !~ m/gbp|dpm/) {
3816         # treat .gitignore just like any other upstream file
3817         $diffbits = { %$diffbits };
3818         $_ = !!$_ foreach values %$diffbits;
3819     }
3820     # We would like any commits we generate to be reproducible
3821     my @authline = clogp_authline($clogp);
3822     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
3823     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3824     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
3825     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
3826     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
3827     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
3828
3829     if ($quilt_mode =~ m/gbp|unapplied/ &&
3830         ($diffbits->{O2H} & 01)) {
3831         my $msg =
3832  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3833  " but git tree differs from orig in upstream files.";
3834         if (!stat_exists "debian/patches") {
3835             $msg .=
3836  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3837         }
3838         fail $msg;
3839     }
3840     if ($quilt_mode =~ m/dpm/ &&
3841         ($diffbits->{H2A} & 01)) {
3842         fail <<END;
3843 --quilt=$quilt_mode specified, implying patches-applied git tree
3844  but git tree differs from result of applying debian/patches to upstream
3845 END
3846     }
3847     if ($quilt_mode =~ m/gbp|unapplied/ &&
3848         ($diffbits->{O2A} & 01)) { # some patches
3849         quiltify_splitbrain_needed();
3850         progress "dgit view: creating patches-applied version using gbp pq";
3851         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
3852         # gbp pq import creates a fresh branch; push back to dgit-view
3853         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3854         runcmd @git, qw(checkout -q dgit-view);
3855     }
3856     if ($quilt_mode =~ m/gbp|dpm/ &&
3857         ($diffbits->{O2A} & 02)) {
3858         fail <<END
3859 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3860  tool which does not create patches for changes to upstream
3861  .gitignores: but, such patches exist in debian/patches.
3862 END
3863     }
3864     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
3865         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3866         quiltify_splitbrain_needed();
3867         progress "dgit view: creating patch to represent .gitignore changes";
3868         ensuredir "debian/patches";
3869         my $gipatch = "debian/patches/auto-gitignore";
3870         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3871         stat GIPATCH or die "$gipatch: $!";
3872         fail "$gipatch already exists; but want to create it".
3873             " to record .gitignore changes" if (stat _)[7];
3874         print GIPATCH <<END or die "$gipatch: $!";
3875 Subject: Update .gitignore from Debian packaging branch
3876
3877 The Debian packaging git branch contains these updates to the upstream
3878 .gitignore file(s).  This patch is autogenerated, to provide these
3879 updates to users of the official Debian archive view of the package.
3880
3881 [dgit ($our_version) update-gitignore]
3882 ---
3883 END
3884         close GIPATCH or die "$gipatch: $!";
3885         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3886             $unapplied, $headref, "--", sort keys %$editedignores;
3887         open SERIES, "+>>", "debian/patches/series" or die $!;
3888         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3889         my $newline;
3890         defined read SERIES, $newline, 1 or die $!;
3891         print SERIES "\n" or die $! unless $newline eq "\n";
3892         print SERIES "auto-gitignore\n" or die $!;
3893         close SERIES or die  $!;
3894         runcmd @git, qw(add -- debian/patches/series), $gipatch;
3895         commit_admin <<END
3896 Commit patch to update .gitignore
3897
3898 [dgit ($our_version) update-gitignore-quilt-fixup]
3899 END
3900     }
3901
3902     my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3903
3904     changedir '../../../..';
3905     ensuredir ".git/logs/refs/dgit-intern";
3906     my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3907       or die $!;
3908     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3909         $dgitview;
3910
3911     progress "dgit view: created (commit id $dgitview)";
3912
3913     changedir '.git/dgit/unpack/work';
3914 }
3915
3916 sub quiltify ($$$$) {
3917     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3918
3919     # Quilt patchification algorithm
3920     #
3921     # We search backwards through the history of the main tree's HEAD
3922     # (T) looking for a start commit S whose tree object is identical
3923     # to to the patch tip tree (ie the tree corresponding to the
3924     # current dpkg-committed patch series).  For these purposes
3925     # `identical' disregards anything in debian/ - this wrinkle is
3926     # necessary because dpkg-source treates debian/ specially.
3927     #
3928     # We can only traverse edges where at most one of the ancestors'
3929     # trees differs (in changes outside in debian/).  And we cannot
3930     # handle edges which change .pc/ or debian/patches.  To avoid
3931     # going down a rathole we avoid traversing edges which introduce
3932     # debian/rules or debian/control.  And we set a limit on the
3933     # number of edges we are willing to look at.
3934     #
3935     # If we succeed, we walk forwards again.  For each traversed edge
3936     # PC (with P parent, C child) (starting with P=S and ending with
3937     # C=T) to we do this:
3938     #  - git checkout C
3939     #  - dpkg-source --commit with a patch name and message derived from C
3940     # After traversing PT, we git commit the changes which
3941     # should be contained within debian/patches.
3942
3943     # The search for the path S..T is breadth-first.  We maintain a
3944     # todo list containing search nodes.  A search node identifies a
3945     # commit, and looks something like this:
3946     #  $p = {
3947     #      Commit => $git_commit_id,
3948     #      Child => $c,                          # or undef if P=T
3949     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
3950     #      Nontrivial => true iff $p..$c has relevant changes
3951     #  };
3952
3953     my @todo;
3954     my @nots;
3955     my $sref_S;
3956     my $max_work=100;
3957     my %considered; # saves being exponential on some weird graphs
3958
3959     my $t_sentinels = quiltify_tree_sentinelfiles $target;
3960
3961     my $not = sub {
3962         my ($search,$whynot) = @_;
3963         printdebug " search NOT $search->{Commit} $whynot\n";
3964         $search->{Whynot} = $whynot;
3965         push @nots, $search;
3966         no warnings qw(exiting);
3967         next;
3968     };
3969
3970     push @todo, {
3971         Commit => $target,
3972     };
3973
3974     while (@todo) {
3975         my $c = shift @todo;
3976         next if $considered{$c->{Commit}}++;
3977
3978         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3979
3980         printdebug "quiltify investigate $c->{Commit}\n";
3981
3982         # are we done?
3983         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3984             printdebug " search finished hooray!\n";
3985             $sref_S = $c;
3986             last;
3987         }
3988
3989         if ($quilt_mode eq 'nofix') {
3990             fail "quilt fixup required but quilt mode is \`nofix'\n".
3991                 "HEAD commit $c->{Commit} differs from tree implied by ".
3992                 " debian/patches (tree object $oldtiptree)";
3993         }
3994         if ($quilt_mode eq 'smash') {
3995             printdebug " search quitting smash\n";
3996             last;
3997         }
3998
3999         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4000         $not->($c, "has $c_sentinels not $t_sentinels")
4001             if $c_sentinels ne $t_sentinels;
4002
4003         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4004         $commitdata =~ m/\n\n/;
4005         $commitdata =~ $`;
4006         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4007         @parents = map { { Commit => $_, Child => $c } } @parents;
4008
4009         $not->($c, "root commit") if !@parents;
4010
4011         foreach my $p (@parents) {
4012             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4013         }
4014         my $ndiffers = grep { $_->{Nontrivial} } @parents;
4015         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4016
4017         foreach my $p (@parents) {
4018             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4019
4020             my @cmd= (@git, qw(diff-tree -r --name-only),
4021                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4022             my $patchstackchange = cmdoutput @cmd;
4023             if (length $patchstackchange) {
4024                 $patchstackchange =~ s/\n/,/g;
4025                 $not->($p, "changed $patchstackchange");
4026             }
4027
4028             printdebug " search queue P=$p->{Commit} ",
4029                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4030             push @todo, $p;
4031         }
4032     }
4033
4034     if (!$sref_S) {
4035         printdebug "quiltify want to smash\n";
4036
4037         my $abbrev = sub {
4038             my $x = $_[0]{Commit};
4039             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4040             return $x;
4041         };
4042         my $reportnot = sub {
4043             my ($notp) = @_;
4044             my $s = $abbrev->($notp);
4045             my $c = $notp->{Child};
4046             $s .= "..".$abbrev->($c) if $c;
4047             $s .= ": ".$notp->{Whynot};
4048             return $s;
4049         };
4050         if ($quilt_mode eq 'linear') {
4051             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
4052             foreach my $notp (@nots) {
4053                 print STDERR "$us:  ", $reportnot->($notp), "\n";
4054             }
4055             print STDERR "$us: $_\n" foreach @$failsuggestion;
4056             fail "quilt fixup naive history linearisation failed.\n".
4057  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4058         } elsif ($quilt_mode eq 'smash') {
4059         } elsif ($quilt_mode eq 'auto') {
4060             progress "quilt fixup cannot be linear, smashing...";
4061         } else {
4062             die "$quilt_mode ?";
4063         }
4064
4065         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4066         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4067         my $ncommits = 3;
4068         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4069
4070         quiltify_dpkg_commit "auto-$version-$target-$time",
4071             (getfield $clogp, 'Maintainer'),
4072             "Automatically generated patch ($clogp->{Version})\n".
4073             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4074         return;
4075     }
4076
4077     progress "quiltify linearisation planning successful, executing...";
4078
4079     for (my $p = $sref_S;
4080          my $c = $p->{Child};
4081          $p = $p->{Child}) {
4082         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4083         next unless $p->{Nontrivial};
4084
4085         my $cc = $c->{Commit};
4086
4087         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4088         $commitdata =~ m/\n\n/ or die "$c ?";
4089         $commitdata = $`;
4090         my $msg = $'; #';
4091         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4092         my $author = $1;
4093
4094         my $commitdate = cmdoutput
4095             @git, qw(log -n1 --pretty=format:%aD), $cc;
4096
4097         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4098
4099         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4100         $strip_nls->();
4101
4102         my $title = $1;
4103         my $patchname;
4104         my $patchdir;
4105
4106         my $gbp_check_suitable = sub {
4107             $_ = shift;
4108             my ($what) = @_;
4109
4110             eval {
4111                 die "contains unexpected slashes\n" if m{//} || m{/$};
4112                 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4113                 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4114                 die "too long" if length > 200;
4115             };
4116             return $_ unless $@;
4117             print STDERR "quiltifying commit $cc:".
4118                 " ignoring/dropping Gbp-Pq $what: $@";
4119             return undef;
4120         };
4121
4122         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4123                            gbp-pq-name: \s* )
4124                        (\S+) \s* \n //ixm) {
4125             $patchname = $gbp_check_suitable->($1, 'Name');
4126         }
4127         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4128                            gbp-pq-topic: \s* )
4129                        (\S+) \s* \n //ixm) {
4130             $patchdir = $gbp_check_suitable->($1, 'Topic');
4131         }
4132
4133         $strip_nls->();
4134
4135         if (!defined $patchname) {
4136             $patchname = $title;
4137             $patchname =~ s/[.:]$//;
4138             use Text::Iconv;
4139             eval {
4140                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4141                 my $translitname = $converter->convert($patchname);
4142                 die unless defined $translitname;
4143                 $patchname = $translitname;
4144             };
4145             print STDERR
4146                 "dgit: patch title transliteration error: $@"
4147                 if $@;
4148             $patchname =~ y/ A-Z/-a-z/;
4149             $patchname =~ y/-a-z0-9_.+=~//cd;
4150             $patchname =~ s/^\W/x-$&/;
4151             $patchname = substr($patchname,0,40);
4152         }
4153         if (!defined $patchdir) {
4154             $patchdir = '';
4155         }
4156         if (length $patchdir) {
4157             $patchname = "$patchdir/$patchname";
4158         }
4159         if ($patchname =~ m{^(.*)/}) {
4160             mkpath "debian/patches/$1";
4161         }
4162
4163         my $index;
4164         for ($index='';
4165              stat "debian/patches/$patchname$index";
4166              $index++) { }
4167         $!==ENOENT or die "$patchname$index $!";
4168
4169         runcmd @git, qw(checkout -q), $cc;
4170
4171         # We use the tip's changelog so that dpkg-source doesn't
4172         # produce complaining messages from dpkg-parsechangelog.  None
4173         # of the information dpkg-source gets from the changelog is
4174         # actually relevant - it gets put into the original message
4175         # which dpkg-source provides our stunt editor, and then
4176         # overwritten.
4177         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4178
4179         quiltify_dpkg_commit "$patchname$index", $author, $msg,
4180             "Date: $commitdate\n".
4181             "X-Dgit-Generated: $clogp->{Version} $cc\n";
4182
4183         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4184     }
4185
4186     runcmd @git, qw(checkout -q master);
4187 }
4188
4189 sub build_maybe_quilt_fixup () {
4190     my ($format,$fopts) = get_source_format;
4191     return unless madformat_wantfixup $format;
4192     # sigh
4193
4194     check_for_vendor_patches();
4195
4196     if (quiltmode_splitbrain) {
4197         foreach my $needtf (qw(new maint)) {
4198             next if grep { $_ eq $needtf } access_cfg_tagformats;
4199             fail <<END
4200 quilt mode $quilt_mode requires split view so server needs to support
4201  both "new" and "maint" tag formats, but config says it doesn't.
4202 END
4203         }
4204     }
4205
4206     my $clogp = parsechangelog();
4207     my $headref = git_rev_parse('HEAD');
4208
4209     prep_ud();
4210     changedir $ud;
4211
4212     my $upstreamversion=$version;
4213     $upstreamversion =~ s/-[^-]*$//;
4214
4215     if ($fopts->{'single-debian-patch'}) {
4216         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4217     } else {
4218         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4219     }
4220
4221     die 'bug' if $split_brain && !$need_split_build_invocation;
4222
4223     changedir '../../../..';
4224     runcmd_ordryrun_local
4225         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4226 }
4227
4228 sub quilt_fixup_mkwork ($) {
4229     my ($headref) = @_;
4230
4231     mkdir "work" or die $!;
4232     changedir "work";
4233     mktree_in_ud_here();
4234     runcmd @git, qw(reset -q --hard), $headref;
4235 }
4236
4237 sub quilt_fixup_linkorigs ($$) {
4238     my ($upstreamversion, $fn) = @_;
4239     # calls $fn->($leafname);
4240
4241     foreach my $f (<../../../../*>) { #/){
4242         my $b=$f; $b =~ s{.*/}{};
4243         {
4244             local ($debuglevel) = $debuglevel-1;
4245             printdebug "QF linkorigs $b, $f ?\n";
4246         }
4247         next unless is_orig_file_of_vsn $b, $upstreamversion;
4248         printdebug "QF linkorigs $b, $f Y\n";
4249         link_ltarget $f, $b or die "$b $!";
4250         $fn->($b);
4251     }
4252 }
4253
4254 sub quilt_fixup_delete_pc () {
4255     runcmd @git, qw(rm -rqf .pc);
4256     commit_admin <<END
4257 Commit removal of .pc (quilt series tracking data)
4258
4259 [dgit ($our_version) upgrade quilt-remove-pc]
4260 END
4261 }
4262
4263 sub quilt_fixup_singlepatch ($$$) {
4264     my ($clogp, $headref, $upstreamversion) = @_;
4265
4266     progress "starting quiltify (single-debian-patch)";
4267
4268     # dpkg-source --commit generates new patches even if
4269     # single-debian-patch is in debian/source/options.  In order to
4270     # get it to generate debian/patches/debian-changes, it is
4271     # necessary to build the source package.
4272
4273     quilt_fixup_linkorigs($upstreamversion, sub { });
4274     quilt_fixup_mkwork($headref);
4275
4276     rmtree("debian/patches");
4277
4278     runcmd @dpkgsource, qw(-b .);
4279     changedir "..";
4280     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4281     rename srcfn("$upstreamversion", "/debian/patches"),
4282            "work/debian/patches";
4283
4284     changedir "work";
4285     commit_quilty_patch();
4286 }
4287
4288 sub quilt_make_fake_dsc ($) {
4289     my ($upstreamversion) = @_;
4290
4291     my $fakeversion="$upstreamversion-~~DGITFAKE";
4292
4293     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4294     print $fakedsc <<END or die $!;
4295 Format: 3.0 (quilt)
4296 Source: $package
4297 Version: $fakeversion
4298 Files:
4299 END
4300
4301     my $dscaddfile=sub {
4302         my ($b) = @_;
4303
4304         my $md = new Digest::MD5;
4305
4306         my $fh = new IO::File $b, '<' or die "$b $!";
4307         stat $fh or die $!;
4308         my $size = -s _;
4309
4310         $md->addfile($fh);
4311         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4312     };
4313
4314     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4315
4316     my @files=qw(debian/source/format debian/rules
4317                  debian/control debian/changelog);
4318     foreach my $maybe (qw(debian/patches debian/source/options
4319                           debian/tests/control)) {
4320         next unless stat_exists "../../../$maybe";
4321         push @files, $maybe;
4322     }
4323
4324     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4325     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4326
4327     $dscaddfile->($debtar);
4328     close $fakedsc or die $!;
4329 }
4330
4331 sub quilt_check_splitbrain_cache ($$) {
4332     my ($headref, $upstreamversion) = @_;
4333     # Called only if we are in (potentially) split brain mode.
4334     # Called in $ud.
4335     # Computes the cache key and looks in the cache.
4336     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4337
4338     my $splitbrain_cachekey;
4339
4340     progress
4341  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4342     # we look in the reflog of dgit-intern/quilt-cache
4343     # we look for an entry whose message is the key for the cache lookup
4344     my @cachekey = (qw(dgit), $our_version);
4345     push @cachekey, $upstreamversion;
4346     push @cachekey, $quilt_mode;
4347     push @cachekey, $headref;
4348
4349     push @cachekey, hashfile('fake.dsc');
4350
4351     my $srcshash = Digest::SHA->new(256);
4352     my %sfs = ( %INC, '$0(dgit)' => $0 );
4353     foreach my $sfk (sort keys %sfs) {
4354         next unless m/^\$0\b/ || m{^Debian/Dgit\b};
4355         $srcshash->add($sfk,"  ");
4356         $srcshash->add(hashfile($sfs{$sfk}));
4357         $srcshash->add("\n");
4358     }
4359     push @cachekey, $srcshash->hexdigest();
4360     $splitbrain_cachekey = "@cachekey";
4361
4362     my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
4363                $splitbraincache);
4364     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4365     debugcmd "|(probably)",@cmd;
4366     my $child = open GC, "-|";  defined $child or die $!;
4367     if (!$child) {
4368         chdir '../../..' or die $!;
4369         if (!stat ".git/logs/refs/$splitbraincache") {
4370             $! == ENOENT or die $!;
4371             printdebug ">(no reflog)\n";
4372             exit 0;
4373         }
4374         exec @cmd; die $!;
4375     }
4376     while (<GC>) {
4377         chomp;
4378         printdebug ">| ", $_, "\n" if $debuglevel > 1;
4379         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4380
4381         my $cachehit = $1;
4382         quilt_fixup_mkwork($headref);
4383         if ($cachehit ne $headref) {
4384             progress "dgit view: found cached (commit id $cachehit)";
4385             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4386             $split_brain = 1;
4387             return ($cachehit, $splitbrain_cachekey);
4388         }
4389         progress "dgit view: found cached, no changes required";
4390         return ($headref, $splitbrain_cachekey);
4391     }
4392     die $! if GC->error;
4393     failedcmd unless close GC;
4394
4395     printdebug "splitbrain cache miss\n";
4396     return (undef, $splitbrain_cachekey);
4397 }
4398
4399 sub quilt_fixup_multipatch ($$$) {
4400     my ($clogp, $headref, $upstreamversion) = @_;
4401
4402     progress "examining quilt state (multiple patches, $quilt_mode mode)";
4403
4404     # Our objective is:
4405     #  - honour any existing .pc in case it has any strangeness
4406     #  - determine the git commit corresponding to the tip of
4407     #    the patch stack (if there is one)
4408     #  - if there is such a git commit, convert each subsequent
4409     #    git commit into a quilt patch with dpkg-source --commit
4410     #  - otherwise convert all the differences in the tree into
4411     #    a single git commit
4412     #
4413     # To do this we:
4414
4415     # Our git tree doesn't necessarily contain .pc.  (Some versions of
4416     # dgit would include the .pc in the git tree.)  If there isn't
4417     # one, we need to generate one by unpacking the patches that we
4418     # have.
4419     #
4420     # We first look for a .pc in the git tree.  If there is one, we
4421     # will use it.  (This is not the normal case.)
4422     #
4423     # Otherwise need to regenerate .pc so that dpkg-source --commit
4424     # can work.  We do this as follows:
4425     #     1. Collect all relevant .orig from parent directory
4426     #     2. Generate a debian.tar.gz out of
4427     #         debian/{patches,rules,source/format,source/options}
4428     #     3. Generate a fake .dsc containing just these fields:
4429     #          Format Source Version Files
4430     #     4. Extract the fake .dsc
4431     #        Now the fake .dsc has a .pc directory.
4432     # (In fact we do this in every case, because in future we will
4433     # want to search for a good base commit for generating patches.)
4434     #
4435     # Then we can actually do the dpkg-source --commit
4436     #     1. Make a new working tree with the same object
4437     #        store as our main tree and check out the main
4438     #        tree's HEAD.
4439     #     2. Copy .pc from the fake's extraction, if necessary
4440     #     3. Run dpkg-source --commit
4441     #     4. If the result has changes to debian/, then
4442     #          - git add them them
4443     #          - git add .pc if we had a .pc in-tree
4444     #          - git commit
4445     #     5. If we had a .pc in-tree, delete it, and git commit
4446     #     6. Back in the main tree, fast forward to the new HEAD
4447
4448     # Another situation we may have to cope with is gbp-style
4449     # patches-unapplied trees.
4450     #
4451     # We would want to detect these, so we know to escape into
4452     # quilt_fixup_gbp.  However, this is in general not possible.
4453     # Consider a package with a one patch which the dgit user reverts
4454     # (with git revert or the moral equivalent).
4455     #
4456     # That is indistinguishable in contents from a patches-unapplied
4457     # tree.  And looking at the history to distinguish them is not
4458     # useful because the user might have made a confusing-looking git
4459     # history structure (which ought to produce an error if dgit can't
4460     # cope, not a silent reintroduction of an unwanted patch).
4461     #
4462     # So gbp users will have to pass an option.  But we can usually
4463     # detect their failure to do so: if the tree is not a clean
4464     # patches-applied tree, quilt linearisation fails, but the tree
4465     # _is_ a clean patches-unapplied tree, we can suggest that maybe
4466     # they want --quilt=unapplied.
4467     #
4468     # To help detect this, when we are extracting the fake dsc, we
4469     # first extract it with --skip-patches, and then apply the patches
4470     # afterwards with dpkg-source --before-build.  That lets us save a
4471     # tree object corresponding to .origs.
4472
4473     my $splitbrain_cachekey;
4474
4475     quilt_make_fake_dsc($upstreamversion);
4476
4477     if (quiltmode_splitbrain()) {
4478         my $cachehit;
4479         ($cachehit, $splitbrain_cachekey) =
4480             quilt_check_splitbrain_cache($headref, $upstreamversion);
4481         return if $cachehit;
4482     }
4483
4484     runcmd qw(sh -ec),
4485         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4486
4487     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4488     rename $fakexdir, "fake" or die "$fakexdir $!";
4489
4490     changedir 'fake';
4491
4492     remove_stray_gits();
4493     mktree_in_ud_here();
4494
4495     rmtree '.pc';
4496
4497     runcmd @git, qw(add -Af .);
4498     my $unapplied=git_write_tree();
4499     printdebug "fake orig tree object $unapplied\n";
4500
4501     ensuredir '.pc';
4502
4503     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4504     $!=0; $?=-1;
4505     if (system @bbcmd) {
4506         failedcmd @bbcmd if $? < 0;
4507         fail <<END;
4508 failed to apply your git tree's patch stack (from debian/patches/) to
4509  the corresponding upstream tarball(s).  Your source tree and .orig
4510  are probably too inconsistent.  dgit can only fix up certain kinds of
4511  anomaly (depending on the quilt mode).  See --quilt= in dgit(1).
4512 END
4513     }
4514
4515     changedir '..';
4516
4517     quilt_fixup_mkwork($headref);
4518
4519     my $mustdeletepc=0;
4520     if (stat_exists ".pc") {
4521         -d _ or die;
4522         progress "Tree already contains .pc - will use it then delete it.";
4523         $mustdeletepc=1;
4524     } else {
4525         rename '../fake/.pc','.pc' or die $!;
4526     }
4527
4528     changedir '../fake';
4529     rmtree '.pc';
4530     runcmd @git, qw(add -Af .);
4531     my $oldtiptree=git_write_tree();
4532     printdebug "fake o+d/p tree object $unapplied\n";
4533     changedir '../work';
4534
4535
4536     # We calculate some guesswork now about what kind of tree this might
4537     # be.  This is mostly for error reporting.
4538
4539     my %editedignores;
4540     my @unrepres;
4541     my $diffbits = {
4542         # H = user's HEAD
4543         # O = orig, without patches applied
4544         # A = "applied", ie orig with H's debian/patches applied
4545         O2H => quiltify_trees_differ($unapplied,$headref,   1,
4546                                      \%editedignores, \@unrepres),
4547         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
4548         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4549     };
4550
4551     my @dl;
4552     foreach my $b (qw(01 02)) {
4553         foreach my $v (qw(O2H O2A H2A)) {
4554             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4555         }
4556     }
4557     printdebug "differences \@dl @dl.\n";
4558
4559     progress sprintf
4560 "$us: base trees orig=%.20s o+d/p=%.20s",
4561               $unapplied, $oldtiptree;
4562     progress sprintf
4563 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
4564 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
4565                              $dl[0], $dl[1],              $dl[3], $dl[4],
4566                                  $dl[2],                     $dl[5];
4567
4568     if (@unrepres) {
4569         print STDERR "dgit:  cannot represent change: $_->[1]: $_->[0]\n"
4570             foreach @unrepres;
4571         fail <<END;
4572 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4573 END
4574     }
4575
4576     my @failsuggestion;
4577     if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4578         push @failsuggestion, "This might be a patches-unapplied branch.";
4579     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4580         push @failsuggestion, "This might be a patches-applied branch.";
4581     }
4582     push @failsuggestion, "Maybe you need to specify one of".
4583         " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4584
4585     if (quiltmode_splitbrain()) {
4586         quiltify_splitbrain($clogp, $unapplied, $headref,
4587                             $diffbits, \%editedignores,
4588                             $splitbrain_cachekey);
4589         return;
4590     }
4591
4592     progress "starting quiltify (multiple patches, $quilt_mode mode)";
4593     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4594
4595     if (!open P, '>>', ".pc/applied-patches") {
4596         $!==&ENOENT or die $!;
4597     } else {
4598         close P;
4599     }
4600
4601     commit_quilty_patch();
4602
4603     if ($mustdeletepc) {
4604         quilt_fixup_delete_pc();
4605     }
4606 }
4607
4608 sub quilt_fixup_editor () {
4609     my $descfn = $ENV{$fakeeditorenv};
4610     my $editing = $ARGV[$#ARGV];
4611     open I1, '<', $descfn or die "$descfn: $!";
4612     open I2, '<', $editing or die "$editing: $!";
4613     unlink $editing or die "$editing: $!";
4614     open O, '>', $editing or die "$editing: $!";
4615     while (<I1>) { print O or die $!; } I1->error and die $!;
4616     my $copying = 0;
4617     while (<I2>) {
4618         $copying ||= m/^\-\-\- /;
4619         next unless $copying;
4620         print O or die $!;
4621     }
4622     I2->error and die $!;
4623     close O or die $1;
4624     exit 0;
4625 }
4626
4627 sub maybe_apply_patches_dirtily () {
4628     return unless $quilt_mode =~ m/gbp|unapplied/;
4629     print STDERR <<END or die $!;
4630
4631 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4632 dgit: Have to apply the patches - making the tree dirty.
4633 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4634
4635 END
4636     $patches_applied_dirtily = 01;
4637     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4638     runcmd qw(dpkg-source --before-build .);
4639 }
4640
4641 sub maybe_unapply_patches_again () {
4642     progress "dgit: Unapplying patches again to tidy up the tree."
4643         if $patches_applied_dirtily;
4644     runcmd qw(dpkg-source --after-build .)
4645         if $patches_applied_dirtily & 01;
4646     rmtree '.pc'
4647         if $patches_applied_dirtily & 02;
4648     $patches_applied_dirtily = 0;
4649 }
4650
4651 #----- other building -----
4652
4653 our $clean_using_builder;
4654 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4655 #   clean the tree before building (perhaps invoked indirectly by
4656 #   whatever we are using to run the build), rather than separately
4657 #   and explicitly by us.
4658
4659 sub clean_tree () {
4660     return if $clean_using_builder;
4661     if ($cleanmode eq 'dpkg-source') {
4662         maybe_apply_patches_dirtily();
4663         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4664     } elsif ($cleanmode eq 'dpkg-source-d') {
4665         maybe_apply_patches_dirtily();
4666         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4667     } elsif ($cleanmode eq 'git') {
4668         runcmd_ordryrun_local @git, qw(clean -xdf);
4669     } elsif ($cleanmode eq 'git-ff') {
4670         runcmd_ordryrun_local @git, qw(clean -xdff);
4671     } elsif ($cleanmode eq 'check') {
4672         my $leftovers = cmdoutput @git, qw(clean -xdn);
4673         if (length $leftovers) {
4674             print STDERR $leftovers, "\n" or die $!;
4675             fail "tree contains uncommitted files and --clean=check specified";
4676         }
4677     } elsif ($cleanmode eq 'none') {
4678     } else {
4679         die "$cleanmode ?";
4680     }
4681 }
4682
4683 sub cmd_clean () {
4684     badusage "clean takes no additional arguments" if @ARGV;
4685     notpushing();
4686     clean_tree();
4687     maybe_unapply_patches_again();
4688 }
4689
4690 sub build_prep () {
4691     notpushing();
4692     badusage "-p is not allowed when building" if defined $package;
4693     check_not_dirty();
4694     clean_tree();
4695     my $clogp = parsechangelog();
4696     $isuite = getfield $clogp, 'Distribution';
4697     $package = getfield $clogp, 'Source';
4698     $version = getfield $clogp, 'Version';
4699     build_maybe_quilt_fixup();
4700     if ($rmchanges) {
4701         my $pat = changespat $version;
4702         foreach my $f (glob "$buildproductsdir/$pat") {
4703             if (act_local()) {
4704                 unlink $f or fail "remove old changes file $f: $!";
4705             } else {
4706                 progress "would remove $f";
4707             }
4708         }
4709     }
4710 }
4711
4712 sub changesopts_initial () {
4713     my @opts =@changesopts[1..$#changesopts];
4714 }
4715
4716 sub changesopts_version () {
4717     if (!defined $changes_since_version) {
4718         my @vsns = archive_query('archive_query');
4719         my @quirk = access_quirk();
4720         if ($quirk[0] eq 'backports') {
4721             local $isuite = $quirk[2];
4722             local $csuite;
4723             canonicalise_suite();
4724             push @vsns, archive_query('archive_query');
4725         }
4726         if (@vsns) {
4727             @vsns = map { $_->[0] } @vsns;
4728             @vsns = sort { -version_compare($a, $b) } @vsns;
4729             $changes_since_version = $vsns[0];
4730             progress "changelog will contain changes since $vsns[0]";
4731         } else {
4732             $changes_since_version = '_';
4733             progress "package seems new, not specifying -v<version>";
4734         }
4735     }
4736     if ($changes_since_version ne '_') {
4737         return ("-v$changes_since_version");
4738     } else {
4739         return ();
4740     }
4741 }
4742
4743 sub changesopts () {
4744     return (changesopts_initial(), changesopts_version());
4745 }
4746
4747 sub massage_dbp_args ($;$) {
4748     my ($cmd,$xargs) = @_;
4749     # We need to:
4750     #
4751     #  - if we're going to split the source build out so we can
4752     #    do strange things to it, massage the arguments to dpkg-buildpackage
4753     #    so that the main build doessn't build source (or add an argument
4754     #    to stop it building source by default).
4755     #
4756     #  - add -nc to stop dpkg-source cleaning the source tree,
4757     #    unless we're not doing a split build and want dpkg-source
4758     #    as cleanmode, in which case we can do nothing
4759     #
4760     # return values:
4761     #    0 - source will NOT need to be built separately by caller
4762     #   +1 - source will need to be built separately by caller
4763     #   +2 - source will need to be built separately by caller AND
4764     #        dpkg-buildpackage should not in fact be run at all!
4765     debugcmd '#massaging#', @$cmd if $debuglevel>1;
4766 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4767     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4768         $clean_using_builder = 1;
4769         return 0;
4770     }
4771     # -nc has the side effect of specifying -b if nothing else specified
4772     # and some combinations of -S, -b, et al, are errors, rather than
4773     # later simply overriding earlie.  So we need to:
4774     #  - search the command line for these options
4775     #  - pick the last one
4776     #  - perhaps add our own as a default
4777     #  - perhaps adjust it to the corresponding non-source-building version
4778     my $dmode = '-F';
4779     foreach my $l ($cmd, $xargs) {
4780         next unless $l;
4781         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4782     }
4783     push @$cmd, '-nc';
4784 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4785     my $r = 0;
4786     if ($need_split_build_invocation) {
4787         printdebug "massage split $dmode.\n";
4788         $r = $dmode =~ m/[S]/     ? +2 :
4789              $dmode =~ y/gGF/ABb/ ? +1 :
4790              $dmode =~ m/[ABb]/   ?  0 :
4791              die "$dmode ?";
4792     }
4793     printdebug "massage done $r $dmode.\n";
4794     push @$cmd, $dmode;
4795 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4796     return $r;
4797 }
4798
4799 sub cmd_build {
4800     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4801     my $wantsrc = massage_dbp_args \@dbp;
4802     if ($wantsrc > 0) {
4803         build_source();
4804     } else {
4805         build_prep();
4806     }
4807     if ($wantsrc < 2) {
4808         push @dbp, changesopts_version();
4809         maybe_apply_patches_dirtily();
4810         runcmd_ordryrun_local @dbp;
4811     }
4812     maybe_unapply_patches_again();
4813     printdone "build successful\n";
4814 }
4815
4816 sub pre_gbp_build {
4817     $quilt_mode //= 'gbp';
4818 }
4819
4820 sub cmd_gbp_build {
4821     my @dbp = @dpkgbuildpackage;
4822
4823     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4824
4825     if (!length $gbp_build[0]) {
4826         if (length executable_on_path('git-buildpackage')) {
4827             $gbp_build[0] = qw(git-buildpackage);
4828         } else {
4829             $gbp_build[0] = 'gbp buildpackage';
4830         }
4831     }
4832     my @cmd = opts_opt_multi_cmd @gbp_build;
4833
4834     push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4835
4836     if ($wantsrc > 0) {
4837         build_source();
4838     } else {
4839         if (!$clean_using_builder) {
4840             push @cmd, '--git-cleaner=true';
4841         }
4842         build_prep();
4843     }
4844     maybe_unapply_patches_again();
4845     if ($wantsrc < 2) {
4846         unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4847             canonicalise_suite();
4848             push @cmd, "--git-debian-branch=".lbranch();
4849         }
4850         push @cmd, changesopts();
4851         runcmd_ordryrun_local @cmd, @ARGV;
4852     }
4853     printdone "build successful\n";
4854 }
4855 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4856
4857 sub build_source {
4858     my $our_cleanmode = $cleanmode;
4859     if ($need_split_build_invocation) {
4860         # Pretend that clean is being done some other way.  This
4861         # forces us not to try to use dpkg-buildpackage to clean and
4862         # build source all in one go; and instead we run dpkg-source
4863         # (and build_prep() will do the clean since $clean_using_builder
4864         # is false).
4865         $our_cleanmode = 'ELSEWHERE';
4866     }
4867     if ($our_cleanmode =~ m/^dpkg-source/) {
4868         # dpkg-source invocation (below) will clean, so build_prep shouldn't
4869         $clean_using_builder = 1;
4870     }
4871     build_prep();
4872     $sourcechanges = changespat $version,'source';
4873     if (act_local()) {
4874         unlink "../$sourcechanges" or $!==ENOENT
4875             or fail "remove $sourcechanges: $!";
4876     }
4877     $dscfn = dscfn($version);
4878     if ($our_cleanmode eq 'dpkg-source') {
4879         maybe_apply_patches_dirtily();
4880         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4881             changesopts();
4882     } elsif ($our_cleanmode eq 'dpkg-source-d') {
4883         maybe_apply_patches_dirtily();
4884         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4885             changesopts();
4886     } else {
4887         my @cmd = (@dpkgsource, qw(-b --));
4888         if ($split_brain) {
4889             changedir $ud;
4890             runcmd_ordryrun_local @cmd, "work";
4891             my @udfiles = <${package}_*>;
4892             changedir "../../..";
4893             foreach my $f (@udfiles) {
4894                 printdebug "source copy, found $f\n";
4895                 next unless
4896                     $f eq $dscfn or
4897                     ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4898                      $f eq srcfn($version, $&));
4899                 printdebug "source copy, found $f - renaming\n";
4900                 rename "$ud/$f", "../$f" or $!==ENOENT
4901                     or fail "put in place new source file ($f): $!";
4902             }
4903         } else {
4904             my $pwd = must_getcwd();
4905             my $leafdir = basename $pwd;
4906             changedir "..";
4907             runcmd_ordryrun_local @cmd, $leafdir;
4908             changedir $pwd;
4909         }
4910         runcmd_ordryrun_local qw(sh -ec),
4911             'exec >$1; shift; exec "$@"','x',
4912             "../$sourcechanges",
4913             @dpkggenchanges, qw(-S), changesopts();
4914     }
4915 }
4916
4917 sub cmd_build_source {
4918     badusage "build-source takes no additional arguments" if @ARGV;
4919     build_source();
4920     maybe_unapply_patches_again();
4921     printdone "source built, results in $dscfn and $sourcechanges";
4922 }
4923
4924 sub cmd_sbuild {
4925     build_source();
4926     my $pat = changespat $version;
4927     if (!$rmchanges) {
4928         my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4929         @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4930         fail <<END
4931 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
4932 Suggest you delete @unwanted.
4933 END
4934             if @unwanted;
4935     }
4936     my $wasdir = must_getcwd();
4937     changedir "..";
4938     if (act_local()) {
4939         stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4940         stat_exists $sourcechanges
4941             or fail "$sourcechanges (in parent directory): $!";
4942     }
4943     runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4944     my @changesfiles = glob $pat;
4945     @changesfiles = sort {
4946         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4947             or $a cmp $b
4948     } @changesfiles;
4949     fail <<END if @changesfiles==1;
4950 only one changes file from sbuild (@changesfiles)
4951 perhaps you need to pass -A ?  (sbuild's default is to build only
4952 arch-specific binaries; dgit 1.4 used to override that.)
4953 END
4954     fail "wrong number of different changes files (@changesfiles)"
4955         unless @changesfiles==2;
4956     my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4957     foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4958         fail "$l found in binaries changes file $binchanges"
4959             if $l =~ m/\.dsc$/;
4960     }
4961     runcmd_ordryrun_local @mergechanges, @changesfiles;
4962     my $multichanges = changespat $version,'multi';
4963     if (act_local()) {
4964         stat_exists $multichanges or fail "$multichanges: $!";
4965         foreach my $cf (glob $pat) {
4966             next if $cf eq $multichanges;
4967             rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4968         }
4969     }
4970     changedir $wasdir;
4971     maybe_unapply_patches_again();
4972     printdone "build successful, results in $multichanges\n" or die $!;
4973 }
4974
4975 sub cmd_quilt_fixup {
4976     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4977     my $clogp = parsechangelog();
4978     $version = getfield $clogp, 'Version';
4979     $package = getfield $clogp, 'Source';
4980     check_not_dirty();
4981     clean_tree();
4982     build_maybe_quilt_fixup();
4983 }
4984
4985 sub cmd_archive_api_query {
4986     badusage "need only 1 subpath argument" unless @ARGV==1;
4987     my ($subpath) = @ARGV;
4988     my @cmd = archive_api_query_cmd($subpath);
4989     debugcmd ">",@cmd;
4990     exec @cmd or fail "exec curl: $!\n";
4991 }
4992
4993 sub cmd_clone_dgit_repos_server {
4994     badusage "need destination argument" unless @ARGV==1;
4995     my ($destdir) = @ARGV;
4996     $package = '_dgit-repos-server';
4997     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4998     debugcmd ">",@cmd;
4999     exec @cmd or fail "exec git clone: $!\n";
5000 }
5001
5002 sub cmd_setup_mergechangelogs {
5003     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5004     setup_mergechangelogs(1);
5005 }
5006
5007 sub cmd_setup_useremail {
5008     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5009     setup_useremail(1);
5010 }
5011
5012 sub cmd_setup_new_tree {
5013     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5014     setup_new_tree();
5015 }
5016
5017 #---------- argument parsing and main program ----------
5018
5019 sub cmd_version {
5020     print "dgit version $our_version\n" or die $!;
5021     exit 0;
5022 }
5023
5024 our (%valopts_long, %valopts_short);
5025 our @rvalopts;
5026
5027 sub defvalopt ($$$$) {
5028     my ($long,$short,$val_re,$how) = @_;
5029     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5030     $valopts_long{$long} = $oi;
5031     $valopts_short{$short} = $oi;
5032     # $how subref should:
5033     #   do whatever assignemnt or thing it likes with $_[0]
5034     #   if the option should not be passed on to remote, @rvalopts=()
5035     # or $how can be a scalar ref, meaning simply assign the value
5036 }
5037
5038 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5039 defvalopt '--distro',        '-d', '.+',      \$idistro;
5040 defvalopt '',                '-k', '.+',      \$keyid;
5041 defvalopt '--existing-package','', '.*',      \$existing_package;
5042 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
5043 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
5044 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
5045
5046 defvalopt '', '-C', '.+', sub {
5047     ($changesfile) = (@_);
5048     if ($changesfile =~ s#^(.*)/##) {
5049         $buildproductsdir = $1;
5050     }
5051 };
5052
5053 defvalopt '--initiator-tempdir','','.*', sub {
5054     ($initiator_tempdir) = (@_);
5055     $initiator_tempdir =~ m#^/# or
5056         badusage "--initiator-tempdir must be used specify an".
5057         " absolute, not relative, directory."
5058 };
5059
5060 sub parseopts () {
5061     my $om;
5062
5063     if (defined $ENV{'DGIT_SSH'}) {
5064         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5065     } elsif (defined $ENV{'GIT_SSH'}) {
5066         @ssh = ($ENV{'GIT_SSH'});
5067     }
5068
5069     my $oi;
5070     my $val;
5071     my $valopt = sub {
5072         my ($what) = @_;
5073         @rvalopts = ($_);
5074         if (!defined $val) {
5075             badusage "$what needs a value" unless @ARGV;
5076             $val = shift @ARGV;
5077             push @rvalopts, $val;
5078         }
5079         badusage "bad value \`$val' for $what" unless
5080             $val =~ m/^$oi->{Re}$(?!\n)/s;
5081         my $how = $oi->{How};
5082         if (ref($how) eq 'SCALAR') {
5083             $$how = $val;
5084         } else {
5085             $how->($val);
5086         }
5087         push @ropts, @rvalopts;
5088     };
5089
5090     while (@ARGV) {
5091         last unless $ARGV[0] =~ m/^-/;
5092         $_ = shift @ARGV;
5093         last if m/^--?$/;
5094         if (m/^--/) {
5095             if (m/^--dry-run$/) {
5096                 push @ropts, $_;
5097                 $dryrun_level=2;
5098             } elsif (m/^--damp-run$/) {
5099                 push @ropts, $_;
5100                 $dryrun_level=1;
5101             } elsif (m/^--no-sign$/) {
5102                 push @ropts, $_;
5103                 $sign=0;
5104             } elsif (m/^--help$/) {
5105                 cmd_help();
5106             } elsif (m/^--version$/) {
5107                 cmd_version();
5108             } elsif (m/^--new$/) {
5109                 push @ropts, $_;
5110                 $new_package=1;
5111             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5112                      ($om = $opts_opt_map{$1}) &&
5113                      length $om->[0]) {
5114                 push @ropts, $_;
5115                 $om->[0] = $2;
5116             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5117                      !$opts_opt_cmdonly{$1} &&
5118                      ($om = $opts_opt_map{$1})) {
5119                 push @ropts, $_;
5120                 push @$om, $2;
5121             } elsif (m/^--ignore-dirty$/s) {
5122                 push @ropts, $_;
5123                 $ignoredirty = 1;
5124             } elsif (m/^--no-quilt-fixup$/s) {
5125                 push @ropts, $_;
5126                 $quilt_mode = 'nocheck';
5127             } elsif (m/^--no-rm-on-error$/s) {
5128                 push @ropts, $_;
5129                 $rmonerror = 0;
5130             } elsif (m/^--overwrite$/s) {
5131                 push @ropts, $_;
5132                 $overwrite_version = '';
5133             } elsif (m/^--overwrite=(.+)$/s) {
5134                 push @ropts, $_;
5135                 $overwrite_version = $1;
5136             } elsif (m/^--(no-)?rm-old-changes$/s) {
5137                 push @ropts, $_;
5138                 $rmchanges = !$1;
5139             } elsif (m/^--deliberately-($deliberately_re)$/s) {
5140                 push @ropts, $_;
5141                 push @deliberatelies, $&;
5142             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5143                 # undocumented, for testing
5144                 push @ropts, $_;
5145                 $tagformat_want = [ $1, 'command line', 1 ];
5146                 # 1 menas overrides distro configuration
5147             } elsif (m/^--always-split-source-build$/s) {
5148                 # undocumented, for testing
5149                 push @ropts, $_;
5150                 $need_split_build_invocation = 1;
5151             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5152                 $val = $2 ? $' : undef; #';
5153                 $valopt->($oi->{Long});
5154             } else {
5155                 badusage "unknown long option \`$_'";
5156             }
5157         } else {
5158             while (m/^-./s) {
5159                 if (s/^-n/-/) {
5160                     push @ropts, $&;
5161                     $dryrun_level=2;
5162                 } elsif (s/^-L/-/) {
5163                     push @ropts, $&;
5164                     $dryrun_level=1;
5165                 } elsif (s/^-h/-/) {
5166                     cmd_help();
5167                 } elsif (s/^-D/-/) {
5168                     push @ropts, $&;
5169                     $debuglevel++;
5170                     enabledebug();
5171                 } elsif (s/^-N/-/) {
5172                     push @ropts, $&;
5173                     $new_package=1;
5174                 } elsif (m/^-m/) {
5175                     push @ropts, $&;
5176                     push @changesopts, $_;
5177                     $_ = '';
5178                 } elsif (s/^-wn$//s) {
5179                     push @ropts, $&;
5180                     $cleanmode = 'none';
5181                 } elsif (s/^-wg$//s) {
5182                     push @ropts, $&;
5183                     $cleanmode = 'git';
5184                 } elsif (s/^-wgf$//s) {
5185                     push @ropts, $&;
5186                     $cleanmode = 'git-ff';
5187                 } elsif (s/^-wd$//s) {
5188                     push @ropts, $&;
5189                     $cleanmode = 'dpkg-source';
5190                 } elsif (s/^-wdd$//s) {
5191                     push @ropts, $&;
5192                     $cleanmode = 'dpkg-source-d';
5193                 } elsif (s/^-wc$//s) {
5194                     push @ropts, $&;
5195                     $cleanmode = 'check';
5196                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5197                     push @git, '-c', $&;
5198                     $gitcfgs{cmdline}{$1} = [ $2 ];
5199                 } elsif (s/^-c([^=]+)$//s) {
5200                     push @git, '-c', $&;
5201                     $gitcfgs{cmdline}{$1} = [ 'true' ];
5202                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5203                     $val = $'; #';
5204                     $val = undef unless length $val;
5205                     $valopt->($oi->{Short});
5206                     $_ = '';
5207                 } else {
5208                     badusage "unknown short option \`$_'";
5209                 }
5210             }
5211         }
5212     }
5213 }
5214
5215 sub check_env_sanity () {
5216     my $blocked = new POSIX::SigSet;
5217     sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5218
5219     eval {
5220         foreach my $name (qw(PIPE CHLD)) {
5221             my $signame = "SIG$name";
5222             my $signum = eval "POSIX::$signame" // die;
5223             ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5224                 die "$signame is set to something other than SIG_DFL\n";
5225             $blocked->ismember($signum) and
5226                 die "$signame is blocked\n";
5227         }
5228     };
5229     return unless $@;
5230     chomp $@;
5231     fail <<END;
5232 On entry to dgit, $@
5233 This is a bug produced by something in in your execution environment.
5234 Giving up.
5235 END
5236 }
5237
5238
5239 sub finalise_opts_opts () {
5240     foreach my $k (keys %opts_opt_map) {
5241         my $om = $opts_opt_map{$k};
5242
5243         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5244         if (defined $v) {
5245             badcfg "cannot set command for $k"
5246                 unless length $om->[0];
5247             $om->[0] = $v;
5248         }
5249
5250         foreach my $c (access_cfg_cfgs("opts-$k")) {
5251             my @vl =
5252                 map { $_ ? @$_ : () }
5253                 map { $gitcfgs{$_}{$c} }
5254                 reverse @gitcfgsources;
5255             printdebug "CL $c ", (join " ", map { shellquote } @vl),
5256                 "\n" if $debuglevel >= 4;
5257             next unless @vl;
5258             badcfg "cannot configure options for $k"
5259                 if $opts_opt_cmdonly{$k};
5260             my $insertpos = $opts_cfg_insertpos{$k};
5261             @$om = ( @$om[0..$insertpos-1],
5262                      @vl,
5263                      @$om[$insertpos..$#$om] );
5264         }
5265     }
5266 }
5267
5268 if ($ENV{$fakeeditorenv}) {
5269     git_slurp_config();
5270     quilt_fixup_editor();
5271 }
5272
5273 parseopts();
5274 check_env_sanity();
5275 git_slurp_config();
5276
5277 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5278 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5279     if $dryrun_level == 1;
5280 if (!@ARGV) {
5281     print STDERR $helpmsg or die $!;
5282     exit 8;
5283 }
5284 my $cmd = shift @ARGV;
5285 $cmd =~ y/-/_/;
5286
5287 my $pre_fn = ${*::}{"pre_$cmd"};
5288 $pre_fn->() if $pre_fn;
5289
5290 if (!defined $rmchanges) {
5291     local $access_forpush;
5292     $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5293 }
5294
5295 if (!defined $quilt_mode) {
5296     local $access_forpush;
5297     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5298         // access_cfg('quilt-mode', 'RETURN-UNDEF')
5299         // 'linear';
5300     $quilt_mode =~ m/^($quilt_modes_re)$/
5301         or badcfg "unknown quilt-mode \`$quilt_mode'";
5302     $quilt_mode = $1;
5303 }
5304
5305 $need_split_build_invocation ||= quiltmode_splitbrain();
5306
5307 if (!defined $cleanmode) {
5308     local $access_forpush;
5309     $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5310     $cleanmode //= 'dpkg-source';
5311
5312     badcfg "unknown clean-mode \`$cleanmode'" unless
5313         $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5314 }
5315
5316 my $fn = ${*::}{"cmd_$cmd"};
5317 $fn or badusage "unknown operation $cmd";
5318 $fn->();