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