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