dgit

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