dgit

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