dgit

   1 #!/usr/bin/perl -w
   2 # dgit
   3 # Integration between git and Debian-style archives
   4 #
   5 # Copyright (C)2013-2018 Ian Jackson
   6 # Copyright (C)2017-2018 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 = 1;
 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 #---------- remote commands' implementation ----------
4760
4761 sub pre_remote_push_build_host {
4762     my ($nrargs) = shift @ARGV;
4763     my (@rargs) = @ARGV[0..$nrargs-1];
4764     @ARGV = @ARGV[$nrargs..$#ARGV];
4765     die unless @rargs;
4766     my ($dir,$vsnwant) = @rargs;
4767     # vsnwant is a comma-separated list; we report which we have
4768     # chosen in our ready response (so other end can tell if they
4769     # offered several)
4770     $debugprefix = ' ';
4771     $we_are_responder = 1;
4772     $us .= " (build host)";
4773
4774     open PI, "<&STDIN" or die $!;
4775     open STDIN, "/dev/null" or die $!;
4776     open PO, ">&STDOUT" or die $!;
4777     autoflush PO 1;
4778     open STDOUT, ">&STDERR" or die $!;
4779     autoflush STDOUT 1;
4780
4781     $vsnwant //= 1;
4782     ($protovsn) = grep {
4783         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4784     } @rpushprotovsn_support;
4785
4786     fail "build host has dgit rpush protocol versions ".
4787         (join ",", @rpushprotovsn_support).
4788         " but invocation host has $vsnwant"
4789         unless defined $protovsn;
4790
4791     changedir $dir;
4792 }
4793 sub cmd_remote_push_build_host {
4794     responder_send_command("dgit-remote-push-ready $protovsn");
4795     &cmd_push;
4796 }
4797
4798 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4799 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4800 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4801 #     a good error message)
4802
4803 sub rpush_handle_protovsn_bothends () {
4804     if ($protovsn < 4) {
4805         need_tagformat 'old', "rpush negotiated protocol $protovsn";
4806     }
4807     select_tagformat();
4808 }
4809
4810 our $i_tmp;
4811
4812 sub i_cleanup {
4813     local ($@, $?);
4814     my $report = i_child_report();
4815     if (defined $report) {
4816         printdebug "($report)\n";
4817     } elsif ($i_child_pid) {
4818         printdebug "(killing build host child $i_child_pid)\n";
4819         kill 15, $i_child_pid;
4820     }
4821     if (defined $i_tmp && !defined $initiator_tempdir) {
4822         changedir "/";
4823         eval { rmtree $i_tmp; };
4824     }
4825 }
4826
4827 END {
4828     return unless forkcheck_mainprocess();
4829     i_cleanup();
4830 }
4831
4832 sub i_method {
4833     my ($base,$selector,@args) = @_;
4834     $selector =~ s/\-/_/g;
4835     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4836 }
4837
4838 sub pre_rpush () {
4839     not_necessarily_a_tree();
4840 }
4841 sub cmd_rpush {
4842     my $host = nextarg;
4843     my $dir;
4844     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4845         $host = $1;
4846         $dir = $'; #';
4847     } else {
4848         $dir = nextarg;
4849     }
4850     $dir =~ s{^-}{./-};
4851     my @rargs = ($dir);
4852     push @rargs, join ",", @rpushprotovsn_support;
4853     my @rdgit;
4854     push @rdgit, @dgit;
4855     push @rdgit, @ropts;
4856     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4857     push @rdgit, @ARGV;
4858     my @cmd = (@ssh, $host, shellquote @rdgit);
4859     debugcmd "+",@cmd;
4860
4861     $we_are_initiator=1;
4862
4863     if (defined $initiator_tempdir) {
4864         rmtree $initiator_tempdir;
4865         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4866         $i_tmp = $initiator_tempdir;
4867     } else {
4868         $i_tmp = tempdir();
4869     }
4870     $i_child_pid = open2(\*RO, \*RI, @cmd);
4871     changedir $i_tmp;
4872     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4873     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4874     $supplementary_message = '' unless $protovsn >= 3;
4875
4876     for (;;) {
4877         my ($icmd,$iargs) = initiator_expect {
4878             m/^(\S+)(?: (.*))?$/;
4879             ($1,$2);
4880         };
4881         i_method "i_resp", $icmd, $iargs;
4882     }
4883 }
4884
4885 sub i_resp_progress ($) {
4886     my ($rhs) = @_;
4887     my $msg = protocol_read_bytes \*RO, $rhs;
4888     progress $msg;
4889 }
4890
4891 sub i_resp_supplementary_message ($) {
4892     my ($rhs) = @_;
4893     $supplementary_message = protocol_read_bytes \*RO, $rhs;
4894 }
4895
4896 sub i_resp_complete {
4897     my $pid = $i_child_pid;
4898     $i_child_pid = undef; # prevents killing some other process with same pid
4899     printdebug "waiting for build host child $pid...\n";
4900     my $got = waitpid $pid, 0;
4901     die $! unless $got == $pid;
4902     die "build host child failed $?" if $?;
4903
4904     i_cleanup();
4905     printdebug "all done\n";
4906     finish 0;
4907 }
4908
4909 sub i_resp_file ($) {
4910     my ($keyword) = @_;
4911     my $localname = i_method "i_localname", $keyword;
4912     my $localpath = "$i_tmp/$localname";
4913     stat_exists $localpath and
4914         badproto \*RO, "file $keyword ($localpath) twice";
4915     protocol_receive_file \*RO, $localpath;
4916     i_method "i_file", $keyword;
4917 }
4918
4919 our %i_param;
4920
4921 sub i_resp_param ($) {
4922     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4923     $i_param{$1} = $2;
4924 }
4925
4926 sub i_resp_previously ($) {
4927     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4928         or badproto \*RO, "bad previously spec";
4929     my $r = system qw(git check-ref-format), $1;
4930     die "bad previously ref spec ($r)" if $r;
4931     $previously{$1} = $2;
4932 }
4933
4934 our %i_wanted;
4935
4936 sub i_resp_want ($) {
4937     my ($keyword) = @_;
4938     die "$keyword ?" if $i_wanted{$keyword}++;
4939
4940     defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4941     $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4942     die unless $isuite =~ m/^$suite_re$/;
4943
4944     pushing();
4945     rpush_handle_protovsn_bothends();
4946
4947     fail "rpush negotiated protocol version $protovsn".
4948         " which does not support quilt mode $quilt_mode"
4949         if quiltmode_splitbrain;
4950
4951     my @localpaths = i_method "i_want", $keyword;
4952     printdebug "[[  $keyword @localpaths\n";
4953     foreach my $localpath (@localpaths) {
4954         protocol_send_file \*RI, $localpath;
4955     }
4956     print RI "files-end\n" or die $!;
4957 }
4958
4959 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
4960
4961 sub i_localname_parsed_changelog {
4962     return "remote-changelog.822";
4963 }
4964 sub i_file_parsed_changelog {
4965     ($i_clogp, $i_version, $i_dscfn) =
4966         push_parse_changelog "$i_tmp/remote-changelog.822";
4967     die if $i_dscfn =~ m#/|^\W#;
4968 }
4969
4970 sub i_localname_dsc {
4971     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4972     return $i_dscfn;
4973 }
4974 sub i_file_dsc { }
4975
4976 sub i_localname_buildinfo ($) {
4977     my $bi = $i_param{'buildinfo-filename'};
4978     defined $bi or badproto \*RO, "buildinfo before filename";
4979     defined $i_changesfn or badproto \*RO, "buildinfo before changes";
4980     $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
4981         or badproto \*RO, "improper buildinfo filename";
4982     return $&;
4983 }
4984 sub i_file_buildinfo {
4985     my $bi = $i_param{'buildinfo-filename'};
4986     my $bd = parsecontrol "$i_tmp/$bi", $bi;
4987     my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
4988     if (!forceing [qw(buildinfo-changes-mismatch)]) {
4989         files_compare_inputs($bd, $ch);
4990         (getfield $bd, $_) eq (getfield $ch, $_) or
4991             fail "buildinfo mismatch $_"
4992             foreach qw(Source Version);
4993         !defined $bd->{$_} or
4994             fail "buildinfo contains $_"
4995             foreach qw(Changes Changed-by Distribution);
4996     }
4997     push @i_buildinfos, $bi;
4998     delete $i_param{'buildinfo-filename'};
4999 }
5000
5001 sub i_localname_changes {
5002     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5003     $i_changesfn = $i_dscfn;
5004     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5005     return $i_changesfn;
5006 }
5007 sub i_file_changes { }
5008
5009 sub i_want_signed_tag {
5010     printdebug Dumper(\%i_param, $i_dscfn);
5011     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5012         && defined $i_param{'csuite'}
5013         or badproto \*RO, "premature desire for signed-tag";
5014     my $head = $i_param{'head'};
5015     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5016
5017     my $maintview = $i_param{'maint-view'};
5018     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5019
5020     select_tagformat();
5021     if ($protovsn >= 4) {
5022         my $p = $i_param{'tagformat'} // '<undef>';
5023         $p eq $tagformat
5024             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5025     }
5026
5027     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5028     $csuite = $&;
5029     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5030
5031     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5032
5033     return
5034         push_mktags $i_clogp, $i_dscfn,
5035             $i_changesfn, 'remote changes',
5036             \@tagwants;
5037 }
5038
5039 sub i_want_signed_dsc_changes {
5040     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5041     sign_changes $i_changesfn;
5042     return ($i_dscfn, $i_changesfn, @i_buildinfos);
5043 }
5044
5045 #---------- building etc. ----------
5046
5047 our $version;
5048 our $sourcechanges;
5049 our $dscfn;
5050
5051 #----- `3.0 (quilt)' handling -----
5052
5053 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5054
5055 sub quiltify_dpkg_commit ($$$;$) {
5056     my ($patchname,$author,$msg, $xinfo) = @_;
5057     $xinfo //= '';
5058
5059     mkpath '.git/dgit'; # we are in playtree
5060     my $descfn = ".git/dgit/quilt-description.tmp";
5061     open O, '>', $descfn or die "$descfn: $!";
5062     $msg =~ s/\n+/\n\n/;
5063     print O <<END or die $!;
5064 From: $author
5065 ${xinfo}Subject: $msg
5066 ---
5067
5068 END
5069     close O or die $!;
5070
5071     {
5072         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5073         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5074         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5075         runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5076     }
5077 }
5078
5079 sub quiltify_trees_differ ($$;$$$) {
5080     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5081     # returns true iff the two tree objects differ other than in debian/
5082     # with $finegrained,
5083     # returns bitmask 01 - differ in upstream files except .gitignore
5084     #                 02 - differ in .gitignore
5085     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5086     #  is set for each modified .gitignore filename $fn
5087     # if $unrepres is defined, array ref to which is appeneded
5088     #  a list of unrepresentable changes (removals of upstream files
5089     #  (as messages)
5090     local $/=undef;
5091     my @cmd = (@git, qw(diff-tree -z --no-renames));
5092     push @cmd, qw(--name-only) unless $unrepres;
5093     push @cmd, qw(-r) if $finegrained || $unrepres;
5094     push @cmd, $x, $y;
5095     my $diffs= cmdoutput @cmd;
5096     my $r = 0;
5097     my @lmodes;
5098     foreach my $f (split /\0/, $diffs) {
5099         if ($unrepres && !@lmodes) {
5100             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5101             next;
5102         }
5103         my ($oldmode,$newmode) = @lmodes;
5104         @lmodes = ();
5105
5106         next if $f =~ m#^debian(?:/.*)?$#s;
5107
5108         if ($unrepres) {
5109             eval {
5110                 die "not a plain file or symlink\n"
5111                     unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5112                            $oldmode =~ m/^(?:10|12)\d{4}$/;
5113                 if ($oldmode =~ m/[^0]/ &&
5114                     $newmode =~ m/[^0]/) {
5115                     # both old and new files exist
5116                     die "mode or type changed\n" if $oldmode ne $newmode;
5117                     die "modified symlink\n" unless $newmode =~ m/^10/;
5118                 } elsif ($oldmode =~ m/[^0]/) {
5119                     # deletion
5120                     die "deletion of symlink\n"
5121                         unless $oldmode =~ m/^10/;
5122                 } else {
5123                     # creation
5124                     die "creation with non-default mode\n"
5125                         unless $newmode =~ m/^100644$/ or
5126                                $newmode =~ m/^120000$/;
5127                 }
5128             };
5129             if ($@) {
5130                 local $/="\n"; chomp $@;
5131                 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5132             }
5133         }
5134
5135         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5136         $r |= $isignore ? 02 : 01;
5137         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5138     }
5139     printdebug "quiltify_trees_differ $x $y => $r\n";
5140     return $r;
5141 }
5142
5143 sub quiltify_tree_sentinelfiles ($) {
5144     # lists the `sentinel' files present in the tree
5145     my ($x) = @_;
5146     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5147         qw(-- debian/rules debian/control);
5148     $r =~ s/\n/,/g;
5149     return $r;
5150 }
5151
5152 sub quiltify_splitbrain_needed () {
5153     if (!$split_brain) {
5154         progress "dgit view: changes are required...";
5155         runcmd @git, qw(checkout -q -b dgit-view);
5156         $split_brain = 1;
5157     }
5158 }
5159
5160 sub quiltify_splitbrain ($$$$$$$) {
5161     my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5162         $editedignores, $cachekey) = @_;
5163     my $gitignore_special = 1;
5164     if ($quilt_mode !~ m/gbp|dpm/) {
5165         # treat .gitignore just like any other upstream file
5166         $diffbits = { %$diffbits };
5167         $_ = !!$_ foreach values %$diffbits;
5168         $gitignore_special = 0;
5169     }
5170     # We would like any commits we generate to be reproducible
5171     my @authline = clogp_authline($clogp);
5172     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
5173     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5174     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
5175     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
5176     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5177     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
5178
5179     my $fulldiffhint = sub {
5180         my ($x,$y) = @_;
5181         my $cmd = "git diff $x $y -- :/ ':!debian'";
5182         $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5183         return "\nFor full diff showing the problem(s), type:\n $cmd\n";
5184     };
5185
5186     if ($quilt_mode =~ m/gbp|unapplied/ &&
5187         ($diffbits->{O2H} & 01)) {
5188         my $msg =
5189  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5190  " but git tree differs from orig in upstream files.";
5191         $msg .= $fulldiffhint->($unapplied, 'HEAD');
5192         if (!stat_exists "debian/patches") {
5193             $msg .=
5194  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5195         }
5196         fail $msg;
5197     }
5198     if ($quilt_mode =~ m/dpm/ &&
5199         ($diffbits->{H2A} & 01)) {
5200         fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
5201 --quilt=$quilt_mode specified, implying patches-applied git tree
5202  but git tree differs from result of applying debian/patches to upstream
5203 END
5204     }
5205     if ($quilt_mode =~ m/gbp|unapplied/ &&
5206         ($diffbits->{O2A} & 01)) { # some patches
5207         quiltify_splitbrain_needed();
5208         progress "dgit view: creating patches-applied version using gbp pq";
5209         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5210         # gbp pq import creates a fresh branch; push back to dgit-view
5211         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5212         runcmd @git, qw(checkout -q dgit-view);
5213     }
5214     if ($quilt_mode =~ m/gbp|dpm/ &&
5215         ($diffbits->{O2A} & 02)) {
5216         fail <<END;
5217 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5218  tool which does not create patches for changes to upstream
5219  .gitignores: but, such patches exist in debian/patches.
5220 END
5221     }
5222     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5223         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5224         quiltify_splitbrain_needed();
5225         progress "dgit view: creating patch to represent .gitignore changes";
5226         ensuredir "debian/patches";
5227         my $gipatch = "debian/patches/auto-gitignore";
5228         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5229         stat GIPATCH or die "$gipatch: $!";
5230         fail "$gipatch already exists; but want to create it".
5231             " to record .gitignore changes" if (stat _)[7];
5232         print GIPATCH <<END or die "$gipatch: $!";
5233 Subject: Update .gitignore from Debian packaging branch
5234
5235 The Debian packaging git branch contains these updates to the upstream
5236 .gitignore file(s).  This patch is autogenerated, to provide these
5237 updates to users of the official Debian archive view of the package.
5238
5239 [dgit ($our_version) update-gitignore]
5240 ---
5241 END
5242         close GIPATCH or die "$gipatch: $!";
5243         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5244             $unapplied, $headref, "--", sort keys %$editedignores;
5245         open SERIES, "+>>", "debian/patches/series" or die $!;
5246         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5247         my $newline;
5248         defined read SERIES, $newline, 1 or die $!;
5249         print SERIES "\n" or die $! unless $newline eq "\n";
5250         print SERIES "auto-gitignore\n" or die $!;
5251         close SERIES or die  $!;
5252         runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5253         commit_admin <<END
5254 Commit patch to update .gitignore
5255
5256 [dgit ($our_version) update-gitignore-quilt-fixup]
5257 END
5258     }
5259
5260     my $dgitview = git_rev_parse 'HEAD';
5261
5262     changedir $maindir;
5263     # When we no longer need to support squeeze, use --create-reflog
5264     # instead of this:
5265     ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
5266     my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>'
5267       or die $!;
5268
5269     my $oldcache = git_get_ref "refs/$splitbraincache";
5270     if ($oldcache eq $dgitview) {
5271         my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5272         # git update-ref doesn't always update, in this case.  *sigh*
5273         my $dummy = make_commit_text <<END;
5274 tree $tree
5275 parent $dgitview
5276 author Dgit <dgit\@example.com> 1000000000 +0000
5277 committer Dgit <dgit\@example.com> 1000000000 +0000
5278
5279 Dummy commit - do not use
5280 END
5281         runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5282             "refs/$splitbraincache", $dummy;
5283     }
5284     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5285         $dgitview;
5286
5287     changedir "$playground/work";
5288
5289     my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5290     progress "dgit view: created ($saved)";
5291 }
5292
5293 sub quiltify ($$$$) {
5294     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5295
5296     # Quilt patchification algorithm
5297     #
5298     # We search backwards through the history of the main tree's HEAD
5299     # (T) looking for a start commit S whose tree object is identical
5300     # to to the patch tip tree (ie the tree corresponding to the
5301     # current dpkg-committed patch series).  For these purposes
5302     # `identical' disregards anything in debian/ - this wrinkle is
5303     # necessary because dpkg-source treates debian/ specially.
5304     #
5305     # We can only traverse edges where at most one of the ancestors'
5306     # trees differs (in changes outside in debian/).  And we cannot
5307     # handle edges which change .pc/ or debian/patches.  To avoid
5308     # going down a rathole we avoid traversing edges which introduce
5309     # debian/rules or debian/control.  And we set a limit on the
5310     # number of edges we are willing to look at.
5311     #
5312     # If we succeed, we walk forwards again.  For each traversed edge
5313     # PC (with P parent, C child) (starting with P=S and ending with
5314     # C=T) to we do this:
5315     #  - git checkout C
5316     #  - dpkg-source --commit with a patch name and message derived from C
5317     # After traversing PT, we git commit the changes which
5318     # should be contained within debian/patches.
5319
5320     # The search for the path S..T is breadth-first.  We maintain a
5321     # todo list containing search nodes.  A search node identifies a
5322     # commit, and looks something like this:
5323     #  $p = {
5324     #      Commit => $git_commit_id,
5325     #      Child => $c,                          # or undef if P=T
5326     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
5327     #      Nontrivial => true iff $p..$c has relevant changes
5328     #  };
5329
5330     my @todo;
5331     my @nots;
5332     my $sref_S;
5333     my $max_work=100;
5334     my %considered; # saves being exponential on some weird graphs
5335
5336     my $t_sentinels = quiltify_tree_sentinelfiles $target;
5337
5338     my $not = sub {
5339         my ($search,$whynot) = @_;
5340         printdebug " search NOT $search->{Commit} $whynot\n";
5341         $search->{Whynot} = $whynot;
5342         push @nots, $search;
5343         no warnings qw(exiting);
5344         next;
5345     };
5346
5347     push @todo, {
5348         Commit => $target,
5349     };
5350
5351     while (@todo) {
5352         my $c = shift @todo;
5353         next if $considered{$c->{Commit}}++;
5354
5355         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5356
5357         printdebug "quiltify investigate $c->{Commit}\n";
5358
5359         # are we done?
5360         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5361             printdebug " search finished hooray!\n";
5362             $sref_S = $c;
5363             last;
5364         }
5365
5366         quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5367         if ($quilt_mode eq 'smash') {
5368             printdebug " search quitting smash\n";
5369             last;
5370         }
5371
5372         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5373         $not->($c, "has $c_sentinels not $t_sentinels")
5374             if $c_sentinels ne $t_sentinels;
5375
5376         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5377         $commitdata =~ m/\n\n/;
5378         $commitdata =~ $`;
5379         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5380         @parents = map { { Commit => $_, Child => $c } } @parents;
5381
5382         $not->($c, "root commit") if !@parents;
5383
5384         foreach my $p (@parents) {
5385             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5386         }
5387         my $ndiffers = grep { $_->{Nontrivial} } @parents;
5388         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5389
5390         foreach my $p (@parents) {
5391             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5392
5393             my @cmd= (@git, qw(diff-tree -r --name-only),
5394                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5395             my $patchstackchange = cmdoutput @cmd;
5396             if (length $patchstackchange) {
5397                 $patchstackchange =~ s/\n/,/g;
5398                 $not->($p, "changed $patchstackchange");
5399             }
5400
5401             printdebug " search queue P=$p->{Commit} ",
5402                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5403             push @todo, $p;
5404         }
5405     }
5406
5407     if (!$sref_S) {
5408         printdebug "quiltify want to smash\n";
5409
5410         my $abbrev = sub {
5411             my $x = $_[0]{Commit};
5412             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5413             return $x;
5414         };
5415         my $reportnot = sub {
5416             my ($notp) = @_;
5417             my $s = $abbrev->($notp);
5418             my $c = $notp->{Child};
5419             $s .= "..".$abbrev->($c) if $c;
5420             $s .= ": ".$notp->{Whynot};
5421             return $s;
5422         };
5423         if ($quilt_mode eq 'linear') {
5424             print STDERR "\n$us: error: quilt fixup cannot be linear.  Stopped at:\n";
5425             foreach my $notp (@nots) {
5426                 print STDERR "$us:  ", $reportnot->($notp), "\n";
5427             }
5428             print STDERR "$us: $_\n" foreach @$failsuggestion;
5429             fail
5430  "quilt history linearisation failed.  Search \`quilt fixup' in dgit(7).\n".
5431  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5432         } elsif ($quilt_mode eq 'smash') {
5433         } elsif ($quilt_mode eq 'auto') {
5434             progress "quilt fixup cannot be linear, smashing...";
5435         } else {
5436             die "$quilt_mode ?";
5437         }
5438
5439         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5440         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5441         my $ncommits = 3;
5442         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5443
5444         quiltify_dpkg_commit "auto-$version-$target-$time",
5445             (getfield $clogp, 'Maintainer'),
5446             "Automatically generated patch ($clogp->{Version})\n".
5447             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5448         return;
5449     }
5450
5451     progress "quiltify linearisation planning successful, executing...";
5452
5453     for (my $p = $sref_S;
5454          my $c = $p->{Child};
5455          $p = $p->{Child}) {
5456         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5457         next unless $p->{Nontrivial};
5458
5459         my $cc = $c->{Commit};
5460
5461         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5462         $commitdata =~ m/\n\n/ or die "$c ?";
5463         $commitdata = $`;
5464         my $msg = $'; #';
5465         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5466         my $author = $1;
5467
5468         my $commitdate = cmdoutput
5469             @git, qw(log -n1 --pretty=format:%aD), $cc;
5470
5471         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5472
5473         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5474         $strip_nls->();
5475
5476         my $title = $1;
5477         my $patchname;
5478         my $patchdir;
5479
5480         my $gbp_check_suitable = sub {
5481             $_ = shift;
5482             my ($what) = @_;
5483
5484             eval {
5485                 die "contains unexpected slashes\n" if m{//} || m{/$};
5486                 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5487                 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5488                 die "is series file\n" if m{$series_filename_re}o;
5489                 die "too long" if length > 200;
5490             };
5491             return $_ unless $@;
5492             print STDERR "quiltifying commit $cc:".
5493                 " ignoring/dropping Gbp-Pq $what: $@";
5494             return undef;
5495         };
5496
5497         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5498                            gbp-pq-name: \s* )
5499                        (\S+) \s* \n //ixm) {
5500             $patchname = $gbp_check_suitable->($1, 'Name');
5501         }
5502         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5503                            gbp-pq-topic: \s* )
5504                        (\S+) \s* \n //ixm) {
5505             $patchdir = $gbp_check_suitable->($1, 'Topic');
5506         }
5507
5508         $strip_nls->();
5509
5510         if (!defined $patchname) {
5511             $patchname = $title;
5512             $patchname =~ s/[.:]$//;
5513             use Text::Iconv;
5514             eval {
5515                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5516                 my $translitname = $converter->convert($patchname);
5517                 die unless defined $translitname;
5518                 $patchname = $translitname;
5519             };
5520             print STDERR
5521                 "dgit: patch title transliteration error: $@"
5522                 if $@;
5523             $patchname =~ y/ A-Z/-a-z/;
5524             $patchname =~ y/-a-z0-9_.+=~//cd;
5525             $patchname =~ s/^\W/x-$&/;
5526             $patchname = substr($patchname,0,40);
5527             $patchname .= ".patch";
5528         }
5529         if (!defined $patchdir) {
5530             $patchdir = '';
5531         }
5532         if (length $patchdir) {
5533             $patchname = "$patchdir/$patchname";
5534         }
5535         if ($patchname =~ m{^(.*)/}) {
5536             mkpath "debian/patches/$1";
5537         }
5538
5539         my $index;
5540         for ($index='';
5541              stat "debian/patches/$patchname$index";
5542              $index++) { }
5543         $!==ENOENT or die "$patchname$index $!";
5544
5545         runcmd @git, qw(checkout -q), $cc;
5546
5547         # We use the tip's changelog so that dpkg-source doesn't
5548         # produce complaining messages from dpkg-parsechangelog.  None
5549         # of the information dpkg-source gets from the changelog is
5550         # actually relevant - it gets put into the original message
5551         # which dpkg-source provides our stunt editor, and then
5552         # overwritten.
5553         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5554
5555         quiltify_dpkg_commit "$patchname$index", $author, $msg,
5556             "Date: $commitdate\n".
5557             "X-Dgit-Generated: $clogp->{Version} $cc\n";
5558
5559         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5560     }
5561
5562     runcmd @git, qw(checkout -q master);
5563 }
5564
5565 sub build_maybe_quilt_fixup () {
5566     my ($format,$fopts) = get_source_format;
5567     return unless madformat_wantfixup $format;
5568     # sigh
5569
5570     check_for_vendor_patches();
5571
5572     if (quiltmode_splitbrain) {
5573         fail <<END unless access_cfg_tagformats_can_splitbrain;
5574 quilt mode $quilt_mode requires split view so server needs to support
5575  both "new" and "maint" tag formats, but config says it doesn't.
5576 END
5577     }
5578
5579     my $clogp = parsechangelog();
5580     my $headref = git_rev_parse('HEAD');
5581     my $symref = git_get_symref();
5582
5583     if ($quilt_mode eq 'linear'
5584         && !$fopts->{'single-debian-patch'}
5585         && branch_is_gdr($symref, $headref)) {
5586         # This is much faster.  It also makes patches that gdr
5587         # likes better for future updates without laundering.
5588         #
5589         # However, it can fail in some casses where we would
5590         # succeed: if there are existing patches, which correspond
5591         # to a prefix of the branch, but are not in gbp/gdr
5592         # format, gdr will fail (exiting status 7), but we might
5593         # be able to figure out where to start linearising.  That
5594         # will be slower so hopefully there's not much to do.
5595         my @cmd = (@git_debrebase,
5596                    qw(--noop-ok -funclean-mixed -funclean-ordering
5597                       make-patches --quiet-would-amend));
5598         # We tolerate soe snags that gdr wouldn't, by default.
5599         if (act_local()) {
5600             debugcmd "+",@cmd;
5601             $!=0; $?=-1;
5602             failedcmd @cmd if system @cmd and $?!=7*256;
5603         } else {
5604             dryrun_report @cmd;
5605         }
5606         $headref = git_rev_parse('HEAD');
5607     }
5608
5609     prep_ud();
5610     changedir $playground;
5611
5612     my $upstreamversion = upstreamversion $version;
5613
5614     if ($fopts->{'single-debian-patch'}) {
5615         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5616     } else {
5617         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5618     }
5619
5620     die 'bug' if $split_brain && !$need_split_build_invocation;
5621
5622     changedir $maindir;
5623     runcmd_ordryrun_local
5624         @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5625 }
5626
5627 sub unpack_playtree_mkwork ($) {
5628     my ($headref) = @_;
5629
5630     mkdir "work" or die $!;
5631     changedir "work";
5632     mktree_in_ud_here();
5633     runcmd @git, qw(reset -q --hard), $headref;
5634 }
5635
5636 sub unpack_playtree_linkorigs ($$) {
5637     my ($upstreamversion, $fn) = @_;
5638     # calls $fn->($leafname);
5639
5640     my $bpd_abs = bpd_abs();
5641     opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5642     while ($!=0, defined(my $b = readdir QFD)) {
5643         my $f = bpd_abs()."/".$b;
5644         {
5645             local ($debuglevel) = $debuglevel-1;
5646             printdebug "QF linkorigs $b, $f ?\n";
5647         }
5648         next unless is_orig_file_of_vsn $b, $upstreamversion;
5649         printdebug "QF linkorigs $b, $f Y\n";
5650         link_ltarget $f, $b or die "$b $!";
5651         $fn->($b);
5652     }
5653     die "$buildproductsdir: $!" if $!;
5654     closedir QFD;
5655 }
5656
5657 sub quilt_fixup_delete_pc () {
5658     runcmd @git, qw(rm -rqf .pc);
5659     commit_admin <<END
5660 Commit removal of .pc (quilt series tracking data)
5661
5662 [dgit ($our_version) upgrade quilt-remove-pc]
5663 END
5664 }
5665
5666 sub quilt_fixup_singlepatch ($$$) {
5667     my ($clogp, $headref, $upstreamversion) = @_;
5668
5669     progress "starting quiltify (single-debian-patch)";
5670
5671     # dpkg-source --commit generates new patches even if
5672     # single-debian-patch is in debian/source/options.  In order to
5673     # get it to generate debian/patches/debian-changes, it is
5674     # necessary to build the source package.
5675
5676     unpack_playtree_linkorigs($upstreamversion, sub { });
5677     unpack_playtree_mkwork($headref);
5678
5679     rmtree("debian/patches");
5680
5681     runcmd @dpkgsource, qw(-b .);
5682     changedir "..";
5683     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5684     rename srcfn("$upstreamversion", "/debian/patches"),
5685            "work/debian/patches";
5686
5687     changedir "work";
5688     commit_quilty_patch();
5689 }
5690
5691 sub quilt_make_fake_dsc ($) {
5692     my ($upstreamversion) = @_;
5693
5694     my $fakeversion="$upstreamversion-~~DGITFAKE";
5695
5696     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5697     print $fakedsc <<END or die $!;
5698 Format: 3.0 (quilt)
5699 Source: $package
5700 Version: $fakeversion
5701 Files:
5702 END
5703
5704     my $dscaddfile=sub {
5705         my ($b) = @_;
5706
5707         my $md = new Digest::MD5;
5708
5709         my $fh = new IO::File $b, '<' or die "$b $!";
5710         stat $fh or die $!;
5711         my $size = -s _;
5712
5713         $md->addfile($fh);
5714         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5715     };
5716
5717     unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5718
5719     my @files=qw(debian/source/format debian/rules
5720                  debian/control debian/changelog);
5721     foreach my $maybe (qw(debian/patches debian/source/options
5722                           debian/tests/control)) {
5723         next unless stat_exists "$maindir/$maybe";
5724         push @files, $maybe;
5725     }
5726
5727     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5728     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5729
5730     $dscaddfile->($debtar);
5731     close $fakedsc or die $!;
5732 }
5733
5734 sub quilt_check_splitbrain_cache ($$) {
5735     my ($headref, $upstreamversion) = @_;
5736     # Called only if we are in (potentially) split brain mode.
5737     # Called in playground.
5738     # Computes the cache key and looks in the cache.
5739     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5740
5741     my $splitbrain_cachekey;
5742
5743     progress
5744  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5745     # we look in the reflog of dgit-intern/quilt-cache
5746     # we look for an entry whose message is the key for the cache lookup
5747     my @cachekey = (qw(dgit), $our_version);
5748     push @cachekey, $upstreamversion;
5749     push @cachekey, $quilt_mode;
5750     push @cachekey, $headref;
5751
5752     push @cachekey, hashfile('fake.dsc');
5753
5754     my $srcshash = Digest::SHA->new(256);
5755     my %sfs = ( %INC, '$0(dgit)' => $0 );
5756     foreach my $sfk (sort keys %sfs) {
5757         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5758         $srcshash->add($sfk,"  ");
5759         $srcshash->add(hashfile($sfs{$sfk}));
5760         $srcshash->add("\n");
5761     }
5762     push @cachekey, $srcshash->hexdigest();
5763     $splitbrain_cachekey = "@cachekey";
5764
5765     my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5766                $splitbraincache);
5767     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5768     debugcmd "|(probably)",@cmd;
5769     my $child = open GC, "-|";  defined $child or die $!;
5770     if (!$child) {
5771         chdir $maindir or die $!;
5772         if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
5773             $! == ENOENT or die $!;
5774             printdebug ">(no reflog)\n";
5775             finish 0;
5776         }
5777         exec @cmd; die $!;
5778     }
5779     while (<GC>) {
5780         chomp;
5781         printdebug ">| ", $_, "\n" if $debuglevel > 1;
5782         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5783
5784         my $cachehit = $1;
5785         unpack_playtree_mkwork($headref);
5786         my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5787         if ($cachehit ne $headref) {
5788             progress "dgit view: found cached ($saved)";
5789             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5790             $split_brain = 1;
5791             return ($cachehit, $splitbrain_cachekey);
5792         }
5793         progress "dgit view: found cached, no changes required";
5794         return ($headref, $splitbrain_cachekey);
5795     }
5796     die $! if GC->error;
5797     failedcmd unless close GC;
5798
5799     printdebug "splitbrain cache miss\n";
5800     return (undef, $splitbrain_cachekey);
5801 }
5802
5803 sub quilt_fixup_multipatch ($$$) {
5804     my ($clogp, $headref, $upstreamversion) = @_;
5805
5806     progress "examining quilt state (multiple patches, $quilt_mode mode)";
5807
5808     # Our objective is:
5809     #  - honour any existing .pc in case it has any strangeness
5810     #  - determine the git commit corresponding to the tip of
5811     #    the patch stack (if there is one)
5812     #  - if there is such a git commit, convert each subsequent
5813     #    git commit into a quilt patch with dpkg-source --commit
5814     #  - otherwise convert all the differences in the tree into
5815     #    a single git commit
5816     #
5817     # To do this we:
5818
5819     # Our git tree doesn't necessarily contain .pc.  (Some versions of
5820     # dgit would include the .pc in the git tree.)  If there isn't
5821     # one, we need to generate one by unpacking the patches that we
5822     # have.
5823     #
5824     # We first look for a .pc in the git tree.  If there is one, we
5825     # will use it.  (This is not the normal case.)
5826     #
5827     # Otherwise need to regenerate .pc so that dpkg-source --commit
5828     # can work.  We do this as follows:
5829     #     1. Collect all relevant .orig from parent directory
5830     #     2. Generate a debian.tar.gz out of
5831     #         debian/{patches,rules,source/format,source/options}
5832     #     3. Generate a fake .dsc containing just these fields:
5833     #          Format Source Version Files
5834     #     4. Extract the fake .dsc
5835     #        Now the fake .dsc has a .pc directory.
5836     # (In fact we do this in every case, because in future we will
5837     # want to search for a good base commit for generating patches.)
5838     #
5839     # Then we can actually do the dpkg-source --commit
5840     #     1. Make a new working tree with the same object
5841     #        store as our main tree and check out the main
5842     #        tree's HEAD.
5843     #     2. Copy .pc from the fake's extraction, if necessary
5844     #     3. Run dpkg-source --commit
5845     #     4. If the result has changes to debian/, then
5846     #          - git add them them
5847     #          - git add .pc if we had a .pc in-tree
5848     #          - git commit
5849     #     5. If we had a .pc in-tree, delete it, and git commit
5850     #     6. Back in the main tree, fast forward to the new HEAD
5851
5852     # Another situation we may have to cope with is gbp-style
5853     # patches-unapplied trees.
5854     #
5855     # We would want to detect these, so we know to escape into
5856     # quilt_fixup_gbp.  However, this is in general not possible.
5857     # Consider a package with a one patch which the dgit user reverts
5858     # (with git revert or the moral equivalent).
5859     #
5860     # That is indistinguishable in contents from a patches-unapplied
5861     # tree.  And looking at the history to distinguish them is not
5862     # useful because the user might have made a confusing-looking git
5863     # history structure (which ought to produce an error if dgit can't
5864     # cope, not a silent reintroduction of an unwanted patch).
5865     #
5866     # So gbp users will have to pass an option.  But we can usually
5867     # detect their failure to do so: if the tree is not a clean
5868     # patches-applied tree, quilt linearisation fails, but the tree
5869     # _is_ a clean patches-unapplied tree, we can suggest that maybe
5870     # they want --quilt=unapplied.
5871     #
5872     # To help detect this, when we are extracting the fake dsc, we
5873     # first extract it with --skip-patches, and then apply the patches
5874     # afterwards with dpkg-source --before-build.  That lets us save a
5875     # tree object corresponding to .origs.
5876
5877     my $splitbrain_cachekey;
5878
5879     quilt_make_fake_dsc($upstreamversion);
5880
5881     if (quiltmode_splitbrain()) {
5882         my $cachehit;
5883         ($cachehit, $splitbrain_cachekey) =
5884             quilt_check_splitbrain_cache($headref, $upstreamversion);
5885         return if $cachehit;
5886     }
5887
5888     runcmd qw(sh -ec),
5889         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5890
5891     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5892     rename $fakexdir, "fake" or die "$fakexdir $!";
5893
5894     changedir 'fake';
5895
5896     remove_stray_gits("source package");
5897     mktree_in_ud_here();
5898
5899     rmtree '.pc';
5900
5901     rmtree 'debian'; # git checkout commitish paths does not delete!
5902     runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5903     my $unapplied=git_add_write_tree();
5904     printdebug "fake orig tree object $unapplied\n";
5905
5906     ensuredir '.pc';
5907
5908     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5909     $!=0; $?=-1;
5910     if (system @bbcmd) {
5911         failedcmd @bbcmd if $? < 0;
5912         fail <<END;
5913 failed to apply your git tree's patch stack (from debian/patches/) to
5914  the corresponding upstream tarball(s).  Your source tree and .orig
5915  are probably too inconsistent.  dgit can only fix up certain kinds of
5916  anomaly (depending on the quilt mode).  Please see --quilt= in dgit(1).
5917 END
5918     }
5919
5920     changedir '..';
5921
5922     unpack_playtree_mkwork($headref);
5923
5924     my $mustdeletepc=0;
5925     if (stat_exists ".pc") {
5926         -d _ or die;
5927         progress "Tree already contains .pc - will use it then delete it.";
5928         $mustdeletepc=1;
5929     } else {
5930         rename '../fake/.pc','.pc' or die $!;
5931     }
5932
5933     changedir '../fake';
5934     rmtree '.pc';
5935     my $oldtiptree=git_add_write_tree();
5936     printdebug "fake o+d/p tree object $unapplied\n";
5937     changedir '../work';
5938
5939
5940     # We calculate some guesswork now about what kind of tree this might
5941     # be.  This is mostly for error reporting.
5942
5943     my %editedignores;
5944     my @unrepres;
5945     my $diffbits = {
5946         # H = user's HEAD
5947         # O = orig, without patches applied
5948         # A = "applied", ie orig with H's debian/patches applied
5949         O2H => quiltify_trees_differ($unapplied,$headref,   1,
5950                                      \%editedignores, \@unrepres),
5951         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
5952         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5953     };
5954
5955     my @dl;
5956     foreach my $b (qw(01 02)) {
5957         foreach my $v (qw(O2H O2A H2A)) {
5958             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5959         }
5960     }
5961     printdebug "differences \@dl @dl.\n";
5962
5963     progress sprintf
5964 "$us: base trees orig=%.20s o+d/p=%.20s",
5965               $unapplied, $oldtiptree;
5966     progress sprintf
5967 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
5968 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
5969                              $dl[0], $dl[1],              $dl[3], $dl[4],
5970                                  $dl[2],                     $dl[5];
5971
5972     if (@unrepres) {
5973         print STDERR "dgit:  cannot represent change: $_->[1]: $_->[0]\n"
5974             foreach @unrepres;
5975         forceable_fail [qw(unrepresentable)], <<END;
5976 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5977 END
5978     }
5979
5980     my @failsuggestion;
5981     if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5982         push @failsuggestion, "This might be a patches-unapplied branch.";
5983     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5984         push @failsuggestion, "This might be a patches-applied branch.";
5985     }
5986     push @failsuggestion, "Maybe you need to specify one of".
5987         " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5988
5989     if (quiltmode_splitbrain()) {
5990         quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
5991                             $diffbits, \%editedignores,
5992                             $splitbrain_cachekey);
5993         return;
5994     }
5995
5996     progress "starting quiltify (multiple patches, $quilt_mode mode)";
5997     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5998
5999     if (!open P, '>>', ".pc/applied-patches") {
6000         $!==&ENOENT or die $!;
6001     } else {
6002         close P;
6003     }
6004
6005     commit_quilty_patch();
6006
6007     if ($mustdeletepc) {
6008         quilt_fixup_delete_pc();
6009     }
6010 }
6011
6012 sub quilt_fixup_editor () {
6013     my $descfn = $ENV{$fakeeditorenv};
6014     my $editing = $ARGV[$#ARGV];
6015     open I1, '<', $descfn or die "$descfn: $!";
6016     open I2, '<', $editing or die "$editing: $!";
6017     unlink $editing or die "$editing: $!";
6018     open O, '>', $editing or die "$editing: $!";
6019     while (<I1>) { print O or die $!; } I1->error and die $!;
6020     my $copying = 0;
6021     while (<I2>) {
6022         $copying ||= m/^\-\-\- /;
6023         next unless $copying;
6024         print O or die $!;
6025     }
6026     I2->error and die $!;
6027     close O or die $1;
6028     finish 0;
6029 }
6030
6031 sub maybe_apply_patches_dirtily () {
6032     return unless $quilt_mode =~ m/gbp|unapplied/;
6033     print STDERR <<END or die $!;
6034
6035 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6036 dgit: Have to apply the patches - making the tree dirty.
6037 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6038
6039 END
6040     $patches_applied_dirtily = 01;
6041     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6042     runcmd qw(dpkg-source --before-build .);
6043 }
6044
6045 sub maybe_unapply_patches_again () {
6046     progress "dgit: Unapplying patches again to tidy up the tree."
6047         if $patches_applied_dirtily;
6048     runcmd qw(dpkg-source --after-build .)
6049         if $patches_applied_dirtily & 01;
6050     rmtree '.pc'
6051         if $patches_applied_dirtily & 02;
6052     $patches_applied_dirtily = 0;
6053 }
6054
6055 #----- other building -----
6056
6057 our $clean_using_builder;
6058 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6059 #   clean the tree before building (perhaps invoked indirectly by
6060 #   whatever we are using to run the build), rather than separately
6061 #   and explicitly by us.
6062
6063 sub clean_tree () {
6064     return if $clean_using_builder;
6065     if ($cleanmode eq 'dpkg-source') {
6066         maybe_apply_patches_dirtily();
6067         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6068     } elsif ($cleanmode eq 'dpkg-source-d') {
6069         maybe_apply_patches_dirtily();
6070         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6071     } elsif ($cleanmode eq 'git') {
6072         runcmd_ordryrun_local @git, qw(clean -xdf);
6073     } elsif ($cleanmode eq 'git-ff') {
6074         runcmd_ordryrun_local @git, qw(clean -xdff);
6075     } elsif ($cleanmode eq 'check') {
6076         my $leftovers = cmdoutput @git, qw(clean -xdn);
6077         if (length $leftovers) {
6078             print STDERR $leftovers, "\n" or die $!;
6079             fail "tree contains uncommitted files and --clean=check specified";
6080         }
6081     } elsif ($cleanmode eq 'none') {
6082     } else {
6083         die "$cleanmode ?";
6084     }
6085 }
6086
6087 sub cmd_clean () {
6088     badusage "clean takes no additional arguments" if @ARGV;
6089     notpushing();
6090     clean_tree();
6091     maybe_unapply_patches_again();
6092 }
6093
6094 # return values from massage_dbp_args are one or both of these flags
6095 sub WANTSRC_SOURCE  () { 01; } # caller should build source (separately)
6096 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6097
6098 sub build_or_push_prep_early () {
6099     our $build_or_push_prep_early_done //= 0;
6100     return if $build_or_push_prep_early_done++;
6101     badusage "-p is not allowed with dgit $subcommand" if defined $package;
6102     my $clogp = parsechangelog();
6103     $isuite = getfield $clogp, 'Distribution';
6104     $package = getfield $clogp, 'Source';
6105     $version = getfield $clogp, 'Version';
6106 }
6107
6108 sub build_prep_early () {
6109     build_or_push_prep_early();
6110     notpushing();
6111     check_not_dirty();
6112 }
6113
6114 sub build_prep ($) {
6115     my ($wantsrc) = @_;
6116     build_prep_early();
6117     # clean the tree if we're trying to include dirty changes in the
6118     # source package, or we are running the builder in $maindir
6119     clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
6120     build_maybe_quilt_fixup();
6121     if ($rmchanges) {
6122         my $pat = changespat $version;
6123         foreach my $f (glob "$buildproductsdir/$pat") {
6124             if (act_local()) {
6125                 unlink $f or fail "remove old changes file $f: $!";
6126             } else {
6127                 progress "would remove $f";
6128             }
6129         }
6130     }
6131 }
6132
6133 sub changesopts_initial () {
6134     my @opts =@changesopts[1..$#changesopts];
6135 }
6136
6137 sub changesopts_version () {
6138     if (!defined $changes_since_version) {
6139         my @vsns;
6140         unless (eval {
6141             @vsns = archive_query('archive_query');
6142             my @quirk = access_quirk();
6143             if ($quirk[0] eq 'backports') {
6144                 local $isuite = $quirk[2];
6145                 local $csuite;
6146                 canonicalise_suite();
6147                 push @vsns, archive_query('archive_query');
6148             }
6149             1;
6150         }) {
6151             print STDERR $@;
6152             fail
6153  "archive query failed (queried because --since-version not specified)";
6154         }
6155         if (@vsns) {
6156             @vsns = map { $_->[0] } @vsns;
6157             @vsns = sort { -version_compare($a, $b) } @vsns;
6158             $changes_since_version = $vsns[0];
6159             progress "changelog will contain changes since $vsns[0]";
6160         } else {
6161             $changes_since_version = '_';
6162             progress "package seems new, not specifying -v<version>";
6163         }
6164     }
6165     if ($changes_since_version ne '_') {
6166         return ("-v$changes_since_version");
6167     } else {
6168         return ();
6169     }
6170 }
6171
6172 sub changesopts () {
6173     return (changesopts_initial(), changesopts_version());
6174 }
6175
6176 sub massage_dbp_args ($;$) {
6177     my ($cmd,$xargs) = @_;
6178     # We need to:
6179     #
6180     #  - if we're going to split the source build out so we can
6181     #    do strange things to it, massage the arguments to dpkg-buildpackage
6182     #    so that the main build doessn't build source (or add an argument
6183     #    to stop it building source by default).
6184     #
6185     #  - add -nc to stop dpkg-source cleaning the source tree,
6186     #    unless we're not doing a split build and want dpkg-source
6187     #    as cleanmode, in which case we can do nothing
6188     #
6189     debugcmd '#massaging#', @$cmd if $debuglevel>1;
6190 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
6191     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
6192         $clean_using_builder = 1;
6193         return WANTSRC_BUILDER;
6194     }
6195     # -nc has the side effect of specifying -b if nothing else specified
6196     # and some combinations of -S, -b, et al, are errors, rather than
6197     # later simply overriding earlie.  So we need to:
6198     #  - search the command line for these options
6199     #  - pick the last one
6200     #  - perhaps add our own as a default
6201     #  - perhaps adjust it to the corresponding non-source-building version
6202     my $dmode = '-F';
6203     foreach my $l ($cmd, $xargs) {
6204         next unless $l;
6205         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
6206     }
6207     push @$cmd, '-nc';
6208 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6209     my $r = WANTSRC_BUILDER;
6210     if ($need_split_build_invocation) {
6211         printdebug "massage split $dmode.\n";
6212         $r = $dmode =~ m/[S]/     ?  WANTSRC_SOURCE :
6213              $dmode =~ y/gGF/ABb/ ?  WANTSRC_SOURCE | WANTSRC_BUILDER :
6214              $dmode =~ m/[ABb]/   ?                   WANTSRC_BUILDER :
6215              die "$dmode ?";
6216     }
6217     printdebug "massage done $r $dmode.\n";
6218     push @$cmd, $dmode;
6219 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6220     return $r;
6221 }
6222
6223 sub in_bpd (&) {
6224     my ($fn) = @_;
6225     my $wasdir = must_getcwd();
6226     changedir $buildproductsdir;
6227     $fn->();
6228     changedir $wasdir;
6229 }
6230
6231 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6232 sub postbuild_mergechanges ($) {
6233     my ($msg_if_onlyone) = @_;
6234     # If there is only one .changes file, fail with $msg_if_onlyone,
6235     # or if that is undef, be a no-op.
6236     # Returns the changes file to report to the user.
6237     my $pat = changespat $version;
6238     my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6239     @changesfiles = sort {
6240         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6241             or $a cmp $b
6242     } @changesfiles;
6243     my $result;
6244     if (@changesfiles==1) {
6245         fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6246 only one changes file from build (@changesfiles)
6247 END
6248         $result = $changesfiles[0];
6249     } elsif (@changesfiles==2) {
6250         my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6251         foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6252             fail "$l found in binaries changes file $binchanges"
6253                 if $l =~ m/\.dsc$/;
6254         }
6255         runcmd_ordryrun_local @mergechanges, @changesfiles;
6256         my $multichanges = changespat $version,'multi';
6257         if (act_local()) {
6258             stat_exists $multichanges or fail "$multichanges: $!";
6259             foreach my $cf (glob $pat) {
6260                 next if $cf eq $multichanges;
6261                 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6262             }
6263         }
6264         $result = $multichanges;
6265     } else {
6266         fail "wrong number of different changes files (@changesfiles)";
6267     }
6268     printdone "build successful, results in $result\n" or die $!;
6269 }
6270
6271 sub midbuild_checkchanges () {
6272     my $pat = changespat $version;
6273     return if $rmchanges;
6274     my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6275     @unwanted = grep {
6276         $_ ne changespat $version,'source' and
6277         $_ ne changespat $version,'multi'
6278     } @unwanted;
6279     fail <<END
6280 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6281 Suggest you delete @unwanted.
6282 END
6283         if @unwanted;
6284 }
6285
6286 sub midbuild_checkchanges_vanilla ($) {
6287     my ($wantsrc) = @_;
6288     midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6289 }
6290
6291 sub postbuild_mergechanges_vanilla ($) {
6292     my ($wantsrc) = @_;
6293     if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6294         in_bpd {
6295             postbuild_mergechanges(undef);
6296         };
6297     } else {
6298         printdone "build successful\n";
6299     }
6300 }
6301
6302 sub cmd_build {
6303     build_prep_early();
6304     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6305     my $wantsrc = massage_dbp_args \@dbp;
6306     build_prep($wantsrc);
6307     if ($wantsrc & WANTSRC_SOURCE) {
6308         build_source();
6309         midbuild_checkchanges_vanilla $wantsrc;
6310     }
6311     if ($wantsrc & WANTSRC_BUILDER) {
6312         push @dbp, changesopts_version();
6313         maybe_apply_patches_dirtily();
6314         runcmd_ordryrun_local @dbp;
6315     }
6316     maybe_unapply_patches_again();
6317     postbuild_mergechanges_vanilla $wantsrc;
6318 }
6319
6320 sub pre_gbp_build {
6321     $quilt_mode //= 'gbp';
6322 }
6323
6324 sub cmd_gbp_build {
6325     build_prep_early();
6326
6327     # gbp can make .origs out of thin air.  In my tests it does this
6328     # even for a 1.0 format package, with no origs present.  So I
6329     # guess it keys off just the version number.  We don't know
6330     # exactly what .origs ought to exist, but let's assume that we
6331     # should run gbp if: the version has an upstream part and the main
6332     # orig is absent.
6333     my $upstreamversion = upstreamversion $version;
6334     my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6335     my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6336
6337     if ($gbp_make_orig) {
6338         clean_tree();
6339         $cleanmode = 'none'; # don't do it again
6340         $need_split_build_invocation = 1;
6341     }
6342
6343     my @dbp = @dpkgbuildpackage;
6344
6345     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6346
6347     if (!length $gbp_build[0]) {
6348         if (length executable_on_path('git-buildpackage')) {
6349             $gbp_build[0] = qw(git-buildpackage);
6350         } else {
6351             $gbp_build[0] = 'gbp buildpackage';
6352         }
6353     }
6354     my @cmd = opts_opt_multi_cmd @gbp_build;
6355
6356     push @cmd, (qw(-us -uc --git-no-sign-tags),
6357                 "--git-builder=".(shellquote @dbp));
6358
6359     if ($gbp_make_orig) {
6360         my $priv = dgit_privdir();
6361         my $ok = "$priv/origs-gen-ok";
6362         unlink $ok or $!==&ENOENT or die $!;
6363         my @origs_cmd = @cmd;
6364         push @origs_cmd, qw(--git-cleaner=true);
6365         push @origs_cmd, "--git-prebuild=".
6366             "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6367         push @origs_cmd, @ARGV;
6368         if (act_local()) {
6369             debugcmd @origs_cmd;
6370             system @origs_cmd;
6371             do { local $!; stat_exists $ok; }
6372                 or failedcmd @origs_cmd;
6373         } else {
6374             dryrun_report @origs_cmd;
6375         }
6376     }
6377
6378     build_prep($wantsrc);
6379     if ($wantsrc & WANTSRC_SOURCE) {
6380         build_source();
6381         midbuild_checkchanges_vanilla $wantsrc;
6382     } else {
6383         if (!$clean_using_builder) {
6384             push @cmd, '--git-cleaner=true';
6385         }
6386     }
6387     maybe_unapply_patches_again();
6388     if ($wantsrc & WANTSRC_BUILDER) {
6389         push @cmd, changesopts();
6390         runcmd_ordryrun_local @cmd, @ARGV;
6391     }
6392     postbuild_mergechanges_vanilla $wantsrc;
6393 }
6394 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6395
6396 sub building_source_in_playtree {
6397     # If $includedirty, we have to build the source package from the
6398     # working tree, not a playtree, so that uncommitted changes are
6399     # included (copying or hardlinking them into the playtree could
6400     # cause trouble).
6401     #
6402     # Note that if we are building a source package in split brain
6403     # mode we do not support including uncommitted changes, because
6404     # that makes quilt fixup too hard.  I.e. ($split_brain && (dgit is
6405     # building a source package)) => !$includedirty
6406     return !$includedirty;
6407 }
6408
6409 sub build_source {
6410     $sourcechanges = changespat $version,'source';
6411     if (act_local()) {
6412         unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6413             or fail "remove $sourcechanges: $!";
6414     }
6415     $dscfn = dscfn($version);
6416     my @cmd = (@dpkgsource, qw(-b --));
6417     my $leafdir;
6418     if (building_source_in_playtree()) {
6419         $leafdir = 'work';
6420         my $headref = git_rev_parse('HEAD');
6421         # If we are in split brain, there is already a playtree with
6422         # the thing we should package into a .dsc (thanks to quilt
6423         # fixup).  If not, make a playtree
6424         prep_ud() unless $split_brain;
6425         changedir $playground;
6426         unless ($split_brain) {
6427             my $upstreamversion = upstreamversion $version;
6428             unpack_playtree_linkorigs($upstreamversion, sub { });
6429             unpack_playtree_mkwork($headref);
6430             changedir '..';
6431         }
6432     } else {
6433         $leafdir = basename $maindir;
6434         changedir '..';
6435     }
6436     runcmd_ordryrun_local @cmd, $leafdir;
6437
6438     changedir $leafdir;
6439     runcmd_ordryrun_local qw(sh -ec),
6440       'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6441       @dpkggenchanges, qw(-S), changesopts();
6442     changedir '..';
6443
6444     printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6445     $dsc = parsecontrol($dscfn, "source package");
6446
6447     my $mv = sub {
6448         my ($why, $l) = @_;
6449         printdebug " renaming ($why) $l\n";
6450         rename "$l", bpd_abs()."/$l"
6451             or fail "put in place new built file ($l): $!";
6452     };
6453     foreach my $l (split /\n/, getfield $dsc, 'Files') {
6454         $l =~ m/\S+$/ or next;
6455         $mv->('Files', $&);
6456     }
6457     $mv->('dsc', $dscfn);
6458     $mv->('changes', $sourcechanges);
6459
6460     changedir $maindir;
6461 }
6462
6463 sub cmd_build_source {
6464     badusage "build-source takes no additional arguments" if @ARGV;
6465     build_prep(WANTSRC_SOURCE);
6466     build_source();
6467     maybe_unapply_patches_again();
6468     printdone "source built, results in $dscfn and $sourcechanges";
6469 }
6470
6471 sub cmd_push_source {
6472     prep_push();
6473     fail "dgit push-source: --include-dirty/--ignore-dirty does not make".
6474       "sense with push-source!" if $includedirty;
6475     build_maybe_quilt_fixup();
6476     if ($changesfile) {
6477         my $changes = parsecontrol("$buildproductsdir/$changesfile",
6478                                    "source changes file");
6479         unless (test_source_only_changes($changes)) {
6480             fail "user-specified changes file is not source-only";
6481         }
6482     } else {
6483         # Building a source package is very fast, so just do it
6484         build_source();
6485         die "er, patches are applied dirtily but shouldn't be.."
6486             if $patches_applied_dirtily;
6487         $changesfile = $sourcechanges;
6488     }
6489     dopush();
6490 }
6491
6492 sub cmd_sbuild {
6493     build_prep(WANTSRC_SOURCE); # not BUILDER because sbuild uses the .dsc
6494     build_source();
6495     midbuild_checkchanges();
6496     in_bpd {
6497         if (act_local()) {
6498             stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
6499             stat_exists $sourcechanges
6500                 or fail "$sourcechanges (in parent directory): $!";
6501         }
6502         runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
6503     };
6504     maybe_unapply_patches_again();
6505     in_bpd {
6506         postbuild_mergechanges(<<END);
6507 perhaps you need to pass -A ?  (sbuild's default is to build only
6508 arch-specific binaries; dgit 1.4 used to override that.)
6509 END
6510     };
6511 }
6512
6513 sub cmd_quilt_fixup {
6514     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6515     build_prep_early();
6516     clean_tree();
6517     build_maybe_quilt_fixup();
6518 }
6519
6520 sub import_dsc_result {
6521     my ($dstref, $newhash, $what_log, $what_msg) = @_;
6522     my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6523     runcmd @cmd;
6524     check_gitattrs($newhash, "source tree");
6525
6526     progress "dgit: import-dsc: $what_msg";
6527 }
6528
6529 sub cmd_import_dsc {
6530     my $needsig = 0;
6531
6532     while (@ARGV) {
6533         last unless $ARGV[0] =~ m/^-/;
6534         $_ = shift @ARGV;
6535         last if m/^--?$/;
6536         if (m/^--require-valid-signature$/) {
6537             $needsig = 1;
6538         } else {
6539             badusage "unknown dgit import-dsc sub-option \`$_'";
6540         }
6541     }
6542
6543     badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6544     my ($dscfn, $dstbranch) = @ARGV;
6545
6546     badusage "dry run makes no sense with import-dsc" unless act_local();
6547
6548     my $force = $dstbranch =~ s/^\+//   ? +1 :
6549                 $dstbranch =~ s/^\.\.// ? -1 :
6550                                            0;
6551     my $info = $force ? " $&" : '';
6552     $info = "$dscfn$info";
6553
6554     my $specbranch = $dstbranch;
6555     $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6556     $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6557
6558     my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6559     my $chead = cmdoutput_errok @symcmd;
6560     defined $chead or $?==256 or failedcmd @symcmd;
6561
6562     fail "$dstbranch is checked out - will not update it"
6563         if defined $chead and $chead eq $dstbranch;
6564
6565     my $oldhash = git_get_ref $dstbranch;
6566
6567     open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6568     $dscdata = do { local $/ = undef; <D>; };
6569     D->error and fail "read $dscfn: $!";
6570     close C;
6571
6572     # we don't normally need this so import it here
6573     use Dpkg::Source::Package;
6574     my $dp = new Dpkg::Source::Package filename => $dscfn,
6575         require_valid_signature => $needsig;
6576     {
6577         local $SIG{__WARN__} = sub {
6578             print STDERR $_[0];
6579             return unless $needsig;
6580             fail "import-dsc signature check failed";
6581         };
6582         if (!$dp->is_signed()) {
6583             warn "$us: warning: importing unsigned .dsc\n";
6584         } else {
6585             my $r = $dp->check_signature();
6586             die "->check_signature => $r" if $needsig && $r;
6587         }
6588     }
6589
6590     parse_dscdata();
6591
6592     $package = getfield $dsc, 'Source';
6593
6594     parse_dsc_field($dsc, "Dgit metadata in .dsc")
6595         unless forceing [qw(import-dsc-with-dgit-field)];
6596     parse_dsc_field_def_dsc_distro();
6597
6598     $isuite = 'DGIT-IMPORT-DSC';
6599     $idistro //= $dsc_distro;
6600
6601     notpushing();
6602
6603     if (defined $dsc_hash) {
6604         progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6605         resolve_dsc_field_commit undef, undef;
6606     }
6607     if (defined $dsc_hash) {
6608         my @cmd = (qw(sh -ec),
6609                    "echo $dsc_hash | git cat-file --batch-check");
6610         my $objgot = cmdoutput @cmd;
6611         if ($objgot =~ m#^\w+ missing\b#) {
6612             fail <<END
6613 .dsc contains Dgit field referring to object $dsc_hash
6614 Your git tree does not have that object.  Try `git fetch' from a
6615 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6616 END
6617         }
6618         if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6619             if ($force > 0) {
6620                 progress "Not fast forward, forced update.";
6621             } else {
6622                 fail "Not fast forward to $dsc_hash";
6623             }
6624         }
6625         import_dsc_result $dstbranch, $dsc_hash,
6626             "dgit import-dsc (Dgit): $info",
6627             "updated git ref $dstbranch";
6628         return 0;
6629     }
6630
6631     fail <<END
6632 Branch $dstbranch already exists
6633 Specify ..$specbranch for a pseudo-merge, binding in existing history
6634 Specify  +$specbranch to overwrite, discarding existing history
6635 END
6636         if $oldhash && !$force;
6637
6638     my @dfi = dsc_files_info();
6639     foreach my $fi (@dfi) {
6640         my $f = $fi->{Filename};
6641         my $here = "$buildproductsdir/$f";
6642         if (lstat $here) {
6643             next if stat $here;
6644             fail "lstat $here works but stat gives $! !";
6645         }
6646         fail "stat $here: $!" unless $! == ENOENT;
6647         my $there = $dscfn;
6648         if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6649             $there = $';
6650         } elsif ($dscfn =~ m#^/#) {
6651             $there = $dscfn;
6652         } else {
6653             fail "cannot import $dscfn which seems to be inside working tree!";
6654         }
6655         $there =~ s#/+[^/]+$## or
6656             fail "import $dscfn requires ../$f, but it does not exist";
6657         $there .= "/$f";
6658         my $test = $there =~ m{^/} ? $there : "../$there";
6659         stat $test or fail "import $dscfn requires $test, but: $!";
6660         symlink $there, $here or fail "symlink $there to $here: $!";
6661         progress "made symlink $here -> $there";
6662 #       print STDERR Dumper($fi);
6663     }
6664     my @mergeinputs = generate_commits_from_dsc();
6665     die unless @mergeinputs == 1;
6666
6667     my $newhash = $mergeinputs[0]{Commit};
6668
6669     if ($oldhash) {
6670         if ($force > 0) {
6671             progress "Import, forced update - synthetic orphan git history.";
6672         } elsif ($force < 0) {
6673             progress "Import, merging.";
6674             my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6675             my $version = getfield $dsc, 'Version';
6676             my $clogp = commit_getclogp $newhash;
6677             my $authline = clogp_authline $clogp;
6678             $newhash = make_commit_text <<END;
6679 tree $tree
6680 parent $newhash
6681 parent $oldhash
6682 author $authline
6683 committer $authline
6684
6685 Merge $package ($version) import into $dstbranch
6686 END
6687         } else {
6688             die; # caught earlier
6689         }
6690     }
6691
6692     import_dsc_result $dstbranch, $newhash,
6693         "dgit import-dsc: $info",
6694         "results are in in git ref $dstbranch";
6695 }
6696
6697 sub pre_archive_api_query () {
6698     not_necessarily_a_tree();
6699 }
6700 sub cmd_archive_api_query {
6701     badusage "need only 1 subpath argument" unless @ARGV==1;
6702     my ($subpath) = @ARGV;
6703     local $isuite = 'DGIT-API-QUERY-CMD';
6704     my @cmd = archive_api_query_cmd($subpath);
6705     push @cmd, qw(-f);
6706     debugcmd ">",@cmd;
6707     exec @cmd or fail "exec curl: $!\n";
6708 }
6709
6710 sub repos_server_url () {
6711     $package = '_dgit-repos-server';
6712     local $access_forpush = 1;
6713     local $isuite = 'DGIT-REPOS-SERVER';
6714     my $url = access_giturl();
6715 }
6716
6717 sub pre_clone_dgit_repos_server () {
6718     not_necessarily_a_tree();
6719 }
6720 sub cmd_clone_dgit_repos_server {
6721     badusage "need destination argument" unless @ARGV==1;
6722     my ($destdir) = @ARGV;
6723     my $url = repos_server_url();
6724     my @cmd = (@git, qw(clone), $url, $destdir);
6725     debugcmd ">",@cmd;
6726     exec @cmd or fail "exec git clone: $!\n";
6727 }
6728
6729 sub pre_print_dgit_repos_server_source_url () {
6730     not_necessarily_a_tree();
6731 }
6732 sub cmd_print_dgit_repos_server_source_url {
6733     badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6734         if @ARGV;
6735     my $url = repos_server_url();
6736     print $url, "\n" or die $!;
6737 }
6738
6739 sub pre_print_dpkg_source_ignores {
6740     not_necessarily_a_tree();
6741 }
6742 sub cmd_print_dpkg_source_ignores {
6743     badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6744         if @ARGV;
6745     print "@dpkg_source_ignores\n" or die $!;
6746 }
6747
6748 sub cmd_setup_mergechangelogs {
6749     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6750     local $isuite = 'DGIT-SETUP-TREE';
6751     setup_mergechangelogs(1);
6752 }
6753
6754 sub cmd_setup_useremail {
6755     badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6756     local $isuite = 'DGIT-SETUP-TREE';
6757     setup_useremail(1);
6758 }
6759
6760 sub cmd_setup_gitattributes {
6761     badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6762     local $isuite = 'DGIT-SETUP-TREE';
6763     setup_gitattrs(1);
6764 }
6765
6766 sub cmd_setup_new_tree {
6767     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6768     local $isuite = 'DGIT-SETUP-TREE';
6769     setup_new_tree();
6770 }
6771
6772 #---------- argument parsing and main program ----------
6773
6774 sub cmd_version {
6775     print "dgit version $our_version\n" or die $!;
6776     finish 0;
6777 }
6778
6779 our (%valopts_long, %valopts_short);
6780 our (%funcopts_long);
6781 our @rvalopts;
6782 our (@modeopt_cfgs);
6783
6784 sub defvalopt ($$$$) {
6785     my ($long,$short,$val_re,$how) = @_;
6786     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6787     $valopts_long{$long} = $oi;
6788     $valopts_short{$short} = $oi;
6789     # $how subref should:
6790     #   do whatever assignemnt or thing it likes with $_[0]
6791     #   if the option should not be passed on to remote, @rvalopts=()
6792     # or $how can be a scalar ref, meaning simply assign the value
6793 }
6794
6795 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6796 defvalopt '--distro',        '-d', '.+',      \$idistro;
6797 defvalopt '',                '-k', '.+',      \$keyid;
6798 defvalopt '--existing-package','', '.*',      \$existing_package;
6799 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
6800 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
6801 defvalopt '--package',   '-p',   $package_re, \$package;
6802 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
6803
6804 defvalopt '', '-C', '.+', sub {
6805     ($changesfile) = (@_);
6806     if ($changesfile =~ s#^(.*)/##) {
6807         $buildproductsdir = $1;
6808     }
6809 };
6810
6811 defvalopt '--initiator-tempdir','','.*', sub {
6812     ($initiator_tempdir) = (@_);
6813     $initiator_tempdir =~ m#^/# or
6814         badusage "--initiator-tempdir must be used specify an".
6815         " absolute, not relative, directory."
6816 };
6817
6818 sub defoptmodes ($@) {
6819     my ($varref, $cfgkey, $default, %optmap) = @_;
6820     my %permit;
6821     while (my ($opt,$val) = each %optmap) {
6822         $funcopts_long{$opt} = sub { $$varref = $val; };
6823         $permit{$val} = $val;
6824     }
6825     push @modeopt_cfgs, {
6826         Var => $varref,
6827         Key => $cfgkey,
6828         Default => $default,
6829         Vals => \%permit
6830     };
6831 }
6832
6833 defoptmodes \$dodep14tag, qw( dep14tag          want
6834                               --dep14tag        want
6835                               --no-dep14tag     no
6836                               --always-dep14tag always );
6837
6838 sub parseopts () {
6839     my $om;
6840
6841     if (defined $ENV{'DGIT_SSH'}) {
6842         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6843     } elsif (defined $ENV{'GIT_SSH'}) {
6844         @ssh = ($ENV{'GIT_SSH'});
6845     }
6846
6847     my $oi;
6848     my $val;
6849     my $valopt = sub {
6850         my ($what) = @_;
6851         @rvalopts = ($_);
6852         if (!defined $val) {
6853             badusage "$what needs a value" unless @ARGV;
6854             $val = shift @ARGV;
6855             push @rvalopts, $val;
6856         }
6857         badusage "bad value \`$val' for $what" unless
6858             $val =~ m/^$oi->{Re}$(?!\n)/s;
6859         my $how = $oi->{How};
6860         if (ref($how) eq 'SCALAR') {
6861             $$how = $val;
6862         } else {
6863             $how->($val);
6864         }
6865         push @ropts, @rvalopts;
6866     };
6867
6868     while (@ARGV) {
6869         last unless $ARGV[0] =~ m/^-/;
6870         $_ = shift @ARGV;
6871         last if m/^--?$/;
6872         if (m/^--/) {
6873             if (m/^--dry-run$/) {
6874                 push @ropts, $_;
6875                 $dryrun_level=2;
6876             } elsif (m/^--damp-run$/) {
6877                 push @ropts, $_;
6878                 $dryrun_level=1;
6879             } elsif (m/^--no-sign$/) {
6880                 push @ropts, $_;
6881                 $sign=0;
6882             } elsif (m/^--help$/) {
6883                 cmd_help();
6884             } elsif (m/^--version$/) {
6885                 cmd_version();
6886             } elsif (m/^--new$/) {
6887                 push @ropts, $_;
6888                 $new_package=1;
6889             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6890                      ($om = $opts_opt_map{$1}) &&
6891                      length $om->[0]) {
6892                 push @ropts, $_;
6893                 $om->[0] = $2;
6894             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6895                      !$opts_opt_cmdonly{$1} &&
6896                      ($om = $opts_opt_map{$1})) {
6897                 push @ropts, $_;
6898                 push @$om, $2;
6899             } elsif (m/^--(gbp|dpm)$/s) {
6900                 push @ropts, "--quilt=$1";
6901                 $quilt_mode = $1;
6902             } elsif (m/^--(?:ignore|include)-dirty$/s) {
6903                 push @ropts, $_;
6904                 $includedirty = 1;
6905             } elsif (m/^--no-quilt-fixup$/s) {
6906                 push @ropts, $_;
6907                 $quilt_mode = 'nocheck';
6908             } elsif (m/^--no-rm-on-error$/s) {
6909                 push @ropts, $_;
6910                 $rmonerror = 0;
6911             } elsif (m/^--no-chase-dsc-distro$/s) {
6912                 push @ropts, $_;
6913                 $chase_dsc_distro = 0;
6914             } elsif (m/^--overwrite$/s) {
6915                 push @ropts, $_;
6916                 $overwrite_version = '';
6917             } elsif (m/^--overwrite=(.+)$/s) {
6918                 push @ropts, $_;
6919                 $overwrite_version = $1;
6920             } elsif (m/^--delayed=(\d+)$/s) {
6921                 push @ropts, $_;
6922                 push @dput, $_;
6923             } elsif (m/^--dgit-view-save=(.+)$/s) {
6924                 push @ropts, $_;
6925                 $split_brain_save = $1;
6926                 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6927             } elsif (m/^--(no-)?rm-old-changes$/s) {
6928                 push @ropts, $_;
6929                 $rmchanges = !$1;
6930             } elsif (m/^--deliberately-($deliberately_re)$/s) {
6931                 push @ropts, $_;
6932                 push @deliberatelies, $&;
6933             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6934                 push @ropts, $&;
6935                 $forceopts{$1} = 1;
6936                 $_='';
6937             } elsif (m/^--force-/) {
6938                 print STDERR
6939                     "$us: warning: ignoring unknown force option $_\n";
6940                 $_='';
6941             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6942                 # undocumented, for testing
6943                 push @ropts, $_;
6944                 $tagformat_want = [ $1, 'command line', 1 ];
6945                 # 1 menas overrides distro configuration
6946             } elsif (m/^--always-split-source-build$/s) {
6947                 # undocumented, was once for testing, now a no-op
6948                 push @ropts, $_;
6949                 $need_split_build_invocation = 1;
6950             } elsif (m/^--config-lookup-explode=(.+)$/s) {
6951                 # undocumented, for testing
6952                 push @ropts, $_;
6953                 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6954                 # ^ it's supposed to be an array ref
6955             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6956                 $val = $2 ? $' : undef; #';
6957                 $valopt->($oi->{Long});
6958             } elsif ($funcopts_long{$_}) {
6959                 push @ropts, $_;
6960                 $funcopts_long{$_}();
6961             } else {
6962                 badusage "unknown long option \`$_'";
6963             }
6964         } else {
6965             while (m/^-./s) {
6966                 if (s/^-n/-/) {
6967                     push @ropts, $&;
6968                     $dryrun_level=2;
6969                 } elsif (s/^-L/-/) {
6970                     push @ropts, $&;
6971                     $dryrun_level=1;
6972                 } elsif (s/^-h/-/) {
6973                     cmd_help();
6974                 } elsif (s/^-D/-/) {
6975                     push @ropts, $&;
6976                     $debuglevel++;
6977                     enabledebug();
6978                 } elsif (s/^-N/-/) {
6979                     push @ropts, $&;
6980                     $new_package=1;
6981                 } elsif (m/^-m/) {
6982                     push @ropts, $&;
6983                     push @changesopts, $_;
6984                     $_ = '';
6985                 } elsif (s/^-wn$//s) {
6986                     push @ropts, $&;
6987                     $cleanmode = 'none';
6988                 } elsif (s/^-wg$//s) {
6989                     push @ropts, $&;
6990                     $cleanmode = 'git';
6991                 } elsif (s/^-wgf$//s) {
6992                     push @ropts, $&;
6993                     $cleanmode = 'git-ff';
6994                 } elsif (s/^-wd$//s) {
6995                     push @ropts, $&;
6996                     $cleanmode = 'dpkg-source';
6997                 } elsif (s/^-wdd$//s) {
6998                     push @ropts, $&;
6999                     $cleanmode = 'dpkg-source-d';
7000                 } elsif (s/^-wc$//s) {
7001                     push @ropts, $&;
7002                     $cleanmode = 'check';
7003                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7004                     push @git, '-c', $&;
7005                     $gitcfgs{cmdline}{$1} = [ $2 ];
7006                 } elsif (s/^-c([^=]+)$//s) {
7007                     push @git, '-c', $&;
7008                     $gitcfgs{cmdline}{$1} = [ 'true' ];
7009                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7010                     $val = $'; #';
7011                     $val = undef unless length $val;
7012                     $valopt->($oi->{Short});
7013                     $_ = '';
7014                 } else {
7015                     badusage "unknown short option \`$_'";
7016                 }
7017             }
7018         }
7019     }
7020 }
7021
7022 sub check_env_sanity () {
7023     my $blocked = new POSIX::SigSet;
7024     sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
7025
7026     eval {
7027         foreach my $name (qw(PIPE CHLD)) {
7028             my $signame = "SIG$name";
7029             my $signum = eval "POSIX::$signame" // die;
7030             ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
7031                 die "$signame is set to something other than SIG_DFL\n";
7032             $blocked->ismember($signum) and
7033                 die "$signame is blocked\n";
7034         }
7035     };
7036     return unless $@;
7037     chomp $@;
7038     fail <<END;
7039 On entry to dgit, $@
7040 This is a bug produced by something in in your execution environment.
7041 Giving up.
7042 END
7043 }
7044
7045
7046 sub parseopts_late_defaults () {
7047     $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7048         if defined $idistro;
7049     $isuite //= cfg('dgit.default.default-suite');
7050
7051     foreach my $k (keys %opts_opt_map) {
7052         my $om = $opts_opt_map{$k};
7053
7054         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7055         if (defined $v) {
7056             badcfg "cannot set command for $k"
7057                 unless length $om->[0];
7058             $om->[0] = $v;
7059         }
7060
7061         foreach my $c (access_cfg_cfgs("opts-$k")) {
7062             my @vl =
7063                 map { $_ ? @$_ : () }
7064                 map { $gitcfgs{$_}{$c} }
7065                 reverse @gitcfgsources;
7066             printdebug "CL $c ", (join " ", map { shellquote } @vl),
7067                 "\n" if $debuglevel >= 4;
7068             next unless @vl;
7069             badcfg "cannot configure options for $k"
7070                 if $opts_opt_cmdonly{$k};
7071             my $insertpos = $opts_cfg_insertpos{$k};
7072             @$om = ( @$om[0..$insertpos-1],
7073                      @vl,
7074                      @$om[$insertpos..$#$om] );
7075         }
7076     }
7077
7078     if (!defined $rmchanges) {
7079         local $access_forpush;
7080         $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7081     }
7082
7083     if (!defined $quilt_mode) {
7084         local $access_forpush;
7085         $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7086             // access_cfg('quilt-mode', 'RETURN-UNDEF')
7087             // 'linear';
7088         $quilt_mode =~ m/^($quilt_modes_re)$/
7089             or badcfg "unknown quilt-mode \`$quilt_mode'";
7090         $quilt_mode = $1;
7091     }
7092
7093     foreach my $moc (@modeopt_cfgs) {
7094         local $access_forpush;
7095         my $vr = $moc->{Var};
7096         next if defined $$vr;
7097         $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7098         my $v = $moc->{Vals}{$$vr};
7099         badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
7100         $$vr = $v;
7101     }
7102
7103     $need_split_build_invocation ||= quiltmode_splitbrain();
7104
7105     fail "dgit: --include-dirty is not supported in split view quilt mode"
7106         if $split_brain && $includedirty;
7107
7108     if (!defined $cleanmode) {
7109         local $access_forpush;
7110         $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7111         $cleanmode //= 'dpkg-source';
7112
7113         badcfg "unknown clean-mode \`$cleanmode'" unless
7114             $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7115     }
7116
7117     $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7118     $buildproductsdir //= '..';
7119     $bpd_glob = $buildproductsdir;
7120     $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7121 }
7122
7123 if ($ENV{$fakeeditorenv}) {
7124     git_slurp_config();
7125     quilt_fixup_editor();
7126 }
7127
7128 parseopts();
7129 check_env_sanity();
7130
7131 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
7132 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7133     if $dryrun_level == 1;
7134 if (!@ARGV) {
7135     print STDERR $helpmsg or die $!;
7136     finish 8;
7137 }
7138 $cmd = $subcommand = shift @ARGV;
7139 $cmd =~ y/-/_/;
7140
7141 my $pre_fn = ${*::}{"pre_$cmd"};
7142 $pre_fn->() if $pre_fn;
7143
7144 record_maindir if $invoked_in_git_tree;
7145 git_slurp_config();
7146
7147 my $fn = ${*::}{"cmd_$cmd"};
7148 $fn or badusage "unknown operation $cmd";
7149 $fn->();
7150
7151 finish 0;