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