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