dgit

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