dgit

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