dgit

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