dgit

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