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     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3731     runcmd_ordryrun_local @git, qw(add -f), @adds;
3732     commit_admin <<END
3733 Commit Debian 3.0 (quilt) metadata
3734
3735 [dgit ($our_version) quilt-fixup]
3736 END
3737 }
3738
3739 sub get_source_format () {
3740     my %options;
3741     if (open F, "debian/source/options") {
3742         while (<F>) {
3743             next if m/^\s*\#/;
3744             next unless m/\S/;
3745             s/\s+$//; # ignore missing final newline
3746             if (m/\s*\#\s*/) {
3747                 my ($k, $v) = ($`, $'); #');
3748                 $v =~ s/^"(.*)"$/$1/;
3749                 $options{$k} = $v;
3750             } else {
3751                 $options{$_} = 1;
3752             }
3753         }
3754         F->error and die $!;
3755         close F;
3756     } else {
3757         die $! unless $!==&ENOENT;
3758     }
3759
3760     if (!open F, "debian/source/format") {
3761         die $! unless $!==&ENOENT;
3762         return '';
3763     }
3764     $_ = <F>;
3765     F->error and die $!;
3766     chomp;
3767     return ($_, \%options);
3768 }
3769
3770 sub madformat_wantfixup ($) {
3771     my ($format) = @_;
3772     return 0 unless $format eq '3.0 (quilt)';
3773     our $quilt_mode_warned;
3774     if ($quilt_mode eq 'nocheck') {
3775         progress "Not doing any fixup of \`$format' due to".
3776             " ----no-quilt-fixup or --quilt=nocheck"
3777             unless $quilt_mode_warned++;
3778         return 0;
3779     }
3780     progress "Format \`$format', need to check/update patch stack"
3781         unless $quilt_mode_warned++;
3782     return 1;
3783 }
3784
3785 sub maybe_split_brain_save ($$$) {
3786     my ($headref, $dgitview, $msg) = @_;
3787     # => message fragment "$saved" describing disposition of $dgitview
3788     return "commit id $dgitview" unless defined $split_brain_save;
3789     my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3790                @git, qw(update-ref -m),
3791                "dgit --dgit-view-save $msg HEAD=$headref",
3792                $split_brain_save, $dgitview);
3793     runcmd @cmd;
3794     return "and left in $split_brain_save";
3795 }
3796
3797 # An "infopair" is a tuple [ $thing, $what ]
3798 # (often $thing is a commit hash; $what is a description)
3799
3800 sub infopair_cond_equal ($$) {
3801     my ($x,$y) = @_;
3802     $x->[0] eq $y->[0] or fail <<END;
3803 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3804 END
3805 };
3806
3807 sub infopair_lrf_tag_lookup ($$) {
3808     my ($tagnames, $what) = @_;
3809     # $tagname may be an array ref
3810     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3811     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3812     foreach my $tagname (@tagnames) {
3813         my $lrefname = lrfetchrefs."/tags/$tagname";
3814         my $tagobj = $lrfetchrefs_f{$lrefname};
3815         next unless defined $tagobj;
3816         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3817         return [ git_rev_parse($tagobj), $what ];
3818     }
3819     fail @tagnames==1 ? <<END : <<END;
3820 Wanted tag $what (@tagnames) on dgit server, but not found
3821 END
3822 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3823 END
3824 }
3825
3826 sub infopair_cond_ff ($$) {
3827     my ($anc,$desc) = @_;
3828     is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3829 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3830 END
3831 };
3832
3833 sub pseudomerge_version_check ($$) {
3834     my ($clogp, $archive_hash) = @_;
3835
3836     my $arch_clogp = commit_getclogp $archive_hash;
3837     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3838                      'version currently in archive' ];
3839     if (defined $overwrite_version) {
3840         if (length $overwrite_version) {
3841             infopair_cond_equal([ $overwrite_version,
3842                                   '--overwrite= version' ],
3843                                 $i_arch_v);
3844         } else {
3845             my $v = $i_arch_v->[0];
3846             progress "Checking package changelog for archive version $v ...";
3847             my $cd;
3848             eval {
3849                 my @xa = ("-f$v", "-t$v");
3850                 my $vclogp = parsechangelog @xa;
3851                 my $gf = sub {
3852                     my ($fn) = @_;
3853                     [ (getfield $vclogp, $fn),
3854                       "$fn field from dpkg-parsechangelog @xa" ];
3855                 };
3856                 my $cv = $gf->('Version');
3857                 infopair_cond_equal($i_arch_v, $cv);
3858                 $cd = $gf->('Distribution');
3859             };
3860             if ($@) {
3861                 $@ =~ s/^dgit: //gm;
3862                 fail "$@".
3863                     "Perhaps debian/changelog does not mention $v ?";
3864             }
3865             fail <<END if $cd->[0] =~ m/UNRELEASED/;
3866 $cd->[1] is $cd->[0]
3867 Your tree seems to based on earlier (not uploaded) $v.
3868 END
3869         }
3870     }
3871
3872     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3873     return $i_arch_v;
3874 }
3875
3876 sub pseudomerge_make_commit ($$$$ $$) {
3877     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3878         $msg_cmd, $msg_msg) = @_;
3879     progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3880
3881     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3882     my $authline = clogp_authline $clogp;
3883
3884     chomp $msg_msg;
3885     $msg_cmd .=
3886         !defined $overwrite_version ? ""
3887         : !length  $overwrite_version ? " --overwrite"
3888         : " --overwrite=".$overwrite_version;
3889
3890     my $pmf = dgit_privdir()."/pseudomerge";
3891     open MC, ">", $pmf or die "$pmf $!";
3892     print MC <<END or die $!;
3893 tree $tree
3894 parent $dgitview
3895 parent $archive_hash
3896 author $authline
3897 committer $authline
3898
3899 $msg_msg
3900
3901 [$msg_cmd]
3902 END
3903     close MC or die $!;
3904
3905     return make_commit($pmf);
3906 }
3907
3908 sub splitbrain_pseudomerge ($$$$) {
3909     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3910     # => $merged_dgitview
3911     printdebug "splitbrain_pseudomerge...\n";
3912     #
3913     #     We:      debian/PREVIOUS    HEAD($maintview)
3914     # expect:          o ----------------- o
3915     #                    \                   \
3916     #                     o                   o
3917     #                 a/d/PREVIOUS        $dgitview
3918     #                $archive_hash              \
3919     #  If so,                \                   \
3920     #  we do:                 `------------------ o
3921     #   this:                                   $dgitview'
3922     #
3923
3924     return $dgitview unless defined $archive_hash;
3925     return $dgitview if deliberately_not_fast_forward();
3926
3927     printdebug "splitbrain_pseudomerge...\n";
3928
3929     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3930
3931     if (!defined $overwrite_version) {
3932         progress "Checking that HEAD inciudes all changes in archive...";
3933     }
3934
3935     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3936
3937     if (defined $overwrite_version) {
3938     } elsif (!eval {
3939         my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3940         my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3941         my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3942         my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3943         my $i_archive = [ $archive_hash, "current archive contents" ];
3944
3945         printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3946
3947         infopair_cond_equal($i_dgit, $i_archive);
3948         infopair_cond_ff($i_dep14, $i_dgit);
3949         infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3950         1;
3951     }) {
3952         print STDERR <<END;
3953 $us: check failed (maybe --overwrite is needed, consult documentation)
3954 END
3955         die "$@";
3956     }
3957
3958     my $r = pseudomerge_make_commit
3959         $clogp, $dgitview, $archive_hash, $i_arch_v,
3960         "dgit --quilt=$quilt_mode",
3961         (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3962 Declare fast forward from $i_arch_v->[0]
3963 END_OVERWR
3964 Make fast forward from $i_arch_v->[0]
3965 END_MAKEFF
3966
3967     maybe_split_brain_save $maintview, $r, "pseudomerge";
3968
3969     progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3970     return $r;
3971 }
3972
3973 sub plain_overwrite_pseudomerge ($$$) {
3974     my ($clogp, $head, $archive_hash) = @_;
3975
3976     printdebug "plain_overwrite_pseudomerge...";
3977
3978     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3979
3980     return $head if is_fast_fwd $archive_hash, $head;
3981
3982     my $m = "Declare fast forward from $i_arch_v->[0]";
3983
3984     my $r = pseudomerge_make_commit
3985         $clogp, $head, $archive_hash, $i_arch_v,
3986         "dgit", $m;
3987
3988     runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3989
3990     progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3991     return $r;
3992 }
3993
3994 sub push_parse_changelog ($) {
3995     my ($clogpfn) = @_;
3996
3997     my $clogp = Dpkg::Control::Hash->new();
3998     $clogp->load($clogpfn) or die;
3999
4000     my $clogpackage = getfield $clogp, 'Source';
4001     $package //= $clogpackage;
4002     fail "-p specified $package but changelog specified $clogpackage"
4003         unless $package eq $clogpackage;
4004     my $cversion = getfield $clogp, 'Version';
4005
4006     if (!$we_are_initiator) {
4007         # rpush initiator can't do this because it doesn't have $isuite yet
4008         my $tag = debiantag($cversion, access_nomdistro);
4009         runcmd @git, qw(check-ref-format), $tag;
4010     }
4011
4012     my $dscfn = dscfn($cversion);
4013
4014     return ($clogp, $cversion, $dscfn);
4015 }
4016
4017 sub push_parse_dsc ($$$) {
4018     my ($dscfn,$dscfnwhat, $cversion) = @_;
4019     $dsc = parsecontrol($dscfn,$dscfnwhat);
4020     my $dversion = getfield $dsc, 'Version';
4021     my $dscpackage = getfield $dsc, 'Source';
4022     ($dscpackage eq $package && $dversion eq $cversion) or
4023         fail "$dscfn is for $dscpackage $dversion".
4024             " but debian/changelog is for $package $cversion";
4025 }
4026
4027 sub push_tagwants ($$$$) {
4028     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4029     my @tagwants;
4030     push @tagwants, {
4031         TagFn => \&debiantag,
4032         Objid => $dgithead,
4033         TfSuffix => '',
4034         View => 'dgit',
4035     };
4036     if (defined $maintviewhead) {
4037         push @tagwants, {
4038             TagFn => \&debiantag_maintview,
4039             Objid => $maintviewhead,
4040             TfSuffix => '-maintview',
4041             View => 'maint',
4042         };
4043     } elsif ($dodep14tag eq 'no' ? 0
4044              : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4045              : $dodep14tag eq 'always'
4046              ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4047 --dep14tag-always (or equivalent in config) means server must support
4048  both "new" and "maint" tag formats, but config says it doesn't.
4049 END
4050             : die "$dodep14tag ?") {
4051         push @tagwants, {
4052             TagFn => \&debiantag_maintview,
4053             Objid => $dgithead,
4054             TfSuffix => '-dgit',
4055             View => 'dgit',
4056         };
4057     };
4058     foreach my $tw (@tagwants) {
4059         $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4060         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4061     }
4062     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4063     return @tagwants;
4064 }
4065
4066 sub push_mktags ($$ $$ $) {
4067     my ($clogp,$dscfn,
4068         $changesfile,$changesfilewhat,
4069         $tagwants) = @_;
4070
4071     die unless $tagwants->[0]{View} eq 'dgit';
4072
4073     my $declaredistro = access_nomdistro();
4074     my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4075     $dsc->{$ourdscfield[0]} = join " ",
4076         $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4077         $reader_giturl;
4078     $dsc->save("$dscfn.tmp") or die $!;
4079
4080     my $changes = parsecontrol($changesfile,$changesfilewhat);
4081     foreach my $field (qw(Source Distribution Version)) {
4082         $changes->{$field} eq $clogp->{$field} or
4083             fail "changes field $field \`$changes->{$field}'".
4084                 " does not match changelog \`$clogp->{$field}'";
4085     }
4086
4087     my $cversion = getfield $clogp, 'Version';
4088     my $clogsuite = getfield $clogp, 'Distribution';
4089
4090     # We make the git tag by hand because (a) that makes it easier
4091     # to control the "tagger" (b) we can do remote signing
4092     my $authline = clogp_authline $clogp;
4093     my $delibs = join(" ", "",@deliberatelies);
4094
4095     my $mktag = sub {
4096         my ($tw) = @_;
4097         my $tfn = $tw->{Tfn};
4098         my $head = $tw->{Objid};
4099         my $tag = $tw->{Tag};
4100
4101         open TO, '>', $tfn->('.tmp') or die $!;
4102         print TO <<END or die $!;
4103 object $head
4104 type commit
4105 tag $tag
4106 tagger $authline
4107
4108 END
4109         if ($tw->{View} eq 'dgit') {
4110             print TO <<END or die $!;
4111 $package release $cversion for $clogsuite ($csuite) [dgit]
4112 [dgit distro=$declaredistro$delibs]
4113 END
4114             foreach my $ref (sort keys %previously) {
4115                 print TO <<END or die $!;
4116 [dgit previously:$ref=$previously{$ref}]
4117 END
4118             }
4119         } elsif ($tw->{View} eq 'maint') {
4120             print TO <<END or die $!;
4121 $package release $cversion for $clogsuite ($csuite)
4122 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4123 END
4124         } else {
4125             die Dumper($tw)."?";
4126         }
4127
4128         close TO or die $!;
4129
4130         my $tagobjfn = $tfn->('.tmp');
4131         if ($sign) {
4132             if (!defined $keyid) {
4133                 $keyid = access_cfg('keyid','RETURN-UNDEF');
4134             }
4135             if (!defined $keyid) {
4136                 $keyid = getfield $clogp, 'Maintainer';
4137             }
4138             unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4139             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4140             push @sign_cmd, qw(-u),$keyid if defined $keyid;
4141             push @sign_cmd, $tfn->('.tmp');
4142             runcmd_ordryrun @sign_cmd;
4143             if (act_scary()) {
4144                 $tagobjfn = $tfn->('.signed.tmp');
4145                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4146                     $tfn->('.tmp'), $tfn->('.tmp.asc');
4147             }
4148         }
4149         return $tagobjfn;
4150     };
4151
4152     my @r = map { $mktag->($_); } @$tagwants;
4153     return @r;
4154 }
4155
4156 sub sign_changes ($) {
4157     my ($changesfile) = @_;
4158     if ($sign) {
4159         my @debsign_cmd = @debsign;
4160         push @debsign_cmd, "-k$keyid" if defined $keyid;
4161         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4162         push @debsign_cmd, $changesfile;
4163         runcmd_ordryrun @debsign_cmd;
4164     }
4165 }
4166
4167 sub dopush () {
4168     printdebug "actually entering push\n";
4169
4170     supplementary_message(<<'END');
4171 Push failed, while checking state of the archive.
4172 You can retry the push, after fixing the problem, if you like.
4173 END
4174     if (check_for_git()) {
4175         git_fetch_us();
4176     }
4177     my $archive_hash = fetch_from_archive();
4178     if (!$archive_hash) {
4179         $new_package or
4180             fail "package appears to be new in this suite;".
4181                 " if this is intentional, use --new";
4182     }
4183
4184     supplementary_message(<<'END');
4185 Push failed, while preparing your push.
4186 You can retry the push, after fixing the problem, if you like.
4187 END
4188
4189     need_tagformat 'new', "quilt mode $quilt_mode"
4190         if quiltmode_splitbrain;
4191
4192     prep_ud();
4193
4194     access_giturl(); # check that success is vaguely likely
4195     rpush_handle_protovsn_bothends() if $we_are_initiator;
4196     select_tagformat();
4197
4198     my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4199     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4200
4201     responder_send_file('parsed-changelog', $clogpfn);
4202
4203     my ($clogp, $cversion, $dscfn) =
4204         push_parse_changelog("$clogpfn");
4205
4206     my $dscpath = "$buildproductsdir/$dscfn";
4207     stat_exists $dscpath or
4208         fail "looked for .dsc $dscpath, but $!;".
4209             " maybe you forgot to build";
4210
4211     responder_send_file('dsc', $dscpath);
4212
4213     push_parse_dsc($dscpath, $dscfn, $cversion);
4214
4215     my $format = getfield $dsc, 'Format';
4216     printdebug "format $format\n";
4217
4218     my $actualhead = git_rev_parse('HEAD');
4219     my $dgithead = $actualhead;
4220     my $maintviewhead = undef;
4221
4222     my $upstreamversion = upstreamversion $clogp->{Version};
4223
4224     if (madformat_wantfixup($format)) {
4225         # user might have not used dgit build, so maybe do this now:
4226         if (quiltmode_splitbrain()) {
4227             changedir $playground;
4228             quilt_make_fake_dsc($upstreamversion);
4229             my $cachekey;
4230             ($dgithead, $cachekey) =
4231                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4232             $dgithead or fail
4233  "--quilt=$quilt_mode but no cached dgit view:
4234  perhaps HEAD changed since dgit build[-source] ?";
4235             $split_brain = 1;
4236             $dgithead = splitbrain_pseudomerge($clogp,
4237                                                $actualhead, $dgithead,
4238                                                $archive_hash);
4239             $maintviewhead = $actualhead;
4240             changedir $maindir;
4241             prep_ud(); # so _only_subdir() works, below
4242         } else {
4243             commit_quilty_patch();
4244         }
4245     }
4246
4247     if (defined $overwrite_version && !defined $maintviewhead) {
4248         $dgithead = plain_overwrite_pseudomerge($clogp,
4249                                                 $dgithead,
4250                                                 $archive_hash);
4251     }
4252
4253     check_not_dirty();
4254
4255     my $forceflag = '';
4256     if ($archive_hash) {
4257         if (is_fast_fwd($archive_hash, $dgithead)) {
4258             # ok
4259         } elsif (deliberately_not_fast_forward) {
4260             $forceflag = '+';
4261         } else {
4262             fail "dgit push: HEAD is not a descendant".
4263                 " of the archive's version.\n".
4264                 "To overwrite the archive's contents,".
4265                 " pass --overwrite[=VERSION].\n".
4266                 "To rewind history, if permitted by the archive,".
4267                 " use --deliberately-not-fast-forward.";
4268         }
4269     }
4270
4271     changedir $playground;
4272     progress "checking that $dscfn corresponds to HEAD";
4273     runcmd qw(dpkg-source -x --),
4274         $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4275     my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4276     check_for_vendor_patches() if madformat($dsc->{format});
4277     changedir $maindir;
4278     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4279     debugcmd "+",@diffcmd;
4280     $!=0; $?=-1;
4281     my $r = system @diffcmd;
4282     if ($r) {
4283         if ($r==256) {
4284             my $referent = $split_brain ? $dgithead : 'HEAD';
4285             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4286
4287             my @mode_changes;
4288             my $raw = cmdoutput @git,
4289                 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4290             my $changed;
4291             foreach (split /\0/, $raw) {
4292                 if (defined $changed) {
4293                     push @mode_changes, "$changed: $_\n" if $changed;
4294                     $changed = undef;
4295                     next;
4296                 } elsif (m/^:0+ 0+ /) {
4297                     $changed = '';
4298                 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4299                     $changed = "Mode change from $1 to $2"
4300                 } else {
4301                     die "$_ ?";
4302                 }
4303             }
4304             if (@mode_changes) {
4305                 fail <<END.(join '', @mode_changes).<<END;
4306 HEAD specifies a different tree to $dscfn:
4307 $diffs
4308 END
4309 There is a problem with your source tree (see dgit(7) for some hints).
4310 To see a full diff, run git diff $tree $referent
4311 END
4312             }
4313
4314             fail <<END;
4315 HEAD specifies a different tree to $dscfn:
4316 $diffs
4317 Perhaps you forgot to build.  Or perhaps there is a problem with your
4318  source tree (see dgit(7) for some hints).  To see a full diff, run
4319    git diff $tree $referent
4320 END
4321         } else {
4322             failedcmd @diffcmd;
4323         }
4324     }
4325     if (!$changesfile) {
4326         my $pat = changespat $cversion;
4327         my @cs = glob "$buildproductsdir/$pat";
4328         fail "failed to find unique changes file".
4329             " (looked for $pat in $buildproductsdir);".
4330             " perhaps you need to use dgit -C"
4331             unless @cs==1;
4332         ($changesfile) = @cs;
4333     } else {
4334         $changesfile = "$buildproductsdir/$changesfile";
4335     }
4336
4337     # Check that changes and .dsc agree enough
4338     $changesfile =~ m{[^/]*$};
4339     my $changes = parsecontrol($changesfile,$&);
4340     files_compare_inputs($dsc, $changes)
4341         unless forceing [qw(dsc-changes-mismatch)];
4342
4343     # Perhaps adjust .dsc to contain right set of origs
4344     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4345                                   $changesfile)
4346         unless forceing [qw(changes-origs-exactly)];
4347
4348     # Checks complete, we're going to try and go ahead:
4349
4350     responder_send_file('changes',$changesfile);
4351     responder_send_command("param head $dgithead");
4352     responder_send_command("param csuite $csuite");
4353     responder_send_command("param isuite $isuite");
4354     responder_send_command("param tagformat $tagformat");
4355     if (defined $maintviewhead) {
4356         die unless ($protovsn//4) >= 4;
4357         responder_send_command("param maint-view $maintviewhead");
4358     }
4359
4360     # Perhaps send buildinfo(s) for signing
4361     my $changes_files = getfield $changes, 'Files';
4362     my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4363     foreach my $bi (@buildinfos) {
4364         responder_send_command("param buildinfo-filename $bi");
4365         responder_send_file('buildinfo', "$buildproductsdir/$bi");
4366     }
4367
4368     if (deliberately_not_fast_forward) {
4369         git_for_each_ref(lrfetchrefs, sub {
4370             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4371             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4372             responder_send_command("previously $rrefname=$objid");
4373             $previously{$rrefname} = $objid;
4374         });
4375     }
4376
4377     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4378                                  dgit_privdir()."/tag");
4379     my @tagobjfns;
4380
4381     supplementary_message(<<'END');
4382 Push failed, while signing the tag.
4383 You can retry the push, after fixing the problem, if you like.
4384 END
4385     # If we manage to sign but fail to record it anywhere, it's fine.
4386     if ($we_are_responder) {
4387         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4388         responder_receive_files('signed-tag', @tagobjfns);
4389     } else {
4390         @tagobjfns = push_mktags($clogp,$dscpath,
4391                               $changesfile,$changesfile,
4392                               \@tagwants);
4393     }
4394     supplementary_message(<<'END');
4395 Push failed, *after* signing the tag.
4396 If you want to try again, you should use a new version number.
4397 END
4398
4399     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4400
4401     foreach my $tw (@tagwants) {
4402         my $tag = $tw->{Tag};
4403         my $tagobjfn = $tw->{TagObjFn};
4404         my $tag_obj_hash =
4405             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4406         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4407         runcmd_ordryrun_local
4408             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4409     }
4410
4411     supplementary_message(<<'END');
4412 Push failed, while updating the remote git repository - see messages above.
4413 If you want to try again, you should use a new version number.
4414 END
4415     if (!check_for_git()) {
4416         create_remote_git_repo();
4417     }
4418
4419     my @pushrefs = $forceflag.$dgithead.":".rrref();
4420     foreach my $tw (@tagwants) {
4421         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4422     }
4423
4424     runcmd_ordryrun @git,
4425         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4426     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
4427
4428     supplementary_message(<<'END');
4429 Push failed, while obtaining signatures on the .changes and .dsc.
4430 If it was just that the signature failed, you may try again by using
4431 debsign by hand to sign the changes
4432    $changesfile
4433 and then dput to complete the upload.
4434 If you need to change the package, you must use a new version number.
4435 END
4436     if ($we_are_responder) {
4437         my $dryrunsuffix = act_local() ? "" : ".tmp";
4438         my @rfiles = ($dscpath, $changesfile);
4439         push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4440         responder_receive_files('signed-dsc-changes',
4441                                 map { "$_$dryrunsuffix" } @rfiles);
4442     } else {
4443         if (act_local()) {
4444             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4445         } else {
4446             progress "[new .dsc left in $dscpath.tmp]";
4447         }
4448         sign_changes $changesfile;
4449     }
4450
4451     supplementary_message(<<END);
4452 Push failed, while uploading package(s) to the archive server.
4453 You can retry the upload of exactly these same files with dput of:
4454   $changesfile
4455 If that .changes file is broken, you will need to use a new version
4456 number for your next attempt at the upload.
4457 END
4458     my $host = access_cfg('upload-host','RETURN-UNDEF');
4459     my @hostarg = defined($host) ? ($host,) : ();
4460     runcmd_ordryrun @dput, @hostarg, $changesfile;
4461     printdone "pushed and uploaded $cversion";
4462
4463     supplementary_message('');
4464     responder_send_command("complete");
4465 }
4466
4467 sub pre_clone () {
4468     not_necessarily_a_tree();
4469 }
4470 sub cmd_clone {
4471     parseopts();
4472     my $dstdir;
4473     badusage "-p is not allowed with clone; specify as argument instead"
4474         if defined $package;
4475     if (@ARGV==1) {
4476         ($package) = @ARGV;
4477     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4478         ($package,$isuite) = @ARGV;
4479     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4480         ($package,$dstdir) = @ARGV;
4481     } elsif (@ARGV==3) {
4482         ($package,$isuite,$dstdir) = @ARGV;
4483     } else {
4484         badusage "incorrect arguments to dgit clone";
4485     }
4486     notpushing();
4487
4488     $dstdir ||= "$package";
4489     if (stat_exists $dstdir) {
4490         fail "$dstdir already exists";
4491     }
4492
4493     my $cwd_remove;
4494     if ($rmonerror && !$dryrun_level) {
4495         $cwd_remove= getcwd();
4496         unshift @end, sub {
4497             return unless defined $cwd_remove;
4498             if (!chdir "$cwd_remove") {
4499                 return if $!==&ENOENT;
4500                 die "chdir $cwd_remove: $!";
4501             }
4502             printdebug "clone rmonerror removing $dstdir\n";
4503             if (stat $dstdir) {
4504                 rmtree($dstdir) or die "remove $dstdir: $!\n";
4505             } elsif (grep { $! == $_ }
4506                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4507             } else {
4508                 print STDERR "check whether to remove $dstdir: $!\n";
4509             }
4510         };
4511     }
4512
4513     clone($dstdir);
4514     $cwd_remove = undef;
4515 }
4516
4517 sub branchsuite () {
4518     my $branch = git_get_symref();
4519     if (defined $branch && $branch =~ m#$lbranch_re#o) {
4520         return $1;
4521     } else {
4522         return undef;
4523     }
4524 }
4525
4526 sub fetchpullargs () {
4527     if (!defined $package) {
4528         my $sourcep = parsecontrol('debian/control','debian/control');
4529         $package = getfield $sourcep, 'Source';
4530     }
4531     if (@ARGV==0) {
4532         $isuite = branchsuite();
4533         if (!$isuite) {
4534             my $clogp = parsechangelog();
4535             my $clogsuite = getfield $clogp, 'Distribution';
4536             $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4537         }
4538     } elsif (@ARGV==1) {
4539         ($isuite) = @ARGV;
4540     } else {
4541         badusage "incorrect arguments to dgit fetch or dgit pull";
4542     }
4543     notpushing();
4544 }
4545
4546 sub cmd_fetch {
4547     parseopts();
4548     fetchpullargs();
4549     my $multi_fetched = fork_for_multisuite(sub { });
4550     finish 0 if $multi_fetched;
4551     fetch();
4552 }
4553
4554 sub cmd_pull {
4555     parseopts();
4556     fetchpullargs();
4557     if (quiltmode_splitbrain()) {
4558         my ($format, $fopts) = get_source_format();
4559         madformat($format) and fail <<END
4560 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4561 END
4562     }
4563     pull();
4564 }
4565
4566 sub prep_push () {
4567     parseopts();
4568     build_or_push_prep_early();
4569     pushing();
4570     check_not_dirty();
4571     my $specsuite;
4572     if (@ARGV==0) {
4573     } elsif (@ARGV==1) {
4574         ($specsuite) = (@ARGV);
4575     } else {
4576         badusage "incorrect arguments to dgit $subcommand";
4577     }
4578     if ($new_package) {
4579         local ($package) = $existing_package; # this is a hack
4580         canonicalise_suite();
4581     } else {
4582         canonicalise_suite();
4583     }
4584     if (defined $specsuite &&
4585         $specsuite ne $isuite &&
4586         $specsuite ne $csuite) {
4587             fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4588                 " but command line specifies $specsuite";
4589     }
4590 }
4591
4592 sub cmd_push {
4593     prep_push();
4594     dopush();
4595 }
4596
4597 sub cmd_push_source {
4598     prep_push();
4599     if ($changesfile) {
4600         my $changes = parsecontrol("$buildproductsdir/$changesfile",
4601                                    "source changes file");
4602         unless (test_source_only_changes($changes)) {
4603             fail "user-specified changes file is not source-only";
4604         }
4605     } else {
4606         # Building a source package is very fast, so just do it
4607         build_source_for_push();
4608     }
4609     dopush();
4610 }
4611
4612 #---------- remote commands' implementation ----------
4613
4614 sub pre_remote_push_build_host {
4615     my ($nrargs) = shift @ARGV;
4616     my (@rargs) = @ARGV[0..$nrargs-1];
4617     @ARGV = @ARGV[$nrargs..$#ARGV];
4618     die unless @rargs;
4619     my ($dir,$vsnwant) = @rargs;
4620     # vsnwant is a comma-separated list; we report which we have
4621     # chosen in our ready response (so other end can tell if they
4622     # offered several)
4623     $debugprefix = ' ';
4624     $we_are_responder = 1;
4625     $us .= " (build host)";
4626
4627     open PI, "<&STDIN" or die $!;
4628     open STDIN, "/dev/null" or die $!;
4629     open PO, ">&STDOUT" or die $!;
4630     autoflush PO 1;
4631     open STDOUT, ">&STDERR" or die $!;
4632     autoflush STDOUT 1;
4633
4634     $vsnwant //= 1;
4635     ($protovsn) = grep {
4636         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4637     } @rpushprotovsn_support;
4638
4639     fail "build host has dgit rpush protocol versions ".
4640         (join ",", @rpushprotovsn_support).
4641         " but invocation host has $vsnwant"
4642         unless defined $protovsn;
4643
4644     changedir $dir;
4645 }
4646 sub cmd_remote_push_build_host {
4647     responder_send_command("dgit-remote-push-ready $protovsn");
4648     &cmd_push;
4649 }
4650
4651 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4652 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4653 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4654 #     a good error message)
4655
4656 sub rpush_handle_protovsn_bothends () {
4657     if ($protovsn < 4) {
4658         need_tagformat 'old', "rpush negotiated protocol $protovsn";
4659     }
4660     select_tagformat();
4661 }
4662
4663 our $i_tmp;
4664
4665 sub i_cleanup {
4666     local ($@, $?);
4667     my $report = i_child_report();
4668     if (defined $report) {
4669         printdebug "($report)\n";
4670     } elsif ($i_child_pid) {
4671         printdebug "(killing build host child $i_child_pid)\n";
4672         kill 15, $i_child_pid;
4673     }
4674     if (defined $i_tmp && !defined $initiator_tempdir) {
4675         changedir "/";
4676         eval { rmtree $i_tmp; };
4677     }
4678 }
4679
4680 END {
4681     return unless forkcheck_mainprocess();
4682     i_cleanup();
4683 }
4684
4685 sub i_method {
4686     my ($base,$selector,@args) = @_;
4687     $selector =~ s/\-/_/g;
4688     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4689 }
4690
4691 sub pre_rpush () {
4692     not_necessarily_a_tree();
4693 }
4694 sub cmd_rpush {
4695     my $host = nextarg;
4696     my $dir;
4697     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4698         $host = $1;
4699         $dir = $'; #';
4700     } else {
4701         $dir = nextarg;
4702     }
4703     $dir =~ s{^-}{./-};
4704     my @rargs = ($dir);
4705     push @rargs, join ",", @rpushprotovsn_support;
4706     my @rdgit;
4707     push @rdgit, @dgit;
4708     push @rdgit, @ropts;
4709     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4710     push @rdgit, @ARGV;
4711     my @cmd = (@ssh, $host, shellquote @rdgit);
4712     debugcmd "+",@cmd;
4713
4714     $we_are_initiator=1;
4715
4716     if (defined $initiator_tempdir) {
4717         rmtree $initiator_tempdir;
4718         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4719         $i_tmp = $initiator_tempdir;
4720     } else {
4721         $i_tmp = tempdir();
4722     }
4723     $i_child_pid = open2(\*RO, \*RI, @cmd);
4724     changedir $i_tmp;
4725     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4726     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4727     $supplementary_message = '' unless $protovsn >= 3;
4728
4729     for (;;) {
4730         my ($icmd,$iargs) = initiator_expect {
4731             m/^(\S+)(?: (.*))?$/;
4732             ($1,$2);
4733         };
4734         i_method "i_resp", $icmd, $iargs;
4735     }
4736 }
4737
4738 sub i_resp_progress ($) {
4739     my ($rhs) = @_;
4740     my $msg = protocol_read_bytes \*RO, $rhs;
4741     progress $msg;
4742 }
4743
4744 sub i_resp_supplementary_message ($) {
4745     my ($rhs) = @_;
4746     $supplementary_message = protocol_read_bytes \*RO, $rhs;
4747 }
4748
4749 sub i_resp_complete {
4750     my $pid = $i_child_pid;
4751     $i_child_pid = undef; # prevents killing some other process with same pid
4752     printdebug "waiting for build host child $pid...\n";
4753     my $got = waitpid $pid, 0;
4754     die $! unless $got == $pid;
4755     die "build host child failed $?" if $?;
4756
4757     i_cleanup();
4758     printdebug "all done\n";
4759     finish 0;
4760 }
4761
4762 sub i_resp_file ($) {
4763     my ($keyword) = @_;
4764     my $localname = i_method "i_localname", $keyword;
4765     my $localpath = "$i_tmp/$localname";
4766     stat_exists $localpath and
4767         badproto \*RO, "file $keyword ($localpath) twice";
4768     protocol_receive_file \*RO, $localpath;
4769     i_method "i_file", $keyword;
4770 }
4771
4772 our %i_param;
4773
4774 sub i_resp_param ($) {
4775     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4776     $i_param{$1} = $2;
4777 }
4778
4779 sub i_resp_previously ($) {
4780     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4781         or badproto \*RO, "bad previously spec";
4782     my $r = system qw(git check-ref-format), $1;
4783     die "bad previously ref spec ($r)" if $r;
4784     $previously{$1} = $2;
4785 }
4786
4787 our %i_wanted;
4788
4789 sub i_resp_want ($) {
4790     my ($keyword) = @_;
4791     die "$keyword ?" if $i_wanted{$keyword}++;
4792
4793     defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4794     $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4795     die unless $isuite =~ m/^$suite_re$/;
4796
4797     pushing();
4798     rpush_handle_protovsn_bothends();
4799
4800     fail "rpush negotiated protocol version $protovsn".
4801         " which does not support quilt mode $quilt_mode"
4802         if quiltmode_splitbrain;
4803
4804     my @localpaths = i_method "i_want", $keyword;
4805     printdebug "[[  $keyword @localpaths\n";
4806     foreach my $localpath (@localpaths) {
4807         protocol_send_file \*RI, $localpath;
4808     }
4809     print RI "files-end\n" or die $!;
4810 }
4811
4812 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
4813
4814 sub i_localname_parsed_changelog {
4815     return "remote-changelog.822";
4816 }
4817 sub i_file_parsed_changelog {
4818     ($i_clogp, $i_version, $i_dscfn) =
4819         push_parse_changelog "$i_tmp/remote-changelog.822";
4820     die if $i_dscfn =~ m#/|^\W#;
4821 }
4822
4823 sub i_localname_dsc {
4824     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4825     return $i_dscfn;
4826 }
4827 sub i_file_dsc { }
4828
4829 sub i_localname_buildinfo ($) {
4830     my $bi = $i_param{'buildinfo-filename'};
4831     defined $bi or badproto \*RO, "buildinfo before filename";
4832     defined $i_changesfn or badproto \*RO, "buildinfo before changes";
4833     $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
4834         or badproto \*RO, "improper buildinfo filename";
4835     return $&;
4836 }
4837 sub i_file_buildinfo {
4838     my $bi = $i_param{'buildinfo-filename'};
4839     my $bd = parsecontrol "$i_tmp/$bi", $bi;
4840     my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
4841     if (!forceing [qw(buildinfo-changes-mismatch)]) {
4842         files_compare_inputs($bd, $ch);
4843         (getfield $bd, $_) eq (getfield $ch, $_) or
4844             fail "buildinfo mismatch $_"
4845             foreach qw(Source Version);
4846         !defined $bd->{$_} or
4847             fail "buildinfo contains $_"
4848             foreach qw(Changes Changed-by Distribution);
4849     }
4850     push @i_buildinfos, $bi;
4851     delete $i_param{'buildinfo-filename'};
4852 }
4853
4854 sub i_localname_changes {
4855     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4856     $i_changesfn = $i_dscfn;
4857     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4858     return $i_changesfn;
4859 }
4860 sub i_file_changes { }
4861
4862 sub i_want_signed_tag {
4863     printdebug Dumper(\%i_param, $i_dscfn);
4864     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4865         && defined $i_param{'csuite'}
4866         or badproto \*RO, "premature desire for signed-tag";
4867     my $head = $i_param{'head'};
4868     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4869
4870     my $maintview = $i_param{'maint-view'};
4871     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4872
4873     select_tagformat();
4874     if ($protovsn >= 4) {
4875         my $p = $i_param{'tagformat'} // '<undef>';
4876         $p eq $tagformat
4877             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4878     }
4879
4880     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4881     $csuite = $&;
4882     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4883
4884     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4885
4886     return
4887         push_mktags $i_clogp, $i_dscfn,
4888             $i_changesfn, 'remote changes',
4889             \@tagwants;
4890 }
4891
4892 sub i_want_signed_dsc_changes {
4893     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4894     sign_changes $i_changesfn;
4895     return ($i_dscfn, $i_changesfn, @i_buildinfos);
4896 }
4897
4898 #---------- building etc. ----------
4899
4900 our $version;
4901 our $sourcechanges;
4902 our $dscfn;
4903
4904 #----- `3.0 (quilt)' handling -----
4905
4906 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4907
4908 sub quiltify_dpkg_commit ($$$;$) {
4909     my ($patchname,$author,$msg, $xinfo) = @_;
4910     $xinfo //= '';
4911
4912     mkpath '.git/dgit'; # we are in playtree
4913     my $descfn = ".git/dgit/quilt-description.tmp";
4914     open O, '>', $descfn or die "$descfn: $!";
4915     $msg =~ s/\n+/\n\n/;
4916     print O <<END or die $!;
4917 From: $author
4918 ${xinfo}Subject: $msg
4919 ---
4920
4921 END
4922     close O or die $!;
4923
4924     {
4925         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4926         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4927         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4928         runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4929     }
4930 }
4931
4932 sub quiltify_trees_differ ($$;$$$) {
4933     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4934     # returns true iff the two tree objects differ other than in debian/
4935     # with $finegrained,
4936     # returns bitmask 01 - differ in upstream files except .gitignore
4937     #                 02 - differ in .gitignore
4938     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4939     #  is set for each modified .gitignore filename $fn
4940     # if $unrepres is defined, array ref to which is appeneded
4941     #  a list of unrepresentable changes (removals of upstream files
4942     #  (as messages)
4943     local $/=undef;
4944     my @cmd = (@git, qw(diff-tree -z --no-renames));
4945     push @cmd, qw(--name-only) unless $unrepres;
4946     push @cmd, qw(-r) if $finegrained || $unrepres;
4947     push @cmd, $x, $y;
4948     my $diffs= cmdoutput @cmd;
4949     my $r = 0;
4950     my @lmodes;
4951     foreach my $f (split /\0/, $diffs) {
4952         if ($unrepres && !@lmodes) {
4953             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4954             next;
4955         }
4956         my ($oldmode,$newmode) = @lmodes;
4957         @lmodes = ();
4958
4959         next if $f =~ m#^debian(?:/.*)?$#s;
4960
4961         if ($unrepres) {
4962             eval {
4963                 die "not a plain file or symlink\n"
4964                     unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
4965                            $oldmode =~ m/^(?:10|12)\d{4}$/;
4966                 if ($oldmode =~ m/[^0]/ &&
4967                     $newmode =~ m/[^0]/) {
4968                     # both old and new files exist
4969                     die "mode or type changed\n" if $oldmode ne $newmode;
4970                     die "modified symlink\n" unless $newmode =~ m/^10/;
4971                 } elsif ($oldmode =~ m/[^0]/) {
4972                     # deletion
4973                     die "deletion of symlink\n"
4974                         unless $oldmode =~ m/^10/;
4975                 } else {
4976                     # creation
4977                     die "creation with non-default mode\n"
4978                         unless $newmode =~ m/^100644$/ or
4979                                $newmode =~ m/^120000$/;
4980                 }
4981             };
4982             if ($@) {
4983                 local $/="\n"; chomp $@;
4984                 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4985             }
4986         }
4987
4988         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4989         $r |= $isignore ? 02 : 01;
4990         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4991     }
4992     printdebug "quiltify_trees_differ $x $y => $r\n";
4993     return $r;
4994 }
4995
4996 sub quiltify_tree_sentinelfiles ($) {
4997     # lists the `sentinel' files present in the tree
4998     my ($x) = @_;
4999     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5000         qw(-- debian/rules debian/control);
5001     $r =~ s/\n/,/g;
5002     return $r;
5003 }
5004
5005 sub quiltify_splitbrain_needed () {
5006     if (!$split_brain) {
5007         progress "dgit view: changes are required...";
5008         runcmd @git, qw(checkout -q -b dgit-view);
5009         $split_brain = 1;
5010     }
5011 }
5012
5013 sub quiltify_splitbrain ($$$$$$) {
5014     my ($clogp, $unapplied, $headref, $diffbits,
5015         $editedignores, $cachekey) = @_;
5016     if ($quilt_mode !~ m/gbp|dpm/) {
5017         # treat .gitignore just like any other upstream file
5018         $diffbits = { %$diffbits };
5019         $_ = !!$_ foreach values %$diffbits;
5020     }
5021     # We would like any commits we generate to be reproducible
5022     my @authline = clogp_authline($clogp);
5023     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
5024     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5025     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
5026     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
5027     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5028     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
5029
5030     if ($quilt_mode =~ m/gbp|unapplied/ &&
5031         ($diffbits->{O2H} & 01)) {
5032         my $msg =
5033  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5034  " but git tree differs from orig in upstream files.";
5035         if (!stat_exists "debian/patches") {
5036             $msg .=
5037  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5038         }
5039         fail $msg;
5040     }
5041     if ($quilt_mode =~ m/dpm/ &&
5042         ($diffbits->{H2A} & 01)) {
5043         fail <<END;
5044 --quilt=$quilt_mode specified, implying patches-applied git tree
5045  but git tree differs from result of applying debian/patches to upstream
5046 END
5047     }
5048     if ($quilt_mode =~ m/gbp|unapplied/ &&
5049         ($diffbits->{O2A} & 01)) { # some patches
5050         quiltify_splitbrain_needed();
5051         progress "dgit view: creating patches-applied version using gbp pq";
5052         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5053         # gbp pq import creates a fresh branch; push back to dgit-view
5054         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5055         runcmd @git, qw(checkout -q dgit-view);
5056     }
5057     if ($quilt_mode =~ m/gbp|dpm/ &&
5058         ($diffbits->{O2A} & 02)) {
5059         fail <<END
5060 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5061  tool which does not create patches for changes to upstream
5062  .gitignores: but, such patches exist in debian/patches.
5063 END
5064     }
5065     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5066         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5067         quiltify_splitbrain_needed();
5068         progress "dgit view: creating patch to represent .gitignore changes";
5069         ensuredir "debian/patches";
5070         my $gipatch = "debian/patches/auto-gitignore";
5071         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5072         stat GIPATCH or die "$gipatch: $!";
5073         fail "$gipatch already exists; but want to create it".
5074             " to record .gitignore changes" if (stat _)[7];
5075         print GIPATCH <<END or die "$gipatch: $!";
5076 Subject: Update .gitignore from Debian packaging branch
5077
5078 The Debian packaging git branch contains these updates to the upstream
5079 .gitignore file(s).  This patch is autogenerated, to provide these
5080 updates to users of the official Debian archive view of the package.
5081
5082 [dgit ($our_version) update-gitignore]
5083 ---
5084 END
5085         close GIPATCH or die "$gipatch: $!";
5086         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5087             $unapplied, $headref, "--", sort keys %$editedignores;
5088         open SERIES, "+>>", "debian/patches/series" or die $!;
5089         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5090         my $newline;
5091         defined read SERIES, $newline, 1 or die $!;
5092         print SERIES "\n" or die $! unless $newline eq "\n";
5093         print SERIES "auto-gitignore\n" or die $!;
5094         close SERIES or die  $!;
5095         runcmd @git, qw(add -- debian/patches/series), $gipatch;
5096         commit_admin <<END
5097 Commit patch to update .gitignore
5098
5099 [dgit ($our_version) update-gitignore-quilt-fixup]
5100 END
5101     }
5102
5103     my $dgitview = git_rev_parse 'HEAD';
5104
5105     changedir $maindir;
5106     # When we no longer need to support squeeze, use --create-reflog
5107     # instead of this:
5108     ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
5109     my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>'
5110       or die $!;
5111
5112     my $oldcache = git_get_ref "refs/$splitbraincache";
5113     if ($oldcache eq $dgitview) {
5114         my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5115         # git update-ref doesn't always update, in this case.  *sigh*
5116         my $dummy = make_commit_text <<END;
5117 tree $tree
5118 parent $dgitview
5119 author Dgit <dgit\@example.com> 1000000000 +0000
5120 committer Dgit <dgit\@example.com> 1000000000 +0000
5121
5122 Dummy commit - do not use
5123 END
5124         runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5125             "refs/$splitbraincache", $dummy;
5126     }
5127     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5128         $dgitview;
5129
5130     changedir "$playground/work";
5131
5132     my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5133     progress "dgit view: created ($saved)";
5134 }
5135
5136 sub quiltify ($$$$) {
5137     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5138
5139     # Quilt patchification algorithm
5140     #
5141     # We search backwards through the history of the main tree's HEAD
5142     # (T) looking for a start commit S whose tree object is identical
5143     # to to the patch tip tree (ie the tree corresponding to the
5144     # current dpkg-committed patch series).  For these purposes
5145     # `identical' disregards anything in debian/ - this wrinkle is
5146     # necessary because dpkg-source treates debian/ specially.
5147     #
5148     # We can only traverse edges where at most one of the ancestors'
5149     # trees differs (in changes outside in debian/).  And we cannot
5150     # handle edges which change .pc/ or debian/patches.  To avoid
5151     # going down a rathole we avoid traversing edges which introduce
5152     # debian/rules or debian/control.  And we set a limit on the
5153     # number of edges we are willing to look at.
5154     #
5155     # If we succeed, we walk forwards again.  For each traversed edge
5156     # PC (with P parent, C child) (starting with P=S and ending with
5157     # C=T) to we do this:
5158     #  - git checkout C
5159     #  - dpkg-source --commit with a patch name and message derived from C
5160     # After traversing PT, we git commit the changes which
5161     # should be contained within debian/patches.
5162
5163     # The search for the path S..T is breadth-first.  We maintain a
5164     # todo list containing search nodes.  A search node identifies a
5165     # commit, and looks something like this:
5166     #  $p = {
5167     #      Commit => $git_commit_id,
5168     #      Child => $c,                          # or undef if P=T
5169     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
5170     #      Nontrivial => true iff $p..$c has relevant changes
5171     #  };
5172
5173     my @todo;
5174     my @nots;
5175     my $sref_S;
5176     my $max_work=100;
5177     my %considered; # saves being exponential on some weird graphs
5178
5179     my $t_sentinels = quiltify_tree_sentinelfiles $target;
5180
5181     my $not = sub {
5182         my ($search,$whynot) = @_;
5183         printdebug " search NOT $search->{Commit} $whynot\n";
5184         $search->{Whynot} = $whynot;
5185         push @nots, $search;
5186         no warnings qw(exiting);
5187         next;
5188     };
5189
5190     push @todo, {
5191         Commit => $target,
5192     };
5193
5194     while (@todo) {
5195         my $c = shift @todo;
5196         next if $considered{$c->{Commit}}++;
5197
5198         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5199
5200         printdebug "quiltify investigate $c->{Commit}\n";
5201
5202         # are we done?
5203         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5204             printdebug " search finished hooray!\n";
5205             $sref_S = $c;
5206             last;
5207         }
5208
5209         quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5210         if ($quilt_mode eq 'smash') {
5211             printdebug " search quitting smash\n";
5212             last;
5213         }
5214
5215         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5216         $not->($c, "has $c_sentinels not $t_sentinels")
5217             if $c_sentinels ne $t_sentinels;
5218
5219         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5220         $commitdata =~ m/\n\n/;
5221         $commitdata =~ $`;
5222         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5223         @parents = map { { Commit => $_, Child => $c } } @parents;
5224
5225         $not->($c, "root commit") if !@parents;
5226
5227         foreach my $p (@parents) {
5228             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5229         }
5230         my $ndiffers = grep { $_->{Nontrivial} } @parents;
5231         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5232
5233         foreach my $p (@parents) {
5234             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5235
5236             my @cmd= (@git, qw(diff-tree -r --name-only),
5237                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5238             my $patchstackchange = cmdoutput @cmd;
5239             if (length $patchstackchange) {
5240                 $patchstackchange =~ s/\n/,/g;
5241                 $not->($p, "changed $patchstackchange");
5242             }
5243
5244             printdebug " search queue P=$p->{Commit} ",
5245                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5246             push @todo, $p;
5247         }
5248     }
5249
5250     if (!$sref_S) {
5251         printdebug "quiltify want to smash\n";
5252
5253         my $abbrev = sub {
5254             my $x = $_[0]{Commit};
5255             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5256             return $x;
5257         };
5258         my $reportnot = sub {
5259             my ($notp) = @_;
5260             my $s = $abbrev->($notp);
5261             my $c = $notp->{Child};
5262             $s .= "..".$abbrev->($c) if $c;
5263             $s .= ": ".$notp->{Whynot};
5264             return $s;
5265         };
5266         if ($quilt_mode eq 'linear') {
5267             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
5268             foreach my $notp (@nots) {
5269                 print STDERR "$us:  ", $reportnot->($notp), "\n";
5270             }
5271             print STDERR "$us: $_\n" foreach @$failsuggestion;
5272             fail "quilt fixup naive history linearisation failed.\n".
5273  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5274         } elsif ($quilt_mode eq 'smash') {
5275         } elsif ($quilt_mode eq 'auto') {
5276             progress "quilt fixup cannot be linear, smashing...";
5277         } else {
5278             die "$quilt_mode ?";
5279         }
5280
5281         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5282         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5283         my $ncommits = 3;
5284         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5285
5286         quiltify_dpkg_commit "auto-$version-$target-$time",
5287             (getfield $clogp, 'Maintainer'),
5288             "Automatically generated patch ($clogp->{Version})\n".
5289             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5290         return;
5291     }
5292
5293     progress "quiltify linearisation planning successful, executing...";
5294
5295     for (my $p = $sref_S;
5296          my $c = $p->{Child};
5297          $p = $p->{Child}) {
5298         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5299         next unless $p->{Nontrivial};
5300
5301         my $cc = $c->{Commit};
5302
5303         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5304         $commitdata =~ m/\n\n/ or die "$c ?";
5305         $commitdata = $`;
5306         my $msg = $'; #';
5307         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5308         my $author = $1;
5309
5310         my $commitdate = cmdoutput
5311             @git, qw(log -n1 --pretty=format:%aD), $cc;
5312
5313         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5314
5315         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5316         $strip_nls->();
5317
5318         my $title = $1;
5319         my $patchname;
5320         my $patchdir;
5321
5322         my $gbp_check_suitable = sub {
5323             $_ = shift;
5324             my ($what) = @_;
5325
5326             eval {
5327                 die "contains unexpected slashes\n" if m{//} || m{/$};
5328                 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5329                 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5330                 die "is series file\n" if m{$series_filename_re}o;
5331                 die "too long" if length > 200;
5332             };
5333             return $_ unless $@;
5334             print STDERR "quiltifying commit $cc:".
5335                 " ignoring/dropping Gbp-Pq $what: $@";
5336             return undef;
5337         };
5338
5339         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5340                            gbp-pq-name: \s* )
5341                        (\S+) \s* \n //ixm) {
5342             $patchname = $gbp_check_suitable->($1, 'Name');
5343         }
5344         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5345                            gbp-pq-topic: \s* )
5346                        (\S+) \s* \n //ixm) {
5347             $patchdir = $gbp_check_suitable->($1, 'Topic');
5348         }
5349
5350         $strip_nls->();
5351
5352         if (!defined $patchname) {
5353             $patchname = $title;
5354             $patchname =~ s/[.:]$//;
5355             use Text::Iconv;
5356             eval {
5357                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5358                 my $translitname = $converter->convert($patchname);
5359                 die unless defined $translitname;
5360                 $patchname = $translitname;
5361             };
5362             print STDERR
5363                 "dgit: patch title transliteration error: $@"
5364                 if $@;
5365             $patchname =~ y/ A-Z/-a-z/;
5366             $patchname =~ y/-a-z0-9_.+=~//cd;
5367             $patchname =~ s/^\W/x-$&/;
5368             $patchname = substr($patchname,0,40);
5369             $patchname .= ".patch";
5370         }
5371         if (!defined $patchdir) {
5372             $patchdir = '';
5373         }
5374         if (length $patchdir) {
5375             $patchname = "$patchdir/$patchname";
5376         }
5377         if ($patchname =~ m{^(.*)/}) {
5378             mkpath "debian/patches/$1";
5379         }
5380
5381         my $index;
5382         for ($index='';
5383              stat "debian/patches/$patchname$index";
5384              $index++) { }
5385         $!==ENOENT or die "$patchname$index $!";
5386
5387         runcmd @git, qw(checkout -q), $cc;
5388
5389         # We use the tip's changelog so that dpkg-source doesn't
5390         # produce complaining messages from dpkg-parsechangelog.  None
5391         # of the information dpkg-source gets from the changelog is
5392         # actually relevant - it gets put into the original message
5393         # which dpkg-source provides our stunt editor, and then
5394         # overwritten.
5395         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5396
5397         quiltify_dpkg_commit "$patchname$index", $author, $msg,
5398             "Date: $commitdate\n".
5399             "X-Dgit-Generated: $clogp->{Version} $cc\n";
5400
5401         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5402     }
5403
5404     runcmd @git, qw(checkout -q master);
5405 }
5406
5407 sub build_maybe_quilt_fixup () {
5408     my ($format,$fopts) = get_source_format;
5409     return unless madformat_wantfixup $format;
5410     # sigh
5411
5412     check_for_vendor_patches();
5413
5414     if (quiltmode_splitbrain) {
5415         fail <<END unless access_cfg_tagformats_can_splitbrain;
5416 quilt mode $quilt_mode requires split view so server needs to support
5417  both "new" and "maint" tag formats, but config says it doesn't.
5418 END
5419     }
5420
5421     my $clogp = parsechangelog();
5422     my $headref = git_rev_parse('HEAD');
5423
5424     prep_ud();
5425     changedir $playground;
5426
5427     my $upstreamversion = upstreamversion $version;
5428
5429     if ($fopts->{'single-debian-patch'}) {
5430         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5431     } else {
5432         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5433     }
5434
5435     die 'bug' if $split_brain && !$need_split_build_invocation;
5436
5437     changedir $maindir;
5438     runcmd_ordryrun_local
5439         @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5440 }
5441
5442 sub quilt_fixup_mkwork ($) {
5443     my ($headref) = @_;
5444
5445     mkdir "work" or die $!;
5446     changedir "work";
5447     mktree_in_ud_here();
5448     runcmd @git, qw(reset -q --hard), $headref;
5449 }
5450
5451 sub quilt_fixup_linkorigs ($$) {
5452     my ($upstreamversion, $fn) = @_;
5453     # calls $fn->($leafname);
5454
5455     foreach my $f (<$maindir/../*>) { #/){
5456         my $b=$f; $b =~ s{.*/}{};
5457         {
5458             local ($debuglevel) = $debuglevel-1;
5459             printdebug "QF linkorigs $b, $f ?\n";
5460         }
5461         next unless is_orig_file_of_vsn $b, $upstreamversion;
5462         printdebug "QF linkorigs $b, $f Y\n";
5463         link_ltarget $f, $b or die "$b $!";
5464         $fn->($b);
5465     }
5466 }
5467
5468 sub quilt_fixup_delete_pc () {
5469     runcmd @git, qw(rm -rqf .pc);
5470     commit_admin <<END
5471 Commit removal of .pc (quilt series tracking data)
5472
5473 [dgit ($our_version) upgrade quilt-remove-pc]
5474 END
5475 }
5476
5477 sub quilt_fixup_singlepatch ($$$) {
5478     my ($clogp, $headref, $upstreamversion) = @_;
5479
5480     progress "starting quiltify (single-debian-patch)";
5481
5482     # dpkg-source --commit generates new patches even if
5483     # single-debian-patch is in debian/source/options.  In order to
5484     # get it to generate debian/patches/debian-changes, it is
5485     # necessary to build the source package.
5486
5487     quilt_fixup_linkorigs($upstreamversion, sub { });
5488     quilt_fixup_mkwork($headref);
5489
5490     rmtree("debian/patches");
5491
5492     runcmd @dpkgsource, qw(-b .);
5493     changedir "..";
5494     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5495     rename srcfn("$upstreamversion", "/debian/patches"),
5496            "work/debian/patches";
5497
5498     changedir "work";
5499     commit_quilty_patch();
5500 }
5501
5502 sub quilt_make_fake_dsc ($) {
5503     my ($upstreamversion) = @_;
5504
5505     my $fakeversion="$upstreamversion-~~DGITFAKE";
5506
5507     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5508     print $fakedsc <<END or die $!;
5509 Format: 3.0 (quilt)
5510 Source: $package
5511 Version: $fakeversion
5512 Files:
5513 END
5514
5515     my $dscaddfile=sub {
5516         my ($b) = @_;
5517
5518         my $md = new Digest::MD5;
5519
5520         my $fh = new IO::File $b, '<' or die "$b $!";
5521         stat $fh or die $!;
5522         my $size = -s _;
5523
5524         $md->addfile($fh);
5525         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5526     };
5527
5528     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5529
5530     my @files=qw(debian/source/format debian/rules
5531                  debian/control debian/changelog);
5532     foreach my $maybe (qw(debian/patches debian/source/options
5533                           debian/tests/control)) {
5534         next unless stat_exists "$maindir/$maybe";
5535         push @files, $maybe;
5536     }
5537
5538     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5539     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5540
5541     $dscaddfile->($debtar);
5542     close $fakedsc or die $!;
5543 }
5544
5545 sub quilt_check_splitbrain_cache ($$) {
5546     my ($headref, $upstreamversion) = @_;
5547     # Called only if we are in (potentially) split brain mode.
5548     # Called in playground.
5549     # Computes the cache key and looks in the cache.
5550     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5551
5552     my $splitbrain_cachekey;
5553
5554     progress
5555  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5556     # we look in the reflog of dgit-intern/quilt-cache
5557     # we look for an entry whose message is the key for the cache lookup
5558     my @cachekey = (qw(dgit), $our_version);
5559     push @cachekey, $upstreamversion;
5560     push @cachekey, $quilt_mode;
5561     push @cachekey, $headref;
5562
5563     push @cachekey, hashfile('fake.dsc');
5564
5565     my $srcshash = Digest::SHA->new(256);
5566     my %sfs = ( %INC, '$0(dgit)' => $0 );
5567     foreach my $sfk (sort keys %sfs) {
5568         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5569         $srcshash->add($sfk,"  ");
5570         $srcshash->add(hashfile($sfs{$sfk}));
5571         $srcshash->add("\n");
5572     }
5573     push @cachekey, $srcshash->hexdigest();
5574     $splitbrain_cachekey = "@cachekey";
5575
5576     my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5577                $splitbraincache);
5578     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5579     debugcmd "|(probably)",@cmd;
5580     my $child = open GC, "-|";  defined $child or die $!;
5581     if (!$child) {
5582         chdir $maindir or die $!;
5583         if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
5584             $! == ENOENT or die $!;
5585             printdebug ">(no reflog)\n";
5586             finish 0;
5587         }
5588         exec @cmd; die $!;
5589     }
5590     while (<GC>) {
5591         chomp;
5592         printdebug ">| ", $_, "\n" if $debuglevel > 1;
5593         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5594
5595         my $cachehit = $1;
5596         quilt_fixup_mkwork($headref);
5597         my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5598         if ($cachehit ne $headref) {
5599             progress "dgit view: found cached ($saved)";
5600             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5601             $split_brain = 1;
5602             return ($cachehit, $splitbrain_cachekey);
5603         }
5604         progress "dgit view: found cached, no changes required";
5605         return ($headref, $splitbrain_cachekey);
5606     }
5607     die $! if GC->error;
5608     failedcmd unless close GC;
5609
5610     printdebug "splitbrain cache miss\n";
5611     return (undef, $splitbrain_cachekey);
5612 }
5613
5614 sub quilt_fixup_multipatch ($$$) {
5615     my ($clogp, $headref, $upstreamversion) = @_;
5616
5617     progress "examining quilt state (multiple patches, $quilt_mode mode)";
5618
5619     # Our objective is:
5620     #  - honour any existing .pc in case it has any strangeness
5621     #  - determine the git commit corresponding to the tip of
5622     #    the patch stack (if there is one)
5623     #  - if there is such a git commit, convert each subsequent
5624     #    git commit into a quilt patch with dpkg-source --commit
5625     #  - otherwise convert all the differences in the tree into
5626     #    a single git commit
5627     #
5628     # To do this we:
5629
5630     # Our git tree doesn't necessarily contain .pc.  (Some versions of
5631     # dgit would include the .pc in the git tree.)  If there isn't
5632     # one, we need to generate one by unpacking the patches that we
5633     # have.
5634     #
5635     # We first look for a .pc in the git tree.  If there is one, we
5636     # will use it.  (This is not the normal case.)
5637     #
5638     # Otherwise need to regenerate .pc so that dpkg-source --commit
5639     # can work.  We do this as follows:
5640     #     1. Collect all relevant .orig from parent directory
5641     #     2. Generate a debian.tar.gz out of
5642     #         debian/{patches,rules,source/format,source/options}
5643     #     3. Generate a fake .dsc containing just these fields:
5644     #          Format Source Version Files
5645     #     4. Extract the fake .dsc
5646     #        Now the fake .dsc has a .pc directory.
5647     # (In fact we do this in every case, because in future we will
5648     # want to search for a good base commit for generating patches.)
5649     #
5650     # Then we can actually do the dpkg-source --commit
5651     #     1. Make a new working tree with the same object
5652     #        store as our main tree and check out the main
5653     #        tree's HEAD.
5654     #     2. Copy .pc from the fake's extraction, if necessary
5655     #     3. Run dpkg-source --commit
5656     #     4. If the result has changes to debian/, then
5657     #          - git add them them
5658     #          - git add .pc if we had a .pc in-tree
5659     #          - git commit
5660     #     5. If we had a .pc in-tree, delete it, and git commit
5661     #     6. Back in the main tree, fast forward to the new HEAD
5662
5663     # Another situation we may have to cope with is gbp-style
5664     # patches-unapplied trees.
5665     #
5666     # We would want to detect these, so we know to escape into
5667     # quilt_fixup_gbp.  However, this is in general not possible.
5668     # Consider a package with a one patch which the dgit user reverts
5669     # (with git revert or the moral equivalent).
5670     #
5671     # That is indistinguishable in contents from a patches-unapplied
5672     # tree.  And looking at the history to distinguish them is not
5673     # useful because the user might have made a confusing-looking git
5674     # history structure (which ought to produce an error if dgit can't
5675     # cope, not a silent reintroduction of an unwanted patch).
5676     #
5677     # So gbp users will have to pass an option.  But we can usually
5678     # detect their failure to do so: if the tree is not a clean
5679     # patches-applied tree, quilt linearisation fails, but the tree
5680     # _is_ a clean patches-unapplied tree, we can suggest that maybe
5681     # they want --quilt=unapplied.
5682     #
5683     # To help detect this, when we are extracting the fake dsc, we
5684     # first extract it with --skip-patches, and then apply the patches
5685     # afterwards with dpkg-source --before-build.  That lets us save a
5686     # tree object corresponding to .origs.
5687
5688     my $splitbrain_cachekey;
5689
5690     quilt_make_fake_dsc($upstreamversion);
5691
5692     if (quiltmode_splitbrain()) {
5693         my $cachehit;
5694         ($cachehit, $splitbrain_cachekey) =
5695             quilt_check_splitbrain_cache($headref, $upstreamversion);
5696         return if $cachehit;
5697     }
5698
5699     runcmd qw(sh -ec),
5700         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5701
5702     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5703     rename $fakexdir, "fake" or die "$fakexdir $!";
5704
5705     changedir 'fake';
5706
5707     remove_stray_gits("source package");
5708     mktree_in_ud_here();
5709
5710     rmtree '.pc';
5711
5712     rmtree 'debian'; # git checkout commitish paths does not delete!
5713     runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5714     my $unapplied=git_add_write_tree();
5715     printdebug "fake orig tree object $unapplied\n";
5716
5717     ensuredir '.pc';
5718
5719     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5720     $!=0; $?=-1;
5721     if (system @bbcmd) {
5722         failedcmd @bbcmd if $? < 0;
5723         fail <<END;
5724 failed to apply your git tree's patch stack (from debian/patches/) to
5725  the corresponding upstream tarball(s).  Your source tree and .orig
5726  are probably too inconsistent.  dgit can only fix up certain kinds of
5727  anomaly (depending on the quilt mode).  See --quilt= in dgit(1).
5728 END
5729     }
5730
5731     changedir '..';
5732
5733     quilt_fixup_mkwork($headref);
5734
5735     my $mustdeletepc=0;
5736     if (stat_exists ".pc") {
5737         -d _ or die;
5738         progress "Tree already contains .pc - will use it then delete it.";
5739         $mustdeletepc=1;
5740     } else {
5741         rename '../fake/.pc','.pc' or die $!;
5742     }
5743
5744     changedir '../fake';
5745     rmtree '.pc';
5746     my $oldtiptree=git_add_write_tree();
5747     printdebug "fake o+d/p tree object $unapplied\n";
5748     changedir '../work';
5749
5750
5751     # We calculate some guesswork now about what kind of tree this might
5752     # be.  This is mostly for error reporting.
5753
5754     my %editedignores;
5755     my @unrepres;
5756     my $diffbits = {
5757         # H = user's HEAD
5758         # O = orig, without patches applied
5759         # A = "applied", ie orig with H's debian/patches applied
5760         O2H => quiltify_trees_differ($unapplied,$headref,   1,
5761                                      \%editedignores, \@unrepres),
5762         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
5763         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5764     };
5765
5766     my @dl;
5767     foreach my $b (qw(01 02)) {
5768         foreach my $v (qw(O2H O2A H2A)) {
5769             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5770         }
5771     }
5772     printdebug "differences \@dl @dl.\n";
5773
5774     progress sprintf
5775 "$us: base trees orig=%.20s o+d/p=%.20s",
5776               $unapplied, $oldtiptree;
5777     progress sprintf
5778 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
5779 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
5780                              $dl[0], $dl[1],              $dl[3], $dl[4],
5781                                  $dl[2],                     $dl[5];
5782
5783     if (@unrepres) {
5784         print STDERR "dgit:  cannot represent change: $_->[1]: $_->[0]\n"
5785             foreach @unrepres;
5786         forceable_fail [qw(unrepresentable)], <<END;
5787 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5788 END
5789     }
5790
5791     my @failsuggestion;
5792     if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5793         push @failsuggestion, "This might be a patches-unapplied branch.";
5794     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5795         push @failsuggestion, "This might be a patches-applied branch.";
5796     }
5797     push @failsuggestion, "Maybe you need to specify one of".
5798         " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5799
5800     if (quiltmode_splitbrain()) {
5801         quiltify_splitbrain($clogp, $unapplied, $headref,
5802                             $diffbits, \%editedignores,
5803                             $splitbrain_cachekey);
5804         return;
5805     }
5806
5807     progress "starting quiltify (multiple patches, $quilt_mode mode)";
5808     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5809
5810     if (!open P, '>>', ".pc/applied-patches") {
5811         $!==&ENOENT or die $!;
5812     } else {
5813         close P;
5814     }
5815
5816     commit_quilty_patch();
5817
5818     if ($mustdeletepc) {
5819         quilt_fixup_delete_pc();
5820     }
5821 }
5822
5823 sub quilt_fixup_editor () {
5824     my $descfn = $ENV{$fakeeditorenv};
5825     my $editing = $ARGV[$#ARGV];
5826     open I1, '<', $descfn or die "$descfn: $!";
5827     open I2, '<', $editing or die "$editing: $!";
5828     unlink $editing or die "$editing: $!";
5829     open O, '>', $editing or die "$editing: $!";
5830     while (<I1>) { print O or die $!; } I1->error and die $!;
5831     my $copying = 0;
5832     while (<I2>) {
5833         $copying ||= m/^\-\-\- /;
5834         next unless $copying;
5835         print O or die $!;
5836     }
5837     I2->error and die $!;
5838     close O or die $1;
5839     finish 0;
5840 }
5841
5842 sub maybe_apply_patches_dirtily () {
5843     return unless $quilt_mode =~ m/gbp|unapplied/;
5844     print STDERR <<END or die $!;
5845
5846 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5847 dgit: Have to apply the patches - making the tree dirty.
5848 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5849
5850 END
5851     $patches_applied_dirtily = 01;
5852     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5853     runcmd qw(dpkg-source --before-build .);
5854 }
5855
5856 sub maybe_unapply_patches_again () {
5857     progress "dgit: Unapplying patches again to tidy up the tree."
5858         if $patches_applied_dirtily;
5859     runcmd qw(dpkg-source --after-build .)
5860         if $patches_applied_dirtily & 01;
5861     rmtree '.pc'
5862         if $patches_applied_dirtily & 02;
5863     $patches_applied_dirtily = 0;
5864 }
5865
5866 #----- other building -----
5867
5868 our $clean_using_builder;
5869 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5870 #   clean the tree before building (perhaps invoked indirectly by
5871 #   whatever we are using to run the build), rather than separately
5872 #   and explicitly by us.
5873
5874 sub clean_tree () {
5875     return if $clean_using_builder;
5876     if ($cleanmode eq 'dpkg-source') {
5877         maybe_apply_patches_dirtily();
5878         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5879     } elsif ($cleanmode eq 'dpkg-source-d') {
5880         maybe_apply_patches_dirtily();
5881         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5882     } elsif ($cleanmode eq 'git') {
5883         runcmd_ordryrun_local @git, qw(clean -xdf);
5884     } elsif ($cleanmode eq 'git-ff') {
5885         runcmd_ordryrun_local @git, qw(clean -xdff);
5886     } elsif ($cleanmode eq 'check') {
5887         my $leftovers = cmdoutput @git, qw(clean -xdn);
5888         if (length $leftovers) {
5889             print STDERR $leftovers, "\n" or die $!;
5890             fail "tree contains uncommitted files and --clean=check specified";
5891         }
5892     } elsif ($cleanmode eq 'none') {
5893     } else {
5894         die "$cleanmode ?";
5895     }
5896 }
5897
5898 sub cmd_clean () {
5899     badusage "clean takes no additional arguments" if @ARGV;
5900     notpushing();
5901     clean_tree();
5902     maybe_unapply_patches_again();
5903 }
5904
5905 sub build_or_push_prep_early () {
5906     our $build_or_push_prep_early_done //= 0;
5907     return if $build_or_push_prep_early_done++;
5908     badusage "-p is not allowed with dgit $subcommand" if defined $package;
5909     my $clogp = parsechangelog();
5910     $isuite = getfield $clogp, 'Distribution';
5911     $package = getfield $clogp, 'Source';
5912     $version = getfield $clogp, 'Version';
5913 }
5914
5915 sub build_prep_early () {
5916     build_or_push_prep_early();
5917     notpushing();
5918     check_not_dirty();
5919 }
5920
5921 sub build_prep () {
5922     build_prep_early();
5923     clean_tree();
5924     build_maybe_quilt_fixup();
5925     if ($rmchanges) {
5926         my $pat = changespat $version;
5927         foreach my $f (glob "$buildproductsdir/$pat") {
5928             if (act_local()) {
5929                 unlink $f or fail "remove old changes file $f: $!";
5930             } else {
5931                 progress "would remove $f";
5932             }
5933         }
5934     }
5935 }
5936
5937 sub changesopts_initial () {
5938     my @opts =@changesopts[1..$#changesopts];
5939 }
5940
5941 sub changesopts_version () {
5942     if (!defined $changes_since_version) {
5943         my @vsns = archive_query('archive_query');
5944         my @quirk = access_quirk();
5945         if ($quirk[0] eq 'backports') {
5946             local $isuite = $quirk[2];
5947             local $csuite;
5948             canonicalise_suite();
5949             push @vsns, archive_query('archive_query');
5950         }
5951         if (@vsns) {
5952             @vsns = map { $_->[0] } @vsns;
5953             @vsns = sort { -version_compare($a, $b) } @vsns;
5954             $changes_since_version = $vsns[0];
5955             progress "changelog will contain changes since $vsns[0]";
5956         } else {
5957             $changes_since_version = '_';
5958             progress "package seems new, not specifying -v<version>";
5959         }
5960     }
5961     if ($changes_since_version ne '_') {
5962         return ("-v$changes_since_version");
5963     } else {
5964         return ();
5965     }
5966 }
5967
5968 sub changesopts () {
5969     return (changesopts_initial(), changesopts_version());
5970 }
5971
5972 sub massage_dbp_args ($;$) {
5973     my ($cmd,$xargs) = @_;
5974     # We need to:
5975     #
5976     #  - if we're going to split the source build out so we can
5977     #    do strange things to it, massage the arguments to dpkg-buildpackage
5978     #    so that the main build doessn't build source (or add an argument
5979     #    to stop it building source by default).
5980     #
5981     #  - add -nc to stop dpkg-source cleaning the source tree,
5982     #    unless we're not doing a split build and want dpkg-source
5983     #    as cleanmode, in which case we can do nothing
5984     #
5985     # return values:
5986     #    0 - source will NOT need to be built separately by caller
5987     #   +1 - source will need to be built separately by caller
5988     #   +2 - source will need to be built separately by caller AND
5989     #        dpkg-buildpackage should not in fact be run at all!
5990     debugcmd '#massaging#', @$cmd if $debuglevel>1;
5991 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5992     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5993         $clean_using_builder = 1;
5994         return 0;
5995     }
5996     # -nc has the side effect of specifying -b if nothing else specified
5997     # and some combinations of -S, -b, et al, are errors, rather than
5998     # later simply overriding earlie.  So we need to:
5999     #  - search the command line for these options
6000     #  - pick the last one
6001     #  - perhaps add our own as a default
6002     #  - perhaps adjust it to the corresponding non-source-building version
6003     my $dmode = '-F';
6004     foreach my $l ($cmd, $xargs) {
6005         next unless $l;
6006         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
6007     }
6008     push @$cmd, '-nc';
6009 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6010     my $r = 0;
6011     if ($need_split_build_invocation) {
6012         printdebug "massage split $dmode.\n";
6013         $r = $dmode =~ m/[S]/     ? +2 :
6014              $dmode =~ y/gGF/ABb/ ? +1 :
6015              $dmode =~ m/[ABb]/   ?  0 :
6016              die "$dmode ?";
6017     }
6018     printdebug "massage done $r $dmode.\n";
6019     push @$cmd, $dmode;
6020 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6021     return $r;
6022 }
6023
6024 sub in_parent (&) {
6025     my ($fn) = @_;
6026     my $wasdir = must_getcwd();
6027     changedir "..";
6028     $fn->();
6029     changedir $wasdir;
6030 }
6031
6032 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
6033     my ($msg_if_onlyone) = @_;
6034     # If there is only one .changes file, fail with $msg_if_onlyone,
6035     # or if that is undef, be a no-op.
6036     # Returns the changes file to report to the user.
6037     my $pat = changespat $version;
6038     my @changesfiles = glob $pat;
6039     @changesfiles = sort {
6040         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6041             or $a cmp $b
6042     } @changesfiles;
6043     my $result;
6044     if (@changesfiles==1) {
6045         fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6046 only one changes file from build (@changesfiles)
6047 END
6048         $result = $changesfiles[0];
6049     } elsif (@changesfiles==2) {
6050         my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6051         foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6052             fail "$l found in binaries changes file $binchanges"
6053                 if $l =~ m/\.dsc$/;
6054         }
6055         runcmd_ordryrun_local @mergechanges, @changesfiles;
6056         my $multichanges = changespat $version,'multi';
6057         if (act_local()) {
6058             stat_exists $multichanges or fail "$multichanges: $!";
6059             foreach my $cf (glob $pat) {
6060                 next if $cf eq $multichanges;
6061                 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6062             }
6063         }
6064         $result = $multichanges;
6065     } else {
6066         fail "wrong number of different changes files (@changesfiles)";
6067     }
6068     printdone "build successful, results in $result\n" or die $!;
6069 }
6070
6071 sub midbuild_checkchanges () {
6072     my $pat = changespat $version;
6073     return if $rmchanges;
6074     my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
6075     @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
6076     fail <<END
6077 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6078 Suggest you delete @unwanted.
6079 END
6080         if @unwanted;
6081 }
6082
6083 sub midbuild_checkchanges_vanilla ($) {
6084     my ($wantsrc) = @_;
6085     midbuild_checkchanges() if $wantsrc == 1;
6086 }
6087
6088 sub postbuild_mergechanges_vanilla ($) {
6089     my ($wantsrc) = @_;
6090     if ($wantsrc == 1) {
6091         in_parent {
6092             postbuild_mergechanges(undef);
6093         };
6094     } else {
6095         printdone "build successful\n";
6096     }
6097 }
6098
6099 sub cmd_build {
6100     build_prep_early();
6101     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6102     my $wantsrc = massage_dbp_args \@dbp;
6103     if ($wantsrc > 0) {
6104         build_source();
6105         midbuild_checkchanges_vanilla $wantsrc;
6106     } else {
6107         build_prep();
6108     }
6109     if ($wantsrc < 2) {
6110         push @dbp, changesopts_version();
6111         maybe_apply_patches_dirtily();
6112         runcmd_ordryrun_local @dbp;
6113     }
6114     maybe_unapply_patches_again();
6115     postbuild_mergechanges_vanilla $wantsrc;
6116 }
6117
6118 sub pre_gbp_build {
6119     $quilt_mode //= 'gbp';
6120 }
6121
6122 sub cmd_gbp_build {
6123     build_prep_early();
6124
6125     # gbp can make .origs out of thin air.  In my tests it does this
6126     # even for a 1.0 format package, with no origs present.  So I
6127     # guess it keys off just the version number.  We don't know
6128     # exactly what .origs ought to exist, but let's assume that we
6129     # should run gbp if: the version has an upstream part and the main
6130     # orig is absent.
6131     my $upstreamversion = upstreamversion $version;
6132     my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6133     my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
6134
6135     if ($gbp_make_orig) {
6136         clean_tree();
6137         $cleanmode = 'none'; # don't do it again
6138         $need_split_build_invocation = 1;
6139     }
6140
6141     my @dbp = @dpkgbuildpackage;
6142
6143     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6144
6145     if (!length $gbp_build[0]) {
6146         if (length executable_on_path('git-buildpackage')) {
6147             $gbp_build[0] = qw(git-buildpackage);
6148         } else {
6149             $gbp_build[0] = 'gbp buildpackage';
6150         }
6151     }
6152     my @cmd = opts_opt_multi_cmd @gbp_build;
6153
6154     push @cmd, (qw(-us -uc --git-no-sign-tags),
6155                 "--git-builder=".(shellquote @dbp));
6156
6157     if ($gbp_make_orig) {
6158         my $priv = dgit_privdir();
6159         my $ok = "$priv/origs-gen-ok";
6160         unlink $ok or $!==&ENOENT or die $!;
6161         my @origs_cmd = @cmd;
6162         push @origs_cmd, qw(--git-cleaner=true);
6163         push @origs_cmd, "--git-prebuild=".
6164             "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6165         push @origs_cmd, @ARGV;
6166         if (act_local()) {
6167             debugcmd @origs_cmd;
6168             system @origs_cmd;
6169             do { local $!; stat_exists $ok; }
6170                 or failedcmd @origs_cmd;
6171         } else {
6172             dryrun_report @origs_cmd;
6173         }
6174     }
6175
6176     if ($wantsrc > 0) {
6177         build_source();
6178         midbuild_checkchanges_vanilla $wantsrc;
6179     } else {
6180         if (!$clean_using_builder) {
6181             push @cmd, '--git-cleaner=true';
6182         }
6183         build_prep();
6184     }
6185     maybe_unapply_patches_again();
6186     if ($wantsrc < 2) {
6187         push @cmd, changesopts();
6188         runcmd_ordryrun_local @cmd, @ARGV;
6189     }
6190     postbuild_mergechanges_vanilla $wantsrc;
6191 }
6192 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6193
6194 sub build_source_for_push {
6195     build_source();
6196     maybe_unapply_patches_again();
6197     $changesfile = $sourcechanges;
6198 }
6199
6200 sub build_source {
6201     build_prep_early();
6202     build_prep();
6203     $sourcechanges = changespat $version,'source';
6204     if (act_local()) {
6205         unlink "../$sourcechanges" or $!==ENOENT
6206             or fail "remove $sourcechanges: $!";
6207     }
6208     $dscfn = dscfn($version);
6209     my @cmd = (@dpkgsource, qw(-b --));
6210     if ($split_brain) {
6211         changedir $playground;
6212         runcmd_ordryrun_local @cmd, "work";
6213         my @udfiles = <${package}_*>;
6214         changedir $maindir;
6215         foreach my $f (@udfiles) {
6216             printdebug "source copy, found $f\n";
6217             next unless
6218               $f eq $dscfn or
6219               ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
6220                $f eq srcfn($version, $&));
6221             printdebug "source copy, found $f - renaming\n";
6222             rename "$playground/$f", "../$f" or $!==ENOENT
6223               or fail "put in place new source file ($f): $!";
6224         }
6225     } else {
6226         my $pwd = must_getcwd();
6227         my $leafdir = basename $pwd;
6228         changedir "..";
6229         runcmd_ordryrun_local @cmd, $leafdir;
6230         changedir $pwd;
6231     }
6232     runcmd_ordryrun_local qw(sh -ec),
6233       'exec >$1; shift; exec "$@"','x',
6234       "../$sourcechanges",
6235       @dpkggenchanges, qw(-S), changesopts();
6236 }
6237
6238 sub cmd_build_source {
6239     build_prep_early();
6240     badusage "build-source takes no additional arguments" if @ARGV;
6241     build_source();
6242     maybe_unapply_patches_again();
6243     printdone "source built, results in $dscfn and $sourcechanges";
6244 }
6245
6246 sub cmd_sbuild {
6247     build_source();
6248     midbuild_checkchanges();
6249     in_parent {
6250         if (act_local()) {
6251             stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
6252             stat_exists $sourcechanges
6253                 or fail "$sourcechanges (in parent directory): $!";
6254         }
6255         runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
6256     };
6257     maybe_unapply_patches_again();
6258     in_parent {
6259         postbuild_mergechanges(<<END);
6260 perhaps you need to pass -A ?  (sbuild's default is to build only
6261 arch-specific binaries; dgit 1.4 used to override that.)
6262 END
6263     };
6264 }
6265
6266 sub cmd_quilt_fixup {
6267     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6268     build_prep_early();
6269     clean_tree();
6270     build_maybe_quilt_fixup();
6271 }
6272
6273 sub import_dsc_result {
6274     my ($dstref, $newhash, $what_log, $what_msg) = @_;
6275     my @cmd = (@git, qw(update-ref -m), $what_log, $dstref, $newhash);
6276     runcmd @cmd;
6277     check_gitattrs($newhash, "source tree");
6278
6279     progress "dgit: import-dsc: $what_msg";
6280 }
6281
6282 sub cmd_import_dsc {
6283     my $needsig = 0;
6284
6285     while (@ARGV) {
6286         last unless $ARGV[0] =~ m/^-/;
6287         $_ = shift @ARGV;
6288         last if m/^--?$/;
6289         if (m/^--require-valid-signature$/) {
6290             $needsig = 1;
6291         } else {
6292             badusage "unknown dgit import-dsc sub-option \`$_'";
6293         }
6294     }
6295
6296     badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6297     my ($dscfn, $dstbranch) = @ARGV;
6298
6299     badusage "dry run makes no sense with import-dsc" unless act_local();
6300
6301     my $force = $dstbranch =~ s/^\+//   ? +1 :
6302                 $dstbranch =~ s/^\.\.// ? -1 :
6303                                            0;
6304     my $info = $force ? " $&" : '';
6305     $info = "$dscfn$info";
6306
6307     my $specbranch = $dstbranch;
6308     $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6309     $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6310
6311     my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6312     my $chead = cmdoutput_errok @symcmd;
6313     defined $chead or $?==256 or failedcmd @symcmd;
6314
6315     fail "$dstbranch is checked out - will not update it"
6316         if defined $chead and $chead eq $dstbranch;
6317
6318     my $oldhash = git_get_ref $dstbranch;
6319
6320     open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6321     $dscdata = do { local $/ = undef; <D>; };
6322     D->error and fail "read $dscfn: $!";
6323     close C;
6324
6325     # we don't normally need this so import it here
6326     use Dpkg::Source::Package;
6327     my $dp = new Dpkg::Source::Package filename => $dscfn,
6328         require_valid_signature => $needsig;
6329     {
6330         local $SIG{__WARN__} = sub {
6331             print STDERR $_[0];
6332             return unless $needsig;
6333             fail "import-dsc signature check failed";
6334         };
6335         if (!$dp->is_signed()) {
6336             warn "$us: warning: importing unsigned .dsc\n";
6337         } else {
6338             my $r = $dp->check_signature();
6339             die "->check_signature => $r" if $needsig && $r;
6340         }
6341     }
6342
6343     parse_dscdata();
6344
6345     $package = getfield $dsc, 'Source';
6346
6347     parse_dsc_field($dsc, "Dgit metadata in .dsc")
6348         unless forceing [qw(import-dsc-with-dgit-field)];
6349     parse_dsc_field_def_dsc_distro();
6350
6351     $isuite = 'DGIT-IMPORT-DSC';
6352     $idistro //= $dsc_distro;
6353
6354     notpushing();
6355
6356     if (defined $dsc_hash) {
6357         progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6358         resolve_dsc_field_commit undef, undef;
6359     }
6360     if (defined $dsc_hash) {
6361         my @cmd = (qw(sh -ec),
6362                    "echo $dsc_hash | git cat-file --batch-check");
6363         my $objgot = cmdoutput @cmd;
6364         if ($objgot =~ m#^\w+ missing\b#) {
6365             fail <<END
6366 .dsc contains Dgit field referring to object $dsc_hash
6367 Your git tree does not have that object.  Try `git fetch' from a
6368 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6369 END
6370         }
6371         if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6372             if ($force > 0) {
6373                 progress "Not fast forward, forced update.";
6374             } else {
6375                 fail "Not fast forward to $dsc_hash";
6376             }
6377         }
6378         import_dsc_result $dstbranch, $dsc_hash,
6379             "dgit import-dsc (Dgit): $info",
6380             "updated git ref $dstbranch";
6381         return 0;
6382     }
6383
6384     fail <<END
6385 Branch $dstbranch already exists
6386 Specify ..$specbranch for a pseudo-merge, binding in existing history
6387 Specify  +$specbranch to overwrite, discarding existing history
6388 END
6389         if $oldhash && !$force;
6390
6391     my @dfi = dsc_files_info();
6392     foreach my $fi (@dfi) {
6393         my $f = $fi->{Filename};
6394         my $here = "../$f";
6395         if (lstat $here) {
6396             next if stat $here;
6397             fail "lstat $here works but stat gives $! !";
6398         }
6399         fail "stat $here: $!" unless $! == ENOENT;
6400         my $there = $dscfn;
6401         if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6402             $there = $';
6403         } elsif ($dscfn =~ m#^/#) {
6404             $there = $dscfn;
6405         } else {
6406             fail "cannot import $dscfn which seems to be inside working tree!";
6407         }
6408         $there =~ s#/+[^/]+$## or
6409             fail "import $dscfn requires ../$f, but it does not exist";
6410         $there .= "/$f";
6411         my $test = $there =~ m{^/} ? $there : "../$there";
6412         stat $test or fail "import $dscfn requires $test, but: $!";
6413         symlink $there, $here or fail "symlink $there to $here: $!";
6414         progress "made symlink $here -> $there";
6415 #       print STDERR Dumper($fi);
6416     }
6417     my @mergeinputs = generate_commits_from_dsc();
6418     die unless @mergeinputs == 1;
6419
6420     my $newhash = $mergeinputs[0]{Commit};
6421
6422     if ($oldhash) {
6423         if ($force > 0) {
6424             progress "Import, forced update - synthetic orphan git history.";
6425         } elsif ($force < 0) {
6426             progress "Import, merging.";
6427             my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6428             my $version = getfield $dsc, 'Version';
6429             my $clogp = commit_getclogp $newhash;
6430             my $authline = clogp_authline $clogp;
6431             $newhash = make_commit_text <<END;
6432 tree $tree
6433 parent $newhash
6434 parent $oldhash
6435 author $authline
6436 committer $authline
6437
6438 Merge $package ($version) import into $dstbranch
6439 END
6440         } else {
6441             die; # caught earlier
6442         }
6443     }
6444
6445     import_dsc_result $dstbranch, $newhash,
6446         "dgit import-dsc: $info",
6447         "results are in in git ref $dstbranch";
6448 }
6449
6450 sub pre_archive_api_query () {
6451     not_necessarily_a_tree();
6452 }
6453 sub cmd_archive_api_query {
6454     badusage "need only 1 subpath argument" unless @ARGV==1;
6455     my ($subpath) = @ARGV;
6456     local $isuite = 'DGIT-API-QUERY-CMD';
6457     my @cmd = archive_api_query_cmd($subpath);
6458     push @cmd, qw(-f);
6459     debugcmd ">",@cmd;
6460     exec @cmd or fail "exec curl: $!\n";
6461 }
6462
6463 sub repos_server_url () {
6464     $package = '_dgit-repos-server';
6465     local $access_forpush = 1;
6466     local $isuite = 'DGIT-REPOS-SERVER';
6467     my $url = access_giturl();
6468 }
6469
6470 sub pre_clone_dgit_repos_server () {
6471     not_necessarily_a_tree();
6472 }
6473 sub cmd_clone_dgit_repos_server {
6474     badusage "need destination argument" unless @ARGV==1;
6475     my ($destdir) = @ARGV;
6476     my $url = repos_server_url();
6477     my @cmd = (@git, qw(clone), $url, $destdir);
6478     debugcmd ">",@cmd;
6479     exec @cmd or fail "exec git clone: $!\n";
6480 }
6481
6482 sub pre_print_dgit_repos_server_source_url () {
6483     not_necessarily_a_tree();
6484 }
6485 sub cmd_print_dgit_repos_server_source_url {
6486     badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6487         if @ARGV;
6488     my $url = repos_server_url();
6489     print $url, "\n" or die $!;
6490 }
6491
6492 sub pre_print_dpkg_source_ignores {
6493     not_necessarily_a_tree();
6494 }
6495 sub cmd_print_dpkg_source_ignores {
6496     badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6497         if @ARGV;
6498     print "@dpkg_source_ignores\n" or die $!;
6499 }
6500
6501 sub cmd_setup_mergechangelogs {
6502     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6503     local $isuite = 'DGIT-SETUP-TREE';
6504     setup_mergechangelogs(1);
6505 }
6506
6507 sub cmd_setup_useremail {
6508     badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6509     local $isuite = 'DGIT-SETUP-TREE';
6510     setup_useremail(1);
6511 }
6512
6513 sub cmd_setup_gitattributes {
6514     badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6515     local $isuite = 'DGIT-SETUP-TREE';
6516     setup_gitattrs(1);
6517 }
6518
6519 sub cmd_setup_new_tree {
6520     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6521     local $isuite = 'DGIT-SETUP-TREE';
6522     setup_new_tree();
6523 }
6524
6525 #---------- argument parsing and main program ----------
6526
6527 sub cmd_version {
6528     print "dgit version $our_version\n" or die $!;
6529     finish 0;
6530 }
6531
6532 our (%valopts_long, %valopts_short);
6533 our (%funcopts_long);
6534 our @rvalopts;
6535 our (@modeopt_cfgs);
6536
6537 sub defvalopt ($$$$) {
6538     my ($long,$short,$val_re,$how) = @_;
6539     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6540     $valopts_long{$long} = $oi;
6541     $valopts_short{$short} = $oi;
6542     # $how subref should:
6543     #   do whatever assignemnt or thing it likes with $_[0]
6544     #   if the option should not be passed on to remote, @rvalopts=()
6545     # or $how can be a scalar ref, meaning simply assign the value
6546 }
6547
6548 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6549 defvalopt '--distro',        '-d', '.+',      \$idistro;
6550 defvalopt '',                '-k', '.+',      \$keyid;
6551 defvalopt '--existing-package','', '.*',      \$existing_package;
6552 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
6553 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
6554 defvalopt '--package',   '-p',   $package_re, \$package;
6555 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
6556
6557 defvalopt '', '-C', '.+', sub {
6558     ($changesfile) = (@_);
6559     if ($changesfile =~ s#^(.*)/##) {
6560         $buildproductsdir = $1;
6561     }
6562 };
6563
6564 defvalopt '--initiator-tempdir','','.*', sub {
6565     ($initiator_tempdir) = (@_);
6566     $initiator_tempdir =~ m#^/# or
6567         badusage "--initiator-tempdir must be used specify an".
6568         " absolute, not relative, directory."
6569 };
6570
6571 sub defoptmodes ($@) {
6572     my ($varref, $cfgkey, $default, %optmap) = @_;
6573     my %permit;
6574     while (my ($opt,$val) = each %optmap) {
6575         $funcopts_long{$opt} = sub { $$varref = $val; };
6576         $permit{$val} = $val;
6577     }
6578     push @modeopt_cfgs, {
6579         Var => $varref,
6580         Key => $cfgkey,
6581         Default => $default,
6582         Vals => \%permit
6583     };
6584 }
6585
6586 defoptmodes \$dodep14tag, qw( dep14tag          want
6587                               --dep14tag        want
6588                               --no-dep14tag     no
6589                               --always-dep14tag always );
6590
6591 sub parseopts () {
6592     my $om;
6593
6594     if (defined $ENV{'DGIT_SSH'}) {
6595         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6596     } elsif (defined $ENV{'GIT_SSH'}) {
6597         @ssh = ($ENV{'GIT_SSH'});
6598     }
6599
6600     my $oi;
6601     my $val;
6602     my $valopt = sub {
6603         my ($what) = @_;
6604         @rvalopts = ($_);
6605         if (!defined $val) {
6606             badusage "$what needs a value" unless @ARGV;
6607             $val = shift @ARGV;
6608             push @rvalopts, $val;
6609         }
6610         badusage "bad value \`$val' for $what" unless
6611             $val =~ m/^$oi->{Re}$(?!\n)/s;
6612         my $how = $oi->{How};
6613         if (ref($how) eq 'SCALAR') {
6614             $$how = $val;
6615         } else {
6616             $how->($val);
6617         }
6618         push @ropts, @rvalopts;
6619     };
6620
6621     while (@ARGV) {
6622         last unless $ARGV[0] =~ m/^-/;
6623         $_ = shift @ARGV;
6624         last if m/^--?$/;
6625         if (m/^--/) {
6626             if (m/^--dry-run$/) {
6627                 push @ropts, $_;
6628                 $dryrun_level=2;
6629             } elsif (m/^--damp-run$/) {
6630                 push @ropts, $_;
6631                 $dryrun_level=1;
6632             } elsif (m/^--no-sign$/) {
6633                 push @ropts, $_;
6634                 $sign=0;
6635             } elsif (m/^--help$/) {
6636                 cmd_help();
6637             } elsif (m/^--version$/) {
6638                 cmd_version();
6639             } elsif (m/^--new$/) {
6640                 push @ropts, $_;
6641                 $new_package=1;
6642             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6643                      ($om = $opts_opt_map{$1}) &&
6644                      length $om->[0]) {
6645                 push @ropts, $_;
6646                 $om->[0] = $2;
6647             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6648                      !$opts_opt_cmdonly{$1} &&
6649                      ($om = $opts_opt_map{$1})) {
6650                 push @ropts, $_;
6651                 push @$om, $2;
6652             } elsif (m/^--(gbp|dpm)$/s) {
6653                 push @ropts, "--quilt=$1";
6654                 $quilt_mode = $1;
6655             } elsif (m/^--ignore-dirty$/s) {
6656                 push @ropts, $_;
6657                 $ignoredirty = 1;
6658             } elsif (m/^--no-quilt-fixup$/s) {
6659                 push @ropts, $_;
6660                 $quilt_mode = 'nocheck';
6661             } elsif (m/^--no-rm-on-error$/s) {
6662                 push @ropts, $_;
6663                 $rmonerror = 0;
6664             } elsif (m/^--no-chase-dsc-distro$/s) {
6665                 push @ropts, $_;
6666                 $chase_dsc_distro = 0;
6667             } elsif (m/^--overwrite$/s) {
6668                 push @ropts, $_;
6669                 $overwrite_version = '';
6670             } elsif (m/^--overwrite=(.+)$/s) {
6671                 push @ropts, $_;
6672                 $overwrite_version = $1;
6673             } elsif (m/^--delayed=(\d+)$/s) {
6674                 push @ropts, $_;
6675                 push @dput, $_;
6676             } elsif (m/^--dgit-view-save=(.+)$/s) {
6677                 push @ropts, $_;
6678                 $split_brain_save = $1;
6679                 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6680             } elsif (m/^--(no-)?rm-old-changes$/s) {
6681                 push @ropts, $_;
6682                 $rmchanges = !$1;
6683             } elsif (m/^--deliberately-($deliberately_re)$/s) {
6684                 push @ropts, $_;
6685                 push @deliberatelies, $&;
6686             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6687                 push @ropts, $&;
6688                 $forceopts{$1} = 1;
6689                 $_='';
6690             } elsif (m/^--force-/) {
6691                 print STDERR
6692                     "$us: warning: ignoring unknown force option $_\n";
6693                 $_='';
6694             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6695                 # undocumented, for testing
6696                 push @ropts, $_;
6697                 $tagformat_want = [ $1, 'command line', 1 ];
6698                 # 1 menas overrides distro configuration
6699             } elsif (m/^--always-split-source-build$/s) {
6700                 # undocumented, for testing
6701                 push @ropts, $_;
6702                 $need_split_build_invocation = 1;
6703             } elsif (m/^--config-lookup-explode=(.+)$/s) {
6704                 # undocumented, for testing
6705                 push @ropts, $_;
6706                 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6707                 # ^ it's supposed to be an array ref
6708             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6709                 $val = $2 ? $' : undef; #';
6710                 $valopt->($oi->{Long});
6711             } elsif ($funcopts_long{$_}) {
6712                 push @ropts, $_;
6713                 $funcopts_long{$_}();
6714             } else {
6715                 badusage "unknown long option \`$_'";
6716             }
6717         } else {
6718             while (m/^-./s) {
6719                 if (s/^-n/-/) {
6720                     push @ropts, $&;
6721                     $dryrun_level=2;
6722                 } elsif (s/^-L/-/) {
6723                     push @ropts, $&;
6724                     $dryrun_level=1;
6725                 } elsif (s/^-h/-/) {
6726                     cmd_help();
6727                 } elsif (s/^-D/-/) {
6728                     push @ropts, $&;
6729                     $debuglevel++;
6730                     enabledebug();
6731                 } elsif (s/^-N/-/) {
6732                     push @ropts, $&;
6733                     $new_package=1;
6734                 } elsif (m/^-m/) {
6735                     push @ropts, $&;
6736                     push @changesopts, $_;
6737                     $_ = '';
6738                 } elsif (s/^-wn$//s) {
6739                     push @ropts, $&;
6740                     $cleanmode = 'none';
6741                 } elsif (s/^-wg$//s) {
6742                     push @ropts, $&;
6743                     $cleanmode = 'git';
6744                 } elsif (s/^-wgf$//s) {
6745                     push @ropts, $&;
6746                     $cleanmode = 'git-ff';
6747                 } elsif (s/^-wd$//s) {
6748                     push @ropts, $&;
6749                     $cleanmode = 'dpkg-source';
6750                 } elsif (s/^-wdd$//s) {
6751                     push @ropts, $&;
6752                     $cleanmode = 'dpkg-source-d';
6753                 } elsif (s/^-wc$//s) {
6754                     push @ropts, $&;
6755                     $cleanmode = 'check';
6756                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6757                     push @git, '-c', $&;
6758                     $gitcfgs{cmdline}{$1} = [ $2 ];
6759                 } elsif (s/^-c([^=]+)$//s) {
6760                     push @git, '-c', $&;
6761                     $gitcfgs{cmdline}{$1} = [ 'true' ];
6762                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6763                     $val = $'; #';
6764                     $val = undef unless length $val;
6765                     $valopt->($oi->{Short});
6766                     $_ = '';
6767                 } else {
6768                     badusage "unknown short option \`$_'";
6769                 }
6770             }
6771         }
6772     }
6773 }
6774
6775 sub check_env_sanity () {
6776     my $blocked = new POSIX::SigSet;
6777     sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6778
6779     eval {
6780         foreach my $name (qw(PIPE CHLD)) {
6781             my $signame = "SIG$name";
6782             my $signum = eval "POSIX::$signame" // die;
6783             ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6784                 die "$signame is set to something other than SIG_DFL\n";
6785             $blocked->ismember($signum) and
6786                 die "$signame is blocked\n";
6787         }
6788     };
6789     return unless $@;
6790     chomp $@;
6791     fail <<END;
6792 On entry to dgit, $@
6793 This is a bug produced by something in in your execution environment.
6794 Giving up.
6795 END
6796 }
6797
6798
6799 sub parseopts_late_defaults () {
6800     $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
6801         if defined $idistro;
6802     $isuite //= cfg('dgit.default.default-suite');
6803
6804     foreach my $k (keys %opts_opt_map) {
6805         my $om = $opts_opt_map{$k};
6806
6807         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6808         if (defined $v) {
6809             badcfg "cannot set command for $k"
6810                 unless length $om->[0];
6811             $om->[0] = $v;
6812         }
6813
6814         foreach my $c (access_cfg_cfgs("opts-$k")) {
6815             my @vl =
6816                 map { $_ ? @$_ : () }
6817                 map { $gitcfgs{$_}{$c} }
6818                 reverse @gitcfgsources;
6819             printdebug "CL $c ", (join " ", map { shellquote } @vl),
6820                 "\n" if $debuglevel >= 4;
6821             next unless @vl;
6822             badcfg "cannot configure options for $k"
6823                 if $opts_opt_cmdonly{$k};
6824             my $insertpos = $opts_cfg_insertpos{$k};
6825             @$om = ( @$om[0..$insertpos-1],
6826                      @vl,
6827                      @$om[$insertpos..$#$om] );
6828         }
6829     }
6830
6831     if (!defined $rmchanges) {
6832         local $access_forpush;
6833         $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6834     }
6835
6836     if (!defined $quilt_mode) {
6837         local $access_forpush;
6838         $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6839             // access_cfg('quilt-mode', 'RETURN-UNDEF')
6840             // 'linear';
6841         $quilt_mode =~ m/^($quilt_modes_re)$/
6842             or badcfg "unknown quilt-mode \`$quilt_mode'";
6843         $quilt_mode = $1;
6844     }
6845
6846     foreach my $moc (@modeopt_cfgs) {
6847         local $access_forpush;
6848         my $vr = $moc->{Var};
6849         next if defined $$vr;
6850         $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
6851         my $v = $moc->{Vals}{$$vr};
6852         badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
6853         $$vr = $v;
6854     }
6855
6856     $need_split_build_invocation ||= quiltmode_splitbrain();
6857
6858     if (!defined $cleanmode) {
6859         local $access_forpush;
6860         $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6861         $cleanmode //= 'dpkg-source';
6862
6863         badcfg "unknown clean-mode \`$cleanmode'" unless
6864             $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6865     }
6866 }
6867
6868 if ($ENV{$fakeeditorenv}) {
6869     git_slurp_config();
6870     quilt_fixup_editor();
6871 }
6872
6873 parseopts();
6874 check_env_sanity();
6875
6876 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6877 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6878     if $dryrun_level == 1;
6879 if (!@ARGV) {
6880     print STDERR $helpmsg or die $!;
6881     finish 8;
6882 }
6883 $cmd = $subcommand = shift @ARGV;
6884 $cmd =~ y/-/_/;
6885
6886 my $pre_fn = ${*::}{"pre_$cmd"};
6887 $pre_fn->() if $pre_fn;
6888
6889 record_maindir if $invoked_in_git_tree;
6890 git_slurp_config();
6891
6892 my $fn = ${*::}{"cmd_$cmd"};
6893 $fn or badusage "unknown operation $cmd";
6894 $fn->();
6895
6896 finish 0;