dgit

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