dgit

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