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