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     check_not_dirty();
2152     changedir $ud;
2153     progress "checking that $dscfn corresponds to HEAD";
2154     runcmd qw(dpkg-source -x --),
2155         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2156     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2157     check_for_vendor_patches() if madformat($dsc->{format});
2158     changedir '../../../..';
2159     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2160     my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2161     debugcmd "+",@diffcmd;
2162     $!=0; $?=-1;
2163     my $r = system @diffcmd;
2164     if ($r) {
2165         if ($r==256) {
2166             fail "$dscfn specifies a different tree to your HEAD commit;".
2167                 " perhaps you forgot to build".
2168                 ($diffopt eq '--exit-code' ? "" :
2169                  " (run with -D to see full diff output)");
2170         } else {
2171             failedcmd @diffcmd;
2172         }
2173     }
2174     if (!$changesfile) {
2175         my $pat = changespat $cversion;
2176         my @cs = glob "$buildproductsdir/$pat";
2177         fail "failed to find unique changes file".
2178             " (looked for $pat in $buildproductsdir);".
2179             " perhaps you need to use dgit -C"
2180             unless @cs==1;
2181         ($changesfile) = @cs;
2182     } else {
2183         $changesfile = "$buildproductsdir/$changesfile";
2184     }
2185
2186     responder_send_file('changes',$changesfile);
2187     responder_send_command("param head $dgithead");
2188     responder_send_command("param csuite $csuite");
2189     responder_send_command("param tagformat $tagformat");
2190     if (quiltmode_splitbrain) {
2191         die unless ($protovsn//4) >= 4;
2192         responder_send_command("param maint-view $maintviewhead");
2193     }
2194
2195     if (deliberately_not_fast_forward) {
2196         git_for_each_ref(lrfetchrefs, sub {
2197             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2198             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2199             responder_send_command("previously $rrefname=$objid");
2200             $previously{$rrefname} = $objid;
2201         });
2202     }
2203
2204     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2205                                  ".git/dgit/tag");
2206     my @tagobjfns;
2207
2208     supplementary_message(<<'END');
2209 Push failed, while signing the tag.
2210 You can retry the push, after fixing the problem, if you like.
2211 END
2212     # If we manage to sign but fail to record it anywhere, it's fine.
2213     if ($we_are_responder) {
2214         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2215         responder_receive_files('signed-tag', @tagobjfns);
2216     } else {
2217         @tagobjfns = push_mktags($clogp,$dscpath,
2218                               $changesfile,$changesfile,
2219                               \@tagwants);
2220     }
2221     supplementary_message(<<'END');
2222 Push failed, *after* signing the tag.
2223 If you want to try again, you should use a new version number.
2224 END
2225
2226     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2227
2228     foreach my $tw (@tagwants) {
2229         my $tag = $tw->{Tag};
2230         my $tagobjfn = $tw->{TagObjFn};
2231         my $tag_obj_hash =
2232             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2233         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2234         runcmd_ordryrun_local
2235             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2236     }
2237
2238     supplementary_message(<<'END');
2239 Push failed, while updating the remote git repository - see messages above.
2240 If you want to try again, you should use a new version number.
2241 END
2242     if (!check_for_git()) {
2243         create_remote_git_repo();
2244     }
2245
2246     my @pushrefs = $forceflag."HEAD:".rrref();
2247     foreach my $tw (@tagwants) {
2248         my $view = $tw->{View};
2249         next unless $view eq 'dgit'
2250             or any { $_ eq $view } access_cfg_tagformats();
2251         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2252     }
2253
2254     runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2255     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2256
2257     supplementary_message(<<'END');
2258 Push failed, after updating the remote git repository.
2259 If you want to try again, you must use a new version number.
2260 END
2261     if ($we_are_responder) {
2262         my $dryrunsuffix = act_local() ? "" : ".tmp";
2263         responder_receive_files('signed-dsc-changes',
2264                                 "$dscpath$dryrunsuffix",
2265                                 "$changesfile$dryrunsuffix");
2266     } else {
2267         if (act_local()) {
2268             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2269         } else {
2270             progress "[new .dsc left in $dscpath.tmp]";
2271         }
2272         sign_changes $changesfile;
2273     }
2274
2275     supplementary_message(<<END);
2276 Push failed, while uploading package(s) to the archive server.
2277 You can retry the upload of exactly these same files with dput of:
2278   $changesfile
2279 If that .changes file is broken, you will need to use a new version
2280 number for your next attempt at the upload.
2281 END
2282     my $host = access_cfg('upload-host','RETURN-UNDEF');
2283     my @hostarg = defined($host) ? ($host,) : ();
2284     runcmd_ordryrun @dput, @hostarg, $changesfile;
2285     printdone "pushed and uploaded $cversion";
2286
2287     supplementary_message('');
2288     responder_send_command("complete");
2289 }
2290
2291 sub cmd_clone {
2292     parseopts();
2293     notpushing();
2294     my $dstdir;
2295     badusage "-p is not allowed with clone; specify as argument instead"
2296         if defined $package;
2297     if (@ARGV==1) {
2298         ($package) = @ARGV;
2299     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2300         ($package,$isuite) = @ARGV;
2301     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2302         ($package,$dstdir) = @ARGV;
2303     } elsif (@ARGV==3) {
2304         ($package,$isuite,$dstdir) = @ARGV;
2305     } else {
2306         badusage "incorrect arguments to dgit clone";
2307     }
2308     $dstdir ||= "$package";
2309
2310     if (stat_exists $dstdir) {
2311         fail "$dstdir already exists";
2312     }
2313
2314     my $cwd_remove;
2315     if ($rmonerror && !$dryrun_level) {
2316         $cwd_remove= getcwd();
2317         unshift @end, sub {
2318             return unless defined $cwd_remove;
2319             if (!chdir "$cwd_remove") {
2320                 return if $!==&ENOENT;
2321                 die "chdir $cwd_remove: $!";
2322             }
2323             if (stat $dstdir) {
2324                 rmtree($dstdir) or die "remove $dstdir: $!\n";
2325             } elsif (!grep { $! == $_ }
2326                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2327             } else {
2328                 print STDERR "check whether to remove $dstdir: $!\n";
2329             }
2330         };
2331     }
2332
2333     clone($dstdir);
2334     $cwd_remove = undef;
2335 }
2336
2337 sub branchsuite () {
2338     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2339     if ($branch =~ m#$lbranch_re#o) {
2340         return $1;
2341     } else {
2342         return undef;
2343     }
2344 }
2345
2346 sub fetchpullargs () {
2347     notpushing();
2348     if (!defined $package) {
2349         my $sourcep = parsecontrol('debian/control','debian/control');
2350         $package = getfield $sourcep, 'Source';
2351     }
2352     if (@ARGV==0) {
2353 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
2354         if (!$isuite) {
2355             my $clogp = parsechangelog();
2356             $isuite = getfield $clogp, 'Distribution';
2357         }
2358         canonicalise_suite();
2359         progress "fetching from suite $csuite";
2360     } elsif (@ARGV==1) {
2361         ($isuite) = @ARGV;
2362         canonicalise_suite();
2363     } else {
2364         badusage "incorrect arguments to dgit fetch or dgit pull";
2365     }
2366 }
2367
2368 sub cmd_fetch {
2369     parseopts();
2370     fetchpullargs();
2371     fetch();
2372 }
2373
2374 sub cmd_pull {
2375     parseopts();
2376     fetchpullargs();
2377     pull();
2378 }
2379
2380 sub cmd_push {
2381     parseopts();
2382     pushing();
2383     badusage "-p is not allowed with dgit push" if defined $package;
2384     check_not_dirty();
2385     my $clogp = parsechangelog();
2386     $package = getfield $clogp, 'Source';
2387     my $specsuite;
2388     if (@ARGV==0) {
2389     } elsif (@ARGV==1) {
2390         ($specsuite) = (@ARGV);
2391     } else {
2392         badusage "incorrect arguments to dgit push";
2393     }
2394     $isuite = getfield $clogp, 'Distribution';
2395     if ($new_package) {
2396         local ($package) = $existing_package; # this is a hack
2397         canonicalise_suite();
2398     } else {
2399         canonicalise_suite();
2400     }
2401     if (defined $specsuite &&
2402         $specsuite ne $isuite &&
2403         $specsuite ne $csuite) {
2404             fail "dgit push: changelog specifies $isuite ($csuite)".
2405                 " but command line specifies $specsuite";
2406     }
2407     supplementary_message(<<'END');
2408 Push failed, while checking state of the archive.
2409 You can retry the push, after fixing the problem, if you like.
2410 END
2411     if (check_for_git()) {
2412         git_fetch_us();
2413     }
2414     my $forceflag = '';
2415     if (fetch_from_archive()) {
2416         if (is_fast_fwd(lrref(), 'HEAD')) {
2417             # ok
2418         } elsif (deliberately_not_fast_forward) {
2419             $forceflag = '+';
2420         } else {
2421             fail "dgit push: HEAD is not a descendant".
2422                 " of the archive's version.\n".
2423                 "dgit: To overwrite its contents,".
2424                 " use git merge -s ours ".lrref().".\n".
2425                 "dgit: To rewind history, if permitted by the archive,".
2426                 " use --deliberately-not-fast-forward";
2427         }
2428     } else {
2429         $new_package or
2430             fail "package appears to be new in this suite;".
2431                 " if this is intentional, use --new";
2432     }
2433     dopush($forceflag);
2434 }
2435
2436 #---------- remote commands' implementation ----------
2437
2438 sub cmd_remote_push_build_host {
2439     my ($nrargs) = shift @ARGV;
2440     my (@rargs) = @ARGV[0..$nrargs-1];
2441     @ARGV = @ARGV[$nrargs..$#ARGV];
2442     die unless @rargs;
2443     my ($dir,$vsnwant) = @rargs;
2444     # vsnwant is a comma-separated list; we report which we have
2445     # chosen in our ready response (so other end can tell if they
2446     # offered several)
2447     $debugprefix = ' ';
2448     $we_are_responder = 1;
2449     $us .= " (build host)";
2450
2451     pushing();
2452
2453     open PI, "<&STDIN" or die $!;
2454     open STDIN, "/dev/null" or die $!;
2455     open PO, ">&STDOUT" or die $!;
2456     autoflush PO 1;
2457     open STDOUT, ">&STDERR" or die $!;
2458     autoflush STDOUT 1;
2459
2460     $vsnwant //= 1;
2461     ($protovsn) = grep {
2462         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2463     } @rpushprotovsn_support;
2464
2465     fail "build host has dgit rpush protocol versions ".
2466         (join ",", @rpushprotovsn_support).
2467         " but invocation host has $vsnwant"
2468         unless defined $protovsn;
2469
2470     responder_send_command("dgit-remote-push-ready $protovsn");
2471     rpush_handle_protovsn_bothends();
2472     changedir $dir;
2473     &cmd_push;
2474 }
2475
2476 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2477 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2478 #     a good error message)
2479
2480 sub rpush_handle_protovsn_bothends () {
2481     if ($protovsn < 4) {
2482         need_tagformat 'old', "rpush negotiated protocol $protovsn";
2483     }
2484     select_tagformat();
2485 }
2486
2487 our $i_tmp;
2488
2489 sub i_cleanup {
2490     local ($@, $?);
2491     my $report = i_child_report();
2492     if (defined $report) {
2493         printdebug "($report)\n";
2494     } elsif ($i_child_pid) {
2495         printdebug "(killing build host child $i_child_pid)\n";
2496         kill 15, $i_child_pid;
2497     }
2498     if (defined $i_tmp && !defined $initiator_tempdir) {
2499         changedir "/";
2500         eval { rmtree $i_tmp; };
2501     }
2502 }
2503
2504 END { i_cleanup(); }
2505
2506 sub i_method {
2507     my ($base,$selector,@args) = @_;
2508     $selector =~ s/\-/_/g;
2509     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2510 }
2511
2512 sub cmd_rpush {
2513     pushing();
2514     my $host = nextarg;
2515     my $dir;
2516     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2517         $host = $1;
2518         $dir = $'; #';
2519     } else {
2520         $dir = nextarg;
2521     }
2522     $dir =~ s{^-}{./-};
2523     my @rargs = ($dir);
2524     push @rargs, join ",", @rpushprotovsn_support;
2525     my @rdgit;
2526     push @rdgit, @dgit;
2527     push @rdgit, @ropts;
2528     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2529     push @rdgit, @ARGV;
2530     my @cmd = (@ssh, $host, shellquote @rdgit);
2531     debugcmd "+",@cmd;
2532
2533     if (defined $initiator_tempdir) {
2534         rmtree $initiator_tempdir;
2535         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2536         $i_tmp = $initiator_tempdir;
2537     } else {
2538         $i_tmp = tempdir();
2539     }
2540     $i_child_pid = open2(\*RO, \*RI, @cmd);
2541     changedir $i_tmp;
2542     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2543     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2544     $supplementary_message = '' unless $protovsn >= 3;
2545
2546     fail "rpush negotiated protocol version $protovsn".
2547         " which does not support quilt mode $quilt_mode"
2548         if quiltmode_splitbrain;
2549
2550     rpush_handle_protovsn_bothends();
2551     for (;;) {
2552         my ($icmd,$iargs) = initiator_expect {
2553             m/^(\S+)(?: (.*))?$/;
2554             ($1,$2);
2555         };
2556         i_method "i_resp", $icmd, $iargs;
2557     }
2558 }
2559
2560 sub i_resp_progress ($) {
2561     my ($rhs) = @_;
2562     my $msg = protocol_read_bytes \*RO, $rhs;
2563     progress $msg;
2564 }
2565
2566 sub i_resp_supplementary_message ($) {
2567     my ($rhs) = @_;
2568     $supplementary_message = protocol_read_bytes \*RO, $rhs;
2569 }
2570
2571 sub i_resp_complete {
2572     my $pid = $i_child_pid;
2573     $i_child_pid = undef; # prevents killing some other process with same pid
2574     printdebug "waiting for build host child $pid...\n";
2575     my $got = waitpid $pid, 0;
2576     die $! unless $got == $pid;
2577     die "build host child failed $?" if $?;
2578
2579     i_cleanup();
2580     printdebug "all done\n";
2581     exit 0;
2582 }
2583
2584 sub i_resp_file ($) {
2585     my ($keyword) = @_;
2586     my $localname = i_method "i_localname", $keyword;
2587     my $localpath = "$i_tmp/$localname";
2588     stat_exists $localpath and
2589         badproto \*RO, "file $keyword ($localpath) twice";
2590     protocol_receive_file \*RO, $localpath;
2591     i_method "i_file", $keyword;
2592 }
2593
2594 our %i_param;
2595
2596 sub i_resp_param ($) {
2597     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2598     $i_param{$1} = $2;
2599 }
2600
2601 sub i_resp_previously ($) {
2602     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2603         or badproto \*RO, "bad previously spec";
2604     my $r = system qw(git check-ref-format), $1;
2605     die "bad previously ref spec ($r)" if $r;
2606     $previously{$1} = $2;
2607 }
2608
2609 our %i_wanted;
2610
2611 sub i_resp_want ($) {
2612     my ($keyword) = @_;
2613     die "$keyword ?" if $i_wanted{$keyword}++;
2614     my @localpaths = i_method "i_want", $keyword;
2615     printdebug "[[  $keyword @localpaths\n";
2616     foreach my $localpath (@localpaths) {
2617         protocol_send_file \*RI, $localpath;
2618     }
2619     print RI "files-end\n" or die $!;
2620 }
2621
2622 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
2623
2624 sub i_localname_parsed_changelog {
2625     return "remote-changelog.822";
2626 }
2627 sub i_file_parsed_changelog {
2628     ($i_clogp, $i_version, $i_dscfn) =
2629         push_parse_changelog "$i_tmp/remote-changelog.822";
2630     die if $i_dscfn =~ m#/|^\W#;
2631 }
2632
2633 sub i_localname_dsc {
2634     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2635     return $i_dscfn;
2636 }
2637 sub i_file_dsc { }
2638
2639 sub i_localname_changes {
2640     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2641     $i_changesfn = $i_dscfn;
2642     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2643     return $i_changesfn;
2644 }
2645 sub i_file_changes { }
2646
2647 sub i_want_signed_tag {
2648     printdebug Dumper(\%i_param, $i_dscfn);
2649     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2650         && defined $i_param{'csuite'}
2651         or badproto \*RO, "premature desire for signed-tag";
2652     my $head = $i_param{'head'};
2653     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2654
2655     my $maintview = $i_param{'maint-view'};
2656     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
2657
2658     select_tagformat();
2659     if ($protovsn >= 4) {
2660         my $p = $i_param{'tagformat'} // '<undef>';
2661         $p eq $tagformat
2662             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
2663     }
2664
2665     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2666     $csuite = $&;
2667     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2668
2669     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
2670
2671     return
2672         push_mktags $i_clogp, $i_dscfn,
2673             $i_changesfn, 'remote changes',
2674             \@tagwants;
2675 }
2676
2677 sub i_want_signed_dsc_changes {
2678     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2679     sign_changes $i_changesfn;
2680     return ($i_dscfn, $i_changesfn);
2681 }
2682
2683 #---------- building etc. ----------
2684
2685 our $version;
2686 our $sourcechanges;
2687 our $dscfn;
2688
2689 #----- `3.0 (quilt)' handling -----
2690
2691 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2692
2693 sub quiltify_dpkg_commit ($$$;$) {
2694     my ($patchname,$author,$msg, $xinfo) = @_;
2695     $xinfo //= '';
2696
2697     mkpath '.git/dgit';
2698     my $descfn = ".git/dgit/quilt-description.tmp";
2699     open O, '>', $descfn or die "$descfn: $!";
2700     $msg =~ s/\s+$//g;
2701     $msg =~ s/\n/\n /g;
2702     $msg =~ s/^\s+$/ ./mg;
2703     print O <<END or die $!;
2704 Description: $msg
2705 Author: $author
2706 $xinfo
2707 ---
2708
2709 END
2710     close O or die $!;
2711
2712     {
2713         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2714         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2715         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2716         runcmd @dpkgsource, qw(--commit .), $patchname;
2717     }
2718 }
2719
2720 sub quiltify_trees_differ ($$;$$) {
2721     my ($x,$y,$finegrained,$ignorenamesr) = @_;
2722     # returns true iff the two tree objects differ other than in debian/
2723     # with $finegrained,
2724     # returns bitmask 01 - differ in upstream files except .gitignore
2725     #                 02 - differ in .gitignore
2726     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
2727     #  is set for each modified .gitignore filename $fn
2728     local $/=undef;
2729     my @cmd = (@git, qw(diff-tree --name-only -z));
2730     push @cmd, qw(-r) if $finegrained;
2731     push @cmd, $x, $y;
2732     my $diffs= cmdoutput @cmd;
2733     my $r = 0;
2734     foreach my $f (split /\0/, $diffs) {
2735         next if $f =~ m#^debian(?:/.*)?$#s;
2736         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
2737         $r |= $isignore ? 02 : 01;
2738         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
2739     }
2740     printdebug "quiltify_trees_differ $x $y => $r\n";
2741     return $r;
2742 }
2743
2744 sub quiltify_tree_sentinelfiles ($) {
2745     # lists the `sentinel' files present in the tree
2746     my ($x) = @_;
2747     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2748         qw(-- debian/rules debian/control);
2749     $r =~ s/\n/,/g;
2750     return $r;
2751 }
2752
2753 sub quiltify_splitbrain_needed () {
2754     if (!$split_brain) {
2755         progress "dgit view: changes are required...";
2756         runcmd @git, qw(checkout -q -b dgit-view);
2757         $split_brain = 1;
2758     }
2759 }
2760
2761 sub quiltify_splitbrain ($$$$$$) {
2762     my ($clogp, $unapplied, $headref, $diffbits,
2763         $editedignores, $cachekey) = @_;
2764     if ($quilt_mode !~ m/gbp|dpm/) {
2765         # treat .gitignore just like any other upstream file
2766         $diffbits = { %$diffbits };
2767         $_ = !!$_ foreach values %$diffbits;
2768     }
2769     # We would like any commits we generate to be reproducible
2770     my @authline = clogp_authline($clogp);
2771     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2772     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2773     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2774
2775     if ($quilt_mode =~ m/gbp|unapplied/ &&
2776         ($diffbits->{H2O} & 01)) {
2777         my $msg =
2778  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
2779  " but git tree differs from orig in upstream files.";
2780         if (!stat_exists "debian/patches") {
2781             $msg .=
2782  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
2783         }
2784         fail $msg;
2785     }
2786     if ($quilt_mode =~ m/gbp|unapplied/ &&
2787         ($diffbits->{O2A} & 01)) { # some patches
2788         quiltify_splitbrain_needed();
2789         progress "dgit view: creating patches-applied version using gbp pq";
2790         runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
2791         # gbp pq import creates a fresh branch; push back to dgit-view
2792         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
2793         runcmd @git, qw(checkout -q dgit-view);
2794     }
2795     if (($diffbits->{H2O} & 02) && # user has modified .gitignore
2796         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
2797         quiltify_splitbrain_needed();
2798         progress "dgit view: creating patch to represent .gitignore changes";
2799         ensuredir "debian/patches";
2800         my $gipatch = "debian/patches/auto-gitignore";
2801         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
2802         stat GIPATCH or die "$gipatch: $!";
2803         fail "$gipatch already exists; but want to create it".
2804             " to record .gitignore changes" if (stat _)[7];
2805         print GIPATCH <<END or die "$gipatch: $!";
2806 Subject: Update .gitignore from Debian packaging branch
2807
2808 The Debian packaging git branch contains these updates to the upstream
2809 .gitignore file(s).  This patch is autogenerated, to provide these
2810 updates to users of the official Debian archive view of the package.
2811
2812 [dgit version $our_version]
2813 ---
2814 END
2815         close GIPATCH or die "$gipatch: $!";
2816         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
2817             $unapplied, $headref, "--", sort keys %$editedignores;
2818         open SERIES, "+>>", "debian/patches/series" or die $!;
2819         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
2820         my $newline;
2821         defined read SERIES, $newline, 1 or die $!;
2822         print SERIES "\n" or die $! unless $newline eq "\n";
2823         print SERIES "auto-gitignore\n" or die $!;
2824         close SERIES or die  $!;
2825         runcmd @git, qw(add -- debian/patches/series), $gipatch;
2826         commit_admin "Commit patch to update .gitignore";
2827     }
2828
2829     my $dgitview = git_rev_parse 'refs/heads/dgit-view';
2830
2831     changedir '../../../..';
2832     ensuredir ".git/logs/refs/dgit-intern";
2833     my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
2834       or die $!;
2835     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
2836         $dgitview;
2837
2838     progress "dgit view: created (commit id $dgitview)";
2839
2840     changedir '.git/dgit/unpack/work';
2841 }
2842
2843 sub quiltify ($$$$) {
2844     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
2845
2846     # Quilt patchification algorithm
2847     #
2848     # We search backwards through the history of the main tree's HEAD
2849     # (T) looking for a start commit S whose tree object is identical
2850     # to to the patch tip tree (ie the tree corresponding to the
2851     # current dpkg-committed patch series).  For these purposes
2852     # `identical' disregards anything in debian/ - this wrinkle is
2853     # necessary because dpkg-source treates debian/ specially.
2854     #
2855     # We can only traverse edges where at most one of the ancestors'
2856     # trees differs (in changes outside in debian/).  And we cannot
2857     # handle edges which change .pc/ or debian/patches.  To avoid
2858     # going down a rathole we avoid traversing edges which introduce
2859     # debian/rules or debian/control.  And we set a limit on the
2860     # number of edges we are willing to look at.
2861     #
2862     # If we succeed, we walk forwards again.  For each traversed edge
2863     # PC (with P parent, C child) (starting with P=S and ending with
2864     # C=T) to we do this:
2865     #  - git checkout C
2866     #  - dpkg-source --commit with a patch name and message derived from C
2867     # After traversing PT, we git commit the changes which
2868     # should be contained within debian/patches.
2869
2870     # The search for the path S..T is breadth-first.  We maintain a
2871     # todo list containing search nodes.  A search node identifies a
2872     # commit, and looks something like this:
2873     #  $p = {
2874     #      Commit => $git_commit_id,
2875     #      Child => $c,                          # or undef if P=T
2876     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
2877     #      Nontrivial => true iff $p..$c has relevant changes
2878     #  };
2879
2880     my @todo;
2881     my @nots;
2882     my $sref_S;
2883     my $max_work=100;
2884     my %considered; # saves being exponential on some weird graphs
2885
2886     my $t_sentinels = quiltify_tree_sentinelfiles $target;
2887
2888     my $not = sub {
2889         my ($search,$whynot) = @_;
2890         printdebug " search NOT $search->{Commit} $whynot\n";
2891         $search->{Whynot} = $whynot;
2892         push @nots, $search;
2893         no warnings qw(exiting);
2894         next;
2895     };
2896
2897     push @todo, {
2898         Commit => $target,
2899     };
2900
2901     while (@todo) {
2902         my $c = shift @todo;
2903         next if $considered{$c->{Commit}}++;
2904
2905         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2906
2907         printdebug "quiltify investigate $c->{Commit}\n";
2908
2909         # are we done?
2910         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2911             printdebug " search finished hooray!\n";
2912             $sref_S = $c;
2913             last;
2914         }
2915
2916         if ($quilt_mode eq 'nofix') {
2917             fail "quilt fixup required but quilt mode is \`nofix'\n".
2918                 "HEAD commit $c->{Commit} differs from tree implied by ".
2919                 " debian/patches (tree object $oldtiptree)";
2920         }
2921         if ($quilt_mode eq 'smash') {
2922             printdebug " search quitting smash\n";
2923             last;
2924         }
2925
2926         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2927         $not->($c, "has $c_sentinels not $t_sentinels")
2928             if $c_sentinels ne $t_sentinels;
2929
2930         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2931         $commitdata =~ m/\n\n/;
2932         $commitdata =~ $`;
2933         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2934         @parents = map { { Commit => $_, Child => $c } } @parents;
2935
2936         $not->($c, "root commit") if !@parents;
2937
2938         foreach my $p (@parents) {
2939             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2940         }
2941         my $ndiffers = grep { $_->{Nontrivial} } @parents;
2942         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2943
2944         foreach my $p (@parents) {
2945             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2946
2947             my @cmd= (@git, qw(diff-tree -r --name-only),
2948                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2949             my $patchstackchange = cmdoutput @cmd;
2950             if (length $patchstackchange) {
2951                 $patchstackchange =~ s/\n/,/g;
2952                 $not->($p, "changed $patchstackchange");
2953             }
2954
2955             printdebug " search queue P=$p->{Commit} ",
2956                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2957             push @todo, $p;
2958         }
2959     }
2960
2961     if (!$sref_S) {
2962         printdebug "quiltify want to smash\n";
2963
2964         my $abbrev = sub {
2965             my $x = $_[0]{Commit};
2966             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2967             return $x;
2968         };
2969         my $reportnot = sub {
2970             my ($notp) = @_;
2971             my $s = $abbrev->($notp);
2972             my $c = $notp->{Child};
2973             $s .= "..".$abbrev->($c) if $c;
2974             $s .= ": ".$notp->{Whynot};
2975             return $s;
2976         };
2977         if ($quilt_mode eq 'linear') {
2978             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
2979             foreach my $notp (@nots) {
2980                 print STDERR "$us:  ", $reportnot->($notp), "\n";
2981             }
2982             print STDERR "$us: $_\n" foreach @$failsuggestion;
2983             fail "quilt fixup naive history linearisation failed.\n".
2984  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2985         } elsif ($quilt_mode eq 'smash') {
2986         } elsif ($quilt_mode eq 'auto') {
2987             progress "quilt fixup cannot be linear, smashing...";
2988         } else {
2989             die "$quilt_mode ?";
2990         }
2991
2992         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
2993         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
2994         my $ncommits = 3;
2995         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2996
2997         quiltify_dpkg_commit "auto-$version-$target-$time",
2998             (getfield $clogp, 'Maintainer'),
2999             "Automatically generated patch ($clogp->{Version})\n".
3000             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3001         return;
3002     }
3003
3004     progress "quiltify linearisation planning successful, executing...";
3005
3006     for (my $p = $sref_S;
3007          my $c = $p->{Child};
3008          $p = $p->{Child}) {
3009         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3010         next unless $p->{Nontrivial};
3011
3012         my $cc = $c->{Commit};
3013
3014         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3015         $commitdata =~ m/\n\n/ or die "$c ?";
3016         $commitdata = $`;
3017         my $msg = $'; #';
3018         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3019         my $author = $1;
3020
3021         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3022
3023         my $title = $1;
3024         my $patchname = $title;
3025         $patchname =~ s/[.:]$//;
3026         $patchname =~ y/ A-Z/-a-z/;
3027         $patchname =~ y/-a-z0-9_.+=~//cd;
3028         $patchname =~ s/^\W/x-$&/;
3029         $patchname = substr($patchname,0,40);
3030         my $index;
3031         for ($index='';
3032              stat "debian/patches/$patchname$index";
3033              $index++) { }
3034         $!==ENOENT or die "$patchname$index $!";
3035
3036         runcmd @git, qw(checkout -q), $cc;
3037
3038         # We use the tip's changelog so that dpkg-source doesn't
3039         # produce complaining messages from dpkg-parsechangelog.  None
3040         # of the information dpkg-source gets from the changelog is
3041         # actually relevant - it gets put into the original message
3042         # which dpkg-source provides our stunt editor, and then
3043         # overwritten.
3044         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3045
3046         quiltify_dpkg_commit "$patchname$index", $author, $msg,
3047             "X-Dgit-Generated: $clogp->{Version} $cc\n";
3048
3049         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3050     }
3051
3052     runcmd @git, qw(checkout -q master);
3053 }
3054
3055 sub build_maybe_quilt_fixup () {
3056     my ($format,$fopts) = get_source_format;
3057     return unless madformat $format;
3058     # sigh
3059
3060     check_for_vendor_patches();
3061
3062     my $clogp = parsechangelog();
3063     my $headref = git_rev_parse('HEAD');
3064
3065     prep_ud();
3066     changedir $ud;
3067
3068     my $upstreamversion=$version;
3069     $upstreamversion =~ s/-[^-]*$//;
3070
3071     if ($fopts->{'single-debian-patch'}) {
3072         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3073     } else {
3074         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3075     }
3076
3077     die 'bug' if $split_brain && !$need_split_build_invocation;
3078
3079     changedir '../../../..';
3080     runcmd_ordryrun_local
3081         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3082 }
3083
3084 sub quilt_fixup_mkwork ($) {
3085     my ($headref) = @_;
3086
3087     mkdir "work" or die $!;
3088     changedir "work";
3089     mktree_in_ud_here();
3090     runcmd @git, qw(reset -q --hard), $headref;
3091 }
3092
3093 sub quilt_fixup_linkorigs ($$) {
3094     my ($upstreamversion, $fn) = @_;
3095     # calls $fn->($leafname);
3096
3097     foreach my $f (<../../../../*>) { #/){
3098         my $b=$f; $b =~ s{.*/}{};
3099         {
3100             local ($debuglevel) = $debuglevel-1;
3101             printdebug "QF linkorigs $b, $f ?\n";
3102         }
3103         next unless is_orig_file $b, srcfn $upstreamversion,'';
3104         printdebug "QF linkorigs $b, $f Y\n";
3105         link_ltarget $f, $b or die "$b $!";
3106         $fn->($b);
3107     }
3108 }
3109
3110 sub quilt_fixup_delete_pc () {
3111     runcmd @git, qw(rm -rqf .pc);
3112     commit_admin "Commit removal of .pc (quilt series tracking data)";
3113 }
3114
3115 sub quilt_fixup_singlepatch ($$$) {
3116     my ($clogp, $headref, $upstreamversion) = @_;
3117
3118     progress "starting quiltify (single-debian-patch)";
3119
3120     # dpkg-source --commit generates new patches even if
3121     # single-debian-patch is in debian/source/options.  In order to
3122     # get it to generate debian/patches/debian-changes, it is
3123     # necessary to build the source package.
3124
3125     quilt_fixup_linkorigs($upstreamversion, sub { });
3126     quilt_fixup_mkwork($headref);
3127
3128     rmtree("debian/patches");
3129
3130     runcmd @dpkgsource, qw(-b .);
3131     chdir "..";
3132     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3133     rename srcfn("$upstreamversion", "/debian/patches"),
3134            "work/debian/patches";
3135
3136     chdir "work";
3137     commit_quilty_patch();
3138 }
3139
3140 sub quilt_make_fake_dsc ($) {
3141     my ($upstreamversion) = @_;
3142
3143     my $fakeversion="$upstreamversion-~~DGITFAKE";
3144
3145     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3146     print $fakedsc <<END or die $!;
3147 Format: 3.0 (quilt)
3148 Source: $package
3149 Version: $fakeversion
3150 Files:
3151 END
3152
3153     my $dscaddfile=sub {
3154         my ($b) = @_;
3155
3156         my $md = new Digest::MD5;
3157
3158         my $fh = new IO::File $b, '<' or die "$b $!";
3159         stat $fh or die $!;
3160         my $size = -s _;
3161
3162         $md->addfile($fh);
3163         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3164     };
3165
3166     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3167
3168     my @files=qw(debian/source/format debian/rules
3169                  debian/control debian/changelog);
3170     foreach my $maybe (qw(debian/patches debian/source/options
3171                           debian/tests/control)) {
3172         next unless stat_exists "../../../$maybe";
3173         push @files, $maybe;
3174     }
3175
3176     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3177     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3178
3179     $dscaddfile->($debtar);
3180     close $fakedsc or die $!;
3181 }
3182
3183 sub quilt_check_splitbrain_cache ($$) {
3184     my ($headref, $upstreamversion) = @_;
3185     # Called only if we are in (potentially) split brain mode.
3186     # Called in $ud.
3187     # Computes the cache key and looks in the cache.
3188     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3189
3190     my $splitbrain_cachekey;
3191
3192     progress
3193  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3194     # we look in the reflog of dgit-intern/quilt-cache
3195     # we look for an entry whose message is the key for the cache lookup
3196     my @cachekey = (qw(dgit), $our_version);
3197     push @cachekey, $upstreamversion;
3198     push @cachekey, $quilt_mode;
3199     push @cachekey, $headref;
3200
3201     push @cachekey, hashfile('fake.dsc');
3202
3203     my $srcshash = Digest::SHA->new(256);
3204     my %sfs = ( %INC, '$0(dgit)' => $0 );
3205     foreach my $sfk (sort keys %sfs) {
3206         next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3207         $srcshash->add($sfk,"  ");
3208         $srcshash->add(hashfile($sfs{$sfk}));
3209         $srcshash->add("\n");
3210     }
3211     push @cachekey, $srcshash->hexdigest();
3212     $splitbrain_cachekey = "@cachekey";
3213
3214     my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3215                $splitbraincache);
3216     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3217     debugcmd "|(probably)",@cmd;
3218     my $child = open GC, "-|";  defined $child or die $!;
3219     if (!$child) {
3220         chdir '../../..' or die $!;
3221         if (!stat ".git/logs/refs/$splitbraincache") {
3222             $! == ENOENT or die $!;
3223             printdebug ">(no reflog)\n";
3224             exit 0;
3225         }
3226         exec @cmd; die $!;
3227     }
3228     while (<GC>) {
3229         chomp;
3230         printdebug ">| ", $_, "\n" if $debuglevel > 1;
3231         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3232
3233         my $cachehit = $1;
3234         quilt_fixup_mkwork($headref);
3235         if ($cachehit ne $headref) {
3236             progress "dgit view: found cached (commit id $cachehit)";
3237             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3238             $split_brain = 1;
3239             return ($cachehit, $splitbrain_cachekey);
3240         }
3241         progress "dgit view: found cached, no changes required";
3242         return ($headref, $splitbrain_cachekey);
3243     }
3244     die $! if GC->error;
3245     failedcmd unless close GC;
3246
3247     printdebug "splitbrain cache miss\n";
3248     return (undef, $splitbrain_cachekey);
3249 }
3250
3251 sub quilt_fixup_multipatch ($$$) {
3252     my ($clogp, $headref, $upstreamversion) = @_;
3253
3254     progress "examining quilt state (multiple patches, $quilt_mode mode)";
3255
3256     # Our objective is:
3257     #  - honour any existing .pc in case it has any strangeness
3258     #  - determine the git commit corresponding to the tip of
3259     #    the patch stack (if there is one)
3260     #  - if there is such a git commit, convert each subsequent
3261     #    git commit into a quilt patch with dpkg-source --commit
3262     #  - otherwise convert all the differences in the tree into
3263     #    a single git commit
3264     #
3265     # To do this we:
3266
3267     # Our git tree doesn't necessarily contain .pc.  (Some versions of
3268     # dgit would include the .pc in the git tree.)  If there isn't
3269     # one, we need to generate one by unpacking the patches that we
3270     # have.
3271     #
3272     # We first look for a .pc in the git tree.  If there is one, we
3273     # will use it.  (This is not the normal case.)
3274     #
3275     # Otherwise need to regenerate .pc so that dpkg-source --commit
3276     # can work.  We do this as follows:
3277     #     1. Collect all relevant .orig from parent directory
3278     #     2. Generate a debian.tar.gz out of
3279     #         debian/{patches,rules,source/format,source/options}
3280     #     3. Generate a fake .dsc containing just these fields:
3281     #          Format Source Version Files
3282     #     4. Extract the fake .dsc
3283     #        Now the fake .dsc has a .pc directory.
3284     # (In fact we do this in every case, because in future we will
3285     # want to search for a good base commit for generating patches.)
3286     #
3287     # Then we can actually do the dpkg-source --commit
3288     #     1. Make a new working tree with the same object
3289     #        store as our main tree and check out the main
3290     #        tree's HEAD.
3291     #     2. Copy .pc from the fake's extraction, if necessary
3292     #     3. Run dpkg-source --commit
3293     #     4. If the result has changes to debian/, then
3294     #          - git-add them them
3295     #          - git-add .pc if we had a .pc in-tree
3296     #          - git-commit
3297     #     5. If we had a .pc in-tree, delete it, and git-commit
3298     #     6. Back in the main tree, fast forward to the new HEAD
3299
3300     # Another situation we may have to cope with is gbp-style
3301     # patches-unapplied trees.
3302     #
3303     # We would want to detect these, so we know to escape into
3304     # quilt_fixup_gbp.  However, this is in general not possible.
3305     # Consider a package with a one patch which the dgit user reverts
3306     # (with git-revert or the moral equivalent).
3307     #
3308     # That is indistinguishable in contents from a patches-unapplied
3309     # tree.  And looking at the history to distinguish them is not
3310     # useful because the user might have made a confusing-looking git
3311     # history structure (which ought to produce an error if dgit can't
3312     # cope, not a silent reintroduction of an unwanted patch).
3313     #
3314     # So gbp users will have to pass an option.  But we can usually
3315     # detect their failure to do so: if the tree is not a clean
3316     # patches-applied tree, quilt linearisation fails, but the tree
3317     # _is_ a clean patches-unapplied tree, we can suggest that maybe
3318     # they want --quilt=unapplied.
3319     #
3320     # To help detect this, when we are extracting the fake dsc, we
3321     # first extract it with --skip-patches, and then apply the patches
3322     # afterwards with dpkg-source --before-build.  That lets us save a
3323     # tree object corresponding to .origs.
3324
3325     my $splitbrain_cachekey;
3326
3327     quilt_make_fake_dsc($upstreamversion);
3328
3329     if (quiltmode_splitbrain()) {
3330         my $cachehit;
3331         ($cachehit, $splitbrain_cachekey) =
3332             quilt_check_splitbrain_cache($headref, $upstreamversion);
3333         return if $cachehit;
3334     }
3335
3336     runcmd qw(sh -ec),
3337         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3338
3339     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3340     rename $fakexdir, "fake" or die "$fakexdir $!";
3341
3342     changedir 'fake';
3343
3344     remove_stray_gits();
3345     mktree_in_ud_here();
3346
3347     rmtree '.pc';
3348
3349     runcmd @git, qw(add -Af .);
3350     my $unapplied=git_write_tree();
3351     printdebug "fake orig tree object $unapplied\n";
3352
3353     ensuredir '.pc';
3354
3355     runcmd qw(sh -ec),
3356         'exec dpkg-source --before-build . >/dev/null';
3357
3358     changedir '..';
3359
3360     quilt_fixup_mkwork($headref);
3361
3362     my $mustdeletepc=0;
3363     if (stat_exists ".pc") {
3364         -d _ or die;
3365         progress "Tree already contains .pc - will use it then delete it.";
3366         $mustdeletepc=1;
3367     } else {
3368         rename '../fake/.pc','.pc' or die $!;
3369     }
3370
3371     changedir '../fake';
3372     rmtree '.pc';
3373     runcmd @git, qw(add -Af .);
3374     my $oldtiptree=git_write_tree();
3375     printdebug "fake o+d/p tree object $unapplied\n";
3376     changedir '../work';
3377
3378
3379     # We calculate some guesswork now about what kind of tree this might
3380     # be.  This is mostly for error reporting.
3381
3382     my %editedignores;
3383     my $diffbits = {
3384         # H = user's HEAD
3385         # O = orig, without patches applied
3386         # A = "applied", ie orig with H's debian/patches applied
3387         H2O => quiltify_trees_differ($headref,  $unapplied, 1,\%editedignores),
3388         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
3389         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3390     };
3391
3392     my @dl;
3393     foreach my $b (qw(01 02)) {
3394         foreach my $v (qw(H2O O2A H2A)) {
3395             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3396         }
3397     }
3398     printdebug "differences \@dl @dl.\n";
3399
3400     progress sprintf
3401 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
3402 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
3403                              $dl[0], $dl[1],              $dl[3], $dl[4],
3404                                  $dl[2],                     $dl[5];
3405
3406     my @failsuggestion;
3407     if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3408         push @failsuggestion, "This might be a patches-unapplied branch.";
3409     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3410         push @failsuggestion, "This might be a patches-applied branch.";
3411     }
3412     push @failsuggestion, "Maybe you need to specify one of".
3413         " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3414
3415     if (quiltmode_splitbrain()) {
3416         quiltify_splitbrain($clogp, $unapplied, $headref,
3417                             $diffbits, \%editedignores,
3418                             $splitbrain_cachekey);
3419         return;
3420     }
3421
3422     progress "starting quiltify (multiple patches, $quilt_mode mode)";
3423     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3424
3425     if (!open P, '>>', ".pc/applied-patches") {
3426         $!==&ENOENT or die $!;
3427     } else {
3428         close P;
3429     }
3430
3431     commit_quilty_patch();
3432
3433     if ($mustdeletepc) {
3434         quilt_fixup_delete_pc();
3435     }
3436 }
3437
3438 sub quilt_fixup_editor () {
3439     my $descfn = $ENV{$fakeeditorenv};
3440     my $editing = $ARGV[$#ARGV];
3441     open I1, '<', $descfn or die "$descfn: $!";
3442     open I2, '<', $editing or die "$editing: $!";
3443     unlink $editing or die "$editing: $!";
3444     open O, '>', $editing or die "$editing: $!";
3445     while (<I1>) { print O or die $!; } I1->error and die $!;
3446     my $copying = 0;
3447     while (<I2>) {
3448         $copying ||= m/^\-\-\- /;
3449         next unless $copying;
3450         print O or die $!;
3451     }
3452     I2->error and die $!;
3453     close O or die $1;
3454     exit 0;
3455 }
3456
3457 sub maybe_apply_patches_dirtily () {
3458     return unless $quilt_mode =~ m/gbp|unapplied/;
3459     print STDERR <<END or die $!;
3460
3461 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3462 dgit: Have to apply the patches - making the tree dirty.
3463 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3464
3465 END
3466     $patches_applied_dirtily = 01;
3467     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3468     runcmd qw(dpkg-source --before-build .);
3469 }
3470
3471 sub maybe_unapply_patches_again () {
3472     progress "dgit: Unapplying patches again to tidy up the tree."
3473         if $patches_applied_dirtily;
3474     runcmd qw(dpkg-source --after-build .)
3475         if $patches_applied_dirtily & 01;
3476     rmtree '.pc'
3477         if $patches_applied_dirtily & 02;
3478 }
3479
3480 #----- other building -----
3481
3482 our $clean_using_builder;
3483 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3484 #   clean the tree before building (perhaps invoked indirectly by
3485 #   whatever we are using to run the build), rather than separately
3486 #   and explicitly by us.
3487
3488 sub clean_tree () {
3489     return if $clean_using_builder;
3490     if ($cleanmode eq 'dpkg-source') {
3491         maybe_apply_patches_dirtily();
3492         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3493     } elsif ($cleanmode eq 'dpkg-source-d') {
3494         maybe_apply_patches_dirtily();
3495         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3496     } elsif ($cleanmode eq 'git') {
3497         runcmd_ordryrun_local @git, qw(clean -xdf);
3498     } elsif ($cleanmode eq 'git-ff') {
3499         runcmd_ordryrun_local @git, qw(clean -xdff);
3500     } elsif ($cleanmode eq 'check') {
3501         my $leftovers = cmdoutput @git, qw(clean -xdn);
3502         if (length $leftovers) {
3503             print STDERR $leftovers, "\n" or die $!;
3504             fail "tree contains uncommitted files and --clean=check specified";
3505         }
3506     } elsif ($cleanmode eq 'none') {
3507     } else {
3508         die "$cleanmode ?";
3509     }
3510 }
3511
3512 sub cmd_clean () {
3513     badusage "clean takes no additional arguments" if @ARGV;
3514     notpushing();
3515     clean_tree();
3516     maybe_unapply_patches_again();
3517 }
3518
3519 sub build_prep () {
3520     notpushing();
3521     badusage "-p is not allowed when building" if defined $package;
3522     check_not_dirty();
3523     clean_tree();
3524     my $clogp = parsechangelog();
3525     $isuite = getfield $clogp, 'Distribution';
3526     $package = getfield $clogp, 'Source';
3527     $version = getfield $clogp, 'Version';
3528     build_maybe_quilt_fixup();
3529     if ($rmchanges) {
3530         my $pat = changespat $version;
3531         foreach my $f (glob "$buildproductsdir/$pat") {
3532             if (act_local()) {
3533                 unlink $f or fail "remove old changes file $f: $!";
3534             } else {
3535                 progress "would remove $f";
3536             }
3537         }
3538     }
3539 }
3540
3541 sub changesopts_initial () {
3542     my @opts =@changesopts[1..$#changesopts];
3543 }
3544
3545 sub changesopts_version () {
3546     if (!defined $changes_since_version) {
3547         my @vsns = archive_query('archive_query');
3548         my @quirk = access_quirk();
3549         if ($quirk[0] eq 'backports') {
3550             local $isuite = $quirk[2];
3551             local $csuite;
3552             canonicalise_suite();
3553             push @vsns, archive_query('archive_query');
3554         }
3555         if (@vsns) {
3556             @vsns = map { $_->[0] } @vsns;
3557             @vsns = sort { -version_compare($a, $b) } @vsns;
3558             $changes_since_version = $vsns[0];
3559             progress "changelog will contain changes since $vsns[0]";
3560         } else {
3561             $changes_since_version = '_';
3562             progress "package seems new, not specifying -v<version>";
3563         }
3564     }
3565     if ($changes_since_version ne '_') {
3566         return ("-v$changes_since_version");
3567     } else {
3568         return ();
3569     }
3570 }
3571
3572 sub changesopts () {
3573     return (changesopts_initial(), changesopts_version());
3574 }
3575
3576 sub massage_dbp_args ($;$) {
3577     my ($cmd,$xargs) = @_;
3578     # We need to:
3579     #
3580     #  - if we're going to split the source build out so we can
3581     #    do strange things to it, massage the arguments to dpkg-buildpackage
3582     #    so that the main build doessn't build source (or add an argument
3583     #    to stop it building source by default).
3584     #
3585     #  - add -nc to stop dpkg-source cleaning the source tree,
3586     #    unless we're not doing a split build and want dpkg-source
3587     #    as cleanmode, in which case we can do nothing
3588     #
3589     # return values:
3590     #    0 - source will NOT need to be built separately by caller
3591     #   +1 - source will need to be built separately by caller
3592     #   +2 - source will need to be built separately by caller AND
3593     #        dpkg-buildpackage should not in fact be run at all!
3594     debugcmd '#massaging#', @$cmd if $debuglevel>1;
3595 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3596     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3597         $clean_using_builder = 1;
3598         return 0;
3599     }
3600     # -nc has the side effect of specifying -b if nothing else specified
3601     # and some combinations of -S, -b, et al, are errors, rather than
3602     # later simply overriding earlie.  So we need to:
3603     #  - search the command line for these options
3604     #  - pick the last one
3605     #  - perhaps add our own as a default
3606     #  - perhaps adjust it to the corresponding non-source-building version
3607     my $dmode = '-F';
3608     foreach my $l ($cmd, $xargs) {
3609         next unless $l;
3610         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3611     }
3612     push @$cmd, '-nc';
3613 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3614     my $r = 0;
3615     if ($need_split_build_invocation) {
3616         printdebug "massage split $dmode.\n";
3617         $r = $dmode =~ m/[S]/     ? +2 :
3618              $dmode =~ y/gGF/ABb/ ? +1 :
3619              $dmode =~ m/[ABb]/   ?  0 :
3620              die "$dmode ?";
3621     }
3622     printdebug "massage done $r $dmode.\n";
3623     push @$cmd, $dmode;
3624 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3625     return $r;
3626 }
3627
3628 sub cmd_build {
3629     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3630     my $wantsrc = massage_dbp_args \@dbp;
3631     if ($wantsrc > 0) {
3632         build_source();
3633     } else {
3634         build_prep();
3635     }
3636     if ($wantsrc < 2) {
3637         push @dbp, changesopts_version();
3638         maybe_apply_patches_dirtily();
3639         runcmd_ordryrun_local @dbp;
3640     }
3641     maybe_unapply_patches_again();
3642     printdone "build successful\n";
3643 }
3644
3645 sub cmd_gbp_build {
3646     my @dbp = @dpkgbuildpackage;
3647
3648     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
3649
3650     my @cmd;
3651     if (length executable_on_path('git-buildpackage')) {
3652         @cmd = qw(git-buildpackage);
3653     } else {
3654         @cmd = qw(gbp buildpackage);
3655     }
3656     push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3657
3658     if ($wantsrc > 0) {
3659         build_source();
3660     } else {
3661         if (!$clean_using_builder) {
3662             push @cmd, '--git-cleaner=true';
3663         }
3664         build_prep();
3665     }
3666     if ($wantsrc < 2) {
3667         unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3668             canonicalise_suite();
3669             push @cmd, "--git-debian-branch=".lbranch();
3670         }
3671         push @cmd, changesopts();
3672         maybe_apply_patches_dirtily();
3673         runcmd_ordryrun_local @cmd, @ARGV;
3674     }
3675     maybe_unapply_patches_again();
3676     printdone "build successful\n";
3677 }
3678 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3679
3680 sub build_source {
3681     my $our_cleanmode = $cleanmode;
3682     if ($need_split_build_invocation) {
3683         # Pretend that clean is being done some other way.  This
3684         # forces us not to try to use dpkg-buildpackage to clean and
3685         # build source all in one go; and instead we run dpkg-source
3686         # (and build_prep() will do the clean since $clean_using_builder
3687         # is false).
3688         $our_cleanmode = 'ELSEWHERE';
3689     }
3690     if ($our_cleanmode =~ m/^dpkg-source/) {
3691         # dpkg-source invocation (below) will clean, so build_prep shouldn't
3692         $clean_using_builder = 1;
3693     }
3694     build_prep();
3695     $sourcechanges = changespat $version,'source';
3696     if (act_local()) {
3697         unlink "../$sourcechanges" or $!==ENOENT
3698             or fail "remove $sourcechanges: $!";
3699     }
3700     $dscfn = dscfn($version);
3701     if ($our_cleanmode eq 'dpkg-source') {
3702         maybe_apply_patches_dirtily();
3703         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3704             changesopts();
3705     } elsif ($our_cleanmode eq 'dpkg-source-d') {
3706         maybe_apply_patches_dirtily();
3707         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3708             changesopts();
3709     } else {
3710         my @cmd = (@dpkgsource, qw(-b --));
3711         if ($split_brain) {
3712             changedir $ud;
3713             runcmd_ordryrun_local @cmd, "work";
3714             my @udfiles = <${package}_*>;
3715             changedir "../../..";
3716             foreach my $f (@udfiles) {
3717                 printdebug "source copy, found $f\n";
3718                 next unless
3719                     $f eq $dscfn or
3720                     ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
3721                      $f eq srcfn($version, $&));
3722                 printdebug "source copy, found $f - renaming\n";
3723                 rename "$ud/$f", "../$f" or $!==ENOENT
3724                     or fail "put in place new source file ($f): $!";
3725             }
3726         } else {
3727             my $pwd = must_getcwd();
3728             my $leafdir = basename $pwd;
3729             changedir "..";
3730             runcmd_ordryrun_local @cmd, $leafdir;
3731             changedir $pwd;
3732         }
3733         runcmd_ordryrun_local qw(sh -ec),
3734             'exec >$1; shift; exec "$@"','x',
3735             "../$sourcechanges",
3736             @dpkggenchanges, qw(-S), changesopts();
3737     }
3738 }
3739
3740 sub cmd_build_source {
3741     badusage "build-source takes no additional arguments" if @ARGV;
3742     build_source();
3743     maybe_unapply_patches_again();
3744     printdone "source built, results in $dscfn and $sourcechanges";
3745 }
3746
3747 sub cmd_sbuild {
3748     build_source();
3749     my $pat = changespat $version;
3750     if (!$rmchanges) {
3751         my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
3752         @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
3753         fail "changes files other than source matching $pat".
3754             " already present (@unwanted);".
3755             " building would result in ambiguity about the intended results"
3756             if @unwanted;
3757     }
3758     changedir "..";
3759     if (act_local()) {
3760         stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3761         stat_exists $sourcechanges
3762             or fail "$sourcechanges (in parent directory): $!";
3763     }
3764     runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3765     my @changesfiles = glob $pat;
3766     @changesfiles = sort {
3767         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3768             or $a cmp $b
3769     } @changesfiles;
3770     fail "wrong number of different changes files (@changesfiles)"
3771         unless @changesfiles==2;
3772     my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
3773     foreach my $l (split /\n/, getfield $binchanges, 'Files') {
3774         fail "$l found in binaries changes file $binchanges"
3775             if $l =~ m/\.dsc$/;
3776     }
3777     runcmd_ordryrun_local @mergechanges, @changesfiles;
3778     my $multichanges = changespat $version,'multi';
3779     if (act_local()) {
3780         stat_exists $multichanges or fail "$multichanges: $!";
3781         foreach my $cf (glob $pat) {
3782             next if $cf eq $multichanges;
3783             rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
3784         }
3785     }
3786     maybe_unapply_patches_again();
3787     printdone "build successful, results in $multichanges\n" or die $!;
3788 }
3789
3790 sub cmd_quilt_fixup {
3791     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3792     my $clogp = parsechangelog();
3793     $version = getfield $clogp, 'Version';
3794     $package = getfield $clogp, 'Source';
3795     check_not_dirty();
3796     clean_tree();
3797     build_maybe_quilt_fixup();
3798 }
3799
3800 sub cmd_archive_api_query {
3801     badusage "need only 1 subpath argument" unless @ARGV==1;
3802     my ($subpath) = @ARGV;
3803     my @cmd = archive_api_query_cmd($subpath);
3804     debugcmd ">",@cmd;
3805     exec @cmd or fail "exec curl: $!\n";
3806 }
3807
3808 sub cmd_clone_dgit_repos_server {
3809     badusage "need destination argument" unless @ARGV==1;
3810     my ($destdir) = @ARGV;
3811     $package = '_dgit-repos-server';
3812     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3813     debugcmd ">",@cmd;
3814     exec @cmd or fail "exec git clone: $!\n";
3815 }
3816
3817 sub cmd_setup_mergechangelogs {
3818     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3819     setup_mergechangelogs(1);
3820 }
3821
3822 sub cmd_setup_useremail {
3823     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3824     setup_useremail(1);
3825 }
3826
3827 sub cmd_setup_new_tree {
3828     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3829     setup_new_tree();
3830 }
3831
3832 #---------- argument parsing and main program ----------
3833
3834 sub cmd_version {
3835     print "dgit version $our_version\n" or die $!;
3836     exit 0;
3837 }
3838
3839 our (%valopts_long, %valopts_short);
3840 our @rvalopts;
3841
3842 sub defvalopt ($$$$) {
3843     my ($long,$short,$val_re,$how) = @_;
3844     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3845     $valopts_long{$long} = $oi;
3846     $valopts_short{$short} = $oi;
3847     # $how subref should:
3848     #   do whatever assignemnt or thing it likes with $_[0]
3849     #   if the option should not be passed on to remote, @rvalopts=()
3850     # or $how can be a scalar ref, meaning simply assign the value
3851 }
3852
3853 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3854 defvalopt '--distro',        '-d', '.+',      \$idistro;
3855 defvalopt '',                '-k', '.+',      \$keyid;
3856 defvalopt '--existing-package','', '.*',      \$existing_package;
3857 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
3858 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
3859 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
3860
3861 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3862
3863 defvalopt '', '-C', '.+', sub {
3864     ($changesfile) = (@_);
3865     if ($changesfile =~ s#^(.*)/##) {
3866         $buildproductsdir = $1;
3867     }
3868 };
3869
3870 defvalopt '--initiator-tempdir','','.*', sub {
3871     ($initiator_tempdir) = (@_);
3872     $initiator_tempdir =~ m#^/# or
3873         badusage "--initiator-tempdir must be used specify an".
3874         " absolute, not relative, directory."
3875 };
3876
3877 sub parseopts () {
3878     my $om;
3879
3880     if (defined $ENV{'DGIT_SSH'}) {
3881         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3882     } elsif (defined $ENV{'GIT_SSH'}) {
3883         @ssh = ($ENV{'GIT_SSH'});
3884     }
3885
3886     my $oi;
3887     my $val;
3888     my $valopt = sub {
3889         my ($what) = @_;
3890         @rvalopts = ($_);
3891         if (!defined $val) {
3892             badusage "$what needs a value" unless @ARGV;
3893             $val = shift @ARGV;
3894             push @rvalopts, $val;
3895         }
3896         badusage "bad value \`$val' for $what" unless
3897             $val =~ m/^$oi->{Re}$(?!\n)/s;
3898         my $how = $oi->{How};
3899         if (ref($how) eq 'SCALAR') {
3900             $$how = $val;
3901         } else {
3902             $how->($val);
3903         }
3904         push @ropts, @rvalopts;
3905     };
3906
3907     while (@ARGV) {
3908         last unless $ARGV[0] =~ m/^-/;
3909         $_ = shift @ARGV;
3910         last if m/^--?$/;
3911         if (m/^--/) {
3912             if (m/^--dry-run$/) {
3913                 push @ropts, $_;
3914                 $dryrun_level=2;
3915             } elsif (m/^--damp-run$/) {
3916                 push @ropts, $_;
3917                 $dryrun_level=1;
3918             } elsif (m/^--no-sign$/) {
3919                 push @ropts, $_;
3920                 $sign=0;
3921             } elsif (m/^--help$/) {
3922                 cmd_help();
3923             } elsif (m/^--version$/) {
3924                 cmd_version();
3925             } elsif (m/^--new$/) {
3926                 push @ropts, $_;
3927                 $new_package=1;
3928             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3929                      ($om = $opts_opt_map{$1}) &&
3930                      length $om->[0]) {
3931                 push @ropts, $_;
3932                 $om->[0] = $2;
3933             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3934                      !$opts_opt_cmdonly{$1} &&
3935                      ($om = $opts_opt_map{$1})) {
3936                 push @ropts, $_;
3937                 push @$om, $2;
3938             } elsif (m/^--ignore-dirty$/s) {
3939                 push @ropts, $_;
3940                 $ignoredirty = 1;
3941             } elsif (m/^--no-quilt-fixup$/s) {
3942                 push @ropts, $_;
3943                 $quilt_mode = 'nocheck';
3944             } elsif (m/^--no-rm-on-error$/s) {
3945                 push @ropts, $_;
3946                 $rmonerror = 0;
3947             } elsif (m/^--(no-)?rm-old-changes$/s) {
3948                 push @ropts, $_;
3949                 $rmchanges = !$1;
3950             } elsif (m/^--deliberately-($deliberately_re)$/s) {
3951                 push @ropts, $_;
3952                 push @deliberatelies, $&;
3953             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
3954                 # undocumented, for testing
3955                 push @ropts, $_;
3956                 $tagformat_want = [ $1, 'command line', 1 ];
3957                 # 1 menas overrides distro configuration
3958             } elsif (m/^--always-split-source-build$/s) {
3959                 # undocumented, for testing
3960                 push @ropts, $_;
3961                 $need_split_build_invocation = 1;
3962             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3963                 $val = $2 ? $' : undef; #';
3964                 $valopt->($oi->{Long});
3965             } else {
3966                 badusage "unknown long option \`$_'";
3967             }
3968         } else {
3969             while (m/^-./s) {
3970                 if (s/^-n/-/) {
3971                     push @ropts, $&;
3972                     $dryrun_level=2;
3973                 } elsif (s/^-L/-/) {
3974                     push @ropts, $&;
3975                     $dryrun_level=1;
3976                 } elsif (s/^-h/-/) {
3977                     cmd_help();
3978                 } elsif (s/^-D/-/) {
3979                     push @ropts, $&;
3980                     $debuglevel++;
3981                     enabledebug();
3982                 } elsif (s/^-N/-/) {
3983                     push @ropts, $&;
3984                     $new_package=1;
3985                 } elsif (m/^-m/) {
3986                     push @ropts, $&;
3987                     push @changesopts, $_;
3988                     $_ = '';
3989                 } elsif (s/^-wn$//s) {
3990                     push @ropts, $&;
3991                     $cleanmode = 'none';
3992                 } elsif (s/^-wg$//s) {
3993                     push @ropts, $&;
3994                     $cleanmode = 'git';
3995                 } elsif (s/^-wgf$//s) {
3996                     push @ropts, $&;
3997                     $cleanmode = 'git-ff';
3998                 } elsif (s/^-wd$//s) {
3999                     push @ropts, $&;
4000                     $cleanmode = 'dpkg-source';
4001                 } elsif (s/^-wdd$//s) {
4002                     push @ropts, $&;
4003                     $cleanmode = 'dpkg-source-d';
4004                 } elsif (s/^-wc$//s) {
4005                     push @ropts, $&;
4006                     $cleanmode = 'check';
4007                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4008                     $val = $'; #';
4009                     $val = undef unless length $val;
4010                     $valopt->($oi->{Short});
4011                     $_ = '';
4012                 } else {
4013                     badusage "unknown short option \`$_'";
4014                 }
4015             }
4016         }
4017     }
4018 }
4019
4020 sub finalise_opts_opts () {
4021     foreach my $k (keys %opts_opt_map) {
4022         my $om = $opts_opt_map{$k};
4023
4024         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4025         if (defined $v) {
4026             badcfg "cannot set command for $k"
4027                 unless length $om->[0];
4028             $om->[0] = $v;
4029         }
4030
4031         foreach my $c (access_cfg_cfgs("opts-$k")) {
4032             my $vl = $gitcfg{$c};
4033             printdebug "CL $c ",
4034                 ($vl ? join " ", map { shellquote } @$vl : ""),
4035                 "\n" if $debuglevel >= 4;
4036             next unless $vl;
4037             badcfg "cannot configure options for $k"
4038                 if $opts_opt_cmdonly{$k};
4039             my $insertpos = $opts_cfg_insertpos{$k};
4040             @$om = ( @$om[0..$insertpos-1],
4041                      @$vl,
4042                      @$om[$insertpos..$#$om] );
4043         }
4044     }
4045 }
4046
4047 if ($ENV{$fakeeditorenv}) {
4048     git_slurp_config();
4049     quilt_fixup_editor();
4050 }
4051
4052 parseopts();
4053 git_slurp_config();
4054
4055 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4056 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4057     if $dryrun_level == 1;
4058 if (!@ARGV) {
4059     print STDERR $helpmsg or die $!;
4060     exit 8;
4061 }
4062 my $cmd = shift @ARGV;
4063 $cmd =~ y/-/_/;
4064
4065 if (!defined $rmchanges) {
4066     local $access_forpush;
4067     $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4068 }
4069
4070 if (!defined $quilt_mode) {
4071     local $access_forpush;
4072     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4073         // access_cfg('quilt-mode', 'RETURN-UNDEF')
4074         // 'linear';
4075     $quilt_mode =~ m/^($quilt_modes_re)$/
4076         or badcfg "unknown quilt-mode \`$quilt_mode'";
4077     $quilt_mode = $1;
4078 }
4079
4080 $need_split_build_invocation ||= quiltmode_splitbrain();
4081
4082 if (!defined $cleanmode) {
4083     local $access_forpush;
4084     $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4085     $cleanmode //= 'dpkg-source';
4086
4087     badcfg "unknown clean-mode \`$cleanmode'" unless
4088         $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4089 }
4090
4091 my $fn = ${*::}{"cmd_$cmd"};
4092 $fn or badusage "unknown operation $cmd";
4093 $fn->();