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