dgit

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