dgit

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