dgit

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