dgit

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