dgit

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