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