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