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