dgit

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