dgit

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