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