dgit

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