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