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