dgit

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