dgit

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