dgit

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