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