dgit

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