dgit

   1 #!/usr/bin/perl -w
   2 # dgit
   3 # Integration between git and Debian-style archives
   4 #
   5 # Copyright (C)2013-2017 Ian Jackson
   6 # Copyright (C)2017 Sean Whitton
   7 #
   8 # This program is free software: you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation, either version 3 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
  22 use Debian::Dgit::ExitStatus;
  23
  24 use strict;
  25
  26 use Debian::Dgit qw(:DEFAULT :playground);
  27 setup_sigwarn();
  28
  29 use IO::Handle;
  30 use Data::Dumper;
  31 use LWP::UserAgent;
  32 use Dpkg::Control::Hash;
  33 use File::Path;
  34 use File::Temp qw(tempdir);
  35 use File::Basename;
  36 use Dpkg::Version;
  37 use Dpkg::Compression;
  38 use Dpkg::Compression::Process;
  39 use POSIX;
  40 use IPC::Open2;
  41 use Digest::SHA;
  42 use Digest::MD5;
  43 use List::MoreUtils qw(pairwise);
  44 use Text::Glob qw(match_glob);
  45 use Fcntl qw(:DEFAULT :flock);
  46 use Carp;
  47
  48 use Debian::Dgit;
  49
  50 our $our_version = 'UNRELEASED'; ###substituted###
  51 our $absurdity = undef; ###substituted###
  52
  53 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
  54 our $protovsn;
  55
  56 our $cmd;
  57 our $subcommand;
  58 our $isuite;
  59 our $idistro;
  60 our $package;
  61 our @ropts;
  62
  63 our $sign = 1;
  64 our $dryrun_level = 0;
  65 our $changesfile;
  66 our $buildproductsdir = '..';
  67 our $new_package = 0;
  68 our $ignoredirty = 0;
  69 our $rmonerror = 1;
  70 our @deliberatelies;
  71 our %previously;
  72 our $existing_package = 'dpkg';
  73 our $cleanmode;
  74 our $changes_since_version;
  75 our $rmchanges;
  76 our $overwrite_version; # undef: not specified; '': check changelog
  77 our $quilt_mode;
  78 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
  79 our $dodep14tag;
  80 our $split_brain_save;
  81 our $we_are_responder;
  82 our $we_are_initiator;
  83 our $initiator_tempdir;
  84 our $patches_applied_dirtily = 00;
  85 our $tagformat_want;
  86 our $tagformat;
  87 our $tagformatfn;
  88 our $chase_dsc_distro=1;
  89
  90 our %forceopts = map { $_=>0 }
  91     qw(unrepresentable unsupported-source-format
  92        dsc-changes-mismatch changes-origs-exactly
  93        import-gitapply-absurd
  94        import-gitapply-no-absurd
  95        import-dsc-with-dgit-field);
  96
  97 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
  98
  99 our $suite_re = '[-+.0-9a-z]+';
 100 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
 101 our $orig_f_comp_re = qr{orig(?:-$extra_orig_namepart_re)?};
 102 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
 103 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
 104
 105 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
 106 our $splitbraincache = 'dgit-intern/quilt-cache';
 107 our $rewritemap = 'dgit-rewrite/map';
 108
 109 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
 110
 111 our (@git) = qw(git);
 112 our (@dget) = qw(dget);
 113 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
 114 our (@dput) = qw(dput);
 115 our (@debsign) = qw(debsign);
 116 our (@gpg) = qw(gpg);
 117 our (@sbuild) = qw(sbuild);
 118 our (@ssh) = 'ssh';
 119 our (@dgit) = qw(dgit);
 120 our (@git_debrebase) = qw(git-debrebase);
 121 our (@aptget) = qw(apt-get);
 122 our (@aptcache) = qw(apt-cache);
 123 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
 124 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
 125 our (@dpkggenchanges) = qw(dpkg-genchanges);
 126 our (@mergechanges) = qw(mergechanges -f);
 127 our (@gbp_build) = ('');
 128 our (@gbp_pq) = ('gbp pq');
 129 our (@changesopts) = ('');
 130
 131 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
 132                      'curl' => \@curl,
 133                      'dput' => \@dput,
 134                      'debsign' => \@debsign,
 135                      'gpg' => \@gpg,
 136                      'sbuild' => \@sbuild,
 137                      'ssh' => \@ssh,
 138                      'dgit' => \@dgit,
 139                      'git' => \@git,
 140                      'git-debrebase' => \@git_debrebase,
 141                      'apt-get' => \@aptget,
 142                      'apt-cache' => \@aptcache,
 143                      'dpkg-source' => \@dpkgsource,
 144                      'dpkg-buildpackage' => \@dpkgbuildpackage,
 145                      'dpkg-genchanges' => \@dpkggenchanges,
 146                      'gbp-build' => \@gbp_build,
 147                      'gbp-pq' => \@gbp_pq,
 148                      'ch' => \@changesopts,
 149                      'mergechanges' => \@mergechanges);
 150
 151 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
 152 our %opts_cfg_insertpos = map {
 153     $_,
 154     scalar @{ $opts_opt_map{$_} }
 155 } keys %opts_opt_map;
 156
 157 sub parseopts_late_defaults();
 158 sub setup_gitattrs(;$);
 159 sub check_gitattrs($$);
 160
 161 our $playground;
 162 our $keyid;
 163
 164 autoflush STDOUT 1;
 165
 166 our $supplementary_message = '';
 167 our $need_split_build_invocation = 0;
 168 our $split_brain = 0;
 169
 170 END {
 171     local ($@, $?);
 172     return unless forkcheck_mainprocess();
 173     print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
 174 }
 175
 176 our $remotename = 'dgit';
 177 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
 178 our $csuite;
 179 our $instead_distro;
 180
 181 if (!defined $absurdity) {
 182     $absurdity = $0;
 183     $absurdity =~ s{/[^/]+$}{/absurd} or die;
 184 }
 185
 186 sub debiantag ($$) {
 187     my ($v,$distro) = @_;
 188     return $tagformatfn->($v, $distro);
 189 }
 190
 191 sub debiantag_maintview ($$) {
 192     my ($v,$distro) = @_;
 193     return "$distro/".dep14_version_mangle $v;
 194 }
 195
 196 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
 197
 198 sub lbranch () { return "$branchprefix/$csuite"; }
 199 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
 200 sub lref () { return "refs/heads/".lbranch(); }
 201 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
 202 sub rrref () { return server_ref($csuite); }
 203
 204 sub stripepoch ($) {
 205     my ($vsn) = @_;
 206     $vsn =~ s/^\d+\://;
 207     return $vsn;
 208 }
 209
 210 sub srcfn ($$) {
 211     my ($vsn,$sfx) = @_;
 212     return "${package}_".(stripepoch $vsn).$sfx
 213 }
 214
 215 sub dscfn ($) {
 216     my ($vsn) = @_;
 217     return srcfn($vsn,".dsc");
 218 }
 219
 220 sub changespat ($;$) {
 221     my ($vsn, $arch) = @_;
 222     return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
 223 }
 224
 225 sub upstreamversion ($) {
 226     my ($vsn) = @_;
 227     $vsn =~ s/-[^-]+$//;
 228     return $vsn;
 229 }
 230
 231 our $us = 'dgit';
 232 initdebug('');
 233
 234 our @end;
 235 END {
 236     local ($?);
 237     return unless forkcheck_mainprocess();
 238     foreach my $f (@end) {
 239         eval { $f->(); };
 240         print STDERR "$us: cleanup: $@" if length $@;
 241     }
 242 };
 243
 244 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; finish 12; }
 245
 246 sub forceable_fail ($$) {
 247     my ($forceoptsl, $msg) = @_;
 248     fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
 249     print STDERR "warning: overriding problem due to --force:\n". $msg;
 250 }
 251
 252 sub forceing ($) {
 253     my ($forceoptsl) = @_;
 254     my @got = grep { $forceopts{$_} } @$forceoptsl;
 255     return 0 unless @got;
 256     print STDERR
 257  "warning: skipping checks or functionality due to --force-$got[0]\n";
 258 }
 259
 260 sub no_such_package () {
 261     print STDERR "$us: package $package does not exist in suite $isuite\n";
 262     finish 4;
 263 }
 264
 265 sub deliberately ($) {
 266     my ($enquiry) = @_;
 267     return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
 268 }
 269
 270 sub deliberately_not_fast_forward () {
 271     foreach (qw(not-fast-forward fresh-repo)) {
 272         return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
 273     }
 274 }
 275
 276 sub quiltmode_splitbrain () {
 277     $quilt_mode =~ m/gbp|dpm|unapplied/;
 278 }
 279
 280 sub opts_opt_multi_cmd {
 281     my @cmd;
 282     push @cmd, split /\s+/, shift @_;
 283     push @cmd, @_;
 284     @cmd;
 285 }
 286
 287 sub gbp_pq {
 288     return opts_opt_multi_cmd @gbp_pq;
 289 }
 290
 291 sub dgit_privdir () {
 292     our $dgit_privdir_made //= ensure_a_playground 'dgit';
 293 }
 294
 295 #---------- remote protocol support, common ----------
 296
 297 # remote push initiator/responder protocol:
 298 #  $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
 299 #  where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
 300 #  < dgit-remote-push-ready <actual-proto-vsn>
 301 #
 302 # occasionally:
 303 #
 304 #  > progress NBYTES
 305 #  [NBYTES message]
 306 #
 307 #  > supplementary-message NBYTES          # $protovsn >= 3
 308 #  [NBYTES message]
 309 #
 310 # main sequence:
 311 #
 312 #  > file parsed-changelog
 313 #  [indicates that output of dpkg-parsechangelog follows]
 314 #  > data-block NBYTES
 315 #  > [NBYTES bytes of data (no newline)]
 316 #  [maybe some more blocks]
 317 #  > data-end
 318 #
 319 #  > file dsc
 320 #  [etc]
 321 #
 322 #  > file changes
 323 #  [etc]
 324 #
 325 #  > param head DGIT-VIEW-HEAD
 326 #  > param csuite SUITE
 327 #  > param tagformat old|new
 328 #  > param maint-view MAINT-VIEW-HEAD
 329 #
 330 #  > param buildinfo-filename P_V_X.buildinfo   # zero or more times
 331 #  > file buildinfo                             # for buildinfos to sign
 332 #
 333 #  > previously REFNAME=OBJNAME       # if --deliberately-not-fast-forward
 334 #                                     # goes into tag, for replay prevention
 335 #
 336 #  > want signed-tag
 337 #  [indicates that signed tag is wanted]
 338 #  < data-block NBYTES
 339 #  < [NBYTES bytes of data (no newline)]
 340 #  [maybe some more blocks]
 341 #  < data-end
 342 #  < files-end
 343 #
 344 #  > want signed-dsc-changes
 345 #  < data-block NBYTES    [transfer of signed dsc]
 346 #  [etc]
 347 #  < data-block NBYTES    [transfer of signed changes]
 348 #  [etc]
 349 #  < data-block NBYTES    [transfer of each signed buildinfo
 350 #  [etc]                   same number and order as "file buildinfo"]
 351 #  ...
 352 #  < files-end
 353 #
 354 #  > complete
 355
 356 our $i_child_pid;
 357
 358 sub i_child_report () {
 359     # Sees if our child has died, and reap it if so.  Returns a string
 360     # describing how it died if it failed, or undef otherwise.
 361     return undef unless $i_child_pid;
 362     my $got = waitpid $i_child_pid, WNOHANG;
 363     return undef if $got <= 0;
 364     die unless $got == $i_child_pid;
 365     $i_child_pid = undef;
 366     return undef unless $?;
 367     return "build host child ".waitstatusmsg();
 368 }
 369
 370 sub badproto ($$) {
 371     my ($fh, $m) = @_;
 372     fail "connection lost: $!" if $fh->error;
 373     fail "protocol violation; $m not expected";
 374 }
 375
 376 sub badproto_badread ($$) {
 377     my ($fh, $wh) = @_;
 378     fail "connection lost: $!" if $!;
 379     my $report = i_child_report();
 380     fail $report if defined $report;
 381     badproto $fh, "eof (reading $wh)";
 382 }
 383
 384 sub protocol_expect (&$) {
 385     my ($match, $fh) = @_;
 386     local $_;
 387     $_ = <$fh>;
 388     defined && chomp or badproto_badread $fh, "protocol message";
 389     if (wantarray) {
 390         my @r = &$match;
 391         return @r if @r;
 392     } else {
 393         my $r = &$match;
 394         return $r if $r;
 395     }
 396     badproto $fh, "\`$_'";
 397 }
 398
 399 sub protocol_send_file ($$) {
 400     my ($fh, $ourfn) = @_;
 401     open PF, "<", $ourfn or die "$ourfn: $!";
 402     for (;;) {
 403         my $d;
 404         my $got = read PF, $d, 65536;
 405         die "$ourfn: $!" unless defined $got;
 406         last if !$got;
 407         print $fh "data-block ".length($d)."\n" or die $!;
 408         print $fh $d or die $!;
 409     }
 410     PF->error and die "$ourfn $!";
 411     print $fh "data-end\n" or die $!;
 412     close PF;
 413 }
 414
 415 sub protocol_read_bytes ($$) {
 416     my ($fh, $nbytes) = @_;
 417     $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
 418     my $d;
 419     my $got = read $fh, $d, $nbytes;
 420     $got==$nbytes or badproto_badread $fh, "data block";
 421     return $d;
 422 }
 423
 424 sub protocol_receive_file ($$) {
 425     my ($fh, $ourfn) = @_;
 426     printdebug "() $ourfn\n";
 427     open PF, ">", $ourfn or die "$ourfn: $!";
 428     for (;;) {
 429         my ($y,$l) = protocol_expect {
 430             m/^data-block (.*)$/ ? (1,$1) :
 431             m/^data-end$/ ? (0,) :
 432             ();
 433         } $fh;
 434         last unless $y;
 435         my $d = protocol_read_bytes $fh, $l;
 436         print PF $d or die $!;
 437     }
 438     close PF or die $!;
 439 }
 440
 441 #---------- remote protocol support, responder ----------
 442
 443 sub responder_send_command ($) {
 444     my ($command) = @_;
 445     return unless $we_are_responder;
 446     # called even without $we_are_responder
 447     printdebug ">> $command\n";
 448     print PO $command, "\n" or die $!;
 449 }
 450
 451 sub responder_send_file ($$) {
 452     my ($keyword, $ourfn) = @_;
 453     return unless $we_are_responder;
 454     printdebug "]] $keyword $ourfn\n";
 455     responder_send_command "file $keyword";
 456     protocol_send_file \*PO, $ourfn;
 457 }
 458
 459 sub responder_receive_files ($@) {
 460     my ($keyword, @ourfns) = @_;
 461     die unless $we_are_responder;
 462     printdebug "[[ $keyword @ourfns\n";
 463     responder_send_command "want $keyword";
 464     foreach my $fn (@ourfns) {
 465         protocol_receive_file \*PI, $fn;
 466     }
 467     printdebug "[[\$\n";
 468     protocol_expect { m/^files-end$/ } \*PI;
 469 }
 470
 471 #---------- remote protocol support, initiator ----------
 472
 473 sub initiator_expect (&) {
 474     my ($match) = @_;
 475     protocol_expect { &$match } \*RO;
 476 }
 477
 478 #---------- end remote code ----------
 479
 480 sub progress {
 481     if ($we_are_responder) {
 482         my $m = join '', @_;
 483         responder_send_command "progress ".length($m) or die $!;
 484         print PO $m or die $!;
 485     } else {
 486         print @_, "\n";
 487     }
 488 }
 489
 490 our $ua;
 491
 492 sub url_get {
 493     if (!$ua) {
 494         $ua = LWP::UserAgent->new();
 495         $ua->env_proxy;
 496     }
 497     my $what = $_[$#_];
 498     progress "downloading $what...";
 499     my $r = $ua->get(@_) or die $!;
 500     return undef if $r->code == 404;
 501     $r->is_success or fail "failed to fetch $what: ".$r->status_line;
 502     return $r->decoded_content(charset => 'none');
 503 }
 504
 505 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
 506
 507 sub act_local () { return $dryrun_level <= 1; }
 508 sub act_scary () { return !$dryrun_level; }
 509
 510 sub printdone {
 511     if (!$dryrun_level) {
 512         progress "$us ok: @_";
 513     } else {
 514         progress "would be ok: @_ (but dry run only)";
 515     }
 516 }
 517
 518 sub dryrun_report {
 519     printcmd(\*STDERR,$debugprefix."#",@_);
 520 }
 521
 522 sub runcmd_ordryrun {
 523     if (act_scary()) {
 524         runcmd @_;
 525     } else {
 526         dryrun_report @_;
 527     }
 528 }
 529
 530 sub runcmd_ordryrun_local {
 531     if (act_local()) {
 532         runcmd @_;
 533     } else {
 534         dryrun_report @_;
 535     }
 536 }
 537
 538 sub shell_cmd {
 539     my ($first_shell, @cmd) = @_;
 540     return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
 541 }
 542
 543 our $helpmsg = <<END;
 544 main usages:
 545   dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
 546   dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
 547   dgit [dgit-opts] build [dpkg-buildpackage-opts]
 548   dgit [dgit-opts] sbuild [sbuild-opts]
 549   dgit [dgit-opts] push [dgit-opts] [suite]
 550   dgit [dgit-opts] push-source [dgit-opts] [suite]
 551   dgit [dgit-opts] rpush build-host:build-dir ...
 552 important dgit options:
 553   -k<keyid>           sign tag and package with <keyid> instead of default
 554   --dry-run -n        do not change anything, but go through the motions
 555   --damp-run -L       like --dry-run but make local changes, without signing
 556   --new -N            allow introducing a new package
 557   --debug -D          increase debug level
 558   -c<name>=<value>    set git config option (used directly by dgit too)
 559 END
 560
 561 our $later_warning_msg = <<END;
 562 Perhaps the upload is stuck in incoming.  Using the version from git.
 563 END
 564
 565 sub badusage {
 566     print STDERR "$us: @_\n", $helpmsg or die $!;
 567     finish 8;
 568 }
 569
 570 sub nextarg {
 571     @ARGV or badusage "too few arguments";
 572     return scalar shift @ARGV;
 573 }
 574
 575 sub pre_help () {
 576     not_necessarily_a_tree();
 577 }
 578 sub cmd_help () {
 579     print $helpmsg or die $!;
 580     finish 0;
 581 }
 582
 583 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
 584
 585 our %defcfg = ('dgit.default.distro' => 'debian',
 586                'dgit.default.default-suite' => 'unstable',
 587                'dgit.default.old-dsc-distro' => 'debian',
 588                'dgit-suite.*-security.distro' => 'debian-security',
 589                'dgit.default.username' => '',
 590                'dgit.default.archive-query-default-component' => 'main',
 591                'dgit.default.ssh' => 'ssh',
 592                'dgit.default.archive-query' => 'madison:',
 593                'dgit.default.sshpsql-dbname' => 'service=projectb',
 594                'dgit.default.aptget-components' => 'main',
 595                'dgit.default.dgit-tag-format' => 'new,old,maint',
 596                'dgit.dsc-url-proto-ok.http'    => 'true',
 597                'dgit.dsc-url-proto-ok.https'   => 'true',
 598                'dgit.dsc-url-proto-ok.git'     => 'true',
 599                'dgit.default.dsc-url-proto-ok' => 'false',
 600                # old means "repo server accepts pushes with old dgit tags"
 601                # new means "repo server accepts pushes with new dgit tags"
 602                # maint means "repo server accepts split brain pushes"
 603                # hist means "repo server may have old pushes without new tag"
 604                #   ("hist" is implied by "old")
 605                'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
 606                'dgit-distro.debian.git-check' => 'url',
 607                'dgit-distro.debian.git-check-suffix' => '/info/refs',
 608                'dgit-distro.debian.new-private-pushers' => 't',
 609                'dgit-distro.debian/push.git-url' => '',
 610                'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
 611                'dgit-distro.debian/push.git-user-force' => 'dgit',
 612                'dgit-distro.debian/push.git-proto' => 'git+ssh://',
 613                'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
 614                'dgit-distro.debian/push.git-create' => 'true',
 615                'dgit-distro.debian/push.git-check' => 'ssh-cmd',
 616  'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
 617 # 'dgit-distro.debian.archive-query-tls-key',
 618 #    '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
 619 # ^ this does not work because curl is broken nowadays
 620 # Fixing #790093 properly will involve providing providing the key
 621 # in some pacagke and maybe updating these paths.
 622 #
 623 # 'dgit-distro.debian.archive-query-tls-curl-args',
 624 #   '--ca-path=/etc/ssl/ca-debian',
 625 # ^ this is a workaround but works (only) on DSA-administered machines
 626                'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
 627                'dgit-distro.debian.git-url-suffix' => '',
 628                'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
 629                'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
 630  'dgit-distro.debian-security.archive-query' => 'aptget:',
 631  'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
 632  'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
 633  'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
 634  'dgit-distro.debian-security.nominal-distro' => 'debian',
 635  'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
 636  'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
 637                'dgit-distro.ubuntu.git-check' => 'false',
 638  'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
 639                'dgit-distro.test-dummy.ssh' => "$td/ssh",
 640                'dgit-distro.test-dummy.username' => "alice",
 641                'dgit-distro.test-dummy.git-check' => "ssh-cmd",
 642                'dgit-distro.test-dummy.git-create' => "ssh-cmd",
 643                'dgit-distro.test-dummy.git-url' => "$td/git",
 644                'dgit-distro.test-dummy.git-host' => "git",
 645                'dgit-distro.test-dummy.git-path' => "$td/git",
 646                'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
 647                'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
 648                'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
 649                'dgit-distro.test-dummy.upload-host' => 'test-dummy',
 650                );
 651
 652 our %gitcfgs;
 653 our @gitcfgsources = qw(cmdline local global system);
 654 our $invoked_in_git_tree = 1;
 655
 656 sub git_slurp_config () {
 657     # This algoritm is a bit subtle, but this is needed so that for
 658     # options which we want to be single-valued, we allow the
 659     # different config sources to override properly.  See #835858.
 660     foreach my $src (@gitcfgsources) {
 661         next if $src eq 'cmdline';
 662         # we do this ourselves since git doesn't handle it
 663
 664         $gitcfgs{$src} = git_slurp_config_src $src;
 665     }
 666 }
 667
 668 sub git_get_config ($) {
 669     my ($c) = @_;
 670     foreach my $src (@gitcfgsources) {
 671         my $l = $gitcfgs{$src}{$c};
 672         confess "internal error ($l $c)" if $l && !ref $l;
 673         printdebug"C $c ".(defined $l ?
 674                            join " ", map { messagequote "'$_'" } @$l :
 675                            "undef")."\n"
 676             if $debuglevel >= 4;
 677         $l or next;
 678         @$l==1 or badcfg "multiple values for $c".
 679             " (in $src git config)" if @$l > 1;
 680         return $l->[0];
 681     }
 682     return undef;
 683 }
 684
 685 sub cfg {
 686     foreach my $c (@_) {
 687         return undef if $c =~ /RETURN-UNDEF/;
 688         printdebug "C? $c\n" if $debuglevel >= 5;
 689         my $v = git_get_config($c);
 690         return $v if defined $v;
 691         my $dv = $defcfg{$c};
 692         if (defined $dv) {
 693             printdebug "CD $c $dv\n" if $debuglevel >= 4;
 694             return $dv;
 695         }
 696     }
 697     badcfg "need value for one of: @_\n".
 698         "$us: distro or suite appears not to be (properly) supported";
 699 }
 700
 701 sub not_necessarily_a_tree () {
 702     # needs to be called from pre_*
 703     @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
 704     $invoked_in_git_tree = 0;
 705 }
 706
 707 sub access_basedistro__noalias () {
 708     if (defined $idistro) {
 709         return $idistro;
 710     } else {
 711         my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
 712         return $def if defined $def;
 713         foreach my $src (@gitcfgsources, 'internal') {
 714             my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
 715             next unless $kl;
 716             foreach my $k (keys %$kl) {
 717                 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
 718                 my $dpat = $1;
 719                 next unless match_glob $dpat, $isuite;
 720                 return $kl->{$k};
 721             }
 722         }
 723         return cfg("dgit.default.distro");
 724     }
 725 }
 726
 727 sub access_basedistro () {
 728     my $noalias = access_basedistro__noalias();
 729     my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
 730     return $canon // $noalias;
 731 }
 732
 733 sub access_nomdistro () {
 734     my $base = access_basedistro();
 735     my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
 736     $r =~ m/^$distro_re$/ or badcfg
 737  "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
 738     return $r;
 739 }
 740
 741 sub access_quirk () {
 742     # returns (quirk name, distro to use instead or undef, quirk-specific info)
 743     my $basedistro = access_basedistro();
 744     my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
 745                               'RETURN-UNDEF');
 746     if (defined $backports_quirk) {
 747         my $re = $backports_quirk;
 748         $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
 749         $re =~ s/\*/.*/g;
 750         $re =~ s/\%/([-0-9a-z_]+)/
 751             or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
 752         if ($isuite =~ m/^$re$/) {
 753             return ('backports',"$basedistro-backports",$1);
 754         }
 755     }
 756     return ('none',undef);
 757 }
 758
 759 our $access_forpush;
 760
 761 sub parse_cfg_bool ($$$) {
 762     my ($what,$def,$v) = @_;
 763     $v //= $def;
 764     return
 765         $v =~ m/^[ty1]/ ? 1 :
 766         $v =~ m/^[fn0]/ ? 0 :
 767         badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
 768 }
 769
 770 sub access_forpush_config () {
 771     my $d = access_basedistro();
 772
 773     return 1 if
 774         $new_package &&
 775         parse_cfg_bool('new-private-pushers', 0,
 776                        cfg("dgit-distro.$d.new-private-pushers",
 777                            'RETURN-UNDEF'));
 778
 779     my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
 780     $v //= 'a';
 781     return
 782         $v =~ m/^[ty1]/ ? 0 : # force readonly,    forpush = 0
 783         $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
 784         $v =~ m/^[a]/  ? '' : # auto,              forpush = ''
 785         badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
 786 }
 787
 788 sub access_forpush () {
 789     $access_forpush //= access_forpush_config();
 790     return $access_forpush;
 791 }
 792
 793 sub pushing () {
 794     die "$access_forpush ?" if ($access_forpush // 1) ne 1;
 795     badcfg "pushing but distro is configured readonly"
 796         if access_forpush_config() eq '0';
 797     $access_forpush = 1;
 798     $supplementary_message = <<'END' unless $we_are_responder;
 799 Push failed, before we got started.
 800 You can retry the push, after fixing the problem, if you like.
 801 END
 802     parseopts_late_defaults();
 803 }
 804
 805 sub notpushing () {
 806     parseopts_late_defaults();
 807 }
 808
 809 sub supplementary_message ($) {
 810     my ($msg) = @_;
 811     if (!$we_are_responder) {
 812         $supplementary_message = $msg;
 813         return;
 814     } elsif ($protovsn >= 3) {
 815         responder_send_command "supplementary-message ".length($msg)
 816             or die $!;
 817         print PO $msg or die $!;
 818     }
 819 }
 820
 821 sub access_distros () {
 822     # Returns list of distros to try, in order
 823     #
 824     # We want to try:
 825     #    0. `instead of' distro name(s) we have been pointed to
 826     #    1. the access_quirk distro, if any
 827     #    2a. the user's specified distro, or failing that  } basedistro
 828     #    2b. the distro calculated from the suite          }
 829     my @l = access_basedistro();
 830
 831     my (undef,$quirkdistro) = access_quirk();
 832     unshift @l, $quirkdistro;
 833     unshift @l, $instead_distro;
 834     @l = grep { defined } @l;
 835
 836     push @l, access_nomdistro();
 837
 838     if (access_forpush()) {
 839         @l = map { ("$_/push", $_) } @l;
 840     }
 841     @l;
 842 }
 843
 844 sub access_cfg_cfgs (@) {
 845     my (@keys) = @_;
 846     my @cfgs;
 847     # The nesting of these loops determines the search order.  We put
 848     # the key loop on the outside so that we search all the distros
 849     # for each key, before going on to the next key.  That means that
 850     # if access_cfg is called with a more specific, and then a less
 851     # specific, key, an earlier distro can override the less specific
 852     # without necessarily overriding any more specific keys.  (If the
 853     # distro wants to override the more specific keys it can simply do
 854     # so; whereas if we did the loop the other way around, it would be
 855     # impossible to for an earlier distro to override a less specific
 856     # key but not the more specific ones without restating the unknown
 857     # values of the more specific keys.
 858     my @realkeys;
 859     my @rundef;
 860     # We have to deal with RETURN-UNDEF specially, so that we don't
 861     # terminate the search prematurely.
 862     foreach (@keys) {
 863         if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
 864         push @realkeys, $_
 865     }
 866     foreach my $d (access_distros()) {
 867         push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
 868     }
 869     push @cfgs, map { "dgit.default.$_" } @realkeys;
 870     push @cfgs, @rundef;
 871     return @cfgs;
 872 }
 873
 874 sub access_cfg (@) {
 875     my (@keys) = @_;
 876     my (@cfgs) = access_cfg_cfgs(@keys);
 877     my $value = cfg(@cfgs);
 878     return $value;
 879 }
 880
 881 sub access_cfg_bool ($$) {
 882     my ($def, @keys) = @_;
 883     parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
 884 }
 885
 886 sub string_to_ssh ($) {
 887     my ($spec) = @_;
 888     if ($spec =~ m/\s/) {
 889         return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
 890     } else {
 891         return ($spec);
 892     }
 893 }
 894
 895 sub access_cfg_ssh () {
 896     my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
 897     if (!defined $gitssh) {
 898         return @ssh;
 899     } else {
 900         return string_to_ssh $gitssh;
 901     }
 902 }
 903
 904 sub access_runeinfo ($) {
 905     my ($info) = @_;
 906     return ": dgit ".access_basedistro()." $info ;";
 907 }
 908
 909 sub access_someuserhost ($) {
 910     my ($some) = @_;
 911     my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
 912     defined($user) && length($user) or
 913         $user = access_cfg("$some-user",'username');
 914     my $host = access_cfg("$some-host");
 915     return length($user) ? "$user\@$host" : $host;
 916 }
 917
 918 sub access_gituserhost () {
 919     return access_someuserhost('git');
 920 }
 921
 922 sub access_giturl (;$) {
 923     my ($optional) = @_;
 924     my $url = access_cfg('git-url','RETURN-UNDEF');
 925     my $suffix;
 926     if (!length $url) {
 927         my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
 928         return undef unless defined $proto;
 929         $url =
 930             $proto.
 931             access_gituserhost().
 932             access_cfg('git-path');
 933     } else {
 934         $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
 935     }
 936     $suffix //= '.git';
 937     return "$url/$package$suffix";
 938 }
 939
 940 sub parsecontrolfh ($$;$) {
 941     my ($fh, $desc, $allowsigned) = @_;
 942     our $dpkgcontrolhash_noissigned;
 943     my $c;
 944     for (;;) {
 945         my %opts = ('name' => $desc);
 946         $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
 947         $c = Dpkg::Control::Hash->new(%opts);
 948         $c->parse($fh,$desc) or die "parsing of $desc failed";
 949         last if $allowsigned;
 950         last if $dpkgcontrolhash_noissigned;
 951         my $issigned= $c->get_option('is_pgp_signed');
 952         if (!defined $issigned) {
 953             $dpkgcontrolhash_noissigned= 1;
 954             seek $fh, 0,0 or die "seek $desc: $!";
 955         } elsif ($issigned) {
 956             fail "control file $desc is (already) PGP-signed. ".
 957                 " Note that dgit push needs to modify the .dsc and then".
 958                 " do the signature itself";
 959         } else {
 960             last;
 961         }
 962     }
 963     return $c;
 964 }
 965
 966 sub parsecontrol {
 967     my ($file, $desc, $allowsigned) = @_;
 968     my $fh = new IO::Handle;
 969     open $fh, '<', $file or die "$file: $!";
 970     my $c = parsecontrolfh($fh,$desc,$allowsigned);
 971     $fh->error and die $!;
 972     close $fh;
 973     return $c;
 974 }
 975
 976 sub getfield ($$) {
 977     my ($dctrl,$field) = @_;
 978     my $v = $dctrl->{$field};
 979     return $v if defined $v;
 980     fail "missing field $field in ".$dctrl->get_option('name');
 981 }
 982
 983 sub parsechangelog {
 984     my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
 985     my $p = new IO::Handle;
 986     my @cmd = (qw(dpkg-parsechangelog), @_);
 987     open $p, '-|', @cmd or die $!;
 988     $c->parse($p);
 989     $?=0; $!=0; close $p or failedcmd @cmd;
 990     return $c;
 991 }
 992
 993 sub commit_getclogp ($) {
 994     # Returns the parsed changelog hashref for a particular commit
 995     my ($objid) = @_;
 996     our %commit_getclogp_memo;
 997     my $memo = $commit_getclogp_memo{$objid};
 998     return $memo if $memo;
 999
1000     my $mclog = dgit_privdir()."clog";
1001     runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1002         "$objid:debian/changelog";
1003     $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1004 }
1005
1006 sub parse_dscdata () {
1007     my $dscfh = new IO::File \$dscdata, '<' or die $!;
1008     printdebug Dumper($dscdata) if $debuglevel>1;
1009     $dsc = parsecontrolfh($dscfh,$dscurl,1);
1010     printdebug Dumper($dsc) if $debuglevel>1;
1011 }
1012
1013 our %rmad;
1014
1015 sub archive_query ($;@) {
1016     my ($method) = shift @_;
1017     fail "this operation does not support multiple comma-separated suites"
1018         if $isuite =~ m/,/;
1019     my $query = access_cfg('archive-query','RETURN-UNDEF');
1020     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1021     my $proto = $1;
1022     my $data = $'; #';
1023     { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1024 }
1025
1026 sub archive_query_prepend_mirror {
1027     my $m = access_cfg('mirror');
1028     return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1029 }
1030
1031 sub pool_dsc_subpath ($$) {
1032     my ($vsn,$component) = @_; # $package is implict arg
1033     my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1034     return "/pool/$component/$prefix/$package/".dscfn($vsn);
1035 }
1036
1037 sub cfg_apply_map ($$$) {
1038     my ($varref, $what, $mapspec) = @_;
1039     return unless $mapspec;
1040
1041     printdebug "config $what EVAL{ $mapspec; }\n";
1042     $_ = $$varref;
1043     eval "package Dgit::Config; $mapspec;";
1044     die $@ if $@;
1045     $$varref = $_;
1046 }
1047
1048 #---------- `ftpmasterapi' archive query method (nascent) ----------
1049
1050 sub archive_api_query_cmd ($) {
1051     my ($subpath) = @_;
1052     my @cmd = (@curl, qw(-sS));
1053     my $url = access_cfg('archive-query-url');
1054     if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1055         my $host = $1;
1056         my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1057         foreach my $key (split /\:/, $keys) {
1058             $key =~ s/\%HOST\%/$host/g;
1059             if (!stat $key) {
1060                 fail "for $url: stat $key: $!" unless $!==ENOENT;
1061                 next;
1062             }
1063             fail "config requested specific TLS key but do not know".
1064                 " how to get curl to use exactly that EE key ($key)";
1065 #           push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1066 #           # Sadly the above line does not work because of changes
1067 #           # to gnutls.   The real fix for #790093 may involve
1068 #           # new curl options.
1069             last;
1070         }
1071         # Fixing #790093 properly will involve providing a value
1072         # for this on clients.
1073         my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1074         push @cmd, split / /, $kargs if defined $kargs;
1075     }
1076     push @cmd, $url.$subpath;
1077     return @cmd;
1078 }
1079
1080 sub api_query ($$;$) {
1081     use JSON;
1082     my ($data, $subpath, $ok404) = @_;
1083     badcfg "ftpmasterapi archive query method takes no data part"
1084         if length $data;
1085     my @cmd = archive_api_query_cmd($subpath);
1086     my $url = $cmd[$#cmd];
1087     push @cmd, qw(-w %{http_code});
1088     my $json = cmdoutput @cmd;
1089     unless ($json =~ s/\d+\d+\d$//) {
1090         failedcmd_report_cmd undef, @cmd;
1091         fail "curl failed to print 3-digit HTTP code";
1092     }
1093     my $code = $&;
1094     return undef if $code eq '404' && $ok404;
1095     fail "fetch of $url gave HTTP code $code"
1096         unless $url =~ m#^file://# or $code =~ m/^2/;
1097     return decode_json($json);
1098 }
1099
1100 sub canonicalise_suite_ftpmasterapi {
1101     my ($proto,$data) = @_;
1102     my $suites = api_query($data, 'suites');
1103     my @matched;
1104     foreach my $entry (@$suites) {
1105         next unless grep {
1106             my $v = $entry->{$_};
1107             defined $v && $v eq $isuite;
1108         } qw(codename name);
1109         push @matched, $entry;
1110     }
1111     fail "unknown suite $isuite" unless @matched;
1112     my $cn;
1113     eval {
1114         @matched==1 or die "multiple matches for suite $isuite\n";
1115         $cn = "$matched[0]{codename}";
1116         defined $cn or die "suite $isuite info has no codename\n";
1117         $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1118     };
1119     die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1120         if length $@;
1121     return $cn;
1122 }
1123
1124 sub archive_query_ftpmasterapi {
1125     my ($proto,$data) = @_;
1126     my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1127     my @rows;
1128     my $digester = Digest::SHA->new(256);
1129     foreach my $entry (@$info) {
1130         eval {
1131             my $vsn = "$entry->{version}";
1132             my ($ok,$msg) = version_check $vsn;
1133             die "bad version: $msg\n" unless $ok;
1134             my $component = "$entry->{component}";
1135             $component =~ m/^$component_re$/ or die "bad component";
1136             my $filename = "$entry->{filename}";
1137             $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1138                 or die "bad filename";
1139             my $sha256sum = "$entry->{sha256sum}";
1140             $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1141             push @rows, [ $vsn, "/pool/$component/$filename",
1142                           $digester, $sha256sum ];
1143         };
1144         die "bad ftpmaster api response: $@\n".Dumper($entry)
1145             if length $@;
1146     }
1147     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1148     return archive_query_prepend_mirror @rows;
1149 }
1150
1151 sub file_in_archive_ftpmasterapi {
1152     my ($proto,$data,$filename) = @_;
1153     my $pat = $filename;
1154     $pat =~ s/_/\\_/g;
1155     $pat = "%/$pat";
1156     $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1157     my $info = api_query($data, "file_in_archive/$pat", 1);
1158 }
1159
1160 #---------- `aptget' archive query method ----------
1161
1162 our $aptget_base;
1163 our $aptget_releasefile;
1164 our $aptget_configpath;
1165
1166 sub aptget_aptget   () { return @aptget,   qw(-c), $aptget_configpath; }
1167 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1168
1169 sub aptget_cache_clean {
1170     runcmd_ordryrun_local qw(sh -ec),
1171         'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1172         'x', $aptget_base;
1173 }
1174
1175 sub aptget_lock_acquire () {
1176     my $lockfile = "$aptget_base/lock";
1177     open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1178     flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1179 }
1180
1181 sub aptget_prep ($) {
1182     my ($data) = @_;
1183     return if defined $aptget_base;
1184
1185     badcfg "aptget archive query method takes no data part"
1186         if length $data;
1187
1188     my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1189
1190     ensuredir $cache;
1191     ensuredir "$cache/dgit";
1192     my $cachekey =
1193         access_cfg('aptget-cachekey','RETURN-UNDEF')
1194         // access_nomdistro();
1195
1196     $aptget_base = "$cache/dgit/aptget";
1197     ensuredir $aptget_base;
1198
1199     my $quoted_base = $aptget_base;
1200     die "$quoted_base contains bad chars, cannot continue"
1201         if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1202
1203     ensuredir $aptget_base;
1204
1205     aptget_lock_acquire();
1206
1207     aptget_cache_clean();
1208
1209     $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1210     my $sourceslist = "source.list#$cachekey";
1211
1212     my $aptsuites = $isuite;
1213     cfg_apply_map(\$aptsuites, 'suite map',
1214                   access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1215
1216     open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1217     printf SRCS "deb-src %s %s %s\n",
1218         access_cfg('mirror'),
1219         $aptsuites,
1220         access_cfg('aptget-components')
1221         or die $!;
1222
1223     ensuredir "$aptget_base/cache";
1224     ensuredir "$aptget_base/lists";
1225
1226     open CONF, ">", $aptget_configpath or die $!;
1227     print CONF <<END;
1228 Debug::NoLocking "true";
1229 APT::Get::List-Cleanup "false";
1230 #clear APT::Update::Post-Invoke-Success;
1231 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1232 Dir::State::Lists "$quoted_base/lists";
1233 Dir::Etc::preferences "$quoted_base/preferences";
1234 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1235 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1236 END
1237
1238     foreach my $key (qw(
1239                         Dir::Cache
1240                         Dir::State
1241                         Dir::Cache::Archives
1242                         Dir::Etc::SourceParts
1243                         Dir::Etc::preferencesparts
1244                       )) {
1245         ensuredir "$aptget_base/$key";
1246         print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1247     };
1248
1249     my $oldatime = (time // die $!) - 1;
1250     foreach my $oldlist (<$aptget_base/lists/*Release>) {
1251         next unless stat_exists $oldlist;
1252         my ($mtime) = (stat _)[9];
1253         utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1254     }
1255
1256     runcmd_ordryrun_local aptget_aptget(), qw(update);
1257
1258     my @releasefiles;
1259     foreach my $oldlist (<$aptget_base/lists/*Release>) {
1260         next unless stat_exists $oldlist;
1261         my ($atime) = (stat _)[8];
1262         next if $atime == $oldatime;
1263         push @releasefiles, $oldlist;
1264     }
1265     my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1266     @releasefiles = @inreleasefiles if @inreleasefiles;
1267     die "apt updated wrong number of Release files (@releasefiles), erk"
1268         unless @releasefiles == 1;
1269
1270     ($aptget_releasefile) = @releasefiles;
1271 }
1272
1273 sub canonicalise_suite_aptget {
1274     my ($proto,$data) = @_;
1275     aptget_prep($data);
1276
1277     my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1278
1279     foreach my $name (qw(Codename Suite)) {
1280         my $val = $release->{$name};
1281         if (defined $val) {
1282             printdebug "release file $name: $val\n";
1283             $val =~ m/^$suite_re$/o or fail
1284  "Release file ($aptget_releasefile) specifies intolerable $name";
1285             cfg_apply_map(\$val, 'suite rmap',
1286                           access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1287             return $val
1288         }
1289     }
1290     return $isuite;
1291 }
1292
1293 sub archive_query_aptget {
1294     my ($proto,$data) = @_;
1295     aptget_prep($data);
1296
1297     ensuredir "$aptget_base/source";
1298     foreach my $old (<$aptget_base/source/*.dsc>) {
1299         unlink $old or die "$old: $!";
1300     }
1301
1302     my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1303     return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1304     # avoids apt-get source failing with ambiguous error code
1305
1306     runcmd_ordryrun_local
1307         shell_cmd 'cd "$1"/source; shift', $aptget_base,
1308         aptget_aptget(), qw(--download-only --only-source source), $package;
1309
1310     my @dscs = <$aptget_base/source/*.dsc>;
1311     fail "apt-get source did not produce a .dsc" unless @dscs;
1312     fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1313
1314     my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1315
1316     use URI::Escape;
1317     my $uri = "file://". uri_escape $dscs[0];
1318     $uri =~ s{\%2f}{/}gi;
1319     return [ (getfield $pre_dsc, 'Version'), $uri ];
1320 }
1321
1322 sub file_in_archive_aptget () { return undef; }
1323
1324 #---------- `dummyapicat' archive query method ----------
1325
1326 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1327 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1328
1329 sub file_in_archive_dummycatapi ($$$) {
1330     my ($proto,$data,$filename) = @_;
1331     my $mirror = access_cfg('mirror');
1332     $mirror =~ s#^file://#/# or die "$mirror ?";
1333     my @out;
1334     my @cmd = (qw(sh -ec), '
1335             cd "$1"
1336             find -name "$2" -print0 |
1337             xargs -0r sha256sum
1338         ', qw(x), $mirror, $filename);
1339     debugcmd "-|", @cmd;
1340     open FIA, "-|", @cmd or die $!;
1341     while (<FIA>) {
1342         chomp or die;
1343         printdebug "| $_\n";
1344         m/^(\w+)  (\S+)$/ or die "$_ ?";
1345         push @out, { sha256sum => $1, filename => $2 };
1346     }
1347     close FIA or die failedcmd @cmd;
1348     return \@out;
1349 }
1350
1351 #---------- `madison' archive query method ----------
1352
1353 sub archive_query_madison {
1354     return archive_query_prepend_mirror
1355         map { [ @$_[0..1] ] } madison_get_parse(@_);
1356 }
1357
1358 sub madison_get_parse {
1359     my ($proto,$data) = @_;
1360     die unless $proto eq 'madison';
1361     if (!length $data) {
1362         $data= access_cfg('madison-distro','RETURN-UNDEF');
1363         $data //= access_basedistro();
1364     }
1365     $rmad{$proto,$data,$package} ||= cmdoutput
1366         qw(rmadison -asource),"-s$isuite","-u$data",$package;
1367     my $rmad = $rmad{$proto,$data,$package};
1368
1369     my @out;
1370     foreach my $l (split /\n/, $rmad) {
1371         $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1372                   \s*( [^ \t|]+ )\s* \|
1373                   \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1374                   \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1375         $1 eq $package or die "$rmad $package ?";
1376         my $vsn = $2;
1377         my $newsuite = $3;
1378         my $component;
1379         if (defined $4) {
1380             $component = $4;
1381         } else {
1382             $component = access_cfg('archive-query-default-component');
1383         }
1384         $5 eq 'source' or die "$rmad ?";
1385         push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1386     }
1387     return sort { -version_compare($a->[0],$b->[0]); } @out;
1388 }
1389
1390 sub canonicalise_suite_madison {
1391     # madison canonicalises for us
1392     my @r = madison_get_parse(@_);
1393     @r or fail
1394         "unable to canonicalise suite using package $package".
1395         " which does not appear to exist in suite $isuite;".
1396         " --existing-package may help";
1397     return $r[0][2];
1398 }
1399
1400 sub file_in_archive_madison { return undef; }
1401
1402 #---------- `sshpsql' archive query method ----------
1403
1404 sub sshpsql ($$$) {
1405     my ($data,$runeinfo,$sql) = @_;
1406     if (!length $data) {
1407         $data= access_someuserhost('sshpsql').':'.
1408             access_cfg('sshpsql-dbname');
1409     }
1410     $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1411     my ($userhost,$dbname) = ($`,$'); #';
1412     my @rows;
1413     my @cmd = (access_cfg_ssh, $userhost,
1414                access_runeinfo("ssh-psql $runeinfo").
1415                " export LC_MESSAGES=C; export LC_CTYPE=C;".
1416                " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1417     debugcmd "|",@cmd;
1418     open P, "-|", @cmd or die $!;
1419     while (<P>) {
1420         chomp or die;
1421         printdebug(">|$_|\n");
1422         push @rows, $_;
1423     }
1424     $!=0; $?=0; close P or failedcmd @cmd;
1425     @rows or die;
1426     my $nrows = pop @rows;
1427     $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1428     @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1429     @rows = map { [ split /\|/, $_ ] } @rows;
1430     my $ncols = scalar @{ shift @rows };
1431     die if grep { scalar @$_ != $ncols } @rows;
1432     return @rows;
1433 }
1434
1435 sub sql_injection_check {
1436     foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1437 }
1438
1439 sub archive_query_sshpsql ($$) {
1440     my ($proto,$data) = @_;
1441     sql_injection_check $isuite, $package;
1442     my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1443         SELECT source.version, component.name, files.filename, files.sha256sum
1444           FROM source
1445           JOIN src_associations ON source.id = src_associations.source
1446           JOIN suite ON suite.id = src_associations.suite
1447           JOIN dsc_files ON dsc_files.source = source.id
1448           JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1449           JOIN component ON component.id = files_archive_map.component_id
1450           JOIN files ON files.id = dsc_files.file
1451          WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1452            AND source.source='$package'
1453            AND files.filename LIKE '%.dsc';
1454 END
1455     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1456     my $digester = Digest::SHA->new(256);
1457     @rows = map {
1458         my ($vsn,$component,$filename,$sha256sum) = @$_;
1459         [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1460     } @rows;
1461     return archive_query_prepend_mirror @rows;
1462 }
1463
1464 sub canonicalise_suite_sshpsql ($$) {
1465     my ($proto,$data) = @_;
1466     sql_injection_check $isuite;
1467     my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1468         SELECT suite.codename
1469           FROM suite where suite_name='$isuite' or codename='$isuite';
1470 END
1471     @rows = map { $_->[0] } @rows;
1472     fail "unknown suite $isuite" unless @rows;
1473     die "ambiguous $isuite: @rows ?" if @rows>1;
1474     return $rows[0];
1475 }
1476
1477 sub file_in_archive_sshpsql ($$$) { return undef; }
1478
1479 #---------- `dummycat' archive query method ----------
1480
1481 sub canonicalise_suite_dummycat ($$) {
1482     my ($proto,$data) = @_;
1483     my $dpath = "$data/suite.$isuite";
1484     if (!open C, "<", $dpath) {
1485         $!==ENOENT or die "$dpath: $!";
1486         printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1487         return $isuite;
1488     }
1489     $!=0; $_ = <C>;
1490     chomp or die "$dpath: $!";
1491     close C;
1492     printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1493     return $_;
1494 }
1495
1496 sub archive_query_dummycat ($$) {
1497     my ($proto,$data) = @_;
1498     canonicalise_suite();
1499     my $dpath = "$data/package.$csuite.$package";
1500     if (!open C, "<", $dpath) {
1501         $!==ENOENT or die "$dpath: $!";
1502         printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1503         return ();
1504     }
1505     my @rows;
1506     while (<C>) {
1507         next if m/^\#/;
1508         next unless m/\S/;
1509         die unless chomp;
1510         printdebug "dummycat query $csuite $package $dpath | $_\n";
1511         my @row = split /\s+/, $_;
1512         @row==2 or die "$dpath: $_ ?";
1513         push @rows, \@row;
1514     }
1515     C->error and die "$dpath: $!";
1516     close C;
1517     return archive_query_prepend_mirror
1518         sort { -version_compare($a->[0],$b->[0]); } @rows;
1519 }
1520
1521 sub file_in_archive_dummycat () { return undef; }
1522
1523 #---------- tag format handling ----------
1524
1525 sub access_cfg_tagformats () {
1526     split /\,/, access_cfg('dgit-tag-format');
1527 }
1528
1529 sub access_cfg_tagformats_can_splitbrain () {
1530     my %y = map { $_ => 1 } access_cfg_tagformats;
1531     foreach my $needtf (qw(new maint)) {
1532         next if $y{$needtf};
1533         return 0;
1534     }
1535     return 1;
1536 }
1537
1538 sub need_tagformat ($$) {
1539     my ($fmt, $why) = @_;
1540     fail "need to use tag format $fmt ($why) but also need".
1541         " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1542         " - no way to proceed"
1543         if $tagformat_want && $tagformat_want->[0] ne $fmt;
1544     $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1545 }
1546
1547 sub select_tagformat () {
1548     # sets $tagformatfn
1549     return if $tagformatfn && !$tagformat_want;
1550     die 'bug' if $tagformatfn && $tagformat_want;
1551     # ... $tagformat_want assigned after previous select_tagformat
1552
1553     my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1554     printdebug "select_tagformat supported @supported\n";
1555
1556     $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1557     printdebug "select_tagformat specified @$tagformat_want\n";
1558
1559     my ($fmt,$why,$override) = @$tagformat_want;
1560
1561     fail "target distro supports tag formats @supported".
1562         " but have to use $fmt ($why)"
1563         unless $override
1564             or grep { $_ eq $fmt } @supported;
1565
1566     $tagformat_want = undef;
1567     $tagformat = $fmt;
1568     $tagformatfn = ${*::}{"debiantag_$fmt"};
1569
1570     fail "trying to use unknown tag format \`$fmt' ($why) !"
1571         unless $tagformatfn;
1572 }
1573
1574 #---------- archive query entrypoints and rest of program ----------
1575
1576 sub canonicalise_suite () {
1577     return if defined $csuite;
1578     fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1579     $csuite = archive_query('canonicalise_suite');
1580     if ($isuite ne $csuite) {
1581         progress "canonical suite name for $isuite is $csuite";
1582     } else {
1583         progress "canonical suite name is $csuite";
1584     }
1585 }
1586
1587 sub get_archive_dsc () {
1588     canonicalise_suite();
1589     my @vsns = archive_query('archive_query');
1590     foreach my $vinfo (@vsns) {
1591         my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1592         $dscurl = $vsn_dscurl;
1593         $dscdata = url_get($dscurl);
1594         if (!$dscdata) {
1595             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1596             next;
1597         }
1598         if ($digester) {
1599             $digester->reset();
1600             $digester->add($dscdata);
1601             my $got = $digester->hexdigest();
1602             $got eq $digest or
1603                 fail "$dscurl has hash $got but".
1604                     " archive told us to expect $digest";
1605         }
1606         parse_dscdata();
1607         my $fmt = getfield $dsc, 'Format';
1608         $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1609             "unsupported source format $fmt, sorry";
1610
1611         $dsc_checked = !!$digester;
1612         printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1613         return;
1614     }
1615     $dsc = undef;
1616     printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1617 }
1618
1619 sub check_for_git ();
1620 sub check_for_git () {
1621     # returns 0 or 1
1622     my $how = access_cfg('git-check');
1623     if ($how eq 'ssh-cmd') {
1624         my @cmd =
1625             (access_cfg_ssh, access_gituserhost(),
1626              access_runeinfo("git-check $package").
1627              " set -e; cd ".access_cfg('git-path').";".
1628              " if test -d $package.git; then echo 1; else echo 0; fi");
1629         my $r= cmdoutput @cmd;
1630         if (defined $r and $r =~ m/^divert (\w+)$/) {
1631             my $divert=$1;
1632             my ($usedistro,) = access_distros();
1633             # NB that if we are pushing, $usedistro will be $distro/push
1634             $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1635             $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1636             progress "diverting to $divert (using config for $instead_distro)";
1637             return check_for_git();
1638         }
1639         failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1640         return $r+0;
1641     } elsif ($how eq 'url') {
1642         my $prefix = access_cfg('git-check-url','git-url');
1643         my $suffix = access_cfg('git-check-suffix','git-suffix',
1644                                 'RETURN-UNDEF') // '.git';
1645         my $url = "$prefix/$package$suffix";
1646         my @cmd = (@curl, qw(-sS -I), $url);
1647         my $result = cmdoutput @cmd;
1648         $result =~ s/^\S+ 200 .*\n\r?\n//;
1649         # curl -sS -I with https_proxy prints
1650         # HTTP/1.0 200 Connection established
1651         $result =~ m/^\S+ (404|200) /s or
1652             fail "unexpected results from git check query - ".
1653                 Dumper($prefix, $result);
1654         my $code = $1;
1655         if ($code eq '404') {
1656             return 0;
1657         } elsif ($code eq '200') {
1658             return 1;
1659         } else {
1660             die;
1661         }
1662     } elsif ($how eq 'true') {
1663         return 1;
1664     } elsif ($how eq 'false') {
1665         return 0;
1666     } else {
1667         badcfg "unknown git-check \`$how'";
1668     }
1669 }
1670
1671 sub create_remote_git_repo () {
1672     my $how = access_cfg('git-create');
1673     if ($how eq 'ssh-cmd') {
1674         runcmd_ordryrun
1675             (access_cfg_ssh, access_gituserhost(),
1676              access_runeinfo("git-create $package").
1677              "set -e; cd ".access_cfg('git-path').";".
1678              " cp -a _template $package.git");
1679     } elsif ($how eq 'true') {
1680         # nothing to do
1681     } else {
1682         badcfg "unknown git-create \`$how'";
1683     }
1684 }
1685
1686 our ($dsc_hash,$lastpush_mergeinput);
1687 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1688
1689
1690 sub prep_ud () {
1691     dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1692     $playground = fresh_playground 'dgit/unpack';
1693 }
1694
1695 sub mktree_in_ud_here () {
1696     playtree_setup $gitcfgs{local};
1697 }
1698
1699 sub git_write_tree () {
1700     my $tree = cmdoutput @git, qw(write-tree);
1701     $tree =~ m/^\w+$/ or die "$tree ?";
1702     return $tree;
1703 }
1704
1705 sub git_add_write_tree () {
1706     runcmd @git, qw(add -Af .);
1707     return git_write_tree();
1708 }
1709
1710 sub remove_stray_gits ($) {
1711     my ($what) = @_;
1712     my @gitscmd = qw(find -name .git -prune -print0);
1713     debugcmd "|",@gitscmd;
1714     open GITS, "-|", @gitscmd or die $!;
1715     {
1716         local $/="\0";
1717         while (<GITS>) {
1718             chomp or die;
1719             print STDERR "$us: warning: removing from $what: ",
1720                 (messagequote $_), "\n";
1721             rmtree $_;
1722         }
1723     }
1724     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1725 }
1726
1727 sub mktree_in_ud_from_only_subdir ($;$) {
1728     my ($what,$raw) = @_;
1729     # changes into the subdir
1730
1731     my (@dirs) = <*/.>;
1732     die "expected one subdir but found @dirs ?" unless @dirs==1;
1733     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1734     my $dir = $1;
1735     changedir $dir;
1736
1737     remove_stray_gits($what);
1738     mktree_in_ud_here();
1739     if (!$raw) {
1740         my ($format, $fopts) = get_source_format();
1741         if (madformat($format)) {
1742             rmtree '.pc';
1743         }
1744     }
1745
1746     my $tree=git_add_write_tree();
1747     return ($tree,$dir);
1748 }
1749
1750 our @files_csum_info_fields =
1751     (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1752      ['Checksums-Sha1',  'Digest::SHA', 'new(1)',   'sha1sum'],
1753      ['Files',           'Digest::MD5', 'new()',    'md5sum']);
1754
1755 sub dsc_files_info () {
1756     foreach my $csumi (@files_csum_info_fields) {
1757         my ($fname, $module, $method) = @$csumi;
1758         my $field = $dsc->{$fname};
1759         next unless defined $field;
1760         eval "use $module; 1;" or die $@;
1761         my @out;
1762         foreach (split /\n/, $field) {
1763             next unless m/\S/;
1764             m/^(\w+) (\d+) (\S+)$/ or
1765                 fail "could not parse .dsc $fname line \`$_'";
1766             my $digester = eval "$module"."->$method;" or die $@;
1767             push @out, {
1768                 Hash => $1,
1769                 Bytes => $2,
1770                 Filename => $3,
1771                 Digester => $digester,
1772             };
1773         }
1774         return @out;
1775     }
1776     fail "missing any supported Checksums-* or Files field in ".
1777         $dsc->get_option('name');
1778 }
1779
1780 sub dsc_files () {
1781     map { $_->{Filename} } dsc_files_info();
1782 }
1783
1784 sub files_compare_inputs (@) {
1785     my $inputs = \@_;
1786     my %record;
1787     my %fchecked;
1788
1789     my $showinputs = sub {
1790         return join "; ", map { $_->get_option('name') } @$inputs;
1791     };
1792
1793     foreach my $in (@$inputs) {
1794         my $expected_files;
1795         my $in_name = $in->get_option('name');
1796
1797         printdebug "files_compare_inputs $in_name\n";
1798
1799         foreach my $csumi (@files_csum_info_fields) {
1800             my ($fname) = @$csumi;
1801             printdebug "files_compare_inputs $in_name $fname\n";
1802
1803             my $field = $in->{$fname};
1804             next unless defined $field;
1805
1806             my @files;
1807             foreach (split /\n/, $field) {
1808                 next unless m/\S/;
1809
1810                 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1811                     fail "could not parse $in_name $fname line \`$_'";
1812
1813                 printdebug "files_compare_inputs $in_name $fname $f\n";
1814
1815                 push @files, $f;
1816
1817                 my $re = \ $record{$f}{$fname};
1818                 if (defined $$re) {
1819                     $fchecked{$f}{$in_name} = 1;
1820                     $$re eq $info or
1821                         fail "hash or size of $f varies in $fname fields".
1822                         " (between: ".$showinputs->().")";
1823                 } else {
1824                     $$re = $info;
1825                 }
1826             }
1827             @files = sort @files;
1828             $expected_files //= \@files;
1829             "@$expected_files" eq "@files" or
1830                 fail "file list in $in_name varies between hash fields!";
1831         }
1832         $expected_files or
1833             fail "$in_name has no files list field(s)";
1834     }
1835     printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1836         if $debuglevel>=2;
1837
1838     grep { keys %$_ == @$inputs-1 } values %fchecked
1839         or fail "no file appears in all file lists".
1840         " (looked in: ".$showinputs->().")";
1841 }
1842
1843 sub is_orig_file_in_dsc ($$) {
1844     my ($f, $dsc_files_info) = @_;
1845     return 0 if @$dsc_files_info <= 1;
1846     # One file means no origs, and the filename doesn't have a "what
1847     # part of dsc" component.  (Consider versions ending `.orig'.)
1848     return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1849     return 1;
1850 }
1851
1852 sub is_orig_file_of_vsn ($$) {
1853     my ($f, $upstreamvsn) = @_;
1854     my $base = srcfn $upstreamvsn, '';
1855     return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1856     return 1;
1857 }
1858
1859 # This function determines whether a .changes file is source-only from
1860 # the point of view of dak.  Thus, it permits *_source.buildinfo
1861 # files.
1862 #
1863 # It does not, however, permit any other buildinfo files.  After a
1864 # source-only upload, the buildds will try to upload files like
1865 # foo_1.2.3_amd64.buildinfo.  If the package maintainer included files
1866 # named like this in their (otherwise) source-only upload, the uploads
1867 # of the buildd can be rejected by dak.  Fixing the resultant
1868 # situation can require manual intervention.  So we block such
1869 # .buildinfo files when the user tells us to perform a source-only
1870 # upload (such as when using the push-source subcommand with the -C
1871 # option, which calls this function).
1872 #
1873 # Note, though, that when dgit is told to prepare a source-only
1874 # upload, such as when subcommands like build-source and push-source
1875 # without -C are used, dgit has a more restrictive notion of
1876 # source-only .changes than dak: such uploads will never include
1877 # *_source.buildinfo files.  This is because there is no use for such
1878 # files when using a tool like dgit to produce the source package, as
1879 # dgit ensures the source is identical to git HEAD.
1880 sub test_source_only_changes ($) {
1881     my ($changes) = @_;
1882     foreach my $l (split /\n/, getfield $changes, 'Files') {
1883         $l =~ m/\S+$/ or next;
1884         # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1885         unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1886             print "purportedly source-only changes polluted by $&\n";
1887             return 0;
1888         }
1889     }
1890     return 1;
1891 }
1892
1893 sub changes_update_origs_from_dsc ($$$$) {
1894     my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1895     my %changes_f;
1896     printdebug "checking origs needed ($upstreamvsn)...\n";
1897     $_ = getfield $changes, 'Files';
1898     m/^\w+ \d+ (\S+ \S+) \S+$/m or
1899         fail "cannot find section/priority from .changes Files field";
1900     my $placementinfo = $1;
1901     my %changed;
1902     printdebug "checking origs needed placement '$placementinfo'...\n";
1903     foreach my $l (split /\n/, getfield $dsc, 'Files') {
1904         $l =~ m/\S+$/ or next;
1905         my $file = $&;
1906         printdebug "origs $file | $l\n";
1907         next unless is_orig_file_of_vsn $file, $upstreamvsn;
1908         printdebug "origs $file is_orig\n";
1909         my $have = archive_query('file_in_archive', $file);
1910         if (!defined $have) {
1911             print STDERR <<END;
1912 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1913 END
1914             return;
1915         }
1916         my $found_same = 0;
1917         my @found_differ;
1918         printdebug "origs $file \$#\$have=$#$have\n";
1919         foreach my $h (@$have) {
1920             my $same = 0;
1921             my @differ;
1922             foreach my $csumi (@files_csum_info_fields) {
1923                 my ($fname, $module, $method, $archivefield) = @$csumi;
1924                 next unless defined $h->{$archivefield};
1925                 $_ = $dsc->{$fname};
1926                 next unless defined;
1927                 m/^(\w+) .* \Q$file\E$/m or
1928                     fail ".dsc $fname missing entry for $file";
1929                 if ($h->{$archivefield} eq $1) {
1930                     $same++;
1931                 } else {
1932                     push @differ,
1933  "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1934                 }
1935             }
1936             die "$file ".Dumper($h)." ?!" if $same && @differ;
1937             $found_same++
1938                 if $same;
1939             push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1940                 if @differ;
1941         }
1942         printdebug "origs $file f.same=$found_same".
1943             " #f._differ=$#found_differ\n";
1944         if (@found_differ && !$found_same) {
1945             fail join "\n",
1946                 "archive contains $file with different checksum",
1947                 @found_differ;
1948         }
1949         # Now we edit the changes file to add or remove it
1950         foreach my $csumi (@files_csum_info_fields) {
1951             my ($fname, $module, $method, $archivefield) = @$csumi;
1952             next unless defined $changes->{$fname};
1953             if ($found_same) {
1954                 # in archive, delete from .changes if it's there
1955                 $changed{$file} = "removed" if
1956                     $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1957             } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1958                 # not in archive, but it's here in the .changes
1959             } else {
1960                 my $dsc_data = getfield $dsc, $fname;
1961                 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1962                 my $extra = $1;
1963                 $extra =~ s/ \d+ /$&$placementinfo /
1964                     or die "$fname $extra >$dsc_data< ?"
1965                     if $fname eq 'Files';
1966                 $changes->{$fname} .= "\n". $extra;
1967                 $changed{$file} = "added";
1968             }
1969         }
1970     }
1971     if (%changed) {
1972         foreach my $file (keys %changed) {
1973             progress sprintf
1974                 "edited .changes for archive .orig contents: %s %s",
1975                 $changed{$file}, $file;
1976         }
1977         my $chtmp = "$changesfile.tmp";
1978         $changes->save($chtmp);
1979         if (act_local()) {
1980             rename $chtmp,$changesfile or die "$changesfile $!";
1981         } else {
1982             progress "[new .changes left in $changesfile]";
1983         }
1984     } else {
1985         progress "$changesfile already has appropriate .orig(s) (if any)";
1986     }
1987 }
1988
1989 sub make_commit ($) {
1990     my ($file) = @_;
1991     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1992 }
1993
1994 sub make_commit_text ($) {
1995     my ($text) = @_;
1996     my ($out, $in);
1997     my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1998     debugcmd "|",@cmd;
1999     print Dumper($text) if $debuglevel > 1;
2000     my $child = open2($out, $in, @cmd) or die $!;
2001     my $h;
2002     eval {
2003         print $in $text or die $!;
2004         close $in or die $!;
2005         $h = <$out>;
2006         $h =~ m/^\w+$/ or die;
2007         $h = $&;
2008         printdebug "=> $h\n";
2009     };
2010     close $out;
2011     waitpid $child, 0 == $child or die "$child $!";
2012     $? and failedcmd @cmd;
2013     return $h;
2014 }
2015
2016 sub clogp_authline ($) {
2017     my ($clogp) = @_;
2018     my $author = getfield $clogp, 'Maintainer';
2019     if ($author =~ m/^[^"\@]+\,/) {
2020         # single entry Maintainer field with unquoted comma
2021         $author = ($& =~ y/,//rd).$'; # strip the comma
2022     }
2023     # git wants a single author; any remaining commas in $author
2024     # are by now preceded by @ (or ").  It seems safer to punt on
2025     # "..." for now rather than attempting to dequote or something.
2026     $author =~ s#,.*##ms unless $author =~ m/"/;
2027     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2028     my $authline = "$author $date";
2029     $authline =~ m/$git_authline_re/o or
2030         fail "unexpected commit author line format \`$authline'".
2031         " (was generated from changelog Maintainer field)";
2032     return ($1,$2,$3) if wantarray;
2033     return $authline;
2034 }
2035
2036 sub vendor_patches_distro ($$) {
2037     my ($checkdistro, $what) = @_;
2038     return unless defined $checkdistro;
2039
2040     my $series = "debian/patches/\L$checkdistro\E.series";
2041     printdebug "checking for vendor-specific $series ($what)\n";
2042
2043     if (!open SERIES, "<", $series) {
2044         die "$series $!" unless $!==ENOENT;
2045         return;
2046     }
2047     while (<SERIES>) {
2048         next unless m/\S/;
2049         next if m/^\s+\#/;
2050
2051         print STDERR <<END;
2052
2053 Unfortunately, this source package uses a feature of dpkg-source where
2054 the same source package unpacks to different source code on different
2055 distros.  dgit cannot safely operate on such packages on affected
2056 distros, because the meaning of source packages is not stable.
2057
2058 Please ask the distro/maintainer to remove the distro-specific series
2059 files and use a different technique (if necessary, uploading actually
2060 different packages, if different distros are supposed to have
2061 different code).
2062
2063 END
2064         fail "Found active distro-specific series file for".
2065             " $checkdistro ($what): $series, cannot continue";
2066     }
2067     die "$series $!" if SERIES->error;
2068     close SERIES;
2069 }
2070
2071 sub check_for_vendor_patches () {
2072     # This dpkg-source feature doesn't seem to be documented anywhere!
2073     # But it can be found in the changelog (reformatted):
2074
2075     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
2076     #   Author: Raphael Hertzog <hertzog@debian.org>
2077     #   Date: Sun  Oct  3  09:36:48  2010 +0200
2078
2079     #   dpkg-source: correctly create .pc/.quilt_series with alternate
2080     #   series files
2081     #
2082     #   If you have debian/patches/ubuntu.series and you were
2083     #   unpacking the source package on ubuntu, quilt was still
2084     #   directed to debian/patches/series instead of
2085     #   debian/patches/ubuntu.series.
2086     #
2087     #   debian/changelog                        |    3 +++
2088     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
2089     #   2 files changed, 6 insertions(+), 1 deletion(-)
2090
2091     use Dpkg::Vendor;
2092     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2093     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2094                          "Dpkg::Vendor \`current vendor'");
2095     vendor_patches_distro(access_basedistro(),
2096                           "(base) distro being accessed");
2097     vendor_patches_distro(access_nomdistro(),
2098                           "(nominal) distro being accessed");
2099 }
2100
2101 sub generate_commits_from_dsc () {
2102     # See big comment in fetch_from_archive, below.
2103     # See also README.dsc-import.
2104     prep_ud();
2105     changedir $playground;
2106
2107     my @dfi = dsc_files_info();
2108     foreach my $fi (@dfi) {
2109         my $f = $fi->{Filename};
2110         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2111         my $upper_f = "$maindir/../$f";
2112
2113         printdebug "considering reusing $f: ";
2114
2115         if (link_ltarget "$upper_f,fetch", $f) {
2116             printdebug "linked (using ...,fetch).\n";
2117         } elsif ((printdebug "($!) "),
2118                  $! != ENOENT) {
2119             fail "accessing ../$f,fetch: $!";
2120         } elsif (link_ltarget $upper_f, $f) {
2121             printdebug "linked.\n";
2122         } elsif ((printdebug "($!) "),
2123                  $! != ENOENT) {
2124             fail "accessing ../$f: $!";
2125         } else {
2126             printdebug "absent.\n";
2127         }
2128
2129         my $refetched;
2130         complete_file_from_dsc('.', $fi, \$refetched)
2131             or next;
2132
2133         printdebug "considering saving $f: ";
2134
2135         if (link $f, $upper_f) {
2136             printdebug "linked.\n";
2137         } elsif ((printdebug "($!) "),
2138                  $! != EEXIST) {
2139             fail "saving ../$f: $!";
2140         } elsif (!$refetched) {
2141             printdebug "no need.\n";
2142         } elsif (link $f, "$upper_f,fetch") {
2143             printdebug "linked (using ...,fetch).\n";
2144         } elsif ((printdebug "($!) "),
2145                  $! != EEXIST) {
2146             fail "saving ../$f,fetch: $!";
2147         } else {
2148             printdebug "cannot.\n";
2149         }
2150     }
2151
2152     # We unpack and record the orig tarballs first, so that we only
2153     # need disk space for one private copy of the unpacked source.
2154     # But we can't make them into commits until we have the metadata
2155     # from the debian/changelog, so we record the tree objects now and
2156     # make them into commits later.
2157     my @tartrees;
2158     my $upstreamv = upstreamversion $dsc->{version};
2159     my $orig_f_base = srcfn $upstreamv, '';
2160
2161     foreach my $fi (@dfi) {
2162         # We actually import, and record as a commit, every tarball
2163         # (unless there is only one file, in which case there seems
2164         # little point.
2165
2166         my $f = $fi->{Filename};
2167         printdebug "import considering $f ";
2168         (printdebug "only one dfi\n"), next if @dfi == 1;
2169         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2170         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2171         my $compr_ext = $1;
2172
2173         my ($orig_f_part) =
2174             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2175
2176         printdebug "Y ", (join ' ', map { $_//"(none)" }
2177                           $compr_ext, $orig_f_part
2178                          ), "\n";
2179
2180         my $input = new IO::File $f, '<' or die "$f $!";
2181         my $compr_pid;
2182         my @compr_cmd;
2183
2184         if (defined $compr_ext) {
2185             my $cname =
2186                 Dpkg::Compression::compression_guess_from_filename $f;
2187             fail "Dpkg::Compression cannot handle file $f in source package"
2188                 if defined $compr_ext && !defined $cname;
2189             my $compr_proc =
2190                 new Dpkg::Compression::Process compression => $cname;
2191             @compr_cmd = $compr_proc->get_uncompress_cmdline();
2192             my $compr_fh = new IO::Handle;
2193             my $compr_pid = open $compr_fh, "-|" // die $!;
2194             if (!$compr_pid) {
2195                 open STDIN, "<&", $input or die $!;
2196                 exec @compr_cmd;
2197                 die "dgit (child): exec $compr_cmd[0]: $!\n";
2198             }
2199             $input = $compr_fh;
2200         }
2201
2202         rmtree "_unpack-tar";
2203         mkdir "_unpack-tar" or die $!;
2204         my @tarcmd = qw(tar -x -f -
2205                         --no-same-owner --no-same-permissions
2206                         --no-acls --no-xattrs --no-selinux);
2207         my $tar_pid = fork // die $!;
2208         if (!$tar_pid) {
2209             chdir "_unpack-tar" or die $!;
2210             open STDIN, "<&", $input or die $!;
2211             exec @tarcmd;
2212             die "dgit (child): exec $tarcmd[0]: $!";
2213         }
2214         $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2215         !$? or failedcmd @tarcmd;
2216
2217         close $input or
2218             (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2219              : die $!);
2220         # finally, we have the results in "tarball", but maybe
2221         # with the wrong permissions
2222
2223         runcmd qw(chmod -R +rwX _unpack-tar);
2224         changedir "_unpack-tar";
2225         remove_stray_gits($f);
2226         mktree_in_ud_here();
2227
2228         my ($tree) = git_add_write_tree();
2229         my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2230         if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2231             $tree = $1;
2232             printdebug "one subtree $1\n";
2233         } else {
2234             printdebug "multiple subtrees\n";
2235         }
2236         changedir "..";
2237         rmtree "_unpack-tar";
2238
2239         my $ent = [ $f, $tree ];
2240         push @tartrees, {
2241             Orig => !!$orig_f_part,
2242             Sort => (!$orig_f_part         ? 2 :
2243                      $orig_f_part =~ m/-/g ? 1 :
2244                                              0),
2245             F => $f,
2246             Tree => $tree,
2247         };
2248     }
2249
2250     @tartrees = sort {
2251         # put any without "_" first (spec is not clear whether files
2252         # are always in the usual order).  Tarballs without "_" are
2253         # the main orig or the debian tarball.
2254         $a->{Sort} <=> $b->{Sort} or
2255         $a->{F}    cmp $b->{F}
2256     } @tartrees;
2257
2258     my $any_orig = grep { $_->{Orig} } @tartrees;
2259
2260     my $dscfn = "$package.dsc";
2261
2262     my $treeimporthow = 'package';
2263
2264     open D, ">", $dscfn or die "$dscfn: $!";
2265     print D $dscdata or die "$dscfn: $!";
2266     close D or die "$dscfn: $!";
2267     my @cmd = qw(dpkg-source);
2268     push @cmd, '--no-check' if $dsc_checked;
2269     if (madformat $dsc->{format}) {
2270         push @cmd, '--skip-patches';
2271         $treeimporthow = 'unpatched';
2272     }
2273     push @cmd, qw(-x --), $dscfn;
2274     runcmd @cmd;
2275
2276     my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2277     if (madformat $dsc->{format}) {
2278         check_for_vendor_patches();
2279     }
2280
2281     my $dappliedtree;
2282     if (madformat $dsc->{format}) {
2283         my @pcmd = qw(dpkg-source --before-build .);
2284         runcmd shell_cmd 'exec >/dev/null', @pcmd;
2285         rmtree '.pc';
2286         $dappliedtree = git_add_write_tree();
2287     }
2288
2289     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2290     debugcmd "|",@clogcmd;
2291     open CLOGS, "-|", @clogcmd or die $!;
2292
2293     my $clogp;
2294     my $r1clogp;
2295
2296     printdebug "import clog search...\n";
2297
2298     for (;;) {
2299         my $stanzatext = do { local $/=""; <CLOGS>; };
2300         printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2301         last if !defined $stanzatext;
2302
2303         my $desc = "package changelog, entry no.$.";
2304         open my $stanzafh, "<", \$stanzatext or die;
2305         my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2306         $clogp //= $thisstanza;
2307
2308         printdebug "import clog $thisstanza->{version} $desc...\n";
2309
2310         last if !$any_orig; # we don't need $r1clogp
2311
2312         # We look for the first (most recent) changelog entry whose
2313         # version number is lower than the upstream version of this
2314         # package.  Then the last (least recent) previous changelog
2315         # entry is treated as the one which introduced this upstream
2316         # version and used for the synthetic commits for the upstream
2317         # tarballs.
2318
2319         # One might think that a more sophisticated algorithm would be
2320         # necessary.  But: we do not want to scan the whole changelog
2321         # file.  Stopping when we see an earlier version, which
2322         # necessarily then is an earlier upstream version, is the only
2323         # realistic way to do that.  Then, either the earliest
2324         # changelog entry we have seen so far is indeed the earliest
2325         # upload of this upstream version; or there are only changelog
2326         # entries relating to later upstream versions (which is not
2327         # possible unless the changelog and .dsc disagree about the
2328         # version).  Then it remains to choose between the physically
2329         # last entry in the file, and the one with the lowest version
2330         # number.  If these are not the same, we guess that the
2331         # versions were created in a non-monotic order rather than
2332         # that the changelog entries have been misordered.
2333
2334         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2335
2336         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2337         $r1clogp = $thisstanza;
2338
2339         printdebug "import clog $r1clogp->{version} becomes r1\n";
2340     }
2341     die $! if CLOGS->error;
2342     close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2343
2344     $clogp or fail "package changelog has no entries!";
2345
2346     my $authline = clogp_authline $clogp;
2347     my $changes = getfield $clogp, 'Changes';
2348     $changes =~ s/^\n//; # Changes: \n
2349     my $cversion = getfield $clogp, 'Version';
2350
2351     if (@tartrees) {
2352         $r1clogp //= $clogp; # maybe there's only one entry;
2353         my $r1authline = clogp_authline $r1clogp;
2354         # Strictly, r1authline might now be wrong if it's going to be
2355         # unused because !$any_orig.  Whatever.
2356
2357         printdebug "import tartrees authline   $authline\n";
2358         printdebug "import tartrees r1authline $r1authline\n";
2359
2360         foreach my $tt (@tartrees) {
2361             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2362
2363             $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2364 tree $tt->{Tree}
2365 author $r1authline
2366 committer $r1authline
2367
2368 Import $tt->{F}
2369
2370 [dgit import orig $tt->{F}]
2371 END_O
2372 tree $tt->{Tree}
2373 author $authline
2374 committer $authline
2375
2376 Import $tt->{F}
2377
2378 [dgit import tarball $package $cversion $tt->{F}]
2379 END_T
2380         }
2381     }
2382
2383     printdebug "import main commit\n";
2384
2385     open C, ">../commit.tmp" or die $!;
2386     print C <<END or die $!;
2387 tree $tree
2388 END
2389     print C <<END or die $! foreach @tartrees;
2390 parent $_->{Commit}
2391 END
2392     print C <<END or die $!;
2393 author $authline
2394 committer $authline
2395
2396 $changes
2397
2398 [dgit import $treeimporthow $package $cversion]
2399 END
2400
2401     close C or die $!;
2402     my $rawimport_hash = make_commit qw(../commit.tmp);
2403
2404     if (madformat $dsc->{format}) {
2405         printdebug "import apply patches...\n";
2406
2407         # regularise the state of the working tree so that
2408         # the checkout of $rawimport_hash works nicely.
2409         my $dappliedcommit = make_commit_text(<<END);
2410 tree $dappliedtree
2411 author $authline
2412 committer $authline
2413
2414 [dgit dummy commit]
2415 END
2416         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2417
2418         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2419
2420         # We need the answers to be reproducible
2421         my @authline = clogp_authline($clogp);
2422         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2423         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2424         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2425         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
2426         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2427         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
2428
2429         my $path = $ENV{PATH} or die;
2430
2431         # we use ../../gbp-pq-output, which (given that we are in
2432         # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2433         # is .git/dgit.
2434
2435         foreach my $use_absurd (qw(0 1)) {
2436             runcmd @git, qw(checkout -q unpa);
2437             runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2438             local $ENV{PATH} = $path;
2439             if ($use_absurd) {
2440                 chomp $@;
2441                 progress "warning: $@";
2442                 $path = "$absurdity:$path";
2443                 progress "$us: trying slow absurd-git-apply...";
2444                 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2445                     or $!==ENOENT
2446                     or die $!;
2447             }
2448             eval {
2449                 die "forbid absurd git-apply\n" if $use_absurd
2450                     && forceing [qw(import-gitapply-no-absurd)];
2451                 die "only absurd git-apply!\n" if !$use_absurd
2452                     && forceing [qw(import-gitapply-absurd)];
2453
2454                 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2455                 local $ENV{PATH} = $path                    if $use_absurd;
2456
2457                 my @showcmd = (gbp_pq, qw(import));
2458                 my @realcmd = shell_cmd
2459                     'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2460                 debugcmd "+",@realcmd;
2461                 if (system @realcmd) {
2462                     die +(shellquote @showcmd).
2463                         " failed: ".
2464                         failedcmd_waitstatus()."\n";
2465                 }
2466
2467                 my $gapplied = git_rev_parse('HEAD');
2468                 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2469                 $gappliedtree eq $dappliedtree or
2470                     fail <<END;
2471 gbp-pq import and dpkg-source disagree!
2472  gbp-pq import gave commit $gapplied
2473  gbp-pq import gave tree $gappliedtree
2474  dpkg-source --before-build gave tree $dappliedtree
2475 END
2476                 $rawimport_hash = $gapplied;
2477             };
2478             last unless $@;
2479         }
2480         if ($@) {
2481             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2482             die $@;
2483         }
2484     }
2485
2486     progress "synthesised git commit from .dsc $cversion";
2487
2488     my $rawimport_mergeinput = {
2489         Commit => $rawimport_hash,
2490         Info => "Import of source package",
2491     };
2492     my @output = ($rawimport_mergeinput);
2493
2494     if ($lastpush_mergeinput) {
2495         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2496         my $oversion = getfield $oldclogp, 'Version';
2497         my $vcmp =
2498             version_compare($oversion, $cversion);
2499         if ($vcmp < 0) {
2500             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2501                 { Message => <<END, ReverseParents => 1 });
2502 Record $package ($cversion) in archive suite $csuite
2503 END
2504         } elsif ($vcmp > 0) {
2505             print STDERR <<END or die $!;
2506
2507 Version actually in archive:   $cversion (older)
2508 Last version pushed with dgit: $oversion (newer or same)
2509 $later_warning_msg
2510 END
2511             @output = $lastpush_mergeinput;
2512         } else {
2513             # Same version.  Use what's in the server git branch,
2514             # discarding our own import.  (This could happen if the
2515             # server automatically imports all packages into git.)
2516             @output = $lastpush_mergeinput;
2517         }
2518     }
2519     changedir $maindir;
2520     rmtree $playground;
2521     return @output;
2522 }
2523
2524 sub complete_file_from_dsc ($$;$) {
2525     our ($dstdir, $fi, $refetched) = @_;
2526     # Ensures that we have, in $dstdir, the file $fi, with the correct
2527     # contents.  (Downloading it from alongside $dscurl if necessary.)
2528     # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2529     # and will set $$refetched=1 if it did so (or tried to).
2530
2531     my $f = $fi->{Filename};
2532     my $tf = "$dstdir/$f";
2533     my $downloaded = 0;
2534
2535     my $got;
2536     my $checkhash = sub {
2537         open F, "<", "$tf" or die "$tf: $!";
2538         $fi->{Digester}->reset();
2539         $fi->{Digester}->addfile(*F);
2540         F->error and die $!;
2541         $got = $fi->{Digester}->hexdigest();
2542         return $got eq $fi->{Hash};
2543     };
2544
2545     if (stat_exists $tf) {
2546         if ($checkhash->()) {
2547             progress "using existing $f";
2548             return 1;
2549         }
2550         if (!$refetched) {
2551             fail "file $f has hash $got but .dsc".
2552                 " demands hash $fi->{Hash} ".
2553                 "(perhaps you should delete this file?)";
2554         }
2555         progress "need to fetch correct version of $f";
2556         unlink $tf or die "$tf $!";
2557         $$refetched = 1;
2558     } else {
2559         printdebug "$tf does not exist, need to fetch\n";
2560     }
2561
2562     my $furl = $dscurl;
2563     $furl =~ s{/[^/]+$}{};
2564     $furl .= "/$f";
2565     die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2566     die "$f ?" if $f =~ m#/#;
2567     runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2568     return 0 if !act_local();
2569
2570     $checkhash->() or
2571         fail "file $f has hash $got but .dsc".
2572             " demands hash $fi->{Hash} ".
2573             "(got wrong file from archive!)";
2574
2575     return 1;
2576 }
2577
2578 sub ensure_we_have_orig () {
2579     my @dfi = dsc_files_info();
2580     foreach my $fi (@dfi) {
2581         my $f = $fi->{Filename};
2582         next unless is_orig_file_in_dsc($f, \@dfi);
2583         complete_file_from_dsc('..', $fi)
2584             or next;
2585     }
2586 }
2587
2588 #---------- git fetch ----------
2589
2590 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2591 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2592
2593 # We fetch some parts of lrfetchrefs/*.  Ideally we delete these
2594 # locally fetched refs because they have unhelpful names and clutter
2595 # up gitk etc.  So we track whether we have "used up" head ref (ie,
2596 # whether we have made another local ref which refers to this object).
2597 #
2598 # (If we deleted them unconditionally, then we might end up
2599 # re-fetching the same git objects each time dgit fetch was run.)
2600 #
2601 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2602 # in git_fetch_us to fetch the refs in question, and possibly a call
2603 # to lrfetchref_used.
2604
2605 our (%lrfetchrefs_f, %lrfetchrefs_d);
2606 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2607
2608 sub lrfetchref_used ($) {
2609     my ($fullrefname) = @_;
2610     my $objid = $lrfetchrefs_f{$fullrefname};
2611     $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2612 }
2613
2614 sub git_lrfetch_sane {
2615     my ($url, $supplementary, @specs) = @_;
2616     # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2617     # at least as regards @specs.  Also leave the results in
2618     # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2619     # able to clean these up.
2620     #
2621     # With $supplementary==1, @specs must not contain wildcards
2622     # and we add to our previous fetches (non-atomically).
2623
2624     # This is rather miserable:
2625     # When git fetch --prune is passed a fetchspec ending with a *,
2626     # it does a plausible thing.  If there is no * then:
2627     # - it matches subpaths too, even if the supplied refspec
2628     #   starts refs, and behaves completely madly if the source
2629     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2630     # - if there is no matching remote ref, it bombs out the whole
2631     #   fetch.
2632     # We want to fetch a fixed ref, and we don't know in advance
2633     # if it exists, so this is not suitable.
2634     #
2635     # Our workaround is to use git ls-remote.  git ls-remote has its
2636     # own qairks.  Notably, it has the absurd multi-tail-matching
2637     # behaviour: git ls-remote R refs/foo can report refs/foo AND
2638     # refs/refs/foo etc.
2639     #
2640     # Also, we want an idempotent snapshot, but we have to make two
2641     # calls to the remote: one to git ls-remote and to git fetch.  The
2642     # solution is use git ls-remote to obtain a target state, and
2643     # git fetch to try to generate it.  If we don't manage to generate
2644     # the target state, we try again.
2645
2646     printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2647
2648     my $specre = join '|', map {
2649         my $x = $_;
2650         $x =~ s/\W/\\$&/g;
2651         my $wildcard = $x =~ s/\\\*$/.*/;
2652         die if $wildcard && $supplementary;
2653         "(?:refs/$x)";
2654     } @specs;
2655     printdebug "git_lrfetch_sane specre=$specre\n";
2656     my $wanted_rref = sub {
2657         local ($_) = @_;
2658         return m/^(?:$specre)$/;
2659     };
2660
2661     my $fetch_iteration = 0;
2662     FETCH_ITERATION:
2663     for (;;) {
2664         printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2665         if (++$fetch_iteration > 10) {
2666             fail "too many iterations trying to get sane fetch!";
2667         }
2668
2669         my @look = map { "refs/$_" } @specs;
2670         my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2671         debugcmd "|",@lcmd;
2672
2673         my %wantr;
2674         open GITLS, "-|", @lcmd or die $!;
2675         while (<GITLS>) {
2676             printdebug "=> ", $_;
2677             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2678             my ($objid,$rrefname) = ($1,$2);
2679             if (!$wanted_rref->($rrefname)) {
2680                 print STDERR <<END;
2681 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2682 END
2683                 next;
2684             }
2685             $wantr{$rrefname} = $objid;
2686         }
2687         $!=0; $?=0;
2688         close GITLS or failedcmd @lcmd;
2689
2690         # OK, now %want is exactly what we want for refs in @specs
2691         my @fspecs = map {
2692             !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2693             "+refs/$_:".lrfetchrefs."/$_";
2694         } @specs;
2695
2696         printdebug "git_lrfetch_sane fspecs @fspecs\n";
2697
2698         my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2699         runcmd_ordryrun_local @fcmd if @fspecs;
2700
2701         if (!$supplementary) {
2702             %lrfetchrefs_f = ();
2703         }
2704         my %objgot;
2705
2706         git_for_each_ref(lrfetchrefs, sub {
2707             my ($objid,$objtype,$lrefname,$reftail) = @_;
2708             $lrfetchrefs_f{$lrefname} = $objid;
2709             $objgot{$objid} = 1;
2710         });
2711
2712         if ($supplementary) {
2713             last;
2714         }
2715
2716         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2717             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2718             if (!exists $wantr{$rrefname}) {
2719                 if ($wanted_rref->($rrefname)) {
2720                     printdebug <<END;
2721 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2722 END
2723                 } else {
2724                     print STDERR <<END
2725 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2726 END
2727                 }
2728                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2729                 delete $lrfetchrefs_f{$lrefname};
2730                 next;
2731             }
2732         }
2733         foreach my $rrefname (sort keys %wantr) {
2734             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2735             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2736             my $want = $wantr{$rrefname};
2737             next if $got eq $want;
2738             if (!defined $objgot{$want}) {
2739                 print STDERR <<END;
2740 warning: git ls-remote suggests we want $lrefname
2741 warning:  and it should refer to $want
2742 warning:  but git fetch didn't fetch that object to any relevant ref.
2743 warning:  This may be due to a race with someone updating the server.
2744 warning:  Will try again...
2745 END
2746                 next FETCH_ITERATION;
2747             }
2748             printdebug <<END;
2749 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2750 END
2751             runcmd_ordryrun_local @git, qw(update-ref -m),
2752                 "dgit fetch git fetch fixup", $lrefname, $want;
2753             $lrfetchrefs_f{$lrefname} = $want;
2754         }
2755         last;
2756     }
2757
2758     if (defined $csuite) {
2759         printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2760         git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2761             my ($objid,$objtype,$lrefname,$reftail) = @_;
2762             next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2763             runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2764         });
2765     }
2766
2767     printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2768         Dumper(\%lrfetchrefs_f);
2769 }
2770
2771 sub git_fetch_us () {
2772     # Want to fetch only what we are going to use, unless
2773     # deliberately-not-ff, in which case we must fetch everything.
2774
2775     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2776         map { "tags/$_" }
2777         (quiltmode_splitbrain
2778          ? (map { $_->('*',access_nomdistro) }
2779             \&debiantag_new, \&debiantag_maintview)
2780          : debiantags('*',access_nomdistro));
2781     push @specs, server_branch($csuite);
2782     push @specs, $rewritemap;
2783     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2784
2785     my $url = access_giturl();
2786     git_lrfetch_sane $url, 0, @specs;
2787
2788     my %here;
2789     my @tagpats = debiantags('*',access_nomdistro);
2790
2791     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2792         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2793         printdebug "currently $fullrefname=$objid\n";
2794         $here{$fullrefname} = $objid;
2795     });
2796     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2797         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2798         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2799         printdebug "offered $lref=$objid\n";
2800         if (!defined $here{$lref}) {
2801             my @upd = (@git, qw(update-ref), $lref, $objid, '');
2802             runcmd_ordryrun_local @upd;
2803             lrfetchref_used $fullrefname;
2804         } elsif ($here{$lref} eq $objid) {
2805             lrfetchref_used $fullrefname;
2806         } else {
2807             print STDERR
2808                 "Not updating $lref from $here{$lref} to $objid.\n";
2809         }
2810     });
2811 }
2812
2813 #---------- dsc and archive handling ----------
2814
2815 sub mergeinfo_getclogp ($) {
2816     # Ensures thit $mi->{Clogp} exists and returns it
2817     my ($mi) = @_;
2818     $mi->{Clogp} = commit_getclogp($mi->{Commit});
2819 }
2820
2821 sub mergeinfo_version ($) {
2822     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2823 }
2824
2825 sub fetch_from_archive_record_1 ($) {
2826     my ($hash) = @_;
2827     runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2828             'DGIT_ARCHIVE', $hash;
2829     cmdoutput @git, qw(log -n2), $hash;
2830     # ... gives git a chance to complain if our commit is malformed
2831 }
2832
2833 sub fetch_from_archive_record_2 ($) {
2834     my ($hash) = @_;
2835     my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2836     if (act_local()) {
2837         cmdoutput @upd_cmd;
2838     } else {
2839         dryrun_report @upd_cmd;
2840     }
2841 }
2842
2843 sub parse_dsc_field_def_dsc_distro () {
2844     $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2845                            dgit.default.distro);
2846 }
2847
2848 sub parse_dsc_field ($$) {
2849     my ($dsc, $what) = @_;
2850     my $f;
2851     foreach my $field (@ourdscfield) {
2852         $f = $dsc->{$field};
2853         last if defined $f;
2854     }
2855
2856     if (!defined $f) {
2857         progress "$what: NO git hash";
2858         parse_dsc_field_def_dsc_distro();
2859     } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2860              = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2861         progress "$what: specified git info ($dsc_distro)";
2862         $dsc_hint_tag = [ $dsc_hint_tag ];
2863     } elsif ($f =~ m/^\w+\s*$/) {
2864         $dsc_hash = $&;
2865         parse_dsc_field_def_dsc_distro();
2866         $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2867                           $dsc_distro ];
2868         progress "$what: specified git hash";
2869     } else {
2870         fail "$what: invalid Dgit info";
2871     }
2872 }
2873
2874 sub resolve_dsc_field_commit ($$) {
2875     my ($already_distro, $already_mapref) = @_;
2876
2877     return unless defined $dsc_hash;
2878
2879     my $mapref =
2880         defined $already_mapref &&
2881         ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2882         ? $already_mapref : undef;
2883
2884     my $do_fetch;
2885     $do_fetch = sub {
2886         my ($what, @fetch) = @_;
2887
2888         local $idistro = $dsc_distro;
2889         my $lrf = lrfetchrefs;
2890
2891         if (!$chase_dsc_distro) {
2892             progress
2893                 "not chasing .dsc distro $dsc_distro: not fetching $what";
2894             return 0;
2895         }
2896
2897         progress
2898             ".dsc names distro $dsc_distro: fetching $what";
2899
2900         my $url = access_giturl();
2901         if (!defined $url) {
2902             defined $dsc_hint_url or fail <<END;
2903 .dsc Dgit metadata is in context of distro $dsc_distro
2904 for which we have no configured url and .dsc provides no hint
2905 END
2906             my $proto =
2907                 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2908                 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2909             parse_cfg_bool "dsc-url-proto-ok", 'false',
2910                 cfg("dgit.dsc-url-proto-ok.$proto",
2911                     "dgit.default.dsc-url-proto-ok")
2912                 or fail <<END;
2913 .dsc Dgit metadata is in context of distro $dsc_distro
2914 for which we have no configured url;
2915 .dsc provides hinted url with protocol $proto which is unsafe.
2916 (can be overridden by config - consult documentation)
2917 END
2918             $url = $dsc_hint_url;
2919         }
2920
2921         git_lrfetch_sane $url, 1, @fetch;
2922
2923         return $lrf;
2924     };
2925
2926     my $rewrite_enable = do {
2927         local $idistro = $dsc_distro;
2928         access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2929     };
2930
2931     if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2932         if (!defined $mapref) {
2933             my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2934             $mapref = $lrf.'/'.$rewritemap;
2935         }
2936         my $rewritemapdata = git_cat_file $mapref.':map';
2937         if (defined $rewritemapdata
2938             && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2939             progress
2940                 "server's git history rewrite map contains a relevant entry!";
2941
2942             $dsc_hash = $1;
2943             if (defined $dsc_hash) {
2944                 progress "using rewritten git hash in place of .dsc value";
2945             } else {
2946                 progress "server data says .dsc hash is to be disregarded";
2947             }
2948         }
2949     }
2950
2951     if (!defined git_cat_file $dsc_hash) {
2952         my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2953         my $lrf = $do_fetch->("additional commits", @tags) &&
2954             defined git_cat_file $dsc_hash
2955             or fail <<END;
2956 .dsc Dgit metadata requires commit $dsc_hash
2957 but we could not obtain that object anywhere.
2958 END
2959         foreach my $t (@tags) {
2960             my $fullrefname = $lrf.'/'.$t;
2961 #           print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
2962             next unless $lrfetchrefs_f{$fullrefname};
2963             next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
2964             lrfetchref_used $fullrefname;
2965         }
2966     }
2967 }
2968
2969 sub fetch_from_archive () {
2970     ensure_setup_existing_tree();
2971
2972     # Ensures that lrref() is what is actually in the archive, one way
2973     # or another, according to us - ie this client's
2974     # appropritaely-updated archive view.  Also returns the commit id.
2975     # If there is nothing in the archive, leaves lrref alone and
2976     # returns undef.  git_fetch_us must have already been called.
2977     get_archive_dsc();
2978
2979     if ($dsc) {
2980         parse_dsc_field($dsc, 'last upload to archive');
2981         resolve_dsc_field_commit access_basedistro,
2982             lrfetchrefs."/".$rewritemap
2983     } else {
2984         progress "no version available from the archive";
2985     }
2986
2987     # If the archive's .dsc has a Dgit field, there are three
2988     # relevant git commitids we need to choose between and/or merge
2989     # together:
2990     #   1. $dsc_hash: the Dgit field from the archive
2991     #   2. $lastpush_hash: the suite branch on the dgit git server
2992     #   3. $lastfetch_hash: our local tracking brach for the suite
2993     #
2994     # These may all be distinct and need not be in any fast forward
2995     # relationship:
2996     #
2997     # If the dsc was pushed to this suite, then the server suite
2998     # branch will have been updated; but it might have been pushed to
2999     # a different suite and copied by the archive.  Conversely a more
3000     # recent version may have been pushed with dgit but not appeared
3001     # in the archive (yet).
3002     #
3003     # $lastfetch_hash may be awkward because archive imports
3004     # (particularly, imports of Dgit-less .dscs) are performed only as
3005     # needed on individual clients, so different clients may perform a
3006     # different subset of them - and these imports are only made
3007     # public during push.  So $lastfetch_hash may represent a set of
3008     # imports different to a subsequent upload by a different dgit
3009     # client.
3010     #
3011     # Our approach is as follows:
3012     #
3013     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3014     # descendant of $dsc_hash, then it was pushed by a dgit user who
3015     # had based their work on $dsc_hash, so we should prefer it.
3016     # Otherwise, $dsc_hash was installed into this suite in the
3017     # archive other than by a dgit push, and (necessarily) after the
3018     # last dgit push into that suite (since a dgit push would have
3019     # been descended from the dgit server git branch); thus, in that
3020     # case, we prefer the archive's version (and produce a
3021     # pseudo-merge to overwrite the dgit server git branch).
3022     #
3023     # (If there is no Dgit field in the archive's .dsc then
3024     # generate_commit_from_dsc uses the version numbers to decide
3025     # whether the suite branch or the archive is newer.  If the suite
3026     # branch is newer it ignores the archive's .dsc; otherwise it
3027     # generates an import of the .dsc, and produces a pseudo-merge to
3028     # overwrite the suite branch with the archive contents.)
3029     #
3030     # The outcome of that part of the algorithm is the `public view',
3031     # and is same for all dgit clients: it does not depend on any
3032     # unpublished history in the local tracking branch.
3033     #
3034     # As between the public view and the local tracking branch: The
3035     # local tracking branch is only updated by dgit fetch, and
3036     # whenever dgit fetch runs it includes the public view in the
3037     # local tracking branch.  Therefore if the public view is not
3038     # descended from the local tracking branch, the local tracking
3039     # branch must contain history which was imported from the archive
3040     # but never pushed; and, its tip is now out of date.  So, we make
3041     # a pseudo-merge to overwrite the old imports and stitch the old
3042     # history in.
3043     #
3044     # Finally: we do not necessarily reify the public view (as
3045     # described above).  This is so that we do not end up stacking two
3046     # pseudo-merges.  So what we actually do is figure out the inputs
3047     # to any public view pseudo-merge and put them in @mergeinputs.
3048
3049     my @mergeinputs;
3050     # $mergeinputs[]{Commit}
3051     # $mergeinputs[]{Info}
3052     # $mergeinputs[0] is the one whose tree we use
3053     # @mergeinputs is in the order we use in the actual commit)
3054     #
3055     # Also:
3056     # $mergeinputs[]{Message} is a commit message to use
3057     # $mergeinputs[]{ReverseParents} if def specifies that parent
3058     #                                list should be in opposite order
3059     # Such an entry has no Commit or Info.  It applies only when found
3060     # in the last entry.  (This ugliness is to support making
3061     # identical imports to previous dgit versions.)
3062
3063     my $lastpush_hash = git_get_ref(lrfetchref());
3064     printdebug "previous reference hash=$lastpush_hash\n";
3065     $lastpush_mergeinput = $lastpush_hash && {
3066         Commit => $lastpush_hash,
3067         Info => "dgit suite branch on dgit git server",
3068     };
3069
3070     my $lastfetch_hash = git_get_ref(lrref());
3071     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3072     my $lastfetch_mergeinput = $lastfetch_hash && {
3073         Commit => $lastfetch_hash,
3074         Info => "dgit client's archive history view",
3075     };
3076
3077     my $dsc_mergeinput = $dsc_hash && {
3078         Commit => $dsc_hash,
3079         Info => "Dgit field in .dsc from archive",
3080     };
3081
3082     my $cwd = getcwd();
3083     my $del_lrfetchrefs = sub {
3084         changedir $cwd;
3085         my $gur;
3086         printdebug "del_lrfetchrefs...\n";
3087         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3088             my $objid = $lrfetchrefs_d{$fullrefname};
3089             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3090             if (!$gur) {
3091                 $gur ||= new IO::Handle;
3092                 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3093             }
3094             printf $gur "delete %s %s\n", $fullrefname, $objid;
3095         }
3096         if ($gur) {
3097             close $gur or failedcmd "git update-ref delete lrfetchrefs";
3098         }
3099     };
3100
3101     if (defined $dsc_hash) {
3102         ensure_we_have_orig();
3103         if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3104             @mergeinputs = $dsc_mergeinput
3105         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3106             print STDERR <<END or die $!;
3107
3108 Git commit in archive is behind the last version allegedly pushed/uploaded.
3109 Commit referred to by archive: $dsc_hash
3110 Last version pushed with dgit: $lastpush_hash
3111 $later_warning_msg
3112 END
3113             @mergeinputs = ($lastpush_mergeinput);
3114         } else {
3115             # Archive has .dsc which is not a descendant of the last dgit
3116             # push.  This can happen if the archive moves .dscs about.
3117             # Just follow its lead.
3118             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3119                 progress "archive .dsc names newer git commit";
3120                 @mergeinputs = ($dsc_mergeinput);
3121             } else {
3122                 progress "archive .dsc names other git commit, fixing up";
3123                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3124             }
3125         }
3126     } elsif ($dsc) {
3127         @mergeinputs = generate_commits_from_dsc();
3128         # We have just done an import.  Now, our import algorithm might
3129         # have been improved.  But even so we do not want to generate
3130         # a new different import of the same package.  So if the
3131         # version numbers are the same, just use our existing version.
3132         # If the version numbers are different, the archive has changed
3133         # (perhaps, rewound).
3134         if ($lastfetch_mergeinput &&
3135             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3136                               (mergeinfo_version $mergeinputs[0]) )) {
3137             @mergeinputs = ($lastfetch_mergeinput);
3138         }
3139     } elsif ($lastpush_hash) {
3140         # only in git, not in the archive yet
3141         @mergeinputs = ($lastpush_mergeinput);
3142         print STDERR <<END or die $!;
3143
3144 Package not found in the archive, but has allegedly been pushed using dgit.
3145 $later_warning_msg
3146 END
3147     } else {
3148         printdebug "nothing found!\n";
3149         if (defined $skew_warning_vsn) {
3150             print STDERR <<END or die $!;
3151
3152 Warning: relevant archive skew detected.
3153 Archive allegedly contains $skew_warning_vsn
3154 But we were not able to obtain any version from the archive or git.
3155
3156 END
3157         }
3158         unshift @end, $del_lrfetchrefs;
3159         return undef;
3160     }
3161
3162     if ($lastfetch_hash &&
3163         !grep {
3164             my $h = $_->{Commit};
3165             $h and is_fast_fwd($lastfetch_hash, $h);
3166             # If true, one of the existing parents of this commit
3167             # is a descendant of the $lastfetch_hash, so we'll
3168             # be ff from that automatically.
3169         } @mergeinputs
3170         ) {
3171         # Otherwise:
3172         push @mergeinputs, $lastfetch_mergeinput;
3173     }
3174
3175     printdebug "fetch mergeinfos:\n";
3176     foreach my $mi (@mergeinputs) {
3177         if ($mi->{Info}) {
3178             printdebug " commit $mi->{Commit} $mi->{Info}\n";
3179         } else {
3180             printdebug sprintf " ReverseParents=%d Message=%s",
3181                 $mi->{ReverseParents}, $mi->{Message};
3182         }
3183     }
3184
3185     my $compat_info= pop @mergeinputs
3186         if $mergeinputs[$#mergeinputs]{Message};
3187
3188     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3189
3190     my $hash;
3191     if (@mergeinputs > 1) {
3192         # here we go, then:
3193         my $tree_commit = $mergeinputs[0]{Commit};
3194
3195         my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3196         $tree =~ m/\n\n/;  $tree = $`;
3197         $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3198         $tree = $1;
3199
3200         # We use the changelog author of the package in question the
3201         # author of this pseudo-merge.  This is (roughly) correct if
3202         # this commit is simply representing aa non-dgit upload.
3203         # (Roughly because it does not record sponsorship - but we
3204         # don't have sponsorship info because that's in the .changes,
3205         # which isn't in the archivw.)
3206         #
3207         # But, it might be that we are representing archive history
3208         # updates (including in-archive copies).  These are not really
3209         # the responsibility of the person who created the .dsc, but
3210         # there is no-one whose name we should better use.  (The
3211         # author of the .dsc-named commit is clearly worse.)
3212
3213         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3214         my $author = clogp_authline $useclogp;
3215         my $cversion = getfield $useclogp, 'Version';
3216
3217         my $mcf = dgit_privdir()."/mergecommit";
3218         open MC, ">", $mcf or die "$mcf $!";
3219         print MC <<END or die $!;
3220 tree $tree
3221 END
3222
3223         my @parents = grep { $_->{Commit} } @mergeinputs;
3224         @parents = reverse @parents if $compat_info->{ReverseParents};
3225         print MC <<END or die $! foreach @parents;
3226 parent $_->{Commit}
3227 END
3228
3229         print MC <<END or die $!;
3230 author $author
3231 committer $author
3232
3233 END
3234
3235         if (defined $compat_info->{Message}) {
3236             print MC $compat_info->{Message} or die $!;
3237         } else {
3238             print MC <<END or die $!;
3239 Record $package ($cversion) in archive suite $csuite
3240
3241 Record that
3242 END
3243             my $message_add_info = sub {
3244                 my ($mi) = (@_);
3245                 my $mversion = mergeinfo_version $mi;
3246                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
3247                     or die $!;
3248             };
3249
3250             $message_add_info->($mergeinputs[0]);
3251             print MC <<END or die $!;
3252 should be treated as descended from
3253 END
3254             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3255         }
3256
3257         close MC or die $!;
3258         $hash = make_commit $mcf;
3259     } else {
3260         $hash = $mergeinputs[0]{Commit};
3261     }
3262     printdebug "fetch hash=$hash\n";
3263
3264     my $chkff = sub {
3265         my ($lasth, $what) = @_;
3266         return unless $lasth;
3267         die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3268     };
3269
3270     $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3271         if $lastpush_hash;
3272     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3273
3274     fetch_from_archive_record_1($hash);
3275
3276     if (defined $skew_warning_vsn) {
3277         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3278         my $gotclogp = commit_getclogp($hash);
3279         my $got_vsn = getfield $gotclogp, 'Version';
3280         printdebug "SKEW CHECK GOT $got_vsn\n";
3281         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3282             print STDERR <<END or die $!;
3283
3284 Warning: archive skew detected.  Using the available version:
3285 Archive allegedly contains    $skew_warning_vsn
3286 We were able to obtain only   $got_vsn
3287
3288 END
3289         }
3290     }
3291
3292     if ($lastfetch_hash ne $hash) {
3293         fetch_from_archive_record_2($hash);
3294     }
3295
3296     lrfetchref_used lrfetchref();
3297
3298     check_gitattrs($hash, "fetched source tree");
3299
3300     unshift @end, $del_lrfetchrefs;
3301     return $hash;
3302 }
3303
3304 sub set_local_git_config ($$) {
3305     my ($k, $v) = @_;
3306     runcmd @git, qw(config), $k, $v;
3307 }
3308
3309 sub setup_mergechangelogs (;$) {
3310     my ($always) = @_;
3311     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3312
3313     my $driver = 'dpkg-mergechangelogs';
3314     my $cb = "merge.$driver";
3315     confess unless defined $maindir;
3316     my $attrs = "$maindir_gitcommon/info/attributes";
3317     ensuredir "$maindir_gitcommon/info";
3318
3319     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3320     if (!open ATTRS, "<", $attrs) {
3321         $!==ENOENT or die "$attrs: $!";
3322     } else {
3323         while (<ATTRS>) {
3324             chomp;
3325             next if m{^debian/changelog\s};
3326             print NATTRS $_, "\n" or die $!;
3327         }
3328         ATTRS->error and die $!;
3329         close ATTRS;
3330     }
3331     print NATTRS "debian/changelog merge=$driver\n" or die $!;
3332     close NATTRS;
3333
3334     set_local_git_config "$cb.name", 'debian/changelog merge driver';
3335     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3336
3337     rename "$attrs.new", "$attrs" or die "$attrs: $!";
3338 }
3339
3340 sub setup_useremail (;$) {
3341     my ($always) = @_;
3342     return unless $always || access_cfg_bool(1, 'setup-useremail');
3343
3344     my $setup = sub {
3345         my ($k, $envvar) = @_;
3346         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3347         return unless defined $v;
3348         set_local_git_config "user.$k", $v;
3349     };
3350
3351     $setup->('email', 'DEBEMAIL');
3352     $setup->('name', 'DEBFULLNAME');
3353 }
3354
3355 sub ensure_setup_existing_tree () {
3356     my $k = "remote.$remotename.skipdefaultupdate";
3357     my $c = git_get_config $k;
3358     return if defined $c;
3359     set_local_git_config $k, 'true';
3360 }
3361
3362 sub open_main_gitattrs () {
3363     confess 'internal error no maindir' unless defined $maindir;
3364     my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3365         or $!==ENOENT
3366         or die "open $maindir_gitcommon/info/attributes: $!";
3367     return $gai;
3368 }
3369
3370 sub is_gitattrs_setup () {
3371     my $gai = open_main_gitattrs();
3372     return 0 unless $gai;
3373     while (<$gai>) {
3374         return 1 if m{^\[attr\]dgit-defuse-attrs\s};
3375     }
3376     $gai->error and die $!;
3377     return 0;
3378 }
3379
3380 sub setup_gitattrs (;$) {
3381     my ($always) = @_;
3382     return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3383
3384     if (is_gitattrs_setup()) {
3385         progress <<END;
3386 [attr]dgit-defuse-attrs already found in .git/info/attributes
3387  not doing further gitattributes setup
3388 END
3389         return;
3390     }
3391     my $af = "$maindir_gitcommon/info/attributes";
3392     ensuredir "$maindir_gitcommon/info";
3393     open GAO, "> $af.new" or die $!;
3394     print GAO <<END or die $!;
3395 *       dgit-defuse-attrs
3396 [attr]dgit-defuse-attrs $negate_harmful_gitattrs
3397 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3398 END
3399     my $gai = open_main_gitattrs();
3400     if ($gai) {
3401         while (<$gai>) {
3402             chomp;
3403             print GAO $_, "\n" or die $!;
3404         }
3405         $gai->error and die $!;
3406     }
3407     close GAO or die $!;
3408     rename "$af.new", "$af" or die "install $af: $!";
3409 }
3410
3411 sub setup_new_tree () {
3412     setup_mergechangelogs();
3413     setup_useremail();
3414     setup_gitattrs();
3415 }
3416
3417 sub check_gitattrs ($$) {
3418     my ($treeish, $what) = @_;
3419
3420     return if is_gitattrs_setup;
3421
3422     local $/="\0";
3423     my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3424     debugcmd "|",@cmd;
3425     my $gafl = new IO::File;
3426     open $gafl, "-|", @cmd or die $!;
3427     while (<$gafl>) {
3428         chomp or die;
3429         s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3430         next if $1 == 0;
3431         next unless m{(?:^|/)\.gitattributes$};
3432
3433         # oh dear, found one
3434         print STDERR <<END;
3435 dgit: warning: $what contains .gitattributes
3436 dgit: .gitattributes have not been defused.  Recommended: dgit setup-new-tree.
3437 END
3438         close $gafl;
3439         return;
3440     }
3441     # tree contains no .gitattributes files
3442     $?=0; $!=0; close $gafl or failedcmd @cmd;
3443 }
3444
3445
3446 sub multisuite_suite_child ($$$) {
3447     my ($tsuite, $merginputs, $fn) = @_;
3448     # in child, sets things up, calls $fn->(), and returns undef
3449     # in parent, returns canonical suite name for $tsuite
3450     my $canonsuitefh = IO::File::new_tmpfile;
3451     my $pid = fork // die $!;
3452     if (!$pid) {
3453         forkcheck_setup();
3454         $isuite = $tsuite;
3455         $us .= " [$isuite]";
3456         $debugprefix .= " ";
3457         progress "fetching $tsuite...";
3458         canonicalise_suite();
3459         print $canonsuitefh $csuite, "\n" or die $!;
3460         close $canonsuitefh or die $!;
3461         $fn->();
3462         return undef;
3463     }
3464     waitpid $pid,0 == $pid or die $!;
3465     fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3466     seek $canonsuitefh,0,0 or die $!;
3467     local $csuite = <$canonsuitefh>;
3468     die $! unless defined $csuite && chomp $csuite;
3469     if ($? == 256*4) {
3470         printdebug "multisuite $tsuite missing\n";
3471         return $csuite;
3472     }
3473     printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3474     push @$merginputs, {
3475         Ref => lrref,
3476         Info => $csuite,
3477     };
3478     return $csuite;
3479 }
3480
3481 sub fork_for_multisuite ($) {
3482     my ($before_fetch_merge) = @_;
3483     # if nothing unusual, just returns ''
3484     #
3485     # if multisuite:
3486     # returns 0 to caller in child, to do first of the specified suites
3487     # in child, $csuite is not yet set
3488     #
3489     # returns 1 to caller in parent, to finish up anything needed after
3490     # in parent, $csuite is set to canonicalised portmanteau
3491
3492     my $org_isuite = $isuite;
3493     my @suites = split /\,/, $isuite;
3494     return '' unless @suites > 1;
3495     printdebug "fork_for_multisuite: @suites\n";
3496
3497     my @mergeinputs;
3498
3499     my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3500                                             sub { });
3501     return 0 unless defined $cbasesuite;
3502
3503     fail "package $package missing in (base suite) $cbasesuite"
3504         unless @mergeinputs;
3505
3506     my @csuites = ($cbasesuite);
3507
3508     $before_fetch_merge->();
3509
3510     foreach my $tsuite (@suites[1..$#suites]) {
3511         $tsuite =~ s/^-/$cbasesuite-/;
3512         my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3513                                                sub {
3514             @end = ();
3515             fetch();
3516             finish 0;
3517         });
3518         # xxx collecte the ref here
3519
3520         $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3521         push @csuites, $csubsuite;
3522     }
3523
3524     foreach my $mi (@mergeinputs) {
3525         my $ref = git_get_ref $mi->{Ref};
3526         die "$mi->{Ref} ?" unless length $ref;
3527         $mi->{Commit} = $ref;
3528     }
3529
3530     $csuite = join ",", @csuites;
3531
3532     my $previous = git_get_ref lrref;
3533     if ($previous) {
3534         unshift @mergeinputs, {
3535             Commit => $previous,
3536             Info => "local combined tracking branch",
3537             Warning =>
3538  "archive seems to have rewound: local tracking branch is ahead!",
3539         };
3540     }
3541
3542     foreach my $ix (0..$#mergeinputs) {
3543         $mergeinputs[$ix]{Index} = $ix;
3544     }
3545
3546     @mergeinputs = sort {
3547         -version_compare(mergeinfo_version $a,
3548                          mergeinfo_version $b) # highest version first
3549             or
3550         $a->{Index} <=> $b->{Index}; # earliest in spec first
3551     } @mergeinputs;
3552
3553     my @needed;
3554
3555   NEEDED:
3556     foreach my $mi (@mergeinputs) {
3557         printdebug "multisuite merge check $mi->{Info}\n";
3558         foreach my $previous (@needed) {
3559             next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3560             printdebug "multisuite merge un-needed $previous->{Info}\n";
3561             next NEEDED;
3562         }
3563         push @needed, $mi;
3564         printdebug "multisuite merge this-needed\n";
3565         $mi->{Character} = '+';
3566     }
3567
3568     $needed[0]{Character} = '*';
3569
3570     my $output = $needed[0]{Commit};
3571
3572     if (@needed > 1) {
3573         printdebug "multisuite merge nontrivial\n";
3574         my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3575
3576         my $commit = "tree $tree\n";
3577         my $msg = "Combine archive branches $csuite [dgit]\n\n".
3578             "Input branches:\n";
3579
3580         foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3581             printdebug "multisuite merge include $mi->{Info}\n";
3582             $mi->{Character} //= ' ';
3583             $commit .= "parent $mi->{Commit}\n";
3584             $msg .= sprintf " %s  %-25s %s\n",
3585                 $mi->{Character},
3586                 (mergeinfo_version $mi),
3587                 $mi->{Info};
3588         }
3589         my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3590         $msg .= "\nKey\n".
3591             " * marks the highest version branch, which choose to use\n".
3592             " + marks each branch which was not already an ancestor\n\n".
3593             "[dgit multi-suite $csuite]\n";
3594         $commit .=
3595             "author $authline\n".
3596             "committer $authline\n\n";
3597         $output = make_commit_text $commit.$msg;
3598         printdebug "multisuite merge generated $output\n";
3599     }
3600
3601     fetch_from_archive_record_1($output);
3602     fetch_from_archive_record_2($output);
3603
3604     progress "calculated combined tracking suite $csuite";
3605
3606     return 1;
3607 }
3608
3609 sub clone_set_head () {
3610     open H, "> .git/HEAD" or die $!;
3611     print H "ref: ".lref()."\n" or die $!;
3612     close H or die $!;
3613 }
3614 sub clone_finish ($) {
3615     my ($dstdir) = @_;
3616     runcmd @git, qw(reset --hard), lrref();
3617     runcmd qw(bash -ec), <<'END';
3618         set -o pipefail
3619         git ls-tree -r --name-only -z HEAD | \
3620         xargs -0r touch -h -r . --
3621 END
3622     printdone "ready for work in $dstdir";
3623 }
3624
3625 sub clone ($) {
3626     # in multisuite, returns twice!
3627     # once in parent after first suite fetched,
3628     # and then again in child after everything is finished
3629     my ($dstdir) = @_;
3630     badusage "dry run makes no sense with clone" unless act_local();
3631
3632     my $multi_fetched = fork_for_multisuite(sub {
3633         printdebug "multi clone before fetch merge\n";
3634         changedir $dstdir;
3635         record_maindir();
3636     });
3637     if ($multi_fetched) {
3638         printdebug "multi clone after fetch merge\n";
3639         clone_set_head();
3640         clone_finish($dstdir);
3641         return;
3642     }
3643     printdebug "clone main body\n";
3644
3645     canonicalise_suite();
3646     my $hasgit = check_for_git();
3647     mkdir $dstdir or fail "create \`$dstdir': $!";
3648     changedir $dstdir;
3649     runcmd @git, qw(init -q);
3650     record_maindir();
3651     setup_new_tree();
3652     clone_set_head();
3653     my $giturl = access_giturl(1);
3654     if (defined $giturl) {
3655         runcmd @git, qw(remote add), 'origin', $giturl;
3656     }
3657     if ($hasgit) {
3658         progress "fetching existing git history";
3659         git_fetch_us();
3660         runcmd_ordryrun_local @git, qw(fetch origin);
3661     } else {
3662         progress "starting new git history";
3663     }
3664     fetch_from_archive() or no_such_package;
3665     my $vcsgiturl = $dsc->{'Vcs-Git'};
3666     if (length $vcsgiturl) {
3667         $vcsgiturl =~ s/\s+-b\s+\S+//g;
3668         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3669     }
3670     clone_finish($dstdir);
3671 }
3672
3673 sub fetch () {
3674     canonicalise_suite();
3675     if (check_for_git()) {
3676         git_fetch_us();
3677     }
3678     fetch_from_archive() or no_such_package();
3679     printdone "fetched into ".lrref();
3680 }
3681
3682 sub pull () {
3683     my $multi_fetched = fork_for_multisuite(sub { });
3684     fetch() unless $multi_fetched; # parent
3685     return if $multi_fetched eq '0'; # child
3686     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3687         lrref();
3688     printdone "fetched to ".lrref()." and merged into HEAD";
3689 }
3690
3691 sub check_not_dirty () {
3692     foreach my $f (qw(local-options local-patch-header)) {
3693         if (stat_exists "debian/source/$f") {
3694             fail "git tree contains debian/source/$f";
3695         }
3696     }
3697
3698     return if $ignoredirty;
3699
3700     git_check_unmodified();
3701 }
3702
3703 sub commit_admin ($) {
3704     my ($m) = @_;
3705     progress "$m";
3706     runcmd_ordryrun_local @git, qw(commit -m), $m;
3707 }
3708
3709 sub quiltify_nofix_bail ($$) {
3710     my ($headinfo, $xinfo) = @_;
3711     if ($quilt_mode eq 'nofix') {
3712         fail "quilt fixup required but quilt mode is \`nofix'\n".
3713             "HEAD commit".$headinfo." differs from tree implied by ".
3714             " debian/patches".$xinfo;
3715     }
3716 }
3717
3718 sub commit_quilty_patch () {
3719     my $output = cmdoutput @git, qw(status --porcelain);
3720     my %adds;
3721     foreach my $l (split /\n/, $output) {
3722         next unless $l =~ m/\S/;
3723         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3724             $adds{$1}++;
3725         }
3726     }
3727     delete $adds{'.pc'}; # if there wasn't one before, don't add it
3728     if (!%adds) {
3729         progress "nothing quilty to commit, ok.";
3730         return;
3731     }
3732     quiltify_nofix_bail "", " (wanted to commit patch update)";
3733     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3734     runcmd_ordryrun_local @git, qw(add -f), @adds;
3735     commit_admin <<END
3736 Commit Debian 3.0 (quilt) metadata
3737
3738 [dgit ($our_version) quilt-fixup]
3739 END
3740 }
3741
3742 sub get_source_format () {
3743     my %options;
3744     if (open F, "debian/source/options") {
3745         while (<F>) {
3746             next if m/^\s*\#/;
3747             next unless m/\S/;
3748             s/\s+$//; # ignore missing final newline
3749             if (m/\s*\#\s*/) {
3750                 my ($k, $v) = ($`, $'); #');
3751                 $v =~ s/^"(.*)"$/$1/;
3752                 $options{$k} = $v;
3753             } else {
3754                 $options{$_} = 1;
3755             }
3756         }
3757         F->error and die $!;
3758         close F;
3759     } else {
3760         die $! unless $!==&ENOENT;
3761     }
3762
3763     if (!open F, "debian/source/format") {
3764         die $! unless $!==&ENOENT;
3765         return '';
3766     }
3767     $_ = <F>;
3768     F->error and die $!;
3769     chomp;
3770     return ($_, \%options);
3771 }
3772
3773 sub madformat_wantfixup ($) {
3774     my ($format) = @_;
3775     return 0 unless $format eq '3.0 (quilt)';
3776     our $quilt_mode_warned;
3777     if ($quilt_mode eq 'nocheck') {
3778         progress "Not doing any fixup of \`$format' due to".
3779             " ----no-quilt-fixup or --quilt=nocheck"
3780             unless $quilt_mode_warned++;
3781         return 0;
3782     }
3783     progress "Format \`$format', need to check/update patch stack"
3784         unless $quilt_mode_warned++;
3785     return 1;
3786 }
3787
3788 sub maybe_split_brain_save ($$$) {
3789     my ($headref, $dgitview, $msg) = @_;
3790     # => message fragment "$saved" describing disposition of $dgitview
3791     return "commit id $dgitview" unless defined $split_brain_save;
3792     my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3793                @git, qw(update-ref -m),
3794                "dgit --dgit-view-save $msg HEAD=$headref",
3795                $split_brain_save, $dgitview);
3796     runcmd @cmd;
3797     return "and left in $split_brain_save";
3798 }
3799
3800 # An "infopair" is a tuple [ $thing, $what ]
3801 # (often $thing is a commit hash; $what is a description)
3802
3803 sub infopair_cond_equal ($$) {
3804     my ($x,$y) = @_;
3805     $x->[0] eq $y->[0] or fail <<END;
3806 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3807 END
3808 };
3809
3810 sub infopair_lrf_tag_lookup ($$) {
3811     my ($tagnames, $what) = @_;
3812     # $tagname may be an array ref
3813     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3814     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3815     foreach my $tagname (@tagnames) {
3816         my $lrefname = lrfetchrefs."/tags/$tagname";
3817         my $tagobj = $lrfetchrefs_f{$lrefname};
3818         next unless defined $tagobj;
3819         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3820         return [ git_rev_parse($tagobj), $what ];
3821     }
3822     fail @tagnames==1 ? <<END : <<END;
3823 Wanted tag $what (@tagnames) on dgit server, but not found
3824 END
3825 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3826 END
3827 }
3828
3829 sub infopair_cond_ff ($$) {
3830     my ($anc,$desc) = @_;
3831     is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3832 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3833 END
3834 };
3835
3836 sub pseudomerge_version_check ($$) {
3837     my ($clogp, $archive_hash) = @_;
3838
3839     my $arch_clogp = commit_getclogp $archive_hash;
3840     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3841                      'version currently in archive' ];
3842     if (defined $overwrite_version) {
3843         if (length $overwrite_version) {
3844             infopair_cond_equal([ $overwrite_version,
3845                                   '--overwrite= version' ],
3846                                 $i_arch_v);
3847         } else {
3848             my $v = $i_arch_v->[0];
3849             progress "Checking package changelog for archive version $v ...";
3850             my $cd;
3851             eval {
3852                 my @xa = ("-f$v", "-t$v");
3853                 my $vclogp = parsechangelog @xa;
3854                 my $gf = sub {
3855                     my ($fn) = @_;
3856                     [ (getfield $vclogp, $fn),
3857                       "$fn field from dpkg-parsechangelog @xa" ];
3858                 };
3859                 my $cv = $gf->('Version');
3860                 infopair_cond_equal($i_arch_v, $cv);
3861                 $cd = $gf->('Distribution');
3862             };
3863             if ($@) {
3864                 $@ =~ s/^dgit: //gm;
3865                 fail "$@".
3866                     "Perhaps debian/changelog does not mention $v ?";
3867             }
3868             fail <<END if $cd->[0] =~ m/UNRELEASED/;
3869 $cd->[1] is $cd->[0]
3870 Your tree seems to based on earlier (not uploaded) $v.
3871 END
3872         }
3873     }
3874
3875     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3876     return $i_arch_v;
3877 }
3878
3879 sub pseudomerge_make_commit ($$$$ $$) {
3880     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3881         $msg_cmd, $msg_msg) = @_;
3882     progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3883
3884     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3885     my $authline = clogp_authline $clogp;
3886
3887     chomp $msg_msg;
3888     $msg_cmd .=
3889         !defined $overwrite_version ? ""
3890         : !length  $overwrite_version ? " --overwrite"
3891         : " --overwrite=".$overwrite_version;
3892
3893     # Contributing parent is the first parent - that makes
3894     # git rev-list --first-parent DTRT.
3895     my $pmf = dgit_privdir()."/pseudomerge";
3896     open MC, ">", $pmf or die "$pmf $!";
3897     print MC <<END or die $!;
3898 tree $tree
3899 parent $dgitview
3900 parent $archive_hash
3901 author $authline
3902 committer $authline
3903
3904 $msg_msg
3905
3906 [$msg_cmd]
3907 END
3908     close MC or die $!;
3909
3910     return make_commit($pmf);
3911 }
3912
3913 sub splitbrain_pseudomerge ($$$$) {
3914     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3915     # => $merged_dgitview
3916     printdebug "splitbrain_pseudomerge...\n";
3917     #
3918     #     We:      debian/PREVIOUS    HEAD($maintview)
3919     # expect:          o ----------------- o
3920     #                    \                   \
3921     #                     o                   o
3922     #                 a/d/PREVIOUS        $dgitview
3923     #                $archive_hash              \
3924     #  If so,                \                   \
3925     #  we do:                 `------------------ o
3926     #   this:                                   $dgitview'
3927     #
3928
3929     return $dgitview unless defined $archive_hash;
3930     return $dgitview if deliberately_not_fast_forward();
3931
3932     printdebug "splitbrain_pseudomerge...\n";
3933
3934     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3935
3936     if (!defined $overwrite_version) {
3937         progress "Checking that HEAD inciudes all changes in archive...";
3938     }
3939
3940     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3941
3942     if (defined $overwrite_version) {
3943     } elsif (!eval {
3944         my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3945         my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3946         my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3947         my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3948         my $i_archive = [ $archive_hash, "current archive contents" ];
3949
3950         printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3951
3952         infopair_cond_equal($i_dgit, $i_archive);
3953         infopair_cond_ff($i_dep14, $i_dgit);
3954         infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3955         1;
3956     }) {
3957         print STDERR <<END;
3958 $us: check failed (maybe --overwrite is needed, consult documentation)
3959 END
3960         die "$@";
3961     }
3962
3963     my $r = pseudomerge_make_commit
3964         $clogp, $dgitview, $archive_hash, $i_arch_v,
3965         "dgit --quilt=$quilt_mode",
3966         (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3967 Declare fast forward from $i_arch_v->[0]
3968 END_OVERWR
3969 Make fast forward from $i_arch_v->[0]
3970 END_MAKEFF
3971
3972     maybe_split_brain_save $maintview, $r, "pseudomerge";
3973
3974     progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3975     return $r;
3976 }
3977
3978 sub plain_overwrite_pseudomerge ($$$) {
3979     my ($clogp, $head, $archive_hash) = @_;
3980
3981     printdebug "plain_overwrite_pseudomerge...";
3982
3983     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3984
3985     return $head if is_fast_fwd $archive_hash, $head;
3986
3987     my $m = "Declare fast forward from $i_arch_v->[0]";
3988
3989     my $r = pseudomerge_make_commit
3990         $clogp, $head, $archive_hash, $i_arch_v,
3991         "dgit", $m;
3992
3993     runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3994
3995     progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3996     return $r;
3997 }
3998
3999 sub push_parse_changelog ($) {
4000     my ($clogpfn) = @_;
4001
4002     my $clogp = Dpkg::Control::Hash->new();
4003     $clogp->load($clogpfn) or die;
4004
4005     my $clogpackage = getfield $clogp, 'Source';
4006     $package //= $clogpackage;
4007     fail "-p specified $package but changelog specified $clogpackage"
4008         unless $package eq $clogpackage;
4009     my $cversion = getfield $clogp, 'Version';
4010
4011     if (!$we_are_initiator) {
4012         # rpush initiator can't do this because it doesn't have $isuite yet
4013         my $tag = debiantag($cversion, access_nomdistro);
4014         runcmd @git, qw(check-ref-format), $tag;
4015     }
4016
4017     my $dscfn = dscfn($cversion);
4018
4019     return ($clogp, $cversion, $dscfn);
4020 }
4021
4022 sub push_parse_dsc ($$$) {
4023     my ($dscfn,$dscfnwhat, $cversion) = @_;
4024     $dsc = parsecontrol($dscfn,$dscfnwhat);
4025     my $dversion = getfield $dsc, 'Version';
4026     my $dscpackage = getfield $dsc, 'Source';
4027     ($dscpackage eq $package && $dversion eq $cversion) or
4028         fail "$dscfn is for $dscpackage $dversion".
4029             " but debian/changelog is for $package $cversion";
4030 }
4031
4032 sub push_tagwants ($$$$) {
4033     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4034     my @tagwants;
4035     push @tagwants, {
4036         TagFn => \&debiantag,
4037         Objid => $dgithead,
4038         TfSuffix => '',
4039         View => 'dgit',
4040     };
4041     if (defined $maintviewhead) {
4042         push @tagwants, {
4043             TagFn => \&debiantag_maintview,
4044             Objid => $maintviewhead,
4045             TfSuffix => '-maintview',
4046             View => 'maint',
4047         };
4048     } elsif ($dodep14tag eq 'no' ? 0
4049              : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4050              : $dodep14tag eq 'always'
4051              ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4052 --dep14tag-always (or equivalent in config) means server must support
4053  both "new" and "maint" tag formats, but config says it doesn't.
4054 END
4055             : die "$dodep14tag ?") {
4056         push @tagwants, {
4057             TagFn => \&debiantag_maintview,
4058             Objid => $dgithead,
4059             TfSuffix => '-dgit',
4060             View => 'dgit',
4061         };
4062     };
4063     foreach my $tw (@tagwants) {
4064         $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4065         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4066     }
4067     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4068     return @tagwants;
4069 }
4070
4071 sub push_mktags ($$ $$ $) {
4072     my ($clogp,$dscfn,
4073         $changesfile,$changesfilewhat,
4074         $tagwants) = @_;
4075
4076     die unless $tagwants->[0]{View} eq 'dgit';
4077
4078     my $declaredistro = access_nomdistro();
4079     my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4080     $dsc->{$ourdscfield[0]} = join " ",
4081         $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4082         $reader_giturl;
4083     $dsc->save("$dscfn.tmp") or die $!;
4084
4085     my $changes = parsecontrol($changesfile,$changesfilewhat);
4086     foreach my $field (qw(Source Distribution Version)) {
4087         $changes->{$field} eq $clogp->{$field} or
4088             fail "changes field $field \`$changes->{$field}'".
4089                 " does not match changelog \`$clogp->{$field}'";
4090     }
4091
4092     my $cversion = getfield $clogp, 'Version';
4093     my $clogsuite = getfield $clogp, 'Distribution';
4094
4095     # We make the git tag by hand because (a) that makes it easier
4096     # to control the "tagger" (b) we can do remote signing
4097     my $authline = clogp_authline $clogp;
4098     my $delibs = join(" ", "",@deliberatelies);
4099
4100     my $mktag = sub {
4101         my ($tw) = @_;
4102         my $tfn = $tw->{Tfn};
4103         my $head = $tw->{Objid};
4104         my $tag = $tw->{Tag};
4105
4106         open TO, '>', $tfn->('.tmp') or die $!;
4107         print TO <<END or die $!;
4108 object $head
4109 type commit
4110 tag $tag
4111 tagger $authline
4112
4113 END
4114         if ($tw->{View} eq 'dgit') {
4115             print TO <<END or die $!;
4116 $package release $cversion for $clogsuite ($csuite) [dgit]
4117 [dgit distro=$declaredistro$delibs]
4118 END
4119             foreach my $ref (sort keys %previously) {
4120                 print TO <<END or die $!;
4121 [dgit previously:$ref=$previously{$ref}]
4122 END
4123             }
4124         } elsif ($tw->{View} eq 'maint') {
4125             print TO <<END or die $!;
4126 $package release $cversion for $clogsuite ($csuite)
4127 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4128 END
4129         } else {
4130             die Dumper($tw)."?";
4131         }
4132
4133         close TO or die $!;
4134
4135         my $tagobjfn = $tfn->('.tmp');
4136         if ($sign) {
4137             if (!defined $keyid) {
4138                 $keyid = access_cfg('keyid','RETURN-UNDEF');
4139             }
4140             if (!defined $keyid) {
4141                 $keyid = getfield $clogp, 'Maintainer';
4142             }
4143             unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4144             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4145             push @sign_cmd, qw(-u),$keyid if defined $keyid;
4146             push @sign_cmd, $tfn->('.tmp');
4147             runcmd_ordryrun @sign_cmd;
4148             if (act_scary()) {
4149                 $tagobjfn = $tfn->('.signed.tmp');
4150                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4151                     $tfn->('.tmp'), $tfn->('.tmp.asc');
4152             }
4153         }
4154         return $tagobjfn;
4155     };
4156
4157     my @r = map { $mktag->($_); } @$tagwants;
4158     return @r;
4159 }
4160
4161 sub sign_changes ($) {
4162     my ($changesfile) = @_;
4163     if ($sign) {
4164         my @debsign_cmd = @debsign;
4165         push @debsign_cmd, "-k$keyid" if defined $keyid;
4166         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4167         push @debsign_cmd, $changesfile;
4168         runcmd_ordryrun @debsign_cmd;
4169     }
4170 }
4171
4172 sub dopush () {
4173     printdebug "actually entering push\n";
4174
4175     supplementary_message(<<'END');
4176 Push failed, while checking state of the archive.
4177 You can retry the push, after fixing the problem, if you like.
4178 END
4179     if (check_for_git()) {
4180         git_fetch_us();
4181     }
4182     my $archive_hash = fetch_from_archive();
4183     if (!$archive_hash) {
4184         $new_package or
4185             fail "package appears to be new in this suite;".
4186                 " if this is intentional, use --new";
4187     }
4188
4189     supplementary_message(<<'END');
4190 Push failed, while preparing your push.
4191 You can retry the push, after fixing the problem, if you like.
4192 END
4193
4194     need_tagformat 'new', "quilt mode $quilt_mode"
4195         if quiltmode_splitbrain;
4196
4197     prep_ud();
4198
4199     access_giturl(); # check that success is vaguely likely
4200     rpush_handle_protovsn_bothends() if $we_are_initiator;
4201     select_tagformat();
4202
4203     my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4204     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4205
4206     responder_send_file('parsed-changelog', $clogpfn);
4207
4208     my ($clogp, $cversion, $dscfn) =
4209         push_parse_changelog("$clogpfn");
4210
4211     my $dscpath = "$buildproductsdir/$dscfn";
4212     stat_exists $dscpath or
4213         fail "looked for .dsc $dscpath, but $!;".
4214             " maybe you forgot to build";
4215
4216     responder_send_file('dsc', $dscpath);
4217
4218     push_parse_dsc($dscpath, $dscfn, $cversion);
4219
4220     my $format = getfield $dsc, 'Format';
4221     printdebug "format $format\n";
4222
4223     my $actualhead = git_rev_parse('HEAD');
4224     my $dgithead = $actualhead;
4225     my $maintviewhead = undef;
4226
4227     my $upstreamversion = upstreamversion $clogp->{Version};
4228
4229     if (madformat_wantfixup($format)) {
4230         # user might have not used dgit build, so maybe do this now:
4231         if (quiltmode_splitbrain()) {
4232             changedir $playground;
4233             quilt_make_fake_dsc($upstreamversion);
4234             my $cachekey;
4235             ($dgithead, $cachekey) =
4236                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4237             $dgithead or fail
4238  "--quilt=$quilt_mode but no cached dgit view:
4239  perhaps HEAD changed since dgit build[-source] ?";
4240             $split_brain = 1;
4241             $dgithead = splitbrain_pseudomerge($clogp,
4242                                                $actualhead, $dgithead,
4243                                                $archive_hash);
4244             $maintviewhead = $actualhead;
4245             changedir $maindir;
4246             prep_ud(); # so _only_subdir() works, below
4247         } else {
4248             commit_quilty_patch();
4249         }
4250     }
4251
4252     if (defined $overwrite_version && !defined $maintviewhead) {
4253         $dgithead = plain_overwrite_pseudomerge($clogp,
4254                                                 $dgithead,
4255                                                 $archive_hash);
4256     }
4257
4258     check_not_dirty();
4259
4260     my $forceflag = '';
4261     if ($archive_hash) {
4262         if (is_fast_fwd($archive_hash, $dgithead)) {
4263             # ok
4264         } elsif (deliberately_not_fast_forward) {
4265             $forceflag = '+';
4266         } else {
4267             fail "dgit push: HEAD is not a descendant".
4268                 " of the archive's version.\n".
4269                 "To overwrite the archive's contents,".
4270                 " pass --overwrite[=VERSION].\n".
4271                 "To rewind history, if permitted by the archive,".
4272                 " use --deliberately-not-fast-forward.";
4273         }
4274     }
4275
4276     changedir $playground;
4277     progress "checking that $dscfn corresponds to HEAD";
4278     runcmd qw(dpkg-source -x --),
4279         $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4280     my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4281     check_for_vendor_patches() if madformat($dsc->{format});
4282     changedir $maindir;
4283     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4284     debugcmd "+",@diffcmd;
4285     $!=0; $?=-1;
4286     my $r = system @diffcmd;
4287     if ($r) {
4288         if ($r==256) {
4289             my $referent = $split_brain ? $dgithead : 'HEAD';
4290             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4291
4292             my @mode_changes;
4293             my $raw = cmdoutput @git,
4294                 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4295             my $changed;
4296             foreach (split /\0/, $raw) {
4297                 if (defined $changed) {
4298                     push @mode_changes, "$changed: $_\n" if $changed;
4299                     $changed = undef;
4300                     next;
4301                 } elsif (m/^:0+ 0+ /) {
4302                     $changed = '';
4303                 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4304                     $changed = "Mode change from $1 to $2"
4305                 } else {
4306                     die "$_ ?";
4307                 }
4308             }
4309             if (@mode_changes) {
4310                 fail <<END.(join '', @mode_changes).<<END;
4311 HEAD specifies a different tree to $dscfn:
4312 $diffs
4313 END
4314 There is a problem with your source tree (see dgit(7) for some hints).
4315 To see a full diff, run git diff $tree $referent
4316 END
4317             }
4318
4319             fail <<END;
4320 HEAD specifies a different tree to $dscfn:
4321 $diffs
4322 Perhaps you forgot to build.  Or perhaps there is a problem with your
4323  source tree (see dgit(7) for some hints).  To see a full diff, run
4324    git diff $tree $referent
4325 END
4326         } else {
4327             failedcmd @diffcmd;
4328         }
4329     }
4330     if (!$changesfile) {
4331         my $pat = changespat $cversion;
4332         my @cs = glob "$buildproductsdir/$pat";
4333         fail "failed to find unique changes file".
4334             " (looked for $pat in $buildproductsdir);".
4335             " perhaps you need to use dgit -C"
4336             unless @cs==1;
4337         ($changesfile) = @cs;
4338     } else {
4339         $changesfile = "$buildproductsdir/$changesfile";
4340     }
4341
4342     # Check that changes and .dsc agree enough
4343     $changesfile =~ m{[^/]*$};
4344     my $changes = parsecontrol($changesfile,$&);
4345     files_compare_inputs($dsc, $changes)
4346         unless forceing [qw(dsc-changes-mismatch)];
4347
4348     # Perhaps adjust .dsc to contain right set of origs
4349     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4350                                   $changesfile)
4351         unless forceing [qw(changes-origs-exactly)];
4352
4353     # Checks complete, we're going to try and go ahead:
4354
4355     responder_send_file('changes',$changesfile);
4356     responder_send_command("param head $dgithead");
4357     responder_send_command("param csuite $csuite");
4358     responder_send_command("param isuite $isuite");
4359     responder_send_command("param tagformat $tagformat");
4360     if (defined $maintviewhead) {
4361         die unless ($protovsn//4) >= 4;
4362         responder_send_command("param maint-view $maintviewhead");
4363     }
4364
4365     # Perhaps send buildinfo(s) for signing
4366     my $changes_files = getfield $changes, 'Files';
4367     my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4368     foreach my $bi (@buildinfos) {
4369         responder_send_command("param buildinfo-filename $bi");
4370         responder_send_file('buildinfo', "$buildproductsdir/$bi");
4371     }
4372
4373     if (deliberately_not_fast_forward) {
4374         git_for_each_ref(lrfetchrefs, sub {
4375             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4376             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4377             responder_send_command("previously $rrefname=$objid");
4378             $previously{$rrefname} = $objid;
4379         });
4380     }
4381
4382     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4383                                  dgit_privdir()."/tag");
4384     my @tagobjfns;
4385
4386     supplementary_message(<<'END');
4387 Push failed, while signing the tag.
4388 You can retry the push, after fixing the problem, if you like.
4389 END
4390     # If we manage to sign but fail to record it anywhere, it's fine.
4391     if ($we_are_responder) {
4392         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4393         responder_receive_files('signed-tag', @tagobjfns);
4394     } else {
4395         @tagobjfns = push_mktags($clogp,$dscpath,
4396                               $changesfile,$changesfile,
4397                               \@tagwants);
4398     }
4399     supplementary_message(<<'END');
4400 Push failed, *after* signing the tag.
4401 If you want to try again, you should use a new version number.
4402 END
4403
4404     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4405
4406     foreach my $tw (@tagwants) {
4407         my $tag = $tw->{Tag};
4408         my $tagobjfn = $tw->{TagObjFn};
4409         my $tag_obj_hash =
4410             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4411         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4412         runcmd_ordryrun_local
4413             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4414     }
4415
4416     supplementary_message(<<'END');
4417 Push failed, while updating the remote git repository - see messages above.
4418 If you want to try again, you should use a new version number.
4419 END
4420     if (!check_for_git()) {
4421         create_remote_git_repo();
4422     }
4423
4424     my @pushrefs = $forceflag.$dgithead.":".rrref();
4425     foreach my $tw (@tagwants) {
4426         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4427     }
4428
4429     runcmd_ordryrun @git,
4430         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4431     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
4432
4433     supplementary_message(<<'END');
4434 Push failed, while obtaining signatures on the .changes and .dsc.
4435 If it was just that the signature failed, you may try again by using
4436 debsign by hand to sign the changes
4437    $changesfile
4438 and then dput to complete the upload.
4439 If you need to change the package, you must use a new version number.
4440 END
4441     if ($we_are_responder) {
4442         my $dryrunsuffix = act_local() ? "" : ".tmp";
4443         my @rfiles = ($dscpath, $changesfile);
4444         push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4445         responder_receive_files('signed-dsc-changes',
4446                                 map { "$_$dryrunsuffix" } @rfiles);
4447     } else {
4448         if (act_local()) {
4449             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4450         } else {
4451             progress "[new .dsc left in $dscpath.tmp]";
4452         }
4453         sign_changes $changesfile;
4454     }
4455
4456     supplementary_message(<<END);
4457 Push failed, while uploading package(s) to the archive server.
4458 You can retry the upload of exactly these same files with dput of:
4459   $changesfile
4460 If that .changes file is broken, you will need to use a new version
4461 number for your next attempt at the upload.
4462 END
4463     my $host = access_cfg('upload-host','RETURN-UNDEF');
4464     my @hostarg = defined($host) ? ($host,) : ();
4465     runcmd_ordryrun @dput, @hostarg, $changesfile;
4466     printdone "pushed and uploaded $cversion";
4467
4468     supplementary_message('');
4469     responder_send_command("complete");
4470 }
4471
4472 sub pre_clone () {
4473     not_necessarily_a_tree();
4474 }
4475 sub cmd_clone {
4476     parseopts();
4477     my $dstdir;
4478     badusage "-p is not allowed with clone; specify as argument instead"
4479         if defined $package;
4480     if (@ARGV==1) {
4481         ($package) = @ARGV;
4482     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4483         ($package,$isuite) = @ARGV;
4484     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4485         ($package,$dstdir) = @ARGV;
4486     } elsif (@ARGV==3) {
4487         ($package,$isuite,$dstdir) = @ARGV;
4488     } else {
4489         badusage "incorrect arguments to dgit clone";
4490     }
4491     notpushing();
4492
4493     $dstdir ||= "$package";
4494     if (stat_exists $dstdir) {
4495         fail "$dstdir already exists";
4496     }
4497
4498     my $cwd_remove;
4499     if ($rmonerror && !$dryrun_level) {
4500         $cwd_remove= getcwd();
4501         unshift @end, sub {
4502             return unless defined $cwd_remove;
4503             if (!chdir "$cwd_remove") {
4504                 return if $!==&ENOENT;
4505                 die "chdir $cwd_remove: $!";
4506             }
4507             printdebug "clone rmonerror removing $dstdir\n";
4508             if (stat $dstdir) {
4509                 rmtree($dstdir) or die "remove $dstdir: $!\n";
4510             } elsif (grep { $! == $_ }
4511                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4512             } else {
4513                 print STDERR "check whether to remove $dstdir: $!\n";
4514             }
4515         };
4516     }
4517
4518     clone($dstdir);
4519     $cwd_remove = undef;
4520 }
4521
4522 sub branchsuite () {
4523     my $branch = git_get_symref();
4524     if (defined $branch && $branch =~ m#$lbranch_re#o) {
4525         return $1;
4526     } else {
4527         return undef;
4528     }
4529 }
4530
4531 sub fetchpullargs () {
4532     if (!defined $package) {
4533         my $sourcep = parsecontrol('debian/control','debian/control');
4534         $package = getfield $sourcep, 'Source';
4535     }
4536     if (@ARGV==0) {
4537         $isuite = branchsuite();
4538         if (!$isuite) {
4539             my $clogp = parsechangelog();
4540             my $clogsuite = getfield $clogp, 'Distribution';
4541             $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4542         }
4543     } elsif (@ARGV==1) {
4544         ($isuite) = @ARGV;
4545     } else {
4546         badusage "incorrect arguments to dgit fetch or dgit pull";
4547     }
4548     notpushing();
4549 }
4550
4551 sub cmd_fetch {
4552     parseopts();
4553     fetchpullargs();
4554     my $multi_fetched = fork_for_multisuite(sub { });
4555     finish 0 if $multi_fetched;
4556     fetch();
4557 }
4558
4559 sub cmd_pull {
4560     parseopts();
4561     fetchpullargs();
4562     if (quiltmode_splitbrain()) {
4563         my ($format, $fopts) = get_source_format();
4564         madformat($format) and fail <<END
4565 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4566 END
4567     }
4568     pull();
4569 }
4570
4571 sub prep_push () {
4572     parseopts();
4573     build_or_push_prep_early();
4574     pushing();
4575     check_not_dirty();
4576     my $specsuite;
4577     if (@ARGV==0) {
4578     } elsif (@ARGV==1) {
4579         ($specsuite) = (@ARGV);
4580     } else {
4581         badusage "incorrect arguments to dgit $subcommand";
4582     }
4583     if ($new_package) {
4584         local ($package) = $existing_package; # this is a hack
4585         canonicalise_suite();
4586     } else {
4587         canonicalise_suite();
4588     }
4589     if (defined $specsuite &&
4590         $specsuite ne $isuite &&
4591         $specsuite ne $csuite) {
4592             fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4593                 " but command line specifies $specsuite";
4594     }
4595 }
4596
4597 sub cmd_push {
4598     prep_push();
4599     dopush();
4600 }
4601
4602 sub cmd_push_source {
4603     prep_push();
4604     if ($changesfile) {
4605         my $changes = parsecontrol("$buildproductsdir/$changesfile",
4606                                    "source changes file");
4607         unless (test_source_only_changes($changes)) {
4608             fail "user-specified changes file is not source-only";
4609         }
4610     } else {
4611         # Building a source package is very fast, so just do it
4612         build_source_for_push();
4613     }
4614     dopush();
4615 }
4616
4617 #---------- remote commands' implementation ----------
4618
4619 sub pre_remote_push_build_host {
4620     my ($nrargs) = shift @ARGV;
4621     my (@rargs) = @ARGV[0..$nrargs-1];
4622     @ARGV = @ARGV[$nrargs..$#ARGV];
4623     die unless @rargs;
4624     my ($dir,$vsnwant) = @rargs;
4625     # vsnwant is a comma-separated list; we report which we have
4626     # chosen in our ready response (so other end can tell if they
4627     # offered several)
4628     $debugprefix = ' ';
4629     $we_are_responder = 1;
4630     $us .= " (build host)";
4631
4632     open PI, "<&STDIN" or die $!;
4633     open STDIN, "/dev/null" or die $!;
4634     open PO, ">&STDOUT" or die $!;
4635     autoflush PO 1;
4636     open STDOUT, ">&STDERR" or die $!;
4637     autoflush STDOUT 1;
4638
4639     $vsnwant //= 1;
4640     ($protovsn) = grep {
4641         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4642     } @rpushprotovsn_support;
4643
4644     fail "build host has dgit rpush protocol versions ".
4645         (join ",", @rpushprotovsn_support).
4646         " but invocation host has $vsnwant"
4647         unless defined $protovsn;
4648
4649     changedir $dir;
4650 }
4651 sub cmd_remote_push_build_host {
4652     responder_send_command("dgit-remote-push-ready $protovsn");
4653     &cmd_push;
4654 }
4655
4656 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4657 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4658 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4659 #     a good error message)
4660
4661 sub rpush_handle_protovsn_bothends () {
4662     if ($protovsn < 4) {
4663         need_tagformat 'old', "rpush negotiated protocol $protovsn";
4664     }
4665     select_tagformat();
4666 }
4667
4668 our $i_tmp;
4669
4670 sub i_cleanup {
4671     local ($@, $?);
4672     my $report = i_child_report();
4673     if (defined $report) {
4674         printdebug "($report)\n";
4675     } elsif ($i_child_pid) {
4676         printdebug "(killing build host child $i_child_pid)\n";
4677         kill 15, $i_child_pid;
4678     }
4679     if (defined $i_tmp && !defined $initiator_tempdir) {
4680         changedir "/";
4681         eval { rmtree $i_tmp; };
4682     }
4683 }
4684
4685 END {
4686     return unless forkcheck_mainprocess();
4687     i_cleanup();
4688 }
4689
4690 sub i_method {
4691     my ($base,$selector,@args) = @_;
4692     $selector =~ s/\-/_/g;
4693     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4694 }
4695
4696 sub pre_rpush () {
4697     not_necessarily_a_tree();
4698 }
4699 sub cmd_rpush {
4700     my $host = nextarg;
4701     my $dir;
4702     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4703         $host = $1;
4704         $dir = $'; #';
4705     } else {
4706         $dir = nextarg;
4707     }
4708     $dir =~ s{^-}{./-};
4709     my @rargs = ($dir);
4710     push @rargs, join ",", @rpushprotovsn_support;
4711     my @rdgit;
4712     push @rdgit, @dgit;
4713     push @rdgit, @ropts;
4714     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4715     push @rdgit, @ARGV;
4716     my @cmd = (@ssh, $host, shellquote @rdgit);
4717     debugcmd "+",@cmd;
4718
4719     $we_are_initiator=1;
4720
4721     if (defined $initiator_tempdir) {
4722         rmtree $initiator_tempdir;
4723         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4724         $i_tmp = $initiator_tempdir;
4725     } else {
4726         $i_tmp = tempdir();
4727     }
4728     $i_child_pid = open2(\*RO, \*RI, @cmd);
4729     changedir $i_tmp;
4730     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4731     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4732     $supplementary_message = '' unless $protovsn >= 3;
4733
4734     for (;;) {
4735         my ($icmd,$iargs) = initiator_expect {
4736             m/^(\S+)(?: (.*))?$/;
4737             ($1,$2);
4738         };
4739         i_method "i_resp", $icmd, $iargs;
4740     }
4741 }
4742
4743 sub i_resp_progress ($) {
4744     my ($rhs) = @_;
4745     my $msg = protocol_read_bytes \*RO, $rhs;
4746     progress $msg;
4747 }
4748
4749 sub i_resp_supplementary_message ($) {
4750     my ($rhs) = @_;
4751     $supplementary_message = protocol_read_bytes \*RO, $rhs;
4752 }
4753
4754 sub i_resp_complete {
4755     my $pid = $i_child_pid;
4756     $i_child_pid = undef; # prevents killing some other process with same pid
4757     printdebug "waiting for build host child $pid...\n";
4758     my $got = waitpid $pid, 0;
4759     die $! unless $got == $pid;
4760     die "build host child failed $?" if $?;
4761
4762     i_cleanup();
4763     printdebug "all done\n";
4764     finish 0;
4765 }
4766
4767 sub i_resp_file ($) {
4768     my ($keyword) = @_;
4769     my $localname = i_method "i_localname", $keyword;
4770     my $localpath = "$i_tmp/$localname";
4771     stat_exists $localpath and
4772         badproto \*RO, "file $keyword ($localpath) twice";
4773     protocol_receive_file \*RO, $localpath;
4774     i_method "i_file", $keyword;
4775 }
4776
4777 our %i_param;
4778
4779 sub i_resp_param ($) {
4780     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4781     $i_param{$1} = $2;
4782 }
4783
4784 sub i_resp_previously ($) {
4785     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4786         or badproto \*RO, "bad previously spec";
4787     my $r = system qw(git check-ref-format), $1;
4788     die "bad previously ref spec ($r)" if $r;
4789     $previously{$1} = $2;
4790 }
4791
4792 our %i_wanted;
4793
4794 sub i_resp_want ($) {
4795     my ($keyword) = @_;
4796     die "$keyword ?" if $i_wanted{$keyword}++;
4797
4798     defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4799     $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4800     die unless $isuite =~ m/^$suite_re$/;
4801
4802     pushing();
4803     rpush_handle_protovsn_bothends();
4804
4805     fail "rpush negotiated protocol version $protovsn".
4806         " which does not support quilt mode $quilt_mode"
4807         if quiltmode_splitbrain;
4808
4809     my @localpaths = i_method "i_want", $keyword;
4810     printdebug "[[  $keyword @localpaths\n";
4811     foreach my $localpath (@localpaths) {
4812         protocol_send_file \*RI, $localpath;
4813     }
4814     print RI "files-end\n" or die $!;
4815 }
4816
4817 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
4818
4819 sub i_localname_parsed_changelog {
4820     return "remote-changelog.822";
4821 }
4822 sub i_file_parsed_changelog {
4823     ($i_clogp, $i_version, $i_dscfn) =
4824         push_parse_changelog "$i_tmp/remote-changelog.822";
4825     die if $i_dscfn =~ m#/|^\W#;
4826 }
4827
4828 sub i_localname_dsc {
4829     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4830     return $i_dscfn;
4831 }
4832 sub i_file_dsc { }
4833
4834 sub i_localname_buildinfo ($) {
4835     my $bi = $i_param{'buildinfo-filename'};
4836     defined $bi or badproto \*RO, "buildinfo before filename";
4837     defined $i_changesfn or badproto \*RO, "buildinfo before changes";
4838     $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
4839         or badproto \*RO, "improper buildinfo filename";
4840     return $&;
4841 }
4842 sub i_file_buildinfo {
4843     my $bi = $i_param{'buildinfo-filename'};
4844     my $bd = parsecontrol "$i_tmp/$bi", $bi;
4845     my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
4846     if (!forceing [qw(buildinfo-changes-mismatch)]) {
4847         files_compare_inputs($bd, $ch);
4848         (getfield $bd, $_) eq (getfield $ch, $_) or
4849             fail "buildinfo mismatch $_"
4850             foreach qw(Source Version);
4851         !defined $bd->{$_} or
4852             fail "buildinfo contains $_"
4853             foreach qw(Changes Changed-by Distribution);
4854     }
4855     push @i_buildinfos, $bi;
4856     delete $i_param{'buildinfo-filename'};
4857 }
4858
4859 sub i_localname_changes {
4860     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4861     $i_changesfn = $i_dscfn;
4862     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4863     return $i_changesfn;
4864 }
4865 sub i_file_changes { }
4866
4867 sub i_want_signed_tag {
4868     printdebug Dumper(\%i_param, $i_dscfn);
4869     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4870         && defined $i_param{'csuite'}
4871         or badproto \*RO, "premature desire for signed-tag";
4872     my $head = $i_param{'head'};
4873     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4874
4875     my $maintview = $i_param{'maint-view'};
4876     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4877
4878     select_tagformat();
4879     if ($protovsn >= 4) {
4880         my $p = $i_param{'tagformat'} // '<undef>';
4881         $p eq $tagformat
4882             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4883     }
4884
4885     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4886     $csuite = $&;
4887     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4888
4889     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4890
4891     return
4892         push_mktags $i_clogp, $i_dscfn,
4893             $i_changesfn, 'remote changes',
4894             \@tagwants;
4895 }
4896
4897 sub i_want_signed_dsc_changes {
4898     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4899     sign_changes $i_changesfn;
4900     return ($i_dscfn, $i_changesfn, @i_buildinfos);
4901 }
4902
4903 #---------- building etc. ----------
4904
4905 our $version;
4906 our $sourcechanges;
4907 our $dscfn;
4908
4909 #----- `3.0 (quilt)' handling -----
4910
4911 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4912
4913 sub quiltify_dpkg_commit ($$$;$) {
4914     my ($patchname,$author,$msg, $xinfo) = @_;
4915     $xinfo //= '';
4916
4917     mkpath '.git/dgit'; # we are in playtree
4918     my $descfn = ".git/dgit/quilt-description.tmp";
4919     open O, '>', $descfn or die "$descfn: $!";
4920     $msg =~ s/\n+/\n\n/;
4921     print O <<END or die $!;
4922 From: $author
4923 ${xinfo}Subject: $msg
4924 ---
4925
4926 END
4927     close O or die $!;
4928
4929     {
4930         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4931         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4932         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4933         runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4934     }
4935 }
4936
4937 sub quiltify_trees_differ ($$;$$$) {
4938     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4939     # returns true iff the two tree objects differ other than in debian/
4940     # with $finegrained,
4941     # returns bitmask 01 - differ in upstream files except .gitignore
4942     #                 02 - differ in .gitignore
4943     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4944     #  is set for each modified .gitignore filename $fn
4945     # if $unrepres is defined, array ref to which is appeneded
4946     #  a list of unrepresentable changes (removals of upstream files
4947     #  (as messages)
4948     local $/=undef;
4949     my @cmd = (@git, qw(diff-tree -z --no-renames));
4950     push @cmd, qw(--name-only) unless $unrepres;
4951     push @cmd, qw(-r) if $finegrained || $unrepres;
4952     push @cmd, $x, $y;
4953     my $diffs= cmdoutput @cmd;
4954     my $r = 0;
4955     my @lmodes;
4956     foreach my $f (split /\0/, $diffs) {
4957         if ($unrepres && !@lmodes) {
4958             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4959             next;
4960         }
4961         my ($oldmode,$newmode) = @lmodes;
4962         @lmodes = ();
4963
4964         next if $f =~ m#^debian(?:/.*)?$#s;
4965
4966         if ($unrepres) {
4967             eval {
4968                 die "not a plain file or symlink\n"
4969                     unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
4970                            $oldmode =~ m/^(?:10|12)\d{4}$/;
4971                 if ($oldmode =~ m/[^0]/ &&
4972                     $newmode =~ m/[^0]/) {
4973                     # both old and new files exist
4974                     die "mode or type changed\n" if $oldmode ne $newmode;
4975                     die "modified symlink\n" unless $newmode =~ m/^10/;
4976                 } elsif ($oldmode =~ m/[^0]/) {
4977                     # deletion
4978                     die "deletion of symlink\n"
4979                         unless $oldmode =~ m/^10/;
4980                 } else {
4981                     # creation
4982                     die "creation with non-default mode\n"
4983                         unless $newmode =~ m/^100644$/ or
4984                                $newmode =~ m/^120000$/;
4985                 }
4986             };
4987             if ($@) {
4988                 local $/="\n"; chomp $@;
4989                 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4990             }
4991         }
4992
4993         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4994         $r |= $isignore ? 02 : 01;
4995         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4996     }
4997     printdebug "quiltify_trees_differ $x $y => $r\n";
4998     return $r;
4999 }
5000
5001 sub quiltify_tree_sentinelfiles ($) {
5002     # lists the `sentinel' files present in the tree
5003     my ($x) = @_;
5004     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5005         qw(-- debian/rules debian/control);
5006     $r =~ s/\n/,/g;
5007     return $r;
5008 }
5009
5010 sub quiltify_splitbrain_needed () {
5011     if (!$split_brain) {
5012         progress "dgit view: changes are required...";
5013         runcmd @git, qw(checkout -q -b dgit-view);
5014         $split_brain = 1;
5015     }
5016 }
5017
5018 sub quiltify_splitbrain ($$$$$$) {
5019     my ($clogp, $unapplied, $headref, $diffbits,
5020         $editedignores, $cachekey) = @_;
5021     if ($quilt_mode !~ m/gbp|dpm/) {
5022         # treat .gitignore just like any other upstream file
5023         $diffbits = { %$diffbits };
5024         $_ = !!$_ foreach values %$diffbits;
5025     }
5026     # We would like any commits we generate to be reproducible
5027     my @authline = clogp_authline($clogp);
5028     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
5029     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5030     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
5031     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
5032     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5033     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
5034
5035     if ($quilt_mode =~ m/gbp|unapplied/ &&
5036         ($diffbits->{O2H} & 01)) {
5037         my $msg =
5038  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5039  " but git tree differs from orig in upstream files.";
5040         if (!stat_exists "debian/patches") {
5041             $msg .=
5042  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5043         }
5044         fail $msg;
5045     }
5046     if ($quilt_mode =~ m/dpm/ &&
5047         ($diffbits->{H2A} & 01)) {
5048         fail <<END;
5049 --quilt=$quilt_mode specified, implying patches-applied git tree
5050  but git tree differs from result of applying debian/patches to upstream
5051 END
5052     }
5053     if ($quilt_mode =~ m/gbp|unapplied/ &&
5054         ($diffbits->{O2A} & 01)) { # some patches
5055         quiltify_splitbrain_needed();
5056         progress "dgit view: creating patches-applied version using gbp pq";
5057         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5058         # gbp pq import creates a fresh branch; push back to dgit-view
5059         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5060         runcmd @git, qw(checkout -q dgit-view);
5061     }
5062     if ($quilt_mode =~ m/gbp|dpm/ &&
5063         ($diffbits->{O2A} & 02)) {
5064         fail <<END
5065 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5066  tool which does not create patches for changes to upstream
5067  .gitignores: but, such patches exist in debian/patches.
5068 END
5069     }
5070     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5071         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5072         quiltify_splitbrain_needed();
5073         progress "dgit view: creating patch to represent .gitignore changes";
5074         ensuredir "debian/patches";
5075         my $gipatch = "debian/patches/auto-gitignore";
5076         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5077         stat GIPATCH or die "$gipatch: $!";
5078         fail "$gipatch already exists; but want to create it".
5079             " to record .gitignore changes" if (stat _)[7];
5080         print GIPATCH <<END or die "$gipatch: $!";
5081 Subject: Update .gitignore from Debian packaging branch
5082
5083 The Debian packaging git branch contains these updates to the upstream
5084 .gitignore file(s).  This patch is autogenerated, to provide these
5085 updates to users of the official Debian archive view of the package.
5086
5087 [dgit ($our_version) update-gitignore]
5088 ---
5089 END
5090         close GIPATCH or die "$gipatch: $!";
5091         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5092             $unapplied, $headref, "--", sort keys %$editedignores;
5093         open SERIES, "+>>", "debian/patches/series" or die $!;
5094         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5095         my $newline;
5096         defined read SERIES, $newline, 1 or die $!;
5097         print SERIES "\n" or die $! unless $newline eq "\n";
5098         print SERIES "auto-gitignore\n" or die $!;
5099         close SERIES or die  $!;
5100         runcmd @git, qw(add -- debian/patches/series), $gipatch;
5101         commit_admin <<END
5102 Commit patch to update .gitignore
5103
5104 [dgit ($our_version) update-gitignore-quilt-fixup]
5105 END
5106     }
5107
5108     my $dgitview = git_rev_parse 'HEAD';
5109
5110     changedir $maindir;
5111     # When we no longer need to support squeeze, use --create-reflog
5112     # instead of this:
5113     ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
5114     my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>'
5115       or die $!;
5116
5117     my $oldcache = git_get_ref "refs/$splitbraincache";
5118     if ($oldcache eq $dgitview) {
5119         my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5120         # git update-ref doesn't always update, in this case.  *sigh*
5121         my $dummy = make_commit_text <<END;
5122 tree $tree
5123 parent $dgitview
5124 author Dgit <dgit\@example.com> 1000000000 +0000
5125 committer Dgit <dgit\@example.com> 1000000000 +0000
5126
5127 Dummy commit - do not use
5128 END
5129         runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5130             "refs/$splitbraincache", $dummy;
5131     }
5132     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5133         $dgitview;
5134
5135     changedir "$playground/work";
5136
5137     my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5138     progress "dgit view: created ($saved)";
5139 }
5140
5141 sub quiltify ($$$$) {
5142     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5143
5144     # Quilt patchification algorithm
5145     #
5146     # We search backwards through the history of the main tree's HEAD
5147     # (T) looking for a start commit S whose tree object is identical
5148     # to to the patch tip tree (ie the tree corresponding to the
5149     # current dpkg-committed patch series).  For these purposes
5150     # `identical' disregards anything in debian/ - this wrinkle is
5151     # necessary because dpkg-source treates debian/ specially.
5152     #
5153     # We can only traverse edges where at most one of the ancestors'
5154     # trees differs (in changes outside in debian/).  And we cannot
5155     # handle edges which change .pc/ or debian/patches.  To avoid
5156     # going down a rathole we avoid traversing edges which introduce
5157     # debian/rules or debian/control.  And we set a limit on the
5158     # number of edges we are willing to look at.
5159     #
5160     # If we succeed, we walk forwards again.  For each traversed edge
5161     # PC (with P parent, C child) (starting with P=S and ending with
5162     # C=T) to we do this:
5163     #  - git checkout C
5164     #  - dpkg-source --commit with a patch name and message derived from C
5165     # After traversing PT, we git commit the changes which
5166     # should be contained within debian/patches.
5167
5168     # The search for the path S..T is breadth-first.  We maintain a
5169     # todo list containing search nodes.  A search node identifies a
5170     # commit, and looks something like this:
5171     #  $p = {
5172     #      Commit => $git_commit_id,
5173     #      Child => $c,                          # or undef if P=T
5174     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
5175     #      Nontrivial => true iff $p..$c has relevant changes
5176     #  };
5177
5178     my @todo;
5179     my @nots;
5180     my $sref_S;
5181     my $max_work=100;
5182     my %considered; # saves being exponential on some weird graphs
5183
5184     my $t_sentinels = quiltify_tree_sentinelfiles $target;
5185
5186     my $not = sub {
5187         my ($search,$whynot) = @_;
5188         printdebug " search NOT $search->{Commit} $whynot\n";
5189         $search->{Whynot} = $whynot;
5190         push @nots, $search;
5191         no warnings qw(exiting);
5192         next;
5193     };
5194
5195     push @todo, {
5196         Commit => $target,
5197     };
5198
5199     while (@todo) {
5200         my $c = shift @todo;
5201         next if $considered{$c->{Commit}}++;
5202
5203         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5204
5205         printdebug "quiltify investigate $c->{Commit}\n";
5206
5207         # are we done?
5208         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5209             printdebug " search finished hooray!\n";
5210             $sref_S = $c;
5211             last;
5212         }
5213
5214         quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5215         if ($quilt_mode eq 'smash') {
5216             printdebug " search quitting smash\n";
5217             last;
5218         }
5219
5220         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5221         $not->($c, "has $c_sentinels not $t_sentinels")
5222             if $c_sentinels ne $t_sentinels;
5223
5224         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5225         $commitdata =~ m/\n\n/;
5226         $commitdata =~ $`;
5227         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5228         @parents = map { { Commit => $_, Child => $c } } @parents;
5229
5230         $not->($c, "root commit") if !@parents;
5231
5232         foreach my $p (@parents) {
5233             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5234         }
5235         my $ndiffers = grep { $_->{Nontrivial} } @parents;
5236         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5237
5238         foreach my $p (@parents) {
5239             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5240
5241             my @cmd= (@git, qw(diff-tree -r --name-only),
5242                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5243             my $patchstackchange = cmdoutput @cmd;
5244             if (length $patchstackchange) {
5245                 $patchstackchange =~ s/\n/,/g;
5246                 $not->($p, "changed $patchstackchange");
5247             }
5248
5249             printdebug " search queue P=$p->{Commit} ",
5250                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5251             push @todo, $p;
5252         }
5253     }
5254
5255     if (!$sref_S) {
5256         printdebug "quiltify want to smash\n";
5257
5258         my $abbrev = sub {
5259             my $x = $_[0]{Commit};
5260             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5261             return $x;
5262         };
5263         my $reportnot = sub {
5264             my ($notp) = @_;
5265             my $s = $abbrev->($notp);
5266             my $c = $notp->{Child};
5267             $s .= "..".$abbrev->($c) if $c;
5268             $s .= ": ".$notp->{Whynot};
5269             return $s;
5270         };
5271         if ($quilt_mode eq 'linear') {
5272             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
5273             foreach my $notp (@nots) {
5274                 print STDERR "$us:  ", $reportnot->($notp), "\n";
5275             }
5276             print STDERR "$us: $_\n" foreach @$failsuggestion;
5277             fail "quilt fixup naive history linearisation failed.\n".
5278  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5279         } elsif ($quilt_mode eq 'smash') {
5280         } elsif ($quilt_mode eq 'auto') {
5281             progress "quilt fixup cannot be linear, smashing...";
5282         } else {
5283             die "$quilt_mode ?";
5284         }
5285
5286         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5287         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5288         my $ncommits = 3;
5289         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5290
5291         quiltify_dpkg_commit "auto-$version-$target-$time",
5292             (getfield $clogp, 'Maintainer'),
5293             "Automatically generated patch ($clogp->{Version})\n".
5294             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5295         return;
5296     }
5297
5298     progress "quiltify linearisation planning successful, executing...";
5299
5300     for (my $p = $sref_S;
5301          my $c = $p->{Child};
5302          $p = $p->{Child}) {
5303         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5304         next unless $p->{Nontrivial};
5305
5306         my $cc = $c->{Commit};
5307
5308         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5309         $commitdata =~ m/\n\n/ or die "$c ?";
5310         $commitdata = $`;
5311         my $msg = $'; #';
5312         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5313         my $author = $1;
5314
5315         my $commitdate = cmdoutput
5316             @git, qw(log -n1 --pretty=format:%aD), $cc;
5317
5318         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5319
5320         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5321         $strip_nls->();
5322
5323         my $title = $1;
5324         my $patchname;
5325         my $patchdir;
5326
5327         my $gbp_check_suitable = sub {
5328             $_ = shift;
5329             my ($what) = @_;
5330
5331             eval {
5332                 die "contains unexpected slashes\n" if m{//} || m{/$};
5333                 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5334                 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5335                 die "is series file\n" if m{$series_filename_re}o;
5336                 die "too long" if length > 200;
5337             };
5338             return $_ unless $@;
5339             print STDERR "quiltifying commit $cc:".
5340                 " ignoring/dropping Gbp-Pq $what: $@";
5341             return undef;
5342         };
5343
5344         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5345                            gbp-pq-name: \s* )
5346                        (\S+) \s* \n //ixm) {
5347             $patchname = $gbp_check_suitable->($1, 'Name');
5348         }
5349         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5350                            gbp-pq-topic: \s* )
5351                        (\S+) \s* \n //ixm) {
5352             $patchdir = $gbp_check_suitable->($1, 'Topic');
5353         }
5354
5355         $strip_nls->();
5356
5357         if (!defined $patchname) {
5358             $patchname = $title;
5359             $patchname =~ s/[.:]$//;
5360             use Text::Iconv;
5361             eval {
5362                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5363                 my $translitname = $converter->convert($patchname);
5364                 die unless defined $translitname;
5365                 $patchname = $translitname;
5366             };
5367             print STDERR
5368                 "dgit: patch title transliteration error: $@"
5369                 if $@;
5370             $patchname =~ y/ A-Z/-a-z/;
5371             $patchname =~ y/-a-z0-9_.+=~//cd;
5372             $patchname =~ s/^\W/x-$&/;
5373             $patchname = substr($patchname,0,40);
5374             $patchname .= ".patch";
5375         }
5376         if (!defined $patchdir) {
5377             $patchdir = '';
5378         }
5379         if (length $patchdir) {
5380             $patchname = "$patchdir/$patchname";
5381         }
5382         if ($patchname =~ m{^(.*)/}) {
5383             mkpath "debian/patches/$1";
5384         }
5385
5386         my $index;
5387         for ($index='';
5388              stat "debian/patches/$patchname$index";
5389              $index++) { }
5390         $!==ENOENT or die "$patchname$index $!";
5391
5392         runcmd @git, qw(checkout -q), $cc;
5393
5394         # We use the tip's changelog so that dpkg-source doesn't
5395         # produce complaining messages from dpkg-parsechangelog.  None
5396         # of the information dpkg-source gets from the changelog is
5397         # actually relevant - it gets put into the original message
5398         # which dpkg-source provides our stunt editor, and then
5399         # overwritten.
5400         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5401
5402         quiltify_dpkg_commit "$patchname$index", $author, $msg,
5403             "Date: $commitdate\n".
5404             "X-Dgit-Generated: $clogp->{Version} $cc\n";
5405
5406         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5407     }
5408
5409     runcmd @git, qw(checkout -q master);
5410 }
5411
5412 sub build_maybe_quilt_fixup () {
5413     my ($format,$fopts) = get_source_format;
5414     return unless madformat_wantfixup $format;
5415     # sigh
5416
5417     check_for_vendor_patches();
5418
5419     if (quiltmode_splitbrain) {
5420         fail <<END unless access_cfg_tagformats_can_splitbrain;
5421 quilt mode $quilt_mode requires split view so server needs to support
5422  both "new" and "maint" tag formats, but config says it doesn't.
5423 END
5424     }
5425
5426     my $clogp = parsechangelog();
5427     my $headref = git_rev_parse('HEAD');
5428
5429     prep_ud();
5430     changedir $playground;
5431
5432     my $upstreamversion = upstreamversion $version;
5433
5434     if ($fopts->{'single-debian-patch'}) {
5435         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5436     } else {
5437         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5438     }
5439
5440     die 'bug' if $split_brain && !$need_split_build_invocation;
5441
5442     changedir $maindir;
5443     runcmd_ordryrun_local
5444         @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5445 }
5446
5447 sub quilt_fixup_mkwork ($) {
5448     my ($headref) = @_;
5449
5450     mkdir "work" or die $!;
5451     changedir "work";
5452     mktree_in_ud_here();
5453     runcmd @git, qw(reset -q --hard), $headref;
5454 }
5455
5456 sub quilt_fixup_linkorigs ($$) {
5457     my ($upstreamversion, $fn) = @_;
5458     # calls $fn->($leafname);
5459
5460     foreach my $f (<$maindir/../*>) { #/){
5461         my $b=$f; $b =~ s{.*/}{};
5462         {
5463             local ($debuglevel) = $debuglevel-1;
5464             printdebug "QF linkorigs $b, $f ?\n";
5465         }
5466         next unless is_orig_file_of_vsn $b, $upstreamversion;
5467         printdebug "QF linkorigs $b, $f Y\n";
5468         link_ltarget $f, $b or die "$b $!";
5469         $fn->($b);
5470     }
5471 }
5472
5473 sub quilt_fixup_delete_pc () {
5474     runcmd @git, qw(rm -rqf .pc);
5475     commit_admin <<END
5476 Commit removal of .pc (quilt series tracking data)
5477
5478 [dgit ($our_version) upgrade quilt-remove-pc]
5479 END
5480 }
5481
5482 sub quilt_fixup_singlepatch ($$$) {
5483     my ($clogp, $headref, $upstreamversion) = @_;
5484
5485     progress "starting quiltify (single-debian-patch)";
5486
5487     # dpkg-source --commit generates new patches even if
5488     # single-debian-patch is in debian/source/options.  In order to
5489     # get it to generate debian/patches/debian-changes, it is
5490     # necessary to build the source package.
5491
5492     quilt_fixup_linkorigs($upstreamversion, sub { });
5493     quilt_fixup_mkwork($headref);
5494
5495     rmtree("debian/patches");
5496
5497     runcmd @dpkgsource, qw(-b .);
5498     changedir "..";
5499     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5500     rename srcfn("$upstreamversion", "/debian/patches"),
5501            "work/debian/patches";
5502
5503     changedir "work";
5504     commit_quilty_patch();
5505 }
5506
5507 sub quilt_make_fake_dsc ($) {
5508     my ($upstreamversion) = @_;
5509
5510     my $fakeversion="$upstreamversion-~~DGITFAKE";
5511
5512     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5513     print $fakedsc <<END or die $!;
5514 Format: 3.0 (quilt)
5515 Source: $package
5516 Version: $fakeversion
5517 Files:
5518 END
5519
5520     my $dscaddfile=sub {
5521         my ($b) = @_;
5522
5523         my $md = new Digest::MD5;
5524
5525         my $fh = new IO::File $b, '<' or die "$b $!";
5526         stat $fh or die $!;
5527         my $size = -s _;
5528
5529         $md->addfile($fh);
5530         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5531     };
5532
5533     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5534
5535     my @files=qw(debian/source/format debian/rules
5536                  debian/control debian/changelog);
5537     foreach my $maybe (qw(debian/patches debian/source/options
5538                           debian/tests/control)) {
5539         next unless stat_exists "$maindir/$maybe";
5540         push @files, $maybe;
5541     }
5542
5543     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5544     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5545
5546     $dscaddfile->($debtar);
5547     close $fakedsc or die $!;
5548 }
5549
5550 sub quilt_check_splitbrain_cache ($$) {
5551     my ($headref, $upstreamversion) = @_;
5552     # Called only if we are in (potentially) split brain mode.
5553     # Called in playground.
5554     # Computes the cache key and looks in the cache.
5555     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5556
5557     my $splitbrain_cachekey;
5558
5559     progress
5560  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5561     # we look in the reflog of dgit-intern/quilt-cache
5562     # we look for an entry whose message is the key for the cache lookup
5563     my @cachekey = (qw(dgit), $our_version);
5564     push @cachekey, $upstreamversion;
5565     push @cachekey, $quilt_mode;
5566     push @cachekey, $headref;
5567
5568     push @cachekey, hashfile('fake.dsc');
5569
5570     my $srcshash = Digest::SHA->new(256);
5571     my %sfs = ( %INC, '$0(dgit)' => $0 );
5572     foreach my $sfk (sort keys %sfs) {
5573         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5574         $srcshash->add($sfk,"  ");
5575         $srcshash->add(hashfile($sfs{$sfk}));
5576         $srcshash->add("\n");
5577     }
5578     push @cachekey, $srcshash->hexdigest();
5579     $splitbrain_cachekey = "@cachekey";
5580
5581     my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5582                $splitbraincache);
5583     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5584     debugcmd "|(probably)",@cmd;
5585     my $child = open GC, "-|";  defined $child or die $!;
5586     if (!$child) {
5587         chdir $maindir or die $!;
5588         if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
5589             $! == ENOENT or die $!;
5590             printdebug ">(no reflog)\n";
5591             finish 0;
5592         }
5593         exec @cmd; die $!;
5594     }
5595     while (<GC>) {
5596         chomp;
5597         printdebug ">| ", $_, "\n" if $debuglevel > 1;
5598         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5599
5600         my $cachehit = $1;
5601         quilt_fixup_mkwork($headref);
5602         my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5603         if ($cachehit ne $headref) {
5604             progress "dgit view: found cached ($saved)";
5605             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5606             $split_brain = 1;
5607             return ($cachehit, $splitbrain_cachekey);
5608         }
5609         progress "dgit view: found cached, no changes required";
5610         return ($headref, $splitbrain_cachekey);
5611     }
5612     die $! if GC->error;
5613     failedcmd unless close GC;
5614
5615     printdebug "splitbrain cache miss\n";
5616     return (undef, $splitbrain_cachekey);
5617 }
5618
5619 sub quilt_fixup_multipatch ($$$) {
5620     my ($clogp, $headref, $upstreamversion) = @_;
5621
5622     progress "examining quilt state (multiple patches, $quilt_mode mode)";
5623
5624     # Our objective is:
5625     #  - honour any existing .pc in case it has any strangeness
5626     #  - determine the git commit corresponding to the tip of
5627     #    the patch stack (if there is one)
5628     #  - if there is such a git commit, convert each subsequent
5629     #    git commit into a quilt patch with dpkg-source --commit
5630     #  - otherwise convert all the differences in the tree into
5631     #    a single git commit
5632     #
5633     # To do this we:
5634
5635     # Our git tree doesn't necessarily contain .pc.  (Some versions of
5636     # dgit would include the .pc in the git tree.)  If there isn't
5637     # one, we need to generate one by unpacking the patches that we
5638     # have.
5639     #
5640     # We first look for a .pc in the git tree.  If there is one, we
5641     # will use it.  (This is not the normal case.)
5642     #
5643     # Otherwise need to regenerate .pc so that dpkg-source --commit
5644     # can work.  We do this as follows:
5645     #     1. Collect all relevant .orig from parent directory
5646     #     2. Generate a debian.tar.gz out of
5647     #         debian/{patches,rules,source/format,source/options}
5648     #     3. Generate a fake .dsc containing just these fields:
5649     #          Format Source Version Files
5650     #     4. Extract the fake .dsc
5651     #        Now the fake .dsc has a .pc directory.
5652     # (In fact we do this in every case, because in future we will
5653     # want to search for a good base commit for generating patches.)
5654     #
5655     # Then we can actually do the dpkg-source --commit
5656     #     1. Make a new working tree with the same object
5657     #        store as our main tree and check out the main
5658     #        tree's HEAD.
5659     #     2. Copy .pc from the fake's extraction, if necessary
5660     #     3. Run dpkg-source --commit
5661     #     4. If the result has changes to debian/, then
5662     #          - git add them them
5663     #          - git add .pc if we had a .pc in-tree
5664     #          - git commit
5665     #     5. If we had a .pc in-tree, delete it, and git commit
5666     #     6. Back in the main tree, fast forward to the new HEAD
5667
5668     # Another situation we may have to cope with is gbp-style
5669     # patches-unapplied trees.
5670     #
5671     # We would want to detect these, so we know to escape into
5672     # quilt_fixup_gbp.  However, this is in general not possible.
5673     # Consider a package with a one patch which the dgit user reverts
5674     # (with git revert or the moral equivalent).
5675     #
5676     # That is indistinguishable in contents from a patches-unapplied
5677     # tree.  And looking at the history to distinguish them is not
5678     # useful because the user might have made a confusing-looking git
5679     # history structure (which ought to produce an error if dgit can't
5680     # cope, not a silent reintroduction of an unwanted patch).
5681     #
5682     # So gbp users will have to pass an option.  But we can usually
5683     # detect their failure to do so: if the tree is not a clean
5684     # patches-applied tree, quilt linearisation fails, but the tree
5685     # _is_ a clean patches-unapplied tree, we can suggest that maybe
5686     # they want --quilt=unapplied.
5687     #
5688     # To help detect this, when we are extracting the fake dsc, we
5689     # first extract it with --skip-patches, and then apply the patches
5690     # afterwards with dpkg-source --before-build.  That lets us save a
5691     # tree object corresponding to .origs.
5692
5693     my $splitbrain_cachekey;
5694
5695     quilt_make_fake_dsc($upstreamversion);
5696
5697     if (quiltmode_splitbrain()) {
5698         my $cachehit;
5699         ($cachehit, $splitbrain_cachekey) =
5700             quilt_check_splitbrain_cache($headref, $upstreamversion);
5701         return if $cachehit;
5702     }
5703
5704     runcmd qw(sh -ec),
5705         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5706
5707     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5708     rename $fakexdir, "fake" or die "$fakexdir $!";
5709
5710     changedir 'fake';
5711
5712     remove_stray_gits("source package");
5713     mktree_in_ud_here();
5714
5715     rmtree '.pc';
5716
5717     rmtree 'debian'; # git checkout commitish paths does not delete!
5718     runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5719     my $unapplied=git_add_write_tree();
5720     printdebug "fake orig tree object $unapplied\n";
5721
5722     ensuredir '.pc';
5723
5724     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5725     $!=0; $?=-1;
5726     if (system @bbcmd) {
5727         failedcmd @bbcmd if $? < 0;
5728         fail <<END;
5729 failed to apply your git tree's patch stack (from debian/patches/) to
5730  the corresponding upstream tarball(s).  Your source tree and .orig
5731  are probably too inconsistent.  dgit can only fix up certain kinds of
5732  anomaly (depending on the quilt mode).  See --quilt= in dgit(1).
5733 END
5734     }
5735
5736     changedir '..';
5737
5738     quilt_fixup_mkwork($headref);
5739
5740     my $mustdeletepc=0;
5741     if (stat_exists ".pc") {
5742         -d _ or die;
5743         progress "Tree already contains .pc - will use it then delete it.";
5744         $mustdeletepc=1;
5745     } else {
5746         rename '../fake/.pc','.pc' or die $!;
5747     }
5748
5749     changedir '../fake';
5750     rmtree '.pc';
5751     my $oldtiptree=git_add_write_tree();
5752     printdebug "fake o+d/p tree object $unapplied\n";
5753     changedir '../work';
5754
5755
5756     # We calculate some guesswork now about what kind of tree this might
5757     # be.  This is mostly for error reporting.
5758
5759     my %editedignores;
5760     my @unrepres;
5761     my $diffbits = {
5762         # H = user's HEAD
5763         # O = orig, without patches applied
5764         # A = "applied", ie orig with H's debian/patches applied
5765         O2H => quiltify_trees_differ($unapplied,$headref,   1,
5766                                      \%editedignores, \@unrepres),
5767         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
5768         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5769     };
5770
5771     my @dl;
5772     foreach my $b (qw(01 02)) {
5773         foreach my $v (qw(O2H O2A H2A)) {
5774             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5775         }
5776     }
5777     printdebug "differences \@dl @dl.\n";
5778
5779     progress sprintf
5780 "$us: base trees orig=%.20s o+d/p=%.20s",
5781               $unapplied, $oldtiptree;
5782     progress sprintf
5783 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
5784 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
5785                              $dl[0], $dl[1],              $dl[3], $dl[4],
5786                                  $dl[2],                     $dl[5];
5787
5788     if (@unrepres) {
5789         print STDERR "dgit:  cannot represent change: $_->[1]: $_->[0]\n"
5790             foreach @unrepres;
5791         forceable_fail [qw(unrepresentable)], <<END;
5792 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5793 END
5794     }
5795
5796     my @failsuggestion;
5797     if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5798         push @failsuggestion, "This might be a patches-unapplied branch.";
5799     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5800         push @failsuggestion, "This might be a patches-applied branch.";
5801     }
5802     push @failsuggestion, "Maybe you need to specify one of".
5803         " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5804
5805     if (quiltmode_splitbrain()) {
5806         quiltify_splitbrain($clogp, $unapplied, $headref,
5807                             $diffbits, \%editedignores,
5808                             $splitbrain_cachekey);
5809         return;
5810     }
5811
5812     progress "starting quiltify (multiple patches, $quilt_mode mode)";
5813     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5814
5815     if (!open P, '>>', ".pc/applied-patches") {
5816         $!==&ENOENT or die $!;
5817     } else {
5818         close P;
5819     }
5820
5821     commit_quilty_patch();
5822
5823     if ($mustdeletepc) {
5824         quilt_fixup_delete_pc();
5825     }
5826 }
5827
5828 sub quilt_fixup_editor () {
5829     my $descfn = $ENV{$fakeeditorenv};
5830     my $editing = $ARGV[$#ARGV];
5831     open I1, '<', $descfn or die "$descfn: $!";
5832     open I2, '<', $editing or die "$editing: $!";
5833     unlink $editing or die "$editing: $!";
5834     open O, '>', $editing or die "$editing: $!";
5835     while (<I1>) { print O or die $!; } I1->error and die $!;
5836     my $copying = 0;
5837     while (<I2>) {
5838         $copying ||= m/^\-\-\- /;
5839         next unless $copying;
5840         print O or die $!;
5841     }
5842     I2->error and die $!;
5843     close O or die $1;
5844     finish 0;
5845 }
5846
5847 sub maybe_apply_patches_dirtily () {
5848     return unless $quilt_mode =~ m/gbp|unapplied/;
5849     print STDERR <<END or die $!;
5850
5851 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5852 dgit: Have to apply the patches - making the tree dirty.
5853 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5854
5855 END
5856     $patches_applied_dirtily = 01;
5857     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5858     runcmd qw(dpkg-source --before-build .);
5859 }
5860
5861 sub maybe_unapply_patches_again () {
5862     progress "dgit: Unapplying patches again to tidy up the tree."
5863         if $patches_applied_dirtily;
5864     runcmd qw(dpkg-source --after-build .)
5865         if $patches_applied_dirtily & 01;
5866     rmtree '.pc'
5867         if $patches_applied_dirtily & 02;
5868     $patches_applied_dirtily = 0;
5869 }
5870
5871 #----- other building -----
5872
5873 our $clean_using_builder;
5874 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5875 #   clean the tree before building (perhaps invoked indirectly by
5876 #   whatever we are using to run the build), rather than separately
5877 #   and explicitly by us.
5878
5879 sub clean_tree () {
5880     return if $clean_using_builder;
5881     if ($cleanmode eq 'dpkg-source') {
5882         maybe_apply_patches_dirtily();
5883         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5884     } elsif ($cleanmode eq 'dpkg-source-d') {
5885         maybe_apply_patches_dirtily();
5886         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5887     } elsif ($cleanmode eq 'git') {
5888         runcmd_ordryrun_local @git, qw(clean -xdf);
5889     } elsif ($cleanmode eq 'git-ff') {
5890         runcmd_ordryrun_local @git, qw(clean -xdff);
5891     } elsif ($cleanmode eq 'check') {
5892         my $leftovers = cmdoutput @git, qw(clean -xdn);
5893         if (length $leftovers) {
5894             print STDERR $leftovers, "\n" or die $!;
5895             fail "tree contains uncommitted files and --clean=check specified";
5896         }
5897     } elsif ($cleanmode eq 'none') {
5898     } else {
5899         die "$cleanmode ?";
5900     }
5901 }
5902
5903 sub cmd_clean () {
5904     badusage "clean takes no additional arguments" if @ARGV;
5905     notpushing();
5906     clean_tree();
5907     maybe_unapply_patches_again();
5908 }
5909
5910 sub build_or_push_prep_early () {
5911     our $build_or_push_prep_early_done //= 0;
5912     return if $build_or_push_prep_early_done++;
5913     badusage "-p is not allowed with dgit $subcommand" if defined $package;
5914     my $clogp = parsechangelog();
5915     $isuite = getfield $clogp, 'Distribution';
5916     $package = getfield $clogp, 'Source';
5917     $version = getfield $clogp, 'Version';
5918 }
5919
5920 sub build_prep_early () {
5921     build_or_push_prep_early();
5922     notpushing();
5923     check_not_dirty();
5924 }
5925
5926 sub build_prep () {
5927     build_prep_early();
5928     clean_tree();
5929     build_maybe_quilt_fixup();
5930     if ($rmchanges) {
5931         my $pat = changespat $version;
5932         foreach my $f (glob "$buildproductsdir/$pat") {
5933             if (act_local()) {
5934                 unlink $f or fail "remove old changes file $f: $!";
5935             } else {
5936                 progress "would remove $f";
5937             }
5938         }
5939     }
5940 }
5941
5942 sub changesopts_initial () {
5943     my @opts =@changesopts[1..$#changesopts];
5944 }
5945
5946 sub changesopts_version () {
5947     if (!defined $changes_since_version) {
5948         my @vsns = archive_query('archive_query');
5949         my @quirk = access_quirk();
5950         if ($quirk[0] eq 'backports') {
5951             local $isuite = $quirk[2];
5952             local $csuite;
5953             canonicalise_suite();
5954             push @vsns, archive_query('archive_query');
5955         }
5956         if (@vsns) {
5957             @vsns = map { $_->[0] } @vsns;
5958             @vsns = sort { -version_compare($a, $b) } @vsns;
5959             $changes_since_version = $vsns[0];
5960             progress "changelog will contain changes since $vsns[0]";
5961         } else {
5962             $changes_since_version = '_';
5963             progress "package seems new, not specifying -v<version>";
5964         }
5965     }
5966     if ($changes_since_version ne '_') {
5967         return ("-v$changes_since_version");
5968     } else {
5969         return ();
5970     }
5971 }
5972
5973 sub changesopts () {
5974     return (changesopts_initial(), changesopts_version());
5975 }
5976
5977 sub massage_dbp_args ($;$) {
5978     my ($cmd,$xargs) = @_;
5979     # We need to:
5980     #
5981     #  - if we're going to split the source build out so we can
5982     #    do strange things to it, massage the arguments to dpkg-buildpackage
5983     #    so that the main build doessn't build source (or add an argument
5984     #    to stop it building source by default).
5985     #
5986     #  - add -nc to stop dpkg-source cleaning the source tree,
5987     #    unless we're not doing a split build and want dpkg-source
5988     #    as cleanmode, in which case we can do nothing
5989     #
5990     # return values:
5991     #    0 - source will NOT need to be built separately by caller
5992     #   +1 - source will need to be built separately by caller
5993     #   +2 - source will need to be built separately by caller AND
5994     #        dpkg-buildpackage should not in fact be run at all!
5995     debugcmd '#massaging#', @$cmd if $debuglevel>1;
5996 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5997     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5998         $clean_using_builder = 1;
5999         return 0;
6000     }
6001     # -nc has the side effect of specifying -b if nothing else specified
6002     # and some combinations of -S, -b, et al, are errors, rather than
6003     # later simply overriding earlie.  So we need to:
6004     #  - search the command line for these options
6005     #  - pick the last one
6006     #  - perhaps add our own as a default
6007     #  - perhaps adjust it to the corresponding non-source-building version
6008     my $dmode = '-F';
6009     foreach my $l ($cmd, $xargs) {
6010         next unless $l;
6011         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
6012     }
6013     push @$cmd, '-nc';
6014 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6015     my $r = 0;
6016     if ($need_split_build_invocation) {
6017         printdebug "massage split $dmode.\n";
6018         $r = $dmode =~ m/[S]/     ? +2 :
6019              $dmode =~ y/gGF/ABb/ ? +1 :
6020              $dmode =~ m/[ABb]/   ?  0 :
6021              die "$dmode ?";
6022     }
6023     printdebug "massage done $r $dmode.\n";
6024     push @$cmd, $dmode;
6025 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6026     return $r;
6027 }
6028
6029 sub in_parent (&) {
6030     my ($fn) = @_;
6031     my $wasdir = must_getcwd();
6032     changedir "..";
6033     $fn->();
6034     changedir $wasdir;
6035 }
6036
6037 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
6038     my ($msg_if_onlyone) = @_;
6039     # If there is only one .changes file, fail with $msg_if_onlyone,
6040     # or if that is undef, be a no-op.
6041     # Returns the changes file to report to the user.
6042     my $pat = changespat $version;
6043     my @changesfiles = glob $pat;
6044     @changesfiles = sort {
6045         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6046             or $a cmp $b
6047     } @changesfiles;
6048     my $result;
6049     if (@changesfiles==1) {
6050         fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6051 only one changes file from build (@changesfiles)
6052 END
6053         $result = $changesfiles[0];
6054     } elsif (@changesfiles==2) {
6055         my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6056         foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6057             fail "$l found in binaries changes file $binchanges"
6058                 if $l =~ m/\.dsc$/;
6059         }
6060         runcmd_ordryrun_local @mergechanges, @changesfiles;
6061         my $multichanges = changespat $version,'multi';
6062         if (act_local()) {
6063             stat_exists $multichanges or fail "$multichanges: $!";
6064             foreach my $cf (glob $pat) {
6065                 next if $cf eq $multichanges;
6066                 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6067             }
6068         }
6069         $result = $multichanges;
6070     } else {
6071         fail "wrong number of different changes files (@changesfiles)";
6072     }
6073     printdone "build successful, results in $result\n" or die $!;
6074 }
6075
6076 sub midbuild_checkchanges () {
6077     my $pat = changespat $version;
6078     return if $rmchanges;
6079     my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
6080     @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
6081     fail <<END
6082 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6083 Suggest you delete @unwanted.
6084 END
6085         if @unwanted;
6086 }
6087
6088 sub midbuild_checkchanges_vanilla ($) {
6089     my ($wantsrc) = @_;
6090     midbuild_checkchanges() if $wantsrc == 1;
6091 }
6092
6093 sub postbuild_mergechanges_vanilla ($) {
6094     my ($wantsrc) = @_;
6095     if ($wantsrc == 1) {
6096         in_parent {
6097             postbuild_mergechanges(undef);
6098         };
6099     } else {
6100         printdone "build successful\n";
6101     }
6102 }
6103
6104 sub cmd_build {
6105     build_prep_early();
6106     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6107     my $wantsrc = massage_dbp_args \@dbp;
6108     if ($wantsrc > 0) {
6109         build_source();
6110         midbuild_checkchanges_vanilla $wantsrc;
6111     } else {
6112         build_prep();
6113     }
6114     if ($wantsrc < 2) {
6115         push @dbp, changesopts_version();
6116         maybe_apply_patches_dirtily();
6117         runcmd_ordryrun_local @dbp;
6118     }
6119     maybe_unapply_patches_again();
6120     postbuild_mergechanges_vanilla $wantsrc;
6121 }
6122
6123 sub pre_gbp_build {
6124     $quilt_mode //= 'gbp';
6125 }
6126
6127 sub cmd_gbp_build {
6128     build_prep_early();
6129
6130     # gbp can make .origs out of thin air.  In my tests it does this
6131     # even for a 1.0 format package, with no origs present.  So I
6132     # guess it keys off just the version number.  We don't know
6133     # exactly what .origs ought to exist, but let's assume that we
6134     # should run gbp if: the version has an upstream part and the main
6135     # orig is absent.
6136     my $upstreamversion = upstreamversion $version;
6137     my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6138     my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
6139
6140     if ($gbp_make_orig) {
6141         clean_tree();
6142         $cleanmode = 'none'; # don't do it again
6143         $need_split_build_invocation = 1;
6144     }
6145
6146     my @dbp = @dpkgbuildpackage;
6147
6148     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6149
6150     if (!length $gbp_build[0]) {
6151         if (length executable_on_path('git-buildpackage')) {
6152             $gbp_build[0] = qw(git-buildpackage);
6153         } else {
6154             $gbp_build[0] = 'gbp buildpackage';
6155         }
6156     }
6157     my @cmd = opts_opt_multi_cmd @gbp_build;
6158
6159     push @cmd, (qw(-us -uc --git-no-sign-tags),
6160                 "--git-builder=".(shellquote @dbp));
6161
6162     if ($gbp_make_orig) {
6163         my $priv = dgit_privdir();
6164         my $ok = "$priv/origs-gen-ok";
6165         unlink $ok or $!==&ENOENT or die $!;
6166         my @origs_cmd = @cmd;
6167         push @origs_cmd, qw(--git-cleaner=true);
6168         push @origs_cmd, "--git-prebuild=".
6169             "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6170         push @origs_cmd, @ARGV;
6171         if (act_local()) {
6172             debugcmd @origs_cmd;
6173             system @origs_cmd;
6174             do { local $!; stat_exists $ok; }
6175                 or failedcmd @origs_cmd;
6176         } else {
6177             dryrun_report @origs_cmd;
6178         }
6179     }
6180
6181     if ($wantsrc > 0) {
6182         build_source();
6183         midbuild_checkchanges_vanilla $wantsrc;
6184     } else {
6185         if (!$clean_using_builder) {
6186             push @cmd, '--git-cleaner=true';
6187         }
6188         build_prep();
6189     }
6190     maybe_unapply_patches_again();
6191     if ($wantsrc < 2) {
6192         push @cmd, changesopts();
6193         runcmd_ordryrun_local @cmd, @ARGV;
6194     }
6195     postbuild_mergechanges_vanilla $wantsrc;
6196 }
6197 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6198
6199 sub build_source_for_push {
6200     build_source();
6201     maybe_unapply_patches_again();
6202     $changesfile = $sourcechanges;
6203 }
6204
6205 sub build_source {
6206     build_prep_early();
6207     build_prep();
6208     $sourcechanges = changespat $version,'source';
6209     if (act_local()) {
6210         unlink "../$sourcechanges" or $!==ENOENT
6211             or fail "remove $sourcechanges: $!";
6212     }
6213     $dscfn = dscfn($version);
6214     my @cmd = (@dpkgsource, qw(-b --));
6215     if ($split_brain) {
6216         changedir $playground;
6217         runcmd_ordryrun_local @cmd, "work";
6218         my @udfiles = <${package}_*>;
6219         changedir $maindir;
6220         foreach my $f (@udfiles) {
6221             printdebug "source copy, found $f\n";
6222             next unless
6223               $f eq $dscfn or
6224               ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
6225                $f eq srcfn($version, $&));
6226             printdebug "source copy, found $f - renaming\n";
6227             rename "$playground/$f", "../$f" or $!==ENOENT
6228               or fail "put in place new source file ($f): $!";
6229         }
6230     } else {
6231         my $pwd = must_getcwd();
6232         my $leafdir = basename $pwd;
6233         changedir "..";
6234         runcmd_ordryrun_local @cmd, $leafdir;
6235         changedir $pwd;
6236     }
6237     runcmd_ordryrun_local qw(sh -ec),
6238       'exec >$1; shift; exec "$@"','x',
6239       "../$sourcechanges",
6240       @dpkggenchanges, qw(-S), changesopts();
6241 }
6242
6243 sub cmd_build_source {
6244     build_prep_early();
6245     badusage "build-source takes no additional arguments" if @ARGV;
6246     build_source();
6247     maybe_unapply_patches_again();
6248     printdone "source built, results in $dscfn and $sourcechanges";
6249 }
6250
6251 sub cmd_sbuild {
6252     build_source();
6253     midbuild_checkchanges();
6254     in_parent {
6255         if (act_local()) {
6256             stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
6257             stat_exists $sourcechanges
6258                 or fail "$sourcechanges (in parent directory): $!";
6259         }
6260         runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
6261     };
6262     maybe_unapply_patches_again();
6263     in_parent {
6264         postbuild_mergechanges(<<END);
6265 perhaps you need to pass -A ?  (sbuild's default is to build only
6266 arch-specific binaries; dgit 1.4 used to override that.)
6267 END
6268     };
6269 }
6270
6271 sub cmd_quilt_fixup {
6272     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6273     build_prep_early();
6274     clean_tree();
6275     build_maybe_quilt_fixup();
6276 }
6277
6278 sub import_dsc_result {
6279     my ($dstref, $newhash, $what_log, $what_msg) = @_;
6280     my @cmd = (@git, qw(update-ref -m), $what_log, $dstref, $newhash);
6281     runcmd @cmd;
6282     check_gitattrs($newhash, "source tree");
6283
6284     progress "dgit: import-dsc: $what_msg";
6285 }
6286
6287 sub cmd_import_dsc {
6288     my $needsig = 0;
6289
6290     while (@ARGV) {
6291         last unless $ARGV[0] =~ m/^-/;
6292         $_ = shift @ARGV;
6293         last if m/^--?$/;
6294         if (m/^--require-valid-signature$/) {
6295             $needsig = 1;
6296         } else {
6297             badusage "unknown dgit import-dsc sub-option \`$_'";
6298         }
6299     }
6300
6301     badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6302     my ($dscfn, $dstbranch) = @ARGV;
6303
6304     badusage "dry run makes no sense with import-dsc" unless act_local();
6305
6306     my $force = $dstbranch =~ s/^\+//   ? +1 :
6307                 $dstbranch =~ s/^\.\.// ? -1 :
6308                                            0;
6309     my $info = $force ? " $&" : '';
6310     $info = "$dscfn$info";
6311
6312     my $specbranch = $dstbranch;
6313     $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6314     $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6315
6316     my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6317     my $chead = cmdoutput_errok @symcmd;
6318     defined $chead or $?==256 or failedcmd @symcmd;
6319
6320     fail "$dstbranch is checked out - will not update it"
6321         if defined $chead and $chead eq $dstbranch;
6322
6323     my $oldhash = git_get_ref $dstbranch;
6324
6325     open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6326     $dscdata = do { local $/ = undef; <D>; };
6327     D->error and fail "read $dscfn: $!";
6328     close C;
6329
6330     # we don't normally need this so import it here
6331     use Dpkg::Source::Package;
6332     my $dp = new Dpkg::Source::Package filename => $dscfn,
6333         require_valid_signature => $needsig;
6334     {
6335         local $SIG{__WARN__} = sub {
6336             print STDERR $_[0];
6337             return unless $needsig;
6338             fail "import-dsc signature check failed";
6339         };
6340         if (!$dp->is_signed()) {
6341             warn "$us: warning: importing unsigned .dsc\n";
6342         } else {
6343             my $r = $dp->check_signature();
6344             die "->check_signature => $r" if $needsig && $r;
6345         }
6346     }
6347
6348     parse_dscdata();
6349
6350     $package = getfield $dsc, 'Source';
6351
6352     parse_dsc_field($dsc, "Dgit metadata in .dsc")
6353         unless forceing [qw(import-dsc-with-dgit-field)];
6354     parse_dsc_field_def_dsc_distro();
6355
6356     $isuite = 'DGIT-IMPORT-DSC';
6357     $idistro //= $dsc_distro;
6358
6359     notpushing();
6360
6361     if (defined $dsc_hash) {
6362         progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6363         resolve_dsc_field_commit undef, undef;
6364     }
6365     if (defined $dsc_hash) {
6366         my @cmd = (qw(sh -ec),
6367                    "echo $dsc_hash | git cat-file --batch-check");
6368         my $objgot = cmdoutput @cmd;
6369         if ($objgot =~ m#^\w+ missing\b#) {
6370             fail <<END
6371 .dsc contains Dgit field referring to object $dsc_hash
6372 Your git tree does not have that object.  Try `git fetch' from a
6373 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6374 END
6375         }
6376         if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6377             if ($force > 0) {
6378                 progress "Not fast forward, forced update.";
6379             } else {
6380                 fail "Not fast forward to $dsc_hash";
6381             }
6382         }
6383         import_dsc_result $dstbranch, $dsc_hash,
6384             "dgit import-dsc (Dgit): $info",
6385             "updated git ref $dstbranch";
6386         return 0;
6387     }
6388
6389     fail <<END
6390 Branch $dstbranch already exists
6391 Specify ..$specbranch for a pseudo-merge, binding in existing history
6392 Specify  +$specbranch to overwrite, discarding existing history
6393 END
6394         if $oldhash && !$force;
6395
6396     my @dfi = dsc_files_info();
6397     foreach my $fi (@dfi) {
6398         my $f = $fi->{Filename};
6399         my $here = "../$f";
6400         if (lstat $here) {
6401             next if stat $here;
6402             fail "lstat $here works but stat gives $! !";
6403         }
6404         fail "stat $here: $!" unless $! == ENOENT;
6405         my $there = $dscfn;
6406         if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6407             $there = $';
6408         } elsif ($dscfn =~ m#^/#) {
6409             $there = $dscfn;
6410         } else {
6411             fail "cannot import $dscfn which seems to be inside working tree!";
6412         }
6413         $there =~ s#/+[^/]+$## or
6414             fail "import $dscfn requires ../$f, but it does not exist";
6415         $there .= "/$f";
6416         my $test = $there =~ m{^/} ? $there : "../$there";
6417         stat $test or fail "import $dscfn requires $test, but: $!";
6418         symlink $there, $here or fail "symlink $there to $here: $!";
6419         progress "made symlink $here -> $there";
6420 #       print STDERR Dumper($fi);
6421     }
6422     my @mergeinputs = generate_commits_from_dsc();
6423     die unless @mergeinputs == 1;
6424
6425     my $newhash = $mergeinputs[0]{Commit};
6426
6427     if ($oldhash) {
6428         if ($force > 0) {
6429             progress "Import, forced update - synthetic orphan git history.";
6430         } elsif ($force < 0) {
6431             progress "Import, merging.";
6432             my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6433             my $version = getfield $dsc, 'Version';
6434             my $clogp = commit_getclogp $newhash;
6435             my $authline = clogp_authline $clogp;
6436             $newhash = make_commit_text <<END;
6437 tree $tree
6438 parent $newhash
6439 parent $oldhash
6440 author $authline
6441 committer $authline
6442
6443 Merge $package ($version) import into $dstbranch
6444 END
6445         } else {
6446             die; # caught earlier
6447         }
6448     }
6449
6450     import_dsc_result $dstbranch, $newhash,
6451         "dgit import-dsc: $info",
6452         "results are in in git ref $dstbranch";
6453 }
6454
6455 sub pre_archive_api_query () {
6456     not_necessarily_a_tree();
6457 }
6458 sub cmd_archive_api_query {
6459     badusage "need only 1 subpath argument" unless @ARGV==1;
6460     my ($subpath) = @ARGV;
6461     local $isuite = 'DGIT-API-QUERY-CMD';
6462     my @cmd = archive_api_query_cmd($subpath);
6463     push @cmd, qw(-f);
6464     debugcmd ">",@cmd;
6465     exec @cmd or fail "exec curl: $!\n";
6466 }
6467
6468 sub repos_server_url () {
6469     $package = '_dgit-repos-server';
6470     local $access_forpush = 1;
6471     local $isuite = 'DGIT-REPOS-SERVER';
6472     my $url = access_giturl();
6473 }
6474
6475 sub pre_clone_dgit_repos_server () {
6476     not_necessarily_a_tree();
6477 }
6478 sub cmd_clone_dgit_repos_server {
6479     badusage "need destination argument" unless @ARGV==1;
6480     my ($destdir) = @ARGV;
6481     my $url = repos_server_url();
6482     my @cmd = (@git, qw(clone), $url, $destdir);
6483     debugcmd ">",@cmd;
6484     exec @cmd or fail "exec git clone: $!\n";
6485 }
6486
6487 sub pre_print_dgit_repos_server_source_url () {
6488     not_necessarily_a_tree();
6489 }
6490 sub cmd_print_dgit_repos_server_source_url {
6491     badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6492         if @ARGV;
6493     my $url = repos_server_url();
6494     print $url, "\n" or die $!;
6495 }
6496
6497 sub pre_print_dpkg_source_ignores {
6498     not_necessarily_a_tree();
6499 }
6500 sub cmd_print_dpkg_source_ignores {
6501     badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6502         if @ARGV;
6503     print "@dpkg_source_ignores\n" or die $!;
6504 }
6505
6506 sub cmd_setup_mergechangelogs {
6507     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6508     local $isuite = 'DGIT-SETUP-TREE';
6509     setup_mergechangelogs(1);
6510 }
6511
6512 sub cmd_setup_useremail {
6513     badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6514     local $isuite = 'DGIT-SETUP-TREE';
6515     setup_useremail(1);
6516 }
6517
6518 sub cmd_setup_gitattributes {
6519     badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6520     local $isuite = 'DGIT-SETUP-TREE';
6521     setup_gitattrs(1);
6522 }
6523
6524 sub cmd_setup_new_tree {
6525     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6526     local $isuite = 'DGIT-SETUP-TREE';
6527     setup_new_tree();
6528 }
6529
6530 #---------- argument parsing and main program ----------
6531
6532 sub cmd_version {
6533     print "dgit version $our_version\n" or die $!;
6534     finish 0;
6535 }
6536
6537 our (%valopts_long, %valopts_short);
6538 our (%funcopts_long);
6539 our @rvalopts;
6540 our (@modeopt_cfgs);
6541
6542 sub defvalopt ($$$$) {
6543     my ($long,$short,$val_re,$how) = @_;
6544     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6545     $valopts_long{$long} = $oi;
6546     $valopts_short{$short} = $oi;
6547     # $how subref should:
6548     #   do whatever assignemnt or thing it likes with $_[0]
6549     #   if the option should not be passed on to remote, @rvalopts=()
6550     # or $how can be a scalar ref, meaning simply assign the value
6551 }
6552
6553 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6554 defvalopt '--distro',        '-d', '.+',      \$idistro;
6555 defvalopt '',                '-k', '.+',      \$keyid;
6556 defvalopt '--existing-package','', '.*',      \$existing_package;
6557 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
6558 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
6559 defvalopt '--package',   '-p',   $package_re, \$package;
6560 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
6561
6562 defvalopt '', '-C', '.+', sub {
6563     ($changesfile) = (@_);
6564     if ($changesfile =~ s#^(.*)/##) {
6565         $buildproductsdir = $1;
6566     }
6567 };
6568
6569 defvalopt '--initiator-tempdir','','.*', sub {
6570     ($initiator_tempdir) = (@_);
6571     $initiator_tempdir =~ m#^/# or
6572         badusage "--initiator-tempdir must be used specify an".
6573         " absolute, not relative, directory."
6574 };
6575
6576 sub defoptmodes ($@) {
6577     my ($varref, $cfgkey, $default, %optmap) = @_;
6578     my %permit;
6579     while (my ($opt,$val) = each %optmap) {
6580         $funcopts_long{$opt} = sub { $$varref = $val; };
6581         $permit{$val} = $val;
6582     }
6583     push @modeopt_cfgs, {
6584         Var => $varref,
6585         Key => $cfgkey,
6586         Default => $default,
6587         Vals => \%permit
6588     };
6589 }
6590
6591 defoptmodes \$dodep14tag, qw( dep14tag          want
6592                               --dep14tag        want
6593                               --no-dep14tag     no
6594                               --always-dep14tag always );
6595
6596 sub parseopts () {
6597     my $om;
6598
6599     if (defined $ENV{'DGIT_SSH'}) {
6600         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6601     } elsif (defined $ENV{'GIT_SSH'}) {
6602         @ssh = ($ENV{'GIT_SSH'});
6603     }
6604
6605     my $oi;
6606     my $val;
6607     my $valopt = sub {
6608         my ($what) = @_;
6609         @rvalopts = ($_);
6610         if (!defined $val) {
6611             badusage "$what needs a value" unless @ARGV;
6612             $val = shift @ARGV;
6613             push @rvalopts, $val;
6614         }
6615         badusage "bad value \`$val' for $what" unless
6616             $val =~ m/^$oi->{Re}$(?!\n)/s;
6617         my $how = $oi->{How};
6618         if (ref($how) eq 'SCALAR') {
6619             $$how = $val;
6620         } else {
6621             $how->($val);
6622         }
6623         push @ropts, @rvalopts;
6624     };
6625
6626     while (@ARGV) {
6627         last unless $ARGV[0] =~ m/^-/;
6628         $_ = shift @ARGV;
6629         last if m/^--?$/;
6630         if (m/^--/) {
6631             if (m/^--dry-run$/) {
6632                 push @ropts, $_;
6633                 $dryrun_level=2;
6634             } elsif (m/^--damp-run$/) {
6635                 push @ropts, $_;
6636                 $dryrun_level=1;
6637             } elsif (m/^--no-sign$/) {
6638                 push @ropts, $_;
6639                 $sign=0;
6640             } elsif (m/^--help$/) {
6641                 cmd_help();
6642             } elsif (m/^--version$/) {
6643                 cmd_version();
6644             } elsif (m/^--new$/) {
6645                 push @ropts, $_;
6646                 $new_package=1;
6647             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6648                      ($om = $opts_opt_map{$1}) &&
6649                      length $om->[0]) {
6650                 push @ropts, $_;
6651                 $om->[0] = $2;
6652             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6653                      !$opts_opt_cmdonly{$1} &&
6654                      ($om = $opts_opt_map{$1})) {
6655                 push @ropts, $_;
6656                 push @$om, $2;
6657             } elsif (m/^--(gbp|dpm)$/s) {
6658                 push @ropts, "--quilt=$1";
6659                 $quilt_mode = $1;
6660             } elsif (m/^--ignore-dirty$/s) {
6661                 push @ropts, $_;
6662                 $ignoredirty = 1;
6663             } elsif (m/^--no-quilt-fixup$/s) {
6664                 push @ropts, $_;
6665                 $quilt_mode = 'nocheck';
6666             } elsif (m/^--no-rm-on-error$/s) {
6667                 push @ropts, $_;
6668                 $rmonerror = 0;
6669             } elsif (m/^--no-chase-dsc-distro$/s) {
6670                 push @ropts, $_;
6671                 $chase_dsc_distro = 0;
6672             } elsif (m/^--overwrite$/s) {
6673                 push @ropts, $_;
6674                 $overwrite_version = '';
6675             } elsif (m/^--overwrite=(.+)$/s) {
6676                 push @ropts, $_;
6677                 $overwrite_version = $1;
6678             } elsif (m/^--delayed=(\d+)$/s) {
6679                 push @ropts, $_;
6680                 push @dput, $_;
6681             } elsif (m/^--dgit-view-save=(.+)$/s) {
6682                 push @ropts, $_;
6683                 $split_brain_save = $1;
6684                 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6685             } elsif (m/^--(no-)?rm-old-changes$/s) {
6686                 push @ropts, $_;
6687                 $rmchanges = !$1;
6688             } elsif (m/^--deliberately-($deliberately_re)$/s) {
6689                 push @ropts, $_;
6690                 push @deliberatelies, $&;
6691             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6692                 push @ropts, $&;
6693                 $forceopts{$1} = 1;
6694                 $_='';
6695             } elsif (m/^--force-/) {
6696                 print STDERR
6697                     "$us: warning: ignoring unknown force option $_\n";
6698                 $_='';
6699             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6700                 # undocumented, for testing
6701                 push @ropts, $_;
6702                 $tagformat_want = [ $1, 'command line', 1 ];
6703                 # 1 menas overrides distro configuration
6704             } elsif (m/^--always-split-source-build$/s) {
6705                 # undocumented, for testing
6706                 push @ropts, $_;
6707                 $need_split_build_invocation = 1;
6708             } elsif (m/^--config-lookup-explode=(.+)$/s) {
6709                 # undocumented, for testing
6710                 push @ropts, $_;
6711                 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6712                 # ^ it's supposed to be an array ref
6713             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6714                 $val = $2 ? $' : undef; #';
6715                 $valopt->($oi->{Long});
6716             } elsif ($funcopts_long{$_}) {
6717                 push @ropts, $_;
6718                 $funcopts_long{$_}();
6719             } else {
6720                 badusage "unknown long option \`$_'";
6721             }
6722         } else {
6723             while (m/^-./s) {
6724                 if (s/^-n/-/) {
6725                     push @ropts, $&;
6726                     $dryrun_level=2;
6727                 } elsif (s/^-L/-/) {
6728                     push @ropts, $&;
6729                     $dryrun_level=1;
6730                 } elsif (s/^-h/-/) {
6731                     cmd_help();
6732                 } elsif (s/^-D/-/) {
6733                     push @ropts, $&;
6734                     $debuglevel++;
6735                     enabledebug();
6736                 } elsif (s/^-N/-/) {
6737                     push @ropts, $&;
6738                     $new_package=1;
6739                 } elsif (m/^-m/) {
6740                     push @ropts, $&;
6741                     push @changesopts, $_;
6742                     $_ = '';
6743                 } elsif (s/^-wn$//s) {
6744                     push @ropts, $&;
6745                     $cleanmode = 'none';
6746                 } elsif (s/^-wg$//s) {
6747                     push @ropts, $&;
6748                     $cleanmode = 'git';
6749                 } elsif (s/^-wgf$//s) {
6750                     push @ropts, $&;
6751                     $cleanmode = 'git-ff';
6752                 } elsif (s/^-wd$//s) {
6753                     push @ropts, $&;
6754                     $cleanmode = 'dpkg-source';
6755                 } elsif (s/^-wdd$//s) {
6756                     push @ropts, $&;
6757                     $cleanmode = 'dpkg-source-d';
6758                 } elsif (s/^-wc$//s) {
6759                     push @ropts, $&;
6760                     $cleanmode = 'check';
6761                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6762                     push @git, '-c', $&;
6763                     $gitcfgs{cmdline}{$1} = [ $2 ];
6764                 } elsif (s/^-c([^=]+)$//s) {
6765                     push @git, '-c', $&;
6766                     $gitcfgs{cmdline}{$1} = [ 'true' ];
6767                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6768                     $val = $'; #';
6769                     $val = undef unless length $val;
6770                     $valopt->($oi->{Short});
6771                     $_ = '';
6772                 } else {
6773                     badusage "unknown short option \`$_'";
6774                 }
6775             }
6776         }
6777     }
6778 }
6779
6780 sub check_env_sanity () {
6781     my $blocked = new POSIX::SigSet;
6782     sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6783
6784     eval {
6785         foreach my $name (qw(PIPE CHLD)) {
6786             my $signame = "SIG$name";
6787             my $signum = eval "POSIX::$signame" // die;
6788             ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6789                 die "$signame is set to something other than SIG_DFL\n";
6790             $blocked->ismember($signum) and
6791                 die "$signame is blocked\n";
6792         }
6793     };
6794     return unless $@;
6795     chomp $@;
6796     fail <<END;
6797 On entry to dgit, $@
6798 This is a bug produced by something in in your execution environment.
6799 Giving up.
6800 END
6801 }
6802
6803
6804 sub parseopts_late_defaults () {
6805     $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
6806         if defined $idistro;
6807     $isuite //= cfg('dgit.default.default-suite');
6808
6809     foreach my $k (keys %opts_opt_map) {
6810         my $om = $opts_opt_map{$k};
6811
6812         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6813         if (defined $v) {
6814             badcfg "cannot set command for $k"
6815                 unless length $om->[0];
6816             $om->[0] = $v;
6817         }
6818
6819         foreach my $c (access_cfg_cfgs("opts-$k")) {
6820             my @vl =
6821                 map { $_ ? @$_ : () }
6822                 map { $gitcfgs{$_}{$c} }
6823                 reverse @gitcfgsources;
6824             printdebug "CL $c ", (join " ", map { shellquote } @vl),
6825                 "\n" if $debuglevel >= 4;
6826             next unless @vl;
6827             badcfg "cannot configure options for $k"
6828                 if $opts_opt_cmdonly{$k};
6829             my $insertpos = $opts_cfg_insertpos{$k};
6830             @$om = ( @$om[0..$insertpos-1],
6831                      @vl,
6832                      @$om[$insertpos..$#$om] );
6833         }
6834     }
6835
6836     if (!defined $rmchanges) {
6837         local $access_forpush;
6838         $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6839     }
6840
6841     if (!defined $quilt_mode) {
6842         local $access_forpush;
6843         $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6844             // access_cfg('quilt-mode', 'RETURN-UNDEF')
6845             // 'linear';
6846         $quilt_mode =~ m/^($quilt_modes_re)$/
6847             or badcfg "unknown quilt-mode \`$quilt_mode'";
6848         $quilt_mode = $1;
6849     }
6850
6851     foreach my $moc (@modeopt_cfgs) {
6852         local $access_forpush;
6853         my $vr = $moc->{Var};
6854         next if defined $$vr;
6855         $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
6856         my $v = $moc->{Vals}{$$vr};
6857         badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
6858         $$vr = $v;
6859     }
6860
6861     $need_split_build_invocation ||= quiltmode_splitbrain();
6862
6863     if (!defined $cleanmode) {
6864         local $access_forpush;
6865         $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6866         $cleanmode //= 'dpkg-source';
6867
6868         badcfg "unknown clean-mode \`$cleanmode'" unless
6869             $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6870     }
6871 }
6872
6873 if ($ENV{$fakeeditorenv}) {
6874     git_slurp_config();
6875     quilt_fixup_editor();
6876 }
6877
6878 parseopts();
6879 check_env_sanity();
6880
6881 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6882 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6883     if $dryrun_level == 1;
6884 if (!@ARGV) {
6885     print STDERR $helpmsg or die $!;
6886     finish 8;
6887 }
6888 $cmd = $subcommand = shift @ARGV;
6889 $cmd =~ y/-/_/;
6890
6891 my $pre_fn = ${*::}{"pre_$cmd"};
6892 $pre_fn->() if $pre_fn;
6893
6894 record_maindir if $invoked_in_git_tree;
6895 git_slurp_config();
6896
6897 my $fn = ${*::}{"cmd_$cmd"};
6898 $fn or badusage "unknown operation $cmd";
6899 $fn->();
6900
6901 finish 0;