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