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