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