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