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