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