dgit

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