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