dgit

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