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::Util qw(any);
  38 use List::MoreUtils qw(pairwise);
  39 use Carp;
  40
  41 use Debian::Dgit;
  42
  43 our $our_version = 'UNRELEASED'; ###substituted###
  44
  45 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
  46 our $protovsn;
  47
  48 our $isuite = 'unstable';
  49 our $idistro;
  50 our $package;
  51 our @ropts;
  52
  53 our $sign = 1;
  54 our $dryrun_level = 0;
  55 our $changesfile;
  56 our $buildproductsdir = '..';
  57 our $new_package = 0;
  58 our $ignoredirty = 0;
  59 our $rmonerror = 1;
  60 our @deliberatelies;
  61 our %previously;
  62 our $existing_package = 'dpkg';
  63 our $cleanmode;
  64 our $changes_since_version;
  65 our $rmchanges;
  66 our $overwrite_version; # undef: not specified; '': check changelog
  67 our $quilt_mode;
  68 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
  69 our $we_are_responder;
  70 our $initiator_tempdir;
  71 our $patches_applied_dirtily = 00;
  72 our $tagformat_want;
  73 our $tagformat;
  74 our $tagformatfn;
  75
  76 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
  77
  78 our $suite_re = '[-+.0-9a-z]+';
  79 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
  80 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
  81 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
  82 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
  83
  84 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
  85 our $splitbraincache = 'dgit-intern/quilt-cache';
  86
  87 our (@git) = qw(git);
  88 our (@dget) = qw(dget);
  89 our (@curl) = qw(curl -f);
  90 our (@dput) = qw(dput);
  91 our (@debsign) = qw(debsign);
  92 our (@gpg) = qw(gpg);
  93 our (@sbuild) = qw(sbuild);
  94 our (@ssh) = 'ssh';
  95 our (@dgit) = qw(dgit);
  96 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
  97 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
  98 our (@dpkggenchanges) = qw(dpkg-genchanges);
  99 our (@mergechanges) = qw(mergechanges -f);
 100 our (@gbp_build) = ('');
 101 our (@gbp_pq) = ('gbp pq');
 102 our (@changesopts) = ('');
 103
 104 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
 105                      'curl' => \@curl,
 106                      'dput' => \@dput,
 107                      'debsign' => \@debsign,
 108                      'gpg' => \@gpg,
 109                      'sbuild' => \@sbuild,
 110                      'ssh' => \@ssh,
 111                      'dgit' => \@dgit,
 112                      'git' => \@git,
 113                      'dpkg-source' => \@dpkgsource,
 114                      'dpkg-buildpackage' => \@dpkgbuildpackage,
 115                      'dpkg-genchanges' => \@dpkggenchanges,
 116                      'gbp-build' => \@gbp_build,
 117                      'gbp-pq' => \@gbp_pq,
 118                      'ch' => \@changesopts,
 119                      'mergechanges' => \@mergechanges);
 120
 121 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
 122 our %opts_cfg_insertpos = map {
 123     $_,
 124     scalar @{ $opts_opt_map{$_} }
 125 } keys %opts_opt_map;
 126
 127 sub finalise_opts_opts();
 128
 129 our $keyid;
 130
 131 autoflush STDOUT 1;
 132
 133 our $supplementary_message = '';
 134 our $need_split_build_invocation = 0;
 135 our $split_brain = 0;
 136
 137 END {
 138     local ($@, $?);
 139     print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
 140 }
 141
 142 our $remotename = 'dgit';
 143 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
 144 our $csuite;
 145 our $instead_distro;
 146
 147 sub debiantag ($$) {
 148     my ($v,$distro) = @_;
 149     return $tagformatfn->($v, $distro);
 150 }
 151
 152 sub debiantag_maintview ($$) {
 153     my ($v,$distro) = @_;
 154     $v =~ y/~:/_%/;
 155     return "$distro/$v";
 156 }
 157
 158 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
 159
 160 sub lbranch () { return "$branchprefix/$csuite"; }
 161 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
 162 sub lref () { return "refs/heads/".lbranch(); }
 163 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
 164 sub rrref () { return server_ref($csuite); }
 165
 166 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
 167 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
 168
 169 # We fetch some parts of lrfetchrefs/*.  Ideally we delete these
 170 # locally fetched refs because they have unhelpful names and clutter
 171 # up gitk etc.  So we track whether we have "used up" head ref (ie,
 172 # whether we have made another local ref which refers to this object).
 173 #
 174 # (If we deleted them unconditionally, then we might end up
 175 # re-fetching the same git objects each time dgit fetch was run.)
 176 #
 177 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
 178 # in git_fetch_us to fetch the refs in question, and possibly a call
 179 # to lrfetchref_used.
 180
 181 our (%lrfetchrefs_f, %lrfetchrefs_d);
 182 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
 183
 184 sub lrfetchref_used ($) {
 185     my ($fullrefname) = @_;
 186     my $objid = $lrfetchrefs_f{$fullrefname};
 187     $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
 188 }
 189
 190 sub stripepoch ($) {
 191     my ($vsn) = @_;
 192     $vsn =~ s/^\d+\://;
 193     return $vsn;
 194 }
 195
 196 sub srcfn ($$) {
 197     my ($vsn,$sfx) = @_;
 198     return "${package}_".(stripepoch $vsn).$sfx
 199 }
 200
 201 sub dscfn ($) {
 202     my ($vsn) = @_;
 203     return srcfn($vsn,".dsc");
 204 }
 205
 206 sub changespat ($;$) {
 207     my ($vsn, $arch) = @_;
 208     return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
 209 }
 210
 211 our $us = 'dgit';
 212 initdebug('');
 213
 214 our @end;
 215 END {
 216     local ($?);
 217     foreach my $f (@end) {
 218         eval { $f->(); };
 219         print STDERR "$us: cleanup: $@" if length $@;
 220     }
 221 };
 222
 223 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
 224
 225 sub no_such_package () {
 226     print STDERR "$us: package $package does not exist in suite $isuite\n";
 227     exit 4;
 228 }
 229
 230 sub changedir ($) {
 231     my ($newdir) = @_;
 232     printdebug "CD $newdir\n";
 233     chdir $newdir or confess "chdir: $newdir: $!";
 234 }
 235
 236 sub deliberately ($) {
 237     my ($enquiry) = @_;
 238     return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
 239 }
 240
 241 sub deliberately_not_fast_forward () {
 242     foreach (qw(not-fast-forward fresh-repo)) {
 243         return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
 244     }
 245 }
 246
 247 sub quiltmode_splitbrain () {
 248     $quilt_mode =~ m/gbp|dpm|unapplied/;
 249 }
 250
 251 sub opts_opt_multi_cmd {
 252     my @cmd;
 253     push @cmd, split /\s+/, shift @_;
 254     push @cmd, @_;
 255     @cmd;
 256 }
 257
 258 sub gbp_pq {
 259     return opts_opt_multi_cmd @gbp_pq;
 260 }
 261
 262 #---------- remote protocol support, common ----------
 263
 264 # remote push initiator/responder protocol:
 265 #  $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
 266 #  where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
 267 #  < dgit-remote-push-ready <actual-proto-vsn>
 268 #
 269 # occasionally:
 270 #
 271 #  > progress NBYTES
 272 #  [NBYTES message]
 273 #
 274 #  > supplementary-message NBYTES          # $protovsn >= 3
 275 #  [NBYTES message]
 276 #
 277 # main sequence:
 278 #
 279 #  > file parsed-changelog
 280 #  [indicates that output of dpkg-parsechangelog follows]
 281 #  > data-block NBYTES
 282 #  > [NBYTES bytes of data (no newline)]
 283 #  [maybe some more blocks]
 284 #  > data-end
 285 #
 286 #  > file dsc
 287 #  [etc]
 288 #
 289 #  > file changes
 290 #  [etc]
 291 #
 292 #  > param head DGIT-VIEW-HEAD
 293 #  > param csuite SUITE
 294 #  > param tagformat old|new
 295 #  > param maint-view MAINT-VIEW-HEAD
 296 #
 297 #  > previously REFNAME=OBJNAME       # if --deliberately-not-fast-forward
 298 #                                     # goes into tag, for replay prevention
 299 #
 300 #  > want signed-tag
 301 #  [indicates that signed tag is wanted]
 302 #  < data-block NBYTES
 303 #  < [NBYTES bytes of data (no newline)]
 304 #  [maybe some more blocks]
 305 #  < data-end
 306 #  < files-end
 307 #
 308 #  > want signed-dsc-changes
 309 #  < data-block NBYTES    [transfer of signed dsc]
 310 #  [etc]
 311 #  < data-block NBYTES    [transfer of signed changes]
 312 #  [etc]
 313 #  < files-end
 314 #
 315 #  > complete
 316
 317 our $i_child_pid;
 318
 319 sub i_child_report () {
 320     # Sees if our child has died, and reap it if so.  Returns a string
 321     # describing how it died if it failed, or undef otherwise.
 322     return undef unless $i_child_pid;
 323     my $got = waitpid $i_child_pid, WNOHANG;
 324     return undef if $got <= 0;
 325     die unless $got == $i_child_pid;
 326     $i_child_pid = undef;
 327     return undef unless $?;
 328     return "build host child ".waitstatusmsg();
 329 }
 330
 331 sub badproto ($$) {
 332     my ($fh, $m) = @_;
 333     fail "connection lost: $!" if $fh->error;
 334     fail "protocol violation; $m not expected";
 335 }
 336
 337 sub badproto_badread ($$) {
 338     my ($fh, $wh) = @_;
 339     fail "connection lost: $!" if $!;
 340     my $report = i_child_report();
 341     fail $report if defined $report;
 342     badproto $fh, "eof (reading $wh)";
 343 }
 344
 345 sub protocol_expect (&$) {
 346     my ($match, $fh) = @_;
 347     local $_;
 348     $_ = <$fh>;
 349     defined && chomp or badproto_badread $fh, "protocol message";
 350     if (wantarray) {
 351         my @r = &$match;
 352         return @r if @r;
 353     } else {
 354         my $r = &$match;
 355         return $r if $r;
 356     }
 357     badproto $fh, "\`$_'";
 358 }
 359
 360 sub protocol_send_file ($$) {
 361     my ($fh, $ourfn) = @_;
 362     open PF, "<", $ourfn or die "$ourfn: $!";
 363     for (;;) {
 364         my $d;
 365         my $got = read PF, $d, 65536;
 366         die "$ourfn: $!" unless defined $got;
 367         last if !$got;
 368         print $fh "data-block ".length($d)."\n" or die $!;
 369         print $fh $d or die $!;
 370     }
 371     PF->error and die "$ourfn $!";
 372     print $fh "data-end\n" or die $!;
 373     close PF;
 374 }
 375
 376 sub protocol_read_bytes ($$) {
 377     my ($fh, $nbytes) = @_;
 378     $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
 379     my $d;
 380     my $got = read $fh, $d, $nbytes;
 381     $got==$nbytes or badproto_badread $fh, "data block";
 382     return $d;
 383 }
 384
 385 sub protocol_receive_file ($$) {
 386     my ($fh, $ourfn) = @_;
 387     printdebug "() $ourfn\n";
 388     open PF, ">", $ourfn or die "$ourfn: $!";
 389     for (;;) {
 390         my ($y,$l) = protocol_expect {
 391             m/^data-block (.*)$/ ? (1,$1) :
 392             m/^data-end$/ ? (0,) :
 393             ();
 394         } $fh;
 395         last unless $y;
 396         my $d = protocol_read_bytes $fh, $l;
 397         print PF $d or die $!;
 398     }
 399     close PF or die $!;
 400 }
 401
 402 #---------- remote protocol support, responder ----------
 403
 404 sub responder_send_command ($) {
 405     my ($command) = @_;
 406     return unless $we_are_responder;
 407     # called even without $we_are_responder
 408     printdebug ">> $command\n";
 409     print PO $command, "\n" or die $!;
 410 }
 411
 412 sub responder_send_file ($$) {
 413     my ($keyword, $ourfn) = @_;
 414     return unless $we_are_responder;
 415     printdebug "]] $keyword $ourfn\n";
 416     responder_send_command "file $keyword";
 417     protocol_send_file \*PO, $ourfn;
 418 }
 419
 420 sub responder_receive_files ($@) {
 421     my ($keyword, @ourfns) = @_;
 422     die unless $we_are_responder;
 423     printdebug "[[ $keyword @ourfns\n";
 424     responder_send_command "want $keyword";
 425     foreach my $fn (@ourfns) {
 426         protocol_receive_file \*PI, $fn;
 427     }
 428     printdebug "[[\$\n";
 429     protocol_expect { m/^files-end$/ } \*PI;
 430 }
 431
 432 #---------- remote protocol support, initiator ----------
 433
 434 sub initiator_expect (&) {
 435     my ($match) = @_;
 436     protocol_expect { &$match } \*RO;
 437 }
 438
 439 #---------- end remote code ----------
 440
 441 sub progress {
 442     if ($we_are_responder) {
 443         my $m = join '', @_;
 444         responder_send_command "progress ".length($m) or die $!;
 445         print PO $m or die $!;
 446     } else {
 447         print @_, "\n";
 448     }
 449 }
 450
 451 our $ua;
 452
 453 sub url_get {
 454     if (!$ua) {
 455         $ua = LWP::UserAgent->new();
 456         $ua->env_proxy;
 457     }
 458     my $what = $_[$#_];
 459     progress "downloading $what...";
 460     my $r = $ua->get(@_) or die $!;
 461     return undef if $r->code == 404;
 462     $r->is_success or fail "failed to fetch $what: ".$r->status_line;
 463     return $r->decoded_content(charset => 'none');
 464 }
 465
 466 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
 467
 468 sub runcmd {
 469     debugcmd "+",@_;
 470     $!=0; $?=-1;
 471     failedcmd @_ if system @_;
 472 }
 473
 474 sub act_local () { return $dryrun_level <= 1; }
 475 sub act_scary () { return !$dryrun_level; }
 476
 477 sub printdone {
 478     if (!$dryrun_level) {
 479         progress "dgit ok: @_";
 480     } else {
 481         progress "would be ok: @_ (but dry run only)";
 482     }
 483 }
 484
 485 sub dryrun_report {
 486     printcmd(\*STDERR,$debugprefix."#",@_);
 487 }
 488
 489 sub runcmd_ordryrun {
 490     if (act_scary()) {
 491         runcmd @_;
 492     } else {
 493         dryrun_report @_;
 494     }
 495 }
 496
 497 sub runcmd_ordryrun_local {
 498     if (act_local()) {
 499         runcmd @_;
 500     } else {
 501         dryrun_report @_;
 502     }
 503 }
 504
 505 sub shell_cmd {
 506     my ($first_shell, @cmd) = @_;
 507     return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
 508 }
 509
 510 our $helpmsg = <<END;
 511 main usages:
 512   dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
 513   dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
 514   dgit [dgit-opts] build [dpkg-buildpackage-opts]
 515   dgit [dgit-opts] sbuild [sbuild-opts]
 516   dgit [dgit-opts] push [dgit-opts] [suite]
 517   dgit [dgit-opts] rpush build-host:build-dir ...
 518 important dgit options:
 519   -k<keyid>           sign tag and package with <keyid> instead of default
 520   --dry-run -n        do not change anything, but go through the motions
 521   --damp-run -L       like --dry-run but make local changes, without signing
 522   --new -N            allow introducing a new package
 523   --debug -D          increase debug level
 524   -c<name>=<value>    set git config option (used directly by dgit too)
 525 END
 526
 527 our $later_warning_msg = <<END;
 528 Perhaps the upload is stuck in incoming.  Using the version from git.
 529 END
 530
 531 sub badusage {
 532     print STDERR "$us: @_\n", $helpmsg or die $!;
 533     exit 8;
 534 }
 535
 536 sub nextarg {
 537     @ARGV or badusage "too few arguments";
 538     return scalar shift @ARGV;
 539 }
 540
 541 sub cmd_help () {
 542     print $helpmsg or die $!;
 543     exit 0;
 544 }
 545
 546 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
 547
 548 our %defcfg = ('dgit.default.distro' => 'debian',
 549                'dgit.default.username' => '',
 550                'dgit.default.archive-query-default-component' => 'main',
 551                'dgit.default.ssh' => 'ssh',
 552                'dgit.default.archive-query' => 'madison:',
 553                'dgit.default.sshpsql-dbname' => 'service=projectb',
 554                'dgit.default.dgit-tag-format' => 'new,old,maint',
 555                # old means "repo server accepts pushes with old dgit tags"
 556                # new means "repo server accepts pushes with new dgit tags"
 557                # maint means "repo server accepts split brain pushes"
 558                # hist means "repo server may have old pushes without new tag"
 559                #   ("hist" is implied by "old")
 560                'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
 561                'dgit-distro.debian.git-check' => 'url',
 562                'dgit-distro.debian.git-check-suffix' => '/info/refs',
 563                'dgit-distro.debian.new-private-pushers' => 't',
 564                'dgit-distro.debian/push.git-url' => '',
 565                'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
 566                'dgit-distro.debian/push.git-user-force' => 'dgit',
 567                'dgit-distro.debian/push.git-proto' => 'git+ssh://',
 568                'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
 569                'dgit-distro.debian/push.git-create' => 'true',
 570                'dgit-distro.debian/push.git-check' => 'ssh-cmd',
 571  'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
 572 # 'dgit-distro.debian.archive-query-tls-key',
 573 #    '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
 574 # ^ this does not work because curl is broken nowadays
 575 # Fixing #790093 properly will involve providing providing the key
 576 # in some pacagke and maybe updating these paths.
 577 #
 578 # 'dgit-distro.debian.archive-query-tls-curl-args',
 579 #   '--ca-path=/etc/ssl/ca-debian',
 580 # ^ this is a workaround but works (only) on DSA-administered machines
 581                'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
 582                'dgit-distro.debian.git-url-suffix' => '',
 583                'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
 584                'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
 585  'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
 586  'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
 587                'dgit-distro.ubuntu.git-check' => 'false',
 588  'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
 589                'dgit-distro.test-dummy.ssh' => "$td/ssh",
 590                'dgit-distro.test-dummy.username' => "alice",
 591                'dgit-distro.test-dummy.git-check' => "ssh-cmd",
 592                'dgit-distro.test-dummy.git-create' => "ssh-cmd",
 593                'dgit-distro.test-dummy.git-url' => "$td/git",
 594                'dgit-distro.test-dummy.git-host' => "git",
 595                'dgit-distro.test-dummy.git-path' => "$td/git",
 596                'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
 597                'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
 598                'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
 599                'dgit-distro.test-dummy.upload-host' => 'test-dummy',
 600                );
 601
 602 our %gitcfgs;
 603 our @gitcfgsources = qw(cmdline local global system);
 604
 605 sub git_slurp_config () {
 606     local ($debuglevel) = $debuglevel-2;
 607     local $/="\0";
 608
 609     # This algoritm is a bit subtle, but this is needed so that for
 610     # options which we want to be single-valued, we allow the
 611     # different config sources to override properly.  See #835858.
 612     foreach my $src (@gitcfgsources) {
 613         next if $src eq 'cmdline';
 614         # we do this ourselves since git doesn't handle it
 615
 616         my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
 617         debugcmd "|",@cmd;
 618
 619         open GITS, "-|", @cmd or die $!;
 620         while (<GITS>) {
 621             chomp or die;
 622             printdebug "=> ", (messagequote $_), "\n";
 623             m/\n/ or die "$_ ?";
 624             push @{ $gitcfgs{$src}{$`} }, $'; #';
 625         }
 626         $!=0; $?=0;
 627         close GITS
 628             or ($!==0 && $?==256)
 629             or failedcmd @cmd;
 630     }
 631 }
 632
 633 sub git_get_config ($) {
 634     my ($c) = @_;
 635     foreach my $src (@gitcfgsources) {
 636         my $l = $gitcfgs{$src}{$c};
 637         printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
 638             if $debuglevel >= 4;
 639         $l or next;
 640         @$l==1 or badcfg "multiple values for $c".
 641             " (in $src git config)" if @$l > 1;
 642         return $l->[0];
 643     }
 644     return undef;
 645 }
 646
 647 sub cfg {
 648     foreach my $c (@_) {
 649         return undef if $c =~ /RETURN-UNDEF/;
 650         my $v = git_get_config($c);
 651         return $v if defined $v;
 652         my $dv = $defcfg{$c};
 653         return $dv if defined $dv;
 654     }
 655     badcfg "need value for one of: @_\n".
 656         "$us: distro or suite appears not to be (properly) supported";
 657 }
 658
 659 sub access_basedistro () {
 660     if (defined $idistro) {
 661         return $idistro;
 662     } else {
 663         return cfg("dgit-suite.$isuite.distro",
 664                    "dgit.default.distro");
 665     }
 666 }
 667
 668 sub access_quirk () {
 669     # returns (quirk name, distro to use instead or undef, quirk-specific info)
 670     my $basedistro = access_basedistro();
 671     my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
 672                               'RETURN-UNDEF');
 673     if (defined $backports_quirk) {
 674         my $re = $backports_quirk;
 675         $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
 676         $re =~ s/\*/.*/g;
 677         $re =~ s/\%/([-0-9a-z_]+)/
 678             or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
 679         if ($isuite =~ m/^$re$/) {
 680             return ('backports',"$basedistro-backports",$1);
 681         }
 682     }
 683     return ('none',undef);
 684 }
 685
 686 our $access_forpush;
 687
 688 sub parse_cfg_bool ($$$) {
 689     my ($what,$def,$v) = @_;
 690     $v //= $def;
 691     return
 692         $v =~ m/^[ty1]/ ? 1 :
 693         $v =~ m/^[fn0]/ ? 0 :
 694         badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
 695 }
 696
 697 sub access_forpush_config () {
 698     my $d = access_basedistro();
 699
 700     return 1 if
 701         $new_package &&
 702         parse_cfg_bool('new-private-pushers', 0,
 703                        cfg("dgit-distro.$d.new-private-pushers",
 704                            'RETURN-UNDEF'));
 705
 706     my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
 707     $v //= 'a';
 708     return
 709         $v =~ m/^[ty1]/ ? 0 : # force readonly,    forpush = 0
 710         $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
 711         $v =~ m/^[a]/  ? '' : # auto,              forpush = ''
 712         badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
 713 }
 714
 715 sub access_forpush () {
 716     $access_forpush //= access_forpush_config();
 717     return $access_forpush;
 718 }
 719
 720 sub pushing () {
 721     die "$access_forpush ?" if ($access_forpush // 1) ne 1;
 722     badcfg "pushing but distro is configured readonly"
 723         if access_forpush_config() eq '0';
 724     $access_forpush = 1;
 725     $supplementary_message = <<'END' unless $we_are_responder;
 726 Push failed, before we got started.
 727 You can retry the push, after fixing the problem, if you like.
 728 END
 729     finalise_opts_opts();
 730 }
 731
 732 sub notpushing () {
 733     finalise_opts_opts();
 734 }
 735
 736 sub supplementary_message ($) {
 737     my ($msg) = @_;
 738     if (!$we_are_responder) {
 739         $supplementary_message = $msg;
 740         return;
 741     } elsif ($protovsn >= 3) {
 742         responder_send_command "supplementary-message ".length($msg)
 743             or die $!;
 744         print PO $msg or die $!;
 745     }
 746 }
 747
 748 sub access_distros () {
 749     # Returns list of distros to try, in order
 750     #
 751     # We want to try:
 752     #    0. `instead of' distro name(s) we have been pointed to
 753     #    1. the access_quirk distro, if any
 754     #    2a. the user's specified distro, or failing that  } basedistro
 755     #    2b. the distro calculated from the suite          }
 756     my @l = access_basedistro();
 757
 758     my (undef,$quirkdistro) = access_quirk();
 759     unshift @l, $quirkdistro;
 760     unshift @l, $instead_distro;
 761     @l = grep { defined } @l;
 762
 763     if (access_forpush()) {
 764         @l = map { ("$_/push", $_) } @l;
 765     }
 766     @l;
 767 }
 768
 769 sub access_cfg_cfgs (@) {
 770     my (@keys) = @_;
 771     my @cfgs;
 772     # The nesting of these loops determines the search order.  We put
 773     # the key loop on the outside so that we search all the distros
 774     # for each key, before going on to the next key.  That means that
 775     # if access_cfg is called with a more specific, and then a less
 776     # specific, key, an earlier distro can override the less specific
 777     # without necessarily overriding any more specific keys.  (If the
 778     # distro wants to override the more specific keys it can simply do
 779     # so; whereas if we did the loop the other way around, it would be
 780     # impossible to for an earlier distro to override a less specific
 781     # key but not the more specific ones without restating the unknown
 782     # values of the more specific keys.
 783     my @realkeys;
 784     my @rundef;
 785     # We have to deal with RETURN-UNDEF specially, so that we don't
 786     # terminate the search prematurely.
 787     foreach (@keys) {
 788         if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
 789         push @realkeys, $_
 790     }
 791     foreach my $d (access_distros()) {
 792         push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
 793     }
 794     push @cfgs, map { "dgit.default.$_" } @realkeys;
 795     push @cfgs, @rundef;
 796     return @cfgs;
 797 }
 798
 799 sub access_cfg (@) {
 800     my (@keys) = @_;
 801     my (@cfgs) = access_cfg_cfgs(@keys);
 802     my $value = cfg(@cfgs);
 803     return $value;
 804 }
 805
 806 sub access_cfg_bool ($$) {
 807     my ($def, @keys) = @_;
 808     parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
 809 }
 810
 811 sub string_to_ssh ($) {
 812     my ($spec) = @_;
 813     if ($spec =~ m/\s/) {
 814         return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
 815     } else {
 816         return ($spec);
 817     }
 818 }
 819
 820 sub access_cfg_ssh () {
 821     my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
 822     if (!defined $gitssh) {
 823         return @ssh;
 824     } else {
 825         return string_to_ssh $gitssh;
 826     }
 827 }
 828
 829 sub access_runeinfo ($) {
 830     my ($info) = @_;
 831     return ": dgit ".access_basedistro()." $info ;";
 832 }
 833
 834 sub access_someuserhost ($) {
 835     my ($some) = @_;
 836     my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
 837     defined($user) && length($user) or
 838         $user = access_cfg("$some-user",'username');
 839     my $host = access_cfg("$some-host");
 840     return length($user) ? "$user\@$host" : $host;
 841 }
 842
 843 sub access_gituserhost () {
 844     return access_someuserhost('git');
 845 }
 846
 847 sub access_giturl (;$) {
 848     my ($optional) = @_;
 849     my $url = access_cfg('git-url','RETURN-UNDEF');
 850     my $suffix;
 851     if (!length $url) {
 852         my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
 853         return undef unless defined $proto;
 854         $url =
 855             $proto.
 856             access_gituserhost().
 857             access_cfg('git-path');
 858     } else {
 859         $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
 860     }
 861     $suffix //= '.git';
 862     return "$url/$package$suffix";
 863 }
 864
 865 sub parsecontrolfh ($$;$) {
 866     my ($fh, $desc, $allowsigned) = @_;
 867     our $dpkgcontrolhash_noissigned;
 868     my $c;
 869     for (;;) {
 870         my %opts = ('name' => $desc);
 871         $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
 872         $c = Dpkg::Control::Hash->new(%opts);
 873         $c->parse($fh,$desc) or die "parsing of $desc failed";
 874         last if $allowsigned;
 875         last if $dpkgcontrolhash_noissigned;
 876         my $issigned= $c->get_option('is_pgp_signed');
 877         if (!defined $issigned) {
 878             $dpkgcontrolhash_noissigned= 1;
 879             seek $fh, 0,0 or die "seek $desc: $!";
 880         } elsif ($issigned) {
 881             fail "control file $desc is (already) PGP-signed. ".
 882                 " Note that dgit push needs to modify the .dsc and then".
 883                 " do the signature itself";
 884         } else {
 885             last;
 886         }
 887     }
 888     return $c;
 889 }
 890
 891 sub parsecontrol {
 892     my ($file, $desc) = @_;
 893     my $fh = new IO::Handle;
 894     open $fh, '<', $file or die "$file: $!";
 895     my $c = parsecontrolfh($fh,$desc);
 896     $fh->error and die $!;
 897     close $fh;
 898     return $c;
 899 }
 900
 901 sub getfield ($$) {
 902     my ($dctrl,$field) = @_;
 903     my $v = $dctrl->{$field};
 904     return $v if defined $v;
 905     fail "missing field $field in ".$dctrl->get_option('name');
 906 }
 907
 908 sub parsechangelog {
 909     my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
 910     my $p = new IO::Handle;
 911     my @cmd = (qw(dpkg-parsechangelog), @_);
 912     open $p, '-|', @cmd or die $!;
 913     $c->parse($p);
 914     $?=0; $!=0; close $p or failedcmd @cmd;
 915     return $c;
 916 }
 917
 918 sub commit_getclogp ($) {
 919     # Returns the parsed changelog hashref for a particular commit
 920     my ($objid) = @_;
 921     our %commit_getclogp_memo;
 922     my $memo = $commit_getclogp_memo{$objid};
 923     return $memo if $memo;
 924     mkpath '.git/dgit';
 925     my $mclog = ".git/dgit/clog-$objid";
 926     runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
 927         "$objid:debian/changelog";
 928     $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
 929 }
 930
 931 sub must_getcwd () {
 932     my $d = getcwd();
 933     defined $d or fail "getcwd failed: $!";
 934     return $d;
 935 }
 936
 937 our %rmad;
 938
 939 sub archive_query ($) {
 940     my ($method) = @_;
 941     my $query = access_cfg('archive-query','RETURN-UNDEF');
 942     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
 943     my $proto = $1;
 944     my $data = $'; #';
 945     { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
 946 }
 947
 948 sub pool_dsc_subpath ($$) {
 949     my ($vsn,$component) = @_; # $package is implict arg
 950     my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
 951     return "/pool/$component/$prefix/$package/".dscfn($vsn);
 952 }
 953
 954 #---------- `ftpmasterapi' archive query method (nascent) ----------
 955
 956 sub archive_api_query_cmd ($) {
 957     my ($subpath) = @_;
 958     my @cmd = qw(curl -sS);
 959     my $url = access_cfg('archive-query-url');
 960     if ($url =~ m#^https://([-.0-9a-z]+)/#) {
 961         my $host = $1;
 962         my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
 963         foreach my $key (split /\:/, $keys) {
 964             $key =~ s/\%HOST\%/$host/g;
 965             if (!stat $key) {
 966                 fail "for $url: stat $key: $!" unless $!==ENOENT;
 967                 next;
 968             }
 969             fail "config requested specific TLS key but do not know".
 970                 " how to get curl to use exactly that EE key ($key)";
 971 #           push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
 972 #           # Sadly the above line does not work because of changes
 973 #           # to gnutls.   The real fix for #790093 may involve
 974 #           # new curl options.
 975             last;
 976         }
 977         # Fixing #790093 properly will involve providing a value
 978         # for this on clients.
 979         my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
 980         push @cmd, split / /, $kargs if defined $kargs;
 981     }
 982     push @cmd, $url.$subpath;
 983     return @cmd;
 984 }
 985
 986 sub api_query ($$) {
 987     use JSON;
 988     my ($data, $subpath) = @_;
 989     badcfg "ftpmasterapi archive query method takes no data part"
 990         if length $data;
 991     my @cmd = archive_api_query_cmd($subpath);
 992     my $json = cmdoutput @cmd;
 993     return decode_json($json);
 994 }
 995
 996 sub canonicalise_suite_ftpmasterapi () {
 997     my ($proto,$data) = @_;
 998     my $suites = api_query($data, 'suites');
 999     my @matched;
1000     foreach my $entry (@$suites) {
1001         next unless grep {
1002             my $v = $entry->{$_};
1003             defined $v && $v eq $isuite;
1004         } qw(codename name);
1005         push @matched, $entry;
1006     }
1007     fail "unknown suite $isuite" unless @matched;
1008     my $cn;
1009     eval {
1010         @matched==1 or die "multiple matches for suite $isuite\n";
1011         $cn = "$matched[0]{codename}";
1012         defined $cn or die "suite $isuite info has no codename\n";
1013         $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1014     };
1015     die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1016         if length $@;
1017     return $cn;
1018 }
1019
1020 sub archive_query_ftpmasterapi () {
1021     my ($proto,$data) = @_;
1022     my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1023     my @rows;
1024     my $digester = Digest::SHA->new(256);
1025     foreach my $entry (@$info) {
1026         eval {
1027             my $vsn = "$entry->{version}";
1028             my ($ok,$msg) = version_check $vsn;
1029             die "bad version: $msg\n" unless $ok;
1030             my $component = "$entry->{component}";
1031             $component =~ m/^$component_re$/ or die "bad component";
1032             my $filename = "$entry->{filename}";
1033             $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1034                 or die "bad filename";
1035             my $sha256sum = "$entry->{sha256sum}";
1036             $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1037             push @rows, [ $vsn, "/pool/$component/$filename",
1038                           $digester, $sha256sum ];
1039         };
1040         die "bad ftpmaster api response: $@\n".Dumper($entry)
1041             if length $@;
1042     }
1043     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1044     return @rows;
1045 }
1046
1047 #---------- `madison' archive query method ----------
1048
1049 sub archive_query_madison {
1050     return map { [ @$_[0..1] ] } madison_get_parse(@_);
1051 }
1052
1053 sub madison_get_parse {
1054     my ($proto,$data) = @_;
1055     die unless $proto eq 'madison';
1056     if (!length $data) {
1057         $data= access_cfg('madison-distro','RETURN-UNDEF');
1058         $data //= access_basedistro();
1059     }
1060     $rmad{$proto,$data,$package} ||= cmdoutput
1061         qw(rmadison -asource),"-s$isuite","-u$data",$package;
1062     my $rmad = $rmad{$proto,$data,$package};
1063
1064     my @out;
1065     foreach my $l (split /\n/, $rmad) {
1066         $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1067                   \s*( [^ \t|]+ )\s* \|
1068                   \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1069                   \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1070         $1 eq $package or die "$rmad $package ?";
1071         my $vsn = $2;
1072         my $newsuite = $3;
1073         my $component;
1074         if (defined $4) {
1075             $component = $4;
1076         } else {
1077             $component = access_cfg('archive-query-default-component');
1078         }
1079         $5 eq 'source' or die "$rmad ?";
1080         push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1081     }
1082     return sort { -version_compare($a->[0],$b->[0]); } @out;
1083 }
1084
1085 sub canonicalise_suite_madison {
1086     # madison canonicalises for us
1087     my @r = madison_get_parse(@_);
1088     @r or fail
1089         "unable to canonicalise suite using package $package".
1090         " which does not appear to exist in suite $isuite;".
1091         " --existing-package may help";
1092     return $r[0][2];
1093 }
1094
1095 #---------- `sshpsql' archive query method ----------
1096
1097 sub sshpsql ($$$) {
1098     my ($data,$runeinfo,$sql) = @_;
1099     if (!length $data) {
1100         $data= access_someuserhost('sshpsql').':'.
1101             access_cfg('sshpsql-dbname');
1102     }
1103     $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1104     my ($userhost,$dbname) = ($`,$'); #';
1105     my @rows;
1106     my @cmd = (access_cfg_ssh, $userhost,
1107                access_runeinfo("ssh-psql $runeinfo").
1108                " export LC_MESSAGES=C; export LC_CTYPE=C;".
1109                " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1110     debugcmd "|",@cmd;
1111     open P, "-|", @cmd or die $!;
1112     while (<P>) {
1113         chomp or die;
1114         printdebug(">|$_|\n");
1115         push @rows, $_;
1116     }
1117     $!=0; $?=0; close P or failedcmd @cmd;
1118     @rows or die;
1119     my $nrows = pop @rows;
1120     $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1121     @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1122     @rows = map { [ split /\|/, $_ ] } @rows;
1123     my $ncols = scalar @{ shift @rows };
1124     die if grep { scalar @$_ != $ncols } @rows;
1125     return @rows;
1126 }
1127
1128 sub sql_injection_check {
1129     foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1130 }
1131
1132 sub archive_query_sshpsql ($$) {
1133     my ($proto,$data) = @_;
1134     sql_injection_check $isuite, $package;
1135     my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1136         SELECT source.version, component.name, files.filename, files.sha256sum
1137           FROM source
1138           JOIN src_associations ON source.id = src_associations.source
1139           JOIN suite ON suite.id = src_associations.suite
1140           JOIN dsc_files ON dsc_files.source = source.id
1141           JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1142           JOIN component ON component.id = files_archive_map.component_id
1143           JOIN files ON files.id = dsc_files.file
1144          WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1145            AND source.source='$package'
1146            AND files.filename LIKE '%.dsc';
1147 END
1148     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1149     my $digester = Digest::SHA->new(256);
1150     @rows = map {
1151         my ($vsn,$component,$filename,$sha256sum) = @$_;
1152         [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1153     } @rows;
1154     return @rows;
1155 }
1156
1157 sub canonicalise_suite_sshpsql ($$) {
1158     my ($proto,$data) = @_;
1159     sql_injection_check $isuite;
1160     my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1161         SELECT suite.codename
1162           FROM suite where suite_name='$isuite' or codename='$isuite';
1163 END
1164     @rows = map { $_->[0] } @rows;
1165     fail "unknown suite $isuite" unless @rows;
1166     die "ambiguous $isuite: @rows ?" if @rows>1;
1167     return $rows[0];
1168 }
1169
1170 #---------- `dummycat' archive query method ----------
1171
1172 sub canonicalise_suite_dummycat ($$) {
1173     my ($proto,$data) = @_;
1174     my $dpath = "$data/suite.$isuite";
1175     if (!open C, "<", $dpath) {
1176         $!==ENOENT or die "$dpath: $!";
1177         printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1178         return $isuite;
1179     }
1180     $!=0; $_ = <C>;
1181     chomp or die "$dpath: $!";
1182     close C;
1183     printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1184     return $_;
1185 }
1186
1187 sub archive_query_dummycat ($$) {
1188     my ($proto,$data) = @_;
1189     canonicalise_suite();
1190     my $dpath = "$data/package.$csuite.$package";
1191     if (!open C, "<", $dpath) {
1192         $!==ENOENT or die "$dpath: $!";
1193         printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1194         return ();
1195     }
1196     my @rows;
1197     while (<C>) {
1198         next if m/^\#/;
1199         next unless m/\S/;
1200         die unless chomp;
1201         printdebug "dummycat query $csuite $package $dpath | $_\n";
1202         my @row = split /\s+/, $_;
1203         @row==2 or die "$dpath: $_ ?";
1204         push @rows, \@row;
1205     }
1206     C->error and die "$dpath: $!";
1207     close C;
1208     return sort { -version_compare($a->[0],$b->[0]); } @rows;
1209 }
1210
1211 #---------- tag format handling ----------
1212
1213 sub access_cfg_tagformats () {
1214     split /\,/, access_cfg('dgit-tag-format');
1215 }
1216
1217 sub need_tagformat ($$) {
1218     my ($fmt, $why) = @_;
1219     fail "need to use tag format $fmt ($why) but also need".
1220         " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1221         " - no way to proceed"
1222         if $tagformat_want && $tagformat_want->[0] ne $fmt;
1223     $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1224 }
1225
1226 sub select_tagformat () {
1227     # sets $tagformatfn
1228     return if $tagformatfn && !$tagformat_want;
1229     die 'bug' if $tagformatfn && $tagformat_want;
1230     # ... $tagformat_want assigned after previous select_tagformat
1231
1232     my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1233     printdebug "select_tagformat supported @supported\n";
1234
1235     $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1236     printdebug "select_tagformat specified @$tagformat_want\n";
1237
1238     my ($fmt,$why,$override) = @$tagformat_want;
1239
1240     fail "target distro supports tag formats @supported".
1241         " but have to use $fmt ($why)"
1242         unless $override
1243             or grep { $_ eq $fmt } @supported;
1244
1245     $tagformat_want = undef;
1246     $tagformat = $fmt;
1247     $tagformatfn = ${*::}{"debiantag_$fmt"};
1248
1249     fail "trying to use unknown tag format \`$fmt' ($why) !"
1250         unless $tagformatfn;
1251 }
1252
1253 #---------- archive query entrypoints and rest of program ----------
1254
1255 sub canonicalise_suite () {
1256     return if defined $csuite;
1257     fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1258     $csuite = archive_query('canonicalise_suite');
1259     if ($isuite ne $csuite) {
1260         progress "canonical suite name for $isuite is $csuite";
1261     }
1262 }
1263
1264 sub get_archive_dsc () {
1265     canonicalise_suite();
1266     my @vsns = archive_query('archive_query');
1267     foreach my $vinfo (@vsns) {
1268         my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1269         $dscurl = access_cfg('mirror').$subpath;
1270         $dscdata = url_get($dscurl);
1271         if (!$dscdata) {
1272             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1273             next;
1274         }
1275         if ($digester) {
1276             $digester->reset();
1277             $digester->add($dscdata);
1278             my $got = $digester->hexdigest();
1279             $got eq $digest or
1280                 fail "$dscurl has hash $got but".
1281                     " archive told us to expect $digest";
1282         }
1283         my $dscfh = new IO::File \$dscdata, '<' or die $!;
1284         printdebug Dumper($dscdata) if $debuglevel>1;
1285         $dsc = parsecontrolfh($dscfh,$dscurl,1);
1286         printdebug Dumper($dsc) if $debuglevel>1;
1287         my $fmt = getfield $dsc, 'Format';
1288         fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1289         $dsc_checked = !!$digester;
1290         printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1291         return;
1292     }
1293     $dsc = undef;
1294     printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1295 }
1296
1297 sub check_for_git ();
1298 sub check_for_git () {
1299     # returns 0 or 1
1300     my $how = access_cfg('git-check');
1301     if ($how eq 'ssh-cmd') {
1302         my @cmd =
1303             (access_cfg_ssh, access_gituserhost(),
1304              access_runeinfo("git-check $package").
1305              " set -e; cd ".access_cfg('git-path').";".
1306              " if test -d $package.git; then echo 1; else echo 0; fi");
1307         my $r= cmdoutput @cmd;
1308         if (defined $r and $r =~ m/^divert (\w+)$/) {
1309             my $divert=$1;
1310             my ($usedistro,) = access_distros();
1311             # NB that if we are pushing, $usedistro will be $distro/push
1312             $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1313             $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1314             progress "diverting to $divert (using config for $instead_distro)";
1315             return check_for_git();
1316         }
1317         failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1318         return $r+0;
1319     } elsif ($how eq 'url') {
1320         my $prefix = access_cfg('git-check-url','git-url');
1321         my $suffix = access_cfg('git-check-suffix','git-suffix',
1322                                 'RETURN-UNDEF') // '.git';
1323         my $url = "$prefix/$package$suffix";
1324         my @cmd = (qw(curl -sS -I), $url);
1325         my $result = cmdoutput @cmd;
1326         $result =~ s/^\S+ 200 .*\n\r?\n//;
1327         # curl -sS -I with https_proxy prints
1328         # HTTP/1.0 200 Connection established
1329         $result =~ m/^\S+ (404|200) /s or
1330             fail "unexpected results from git check query - ".
1331                 Dumper($prefix, $result);
1332         my $code = $1;
1333         if ($code eq '404') {
1334             return 0;
1335         } elsif ($code eq '200') {
1336             return 1;
1337         } else {
1338             die;
1339         }
1340     } elsif ($how eq 'true') {
1341         return 1;
1342     } elsif ($how eq 'false') {
1343         return 0;
1344     } else {
1345         badcfg "unknown git-check \`$how'";
1346     }
1347 }
1348
1349 sub create_remote_git_repo () {
1350     my $how = access_cfg('git-create');
1351     if ($how eq 'ssh-cmd') {
1352         runcmd_ordryrun
1353             (access_cfg_ssh, access_gituserhost(),
1354              access_runeinfo("git-create $package").
1355              "set -e; cd ".access_cfg('git-path').";".
1356              " cp -a _template $package.git");
1357     } elsif ($how eq 'true') {
1358         # nothing to do
1359     } else {
1360         badcfg "unknown git-create \`$how'";
1361     }
1362 }
1363
1364 our ($dsc_hash,$lastpush_mergeinput);
1365
1366 our $ud = '.git/dgit/unpack';
1367
1368 sub prep_ud (;$) {
1369     my ($d) = @_;
1370     $d //= $ud;
1371     rmtree($d);
1372     mkpath '.git/dgit';
1373     mkdir $d or die $!;
1374 }
1375
1376 sub mktree_in_ud_here () {
1377     runcmd qw(git init -q);
1378     runcmd qw(git config gc.auto 0);
1379     rmtree('.git/objects');
1380     symlink '../../../../objects','.git/objects' or die $!;
1381 }
1382
1383 sub git_write_tree () {
1384     my $tree = cmdoutput @git, qw(write-tree);
1385     $tree =~ m/^\w+$/ or die "$tree ?";
1386     return $tree;
1387 }
1388
1389 sub remove_stray_gits () {
1390     my @gitscmd = qw(find -name .git -prune -print0);
1391     debugcmd "|",@gitscmd;
1392     open GITS, "-|", @gitscmd or die $!;
1393     {
1394         local $/="\0";
1395         while (<GITS>) {
1396             chomp or die;
1397             print STDERR "$us: warning: removing from source package: ",
1398                 (messagequote $_), "\n";
1399             rmtree $_;
1400         }
1401     }
1402     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1403 }
1404
1405 sub mktree_in_ud_from_only_subdir (;$) {
1406     my ($raw) = @_;
1407
1408     # changes into the subdir
1409     my (@dirs) = <*/.>;
1410     die "expected one subdir but found @dirs ?" unless @dirs==1;
1411     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1412     my $dir = $1;
1413     changedir $dir;
1414
1415     remove_stray_gits();
1416     mktree_in_ud_here();
1417     if (!$raw) {
1418         my ($format, $fopts) = get_source_format();
1419         if (madformat($format)) {
1420             rmtree '.pc';
1421         }
1422     }
1423
1424     runcmd @git, qw(add -Af);
1425     my $tree=git_write_tree();
1426     return ($tree,$dir);
1427 }
1428
1429 our @files_csum_info_fields =
1430     (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1431      ['Checksums-Sha1',  'Digest::SHA', 'new(1)'],
1432      ['Files',           'Digest::MD5', 'new()']);
1433
1434 sub dsc_files_info () {
1435     foreach my $csumi (@files_csum_info_fields) {
1436         my ($fname, $module, $method) = @$csumi;
1437         my $field = $dsc->{$fname};
1438         next unless defined $field;
1439         eval "use $module; 1;" or die $@;
1440         my @out;
1441         foreach (split /\n/, $field) {
1442             next unless m/\S/;
1443             m/^(\w+) (\d+) (\S+)$/ or
1444                 fail "could not parse .dsc $fname line \`$_'";
1445             my $digester = eval "$module"."->$method;" or die $@;
1446             push @out, {
1447                 Hash => $1,
1448                 Bytes => $2,
1449                 Filename => $3,
1450                 Digester => $digester,
1451             };
1452         }
1453         return @out;
1454     }
1455     fail "missing any supported Checksums-* or Files field in ".
1456         $dsc->get_option('name');
1457 }
1458
1459 sub dsc_files () {
1460     map { $_->{Filename} } dsc_files_info();
1461 }
1462
1463 sub files_compare_inputs (@) {
1464     my $inputs = \@_;
1465     my %record;
1466     my %fchecked;
1467
1468     my $showinputs = sub {
1469         return join "; ", map { $_->get_option('name') } @$inputs;
1470     };
1471
1472     foreach my $in (@$inputs) {
1473         my $expected_files;
1474         my $in_name = $in->get_option('name');
1475
1476         printdebug "files_compare_inputs $in_name\n";
1477
1478         foreach my $csumi (@files_csum_info_fields) {
1479             my ($fname) = @$csumi;
1480             printdebug "files_compare_inputs $in_name $fname\n";
1481
1482             my $field = $in->{$fname};
1483             next unless defined $field;
1484
1485             my @files;
1486             foreach (split /\n/, $field) {
1487                 next unless m/\S/;
1488
1489                 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1490                     fail "could not parse $in_name $fname line \`$_'";
1491
1492                 printdebug "files_compare_inputs $in_name $fname $f\n";
1493
1494                 push @files, $f;
1495
1496                 my $re = \ $record{$f}{$fname};
1497                 if (defined $$re) {
1498                     $fchecked{$f}{$in_name} = 1;
1499                     $$re eq $info or
1500                         fail "hash or size of $f varies in $fname fields".
1501                         " (between: ".$showinputs->().")";
1502                 } else {
1503                     $$re = $info;
1504                 }
1505             }
1506             @files = sort @files;
1507             $expected_files //= \@files;
1508             "@$expected_files" eq "@files" or
1509                 fail "file list in $in_name varies between hash fields!";
1510         }
1511         $expected_files or
1512             fail "$in_name has no files list field(s)";
1513     }
1514     printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1515         if $debuglevel>=2;
1516
1517     grep { keys %$_ == @$inputs-1 } values %fchecked
1518         or fail "no file appears in all file lists".
1519         " (looked in: ".$showinputs->().")";
1520 }
1521
1522 sub is_orig_file_in_dsc ($$) {
1523     my ($f, $dsc_files_info) = @_;
1524     return 0 if @$dsc_files_info <= 1;
1525     # One file means no origs, and the filename doesn't have a "what
1526     # part of dsc" component.  (Consider versions ending `.orig'.)
1527     return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1528     return 1;
1529 }
1530
1531 sub is_orig_file_of_vsn ($$) {
1532     my ($f, $upstreamvsn) = @_;
1533     my $base = srcfn $upstreamvsn, '';
1534     return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1535     return 1;
1536 }
1537
1538 sub make_commit ($) {
1539     my ($file) = @_;
1540     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1541 }
1542
1543 sub make_commit_text ($) {
1544     my ($text) = @_;
1545     my ($out, $in);
1546     my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1547     debugcmd "|",@cmd;
1548     print Dumper($text) if $debuglevel > 1;
1549     my $child = open2($out, $in, @cmd) or die $!;
1550     my $h;
1551     eval {
1552         print $in $text or die $!;
1553         close $in or die $!;
1554         $h = <$out>;
1555         $h =~ m/^\w+$/ or die;
1556         $h = $&;
1557         printdebug "=> $h\n";
1558     };
1559     close $out;
1560     waitpid $child, 0 == $child or die "$child $!";
1561     $? and failedcmd @cmd;
1562     return $h;
1563 }
1564
1565 sub clogp_authline ($) {
1566     my ($clogp) = @_;
1567     my $author = getfield $clogp, 'Maintainer';
1568     $author =~ s#,.*##ms;
1569     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1570     my $authline = "$author $date";
1571     $authline =~ m/$git_authline_re/o or
1572         fail "unexpected commit author line format \`$authline'".
1573         " (was generated from changelog Maintainer field)";
1574     return ($1,$2,$3) if wantarray;
1575     return $authline;
1576 }
1577
1578 sub vendor_patches_distro ($$) {
1579     my ($checkdistro, $what) = @_;
1580     return unless defined $checkdistro;
1581
1582     my $series = "debian/patches/\L$checkdistro\E.series";
1583     printdebug "checking for vendor-specific $series ($what)\n";
1584
1585     if (!open SERIES, "<", $series) {
1586         die "$series $!" unless $!==ENOENT;
1587         return;
1588     }
1589     while (<SERIES>) {
1590         next unless m/\S/;
1591         next if m/^\s+\#/;
1592
1593         print STDERR <<END;
1594
1595 Unfortunately, this source package uses a feature of dpkg-source where
1596 the same source package unpacks to different source code on different
1597 distros.  dgit cannot safely operate on such packages on affected
1598 distros, because the meaning of source packages is not stable.
1599
1600 Please ask the distro/maintainer to remove the distro-specific series
1601 files and use a different technique (if necessary, uploading actually
1602 different packages, if different distros are supposed to have
1603 different code).
1604
1605 END
1606         fail "Found active distro-specific series file for".
1607             " $checkdistro ($what): $series, cannot continue";
1608     }
1609     die "$series $!" if SERIES->error;
1610     close SERIES;
1611 }
1612
1613 sub check_for_vendor_patches () {
1614     # This dpkg-source feature doesn't seem to be documented anywhere!
1615     # But it can be found in the changelog (reformatted):
1616
1617     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
1618     #   Author: Raphael Hertzog <hertzog@debian.org>
1619     #   Date: Sun  Oct  3  09:36:48  2010 +0200
1620
1621     #   dpkg-source: correctly create .pc/.quilt_series with alternate
1622     #   series files
1623     #
1624     #   If you have debian/patches/ubuntu.series and you were
1625     #   unpacking the source package on ubuntu, quilt was still
1626     #   directed to debian/patches/series instead of
1627     #   debian/patches/ubuntu.series.
1628     #
1629     #   debian/changelog                        |    3 +++
1630     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
1631     #   2 files changed, 6 insertions(+), 1 deletion(-)
1632
1633     use Dpkg::Vendor;
1634     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1635     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1636                          "Dpkg::Vendor \`current vendor'");
1637     vendor_patches_distro(access_basedistro(),
1638                           "distro being accessed");
1639 }
1640
1641 sub generate_commits_from_dsc () {
1642     # See big comment in fetch_from_archive, below.
1643     # See also README.dsc-import.
1644     prep_ud();
1645     changedir $ud;
1646
1647     my @dfi = dsc_files_info();
1648     foreach my $fi (@dfi) {
1649         my $f = $fi->{Filename};
1650         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1651
1652         link_ltarget "../../../$f", $f
1653             or $!==&ENOENT
1654             or die "$f $!";
1655
1656         complete_file_from_dsc('.', $fi)
1657             or next;
1658
1659         if (is_orig_file_in_dsc($f, \@dfi)) {
1660             link $f, "../../../../$f"
1661                 or $!==&EEXIST
1662                 or die "$f $!";
1663         }
1664     }
1665
1666     # We unpack and record the orig tarballs first, so that we only
1667     # need disk space for one private copy of the unpacked source.
1668     # But we can't make them into commits until we have the metadata
1669     # from the debian/changelog, so we record the tree objects now and
1670     # make them into commits later.
1671     my @tartrees;
1672     my $upstreamv = $dsc->{version};
1673     $upstreamv =~ s/-[^-]+$//;
1674     my $orig_f_base = srcfn $upstreamv, '';
1675
1676     foreach my $fi (@dfi) {
1677         # We actually import, and record as a commit, every tarball
1678         # (unless there is only one file, in which case there seems
1679         # little point.
1680
1681         my $f = $fi->{Filename};
1682         printdebug "import considering $f ";
1683         (printdebug "only one dfi\n"), next if @dfi == 1;
1684         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1685         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1686         my $compr_ext = $1;
1687
1688         my ($orig_f_part) =
1689             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1690
1691         printdebug "Y ", (join ' ', map { $_//"(none)" }
1692                           $compr_ext, $orig_f_part
1693                          ), "\n";
1694
1695         my $input = new IO::File $f, '<' or die "$f $!";
1696         my $compr_pid;
1697         my @compr_cmd;
1698
1699         if (defined $compr_ext) {
1700             my $cname =
1701                 Dpkg::Compression::compression_guess_from_filename $f;
1702             fail "Dpkg::Compression cannot handle file $f in source package"
1703                 if defined $compr_ext && !defined $cname;
1704             my $compr_proc =
1705                 new Dpkg::Compression::Process compression => $cname;
1706             my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1707             my $compr_fh = new IO::Handle;
1708             my $compr_pid = open $compr_fh, "-|" // die $!;
1709             if (!$compr_pid) {
1710                 open STDIN, "<&", $input or die $!;
1711                 exec @compr_cmd;
1712                 die "dgit (child): exec $compr_cmd[0]: $!\n";
1713             }
1714             $input = $compr_fh;
1715         }
1716
1717         rmtree "../unpack-tar";
1718         mkdir "../unpack-tar" or die $!;
1719         my @tarcmd = qw(tar -x -f -
1720                         --no-same-owner --no-same-permissions
1721                         --no-acls --no-xattrs --no-selinux);
1722         my $tar_pid = fork // die $!;
1723         if (!$tar_pid) {
1724             chdir "../unpack-tar" or die $!;
1725             open STDIN, "<&", $input or die $!;
1726             exec @tarcmd;
1727             die "dgit (child): exec $tarcmd[0]: $!";
1728         }
1729         $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1730         !$? or failedcmd @tarcmd;
1731
1732         close $input or
1733             (@compr_cmd ? failedcmd @compr_cmd
1734              : die $!);
1735         # finally, we have the results in "tarball", but maybe
1736         # with the wrong permissions
1737
1738         runcmd qw(chmod -R +rwX ../unpack-tar);
1739         changedir "../unpack-tar";
1740         my ($tree) = mktree_in_ud_from_only_subdir(1);
1741         changedir "../../unpack";
1742         rmtree "../unpack-tar";
1743
1744         my $ent = [ $f, $tree ];
1745         push @tartrees, {
1746             Orig => !!$orig_f_part,
1747             Sort => (!$orig_f_part         ? 2 :
1748                      $orig_f_part =~ m/-/g ? 1 :
1749                                              0),
1750             F => $f,
1751             Tree => $tree,
1752         };
1753     }
1754
1755     @tartrees = sort {
1756         # put any without "_" first (spec is not clear whether files
1757         # are always in the usual order).  Tarballs without "_" are
1758         # the main orig or the debian tarball.
1759         $a->{Sort} <=> $b->{Sort} or
1760         $a->{F}    cmp $b->{F}
1761     } @tartrees;
1762
1763     my $any_orig = grep { $_->{Orig} } @tartrees;
1764
1765     my $dscfn = "$package.dsc";
1766
1767     my $treeimporthow = 'package';
1768
1769     open D, ">", $dscfn or die "$dscfn: $!";
1770     print D $dscdata or die "$dscfn: $!";
1771     close D or die "$dscfn: $!";
1772     my @cmd = qw(dpkg-source);
1773     push @cmd, '--no-check' if $dsc_checked;
1774     if (madformat $dsc->{format}) {
1775         push @cmd, '--skip-patches';
1776         $treeimporthow = 'unpatched';
1777     }
1778     push @cmd, qw(-x --), $dscfn;
1779     runcmd @cmd;
1780
1781     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1782     if (madformat $dsc->{format}) {
1783         check_for_vendor_patches();
1784     }
1785
1786     my $dappliedtree;
1787     if (madformat $dsc->{format}) {
1788         my @pcmd = qw(dpkg-source --before-build .);
1789         runcmd shell_cmd 'exec >/dev/null', @pcmd;
1790         rmtree '.pc';
1791         runcmd @git, qw(add -Af);
1792         $dappliedtree = git_write_tree();
1793     }
1794
1795     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1796     debugcmd "|",@clogcmd;
1797     open CLOGS, "-|", @clogcmd or die $!;
1798
1799     my $clogp;
1800     my $r1clogp;
1801
1802     printdebug "import clog search...\n";
1803
1804     for (;;) {
1805         my $stanzatext = do { local $/=""; <CLOGS>; };
1806         printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1807         last if !defined $stanzatext;
1808
1809         my $desc = "package changelog, entry no.$.";
1810         open my $stanzafh, "<", \$stanzatext or die;
1811         my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1812         $clogp //= $thisstanza;
1813
1814         printdebug "import clog $thisstanza->{version} $desc...\n";
1815
1816         last if !$any_orig; # we don't need $r1clogp
1817
1818         # We look for the first (most recent) changelog entry whose
1819         # version number is lower than the upstream version of this
1820         # package.  Then the last (least recent) previous changelog
1821         # entry is treated as the one which introduced this upstream
1822         # version and used for the synthetic commits for the upstream
1823         # tarballs.
1824
1825         # One might think that a more sophisticated algorithm would be
1826         # necessary.  But: we do not want to scan the whole changelog
1827         # file.  Stopping when we see an earlier version, which
1828         # necessarily then is an earlier upstream version, is the only
1829         # realistic way to do that.  Then, either the earliest
1830         # changelog entry we have seen so far is indeed the earliest
1831         # upload of this upstream version; or there are only changelog
1832         # entries relating to later upstream versions (which is not
1833         # possible unless the changelog and .dsc disagree about the
1834         # version).  Then it remains to choose between the physically
1835         # last entry in the file, and the one with the lowest version
1836         # number.  If these are not the same, we guess that the
1837         # versions were created in a non-monotic order rather than
1838         # that the changelog entries have been misordered.
1839
1840         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
1841
1842         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
1843         $r1clogp = $thisstanza;
1844
1845         printdebug "import clog $r1clogp->{version} becomes r1\n";
1846     }
1847     die $! if CLOGS->error;
1848     close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
1849
1850     $clogp or fail "package changelog has no entries!";
1851
1852     my $authline = clogp_authline $clogp;
1853     my $changes = getfield $clogp, 'Changes';
1854     my $cversion = getfield $clogp, 'Version';
1855
1856     if (@tartrees) {
1857         $r1clogp //= $clogp; # maybe there's only one entry;
1858         my $r1authline = clogp_authline $r1clogp;
1859         # Strictly, r1authline might now be wrong if it's going to be
1860         # unused because !$any_orig.  Whatever.
1861
1862         printdebug "import tartrees authline   $authline\n";
1863         printdebug "import tartrees r1authline $r1authline\n";
1864
1865         foreach my $tt (@tartrees) {
1866             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
1867
1868             $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
1869 tree $tt->{Tree}
1870 author $r1authline
1871 committer $r1authline
1872
1873 Import $tt->{F}
1874
1875 [dgit import orig $tt->{F}]
1876 END_O
1877 tree $tt->{Tree}
1878 author $authline
1879 committer $authline
1880
1881 Import $tt->{F}
1882
1883 [dgit import tarball $package $cversion $tt->{F}]
1884 END_T
1885         }
1886     }
1887
1888     printdebug "import main commit\n";
1889
1890     open C, ">../commit.tmp" or die $!;
1891     print C <<END or die $!;
1892 tree $tree
1893 END
1894     print C <<END or die $! foreach @tartrees;
1895 parent $_->{Commit}
1896 END
1897     print C <<END or die $!;
1898 author $authline
1899 committer $authline
1900
1901 $changes
1902
1903 [dgit import $treeimporthow $package $cversion]
1904 END
1905
1906     close C or die $!;
1907     my $rawimport_hash = make_commit qw(../commit.tmp);
1908
1909     if (madformat $dsc->{format}) {
1910         printdebug "import apply patches...\n";
1911
1912         # regularise the state of the working tree so that
1913         # the checkout of $rawimport_hash works nicely.
1914         my $dappliedcommit = make_commit_text(<<END);
1915 tree $dappliedtree
1916 author $authline
1917 committer $authline
1918
1919 [dgit dummy commit]
1920 END
1921         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
1922
1923         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
1924
1925         # We need the answers to be reproducible
1926         my @authline = clogp_authline($clogp);
1927         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
1928         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
1929         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
1930         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
1931         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
1932         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
1933
1934         eval {
1935             runcmd shell_cmd 'exec >/dev/null 2>../../gbp-pq-output',
1936                 gbp_pq, qw(import);
1937         };
1938         if ($@) {
1939             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
1940             die $@;
1941         }
1942
1943         my $gapplied = git_rev_parse('HEAD');
1944         my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
1945         $gappliedtree eq $dappliedtree or
1946             fail <<END;
1947 gbp-pq import and dpkg-source disagree!
1948  gbp-pq import gave commit $gapplied
1949  gbp-pq import gave tree $gappliedtree
1950  dpkg-source --before-build gave tree $dappliedtree
1951 END
1952         $rawimport_hash = $gapplied;
1953     }
1954
1955     progress "synthesised git commit from .dsc $cversion";
1956
1957     my $rawimport_mergeinput = {
1958         Commit => $rawimport_hash,
1959         Info => "Import of source package",
1960     };
1961     my @output = ($rawimport_mergeinput);
1962
1963     if ($lastpush_mergeinput) {
1964         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1965         my $oversion = getfield $oldclogp, 'Version';
1966         my $vcmp =
1967             version_compare($oversion, $cversion);
1968         if ($vcmp < 0) {
1969             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1970                 { Message => <<END, ReverseParents => 1 });
1971 Record $package ($cversion) in archive suite $csuite
1972 END
1973         } elsif ($vcmp > 0) {
1974             print STDERR <<END or die $!;
1975
1976 Version actually in archive:   $cversion (older)
1977 Last version pushed with dgit: $oversion (newer or same)
1978 $later_warning_msg
1979 END
1980             @output = $lastpush_mergeinput;
1981         } else {
1982             # Same version.  Use what's in the server git branch,
1983             # discarding our own import.  (This could happen if the
1984             # server automatically imports all packages into git.)
1985             @output = $lastpush_mergeinput;
1986         }
1987     }
1988     changedir '../../../..';
1989     rmtree($ud);
1990     return @output;
1991 }
1992
1993 sub complete_file_from_dsc ($$) {
1994     our ($dstdir, $fi) = @_;
1995     # Ensures that we have, in $dir, the file $fi, with the correct
1996     # contents.  (Downloading it from alongside $dscurl if necessary.)
1997
1998     my $f = $fi->{Filename};
1999     my $tf = "$dstdir/$f";
2000     my $downloaded = 0;
2001
2002     if (stat_exists $tf) {
2003         progress "using existing $f";
2004     } else {
2005         my $furl = $dscurl;
2006         $furl =~ s{/[^/]+$}{};
2007         $furl .= "/$f";
2008         die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2009         die "$f ?" if $f =~ m#/#;
2010         runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
2011         return 0 if !act_local();
2012         $downloaded = 1;
2013     }
2014
2015     open F, "<", "$tf" or die "$tf: $!";
2016     $fi->{Digester}->reset();
2017     $fi->{Digester}->addfile(*F);
2018     F->error and die $!;
2019     my $got = $fi->{Digester}->hexdigest();
2020     $got eq $fi->{Hash} or
2021         fail "file $f has hash $got but .dsc".
2022             " demands hash $fi->{Hash} ".
2023             ($downloaded ? "(got wrong file from archive!)"
2024              : "(perhaps you should delete this file?)");
2025
2026     return 1;
2027 }
2028
2029 sub ensure_we_have_orig () {
2030     my @dfi = dsc_files_info();
2031     foreach my $fi (@dfi) {
2032         my $f = $fi->{Filename};
2033         next unless is_orig_file_in_dsc($f, \@dfi);
2034         complete_file_from_dsc('..', $fi)
2035             or next;
2036     }
2037 }
2038
2039 sub git_fetch_us () {
2040     # Want to fetch only what we are going to use, unless
2041     # deliberately-not-ff, in which case we must fetch everything.
2042
2043     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2044         map { "tags/$_" }
2045         (quiltmode_splitbrain
2046          ? (map { $_->('*',access_basedistro) }
2047             \&debiantag_new, \&debiantag_maintview)
2048          : debiantags('*',access_basedistro));
2049     push @specs, server_branch($csuite);
2050     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2051
2052     # This is rather miserable:
2053     # When git fetch --prune is passed a fetchspec ending with a *,
2054     # it does a plausible thing.  If there is no * then:
2055     # - it matches subpaths too, even if the supplied refspec
2056     #   starts refs, and behaves completely madly if the source
2057     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2058     # - if there is no matching remote ref, it bombs out the whole
2059     #   fetch.
2060     # We want to fetch a fixed ref, and we don't know in advance
2061     # if it exists, so this is not suitable.
2062     #
2063     # Our workaround is to use git ls-remote.  git ls-remote has its
2064     # own qairks.  Notably, it has the absurd multi-tail-matching
2065     # behaviour: git ls-remote R refs/foo can report refs/foo AND
2066     # refs/refs/foo etc.
2067     #
2068     # Also, we want an idempotent snapshot, but we have to make two
2069     # calls to the remote: one to git ls-remote and to git fetch.  The
2070     # solution is use git ls-remote to obtain a target state, and
2071     # git fetch to try to generate it.  If we don't manage to generate
2072     # the target state, we try again.
2073
2074     my $specre = join '|', map {
2075         my $x = $_;
2076         $x =~ s/\W/\\$&/g;
2077         $x =~ s/\\\*$/.*/;
2078         "(?:refs/$x)";
2079     } @specs;
2080     printdebug "git_fetch_us specre=$specre\n";
2081     my $wanted_rref = sub {
2082         local ($_) = @_;
2083         return m/^(?:$specre)$/o;
2084     };
2085
2086     my $fetch_iteration = 0;
2087     FETCH_ITERATION:
2088     for (;;) {
2089         if (++$fetch_iteration > 10) {
2090             fail "too many iterations trying to get sane fetch!";
2091         }
2092
2093         my @look = map { "refs/$_" } @specs;
2094         my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2095         debugcmd "|",@lcmd;
2096
2097         my %wantr;
2098         open GITLS, "-|", @lcmd or die $!;
2099         while (<GITLS>) {
2100             printdebug "=> ", $_;
2101             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2102             my ($objid,$rrefname) = ($1,$2);
2103             if (!$wanted_rref->($rrefname)) {
2104                 print STDERR <<END;
2105 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2106 END
2107                 next;
2108             }
2109             $wantr{$rrefname} = $objid;
2110         }
2111         $!=0; $?=0;
2112         close GITLS or failedcmd @lcmd;
2113
2114         # OK, now %want is exactly what we want for refs in @specs
2115         my @fspecs = map {
2116             return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2117             "+refs/$_:".lrfetchrefs."/$_";
2118         } @specs;
2119
2120         my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2121         runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2122             @fspecs;
2123
2124         %lrfetchrefs_f = ();
2125         my %objgot;
2126
2127         git_for_each_ref(lrfetchrefs, sub {
2128             my ($objid,$objtype,$lrefname,$reftail) = @_;
2129             $lrfetchrefs_f{$lrefname} = $objid;
2130             $objgot{$objid} = 1;
2131         });
2132
2133         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2134             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2135             if (!exists $wantr{$rrefname}) {
2136                 if ($wanted_rref->($rrefname)) {
2137                     printdebug <<END;
2138 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2139 END
2140                 } else {
2141                     print STDERR <<END
2142 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2143 END
2144                 }
2145                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2146                 delete $lrfetchrefs_f{$lrefname};
2147                 next;
2148             }
2149         }
2150         foreach my $rrefname (sort keys %wantr) {
2151             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2152             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2153             my $want = $wantr{$rrefname};
2154             next if $got eq $want;
2155             if (!defined $objgot{$want}) {
2156                 print STDERR <<END;
2157 warning: git ls-remote suggests we want $lrefname
2158 warning:  and it should refer to $want
2159 warning:  but git fetch didn't fetch that object to any relevant ref.
2160 warning:  This may be due to a race with someone updating the server.
2161 warning:  Will try again...
2162 END
2163                 next FETCH_ITERATION;
2164             }
2165             printdebug <<END;
2166 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2167 END
2168             runcmd_ordryrun_local @git, qw(update-ref -m),
2169                 "dgit fetch git fetch fixup", $lrefname, $want;
2170             $lrfetchrefs_f{$lrefname} = $want;
2171         }
2172         last;
2173     }
2174     printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2175         Dumper(\%lrfetchrefs_f);
2176
2177     my %here;
2178     my @tagpats = debiantags('*',access_basedistro);
2179
2180     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2181         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2182         printdebug "currently $fullrefname=$objid\n";
2183         $here{$fullrefname} = $objid;
2184     });
2185     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2186         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2187         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2188         printdebug "offered $lref=$objid\n";
2189         if (!defined $here{$lref}) {
2190             my @upd = (@git, qw(update-ref), $lref, $objid, '');
2191             runcmd_ordryrun_local @upd;
2192             lrfetchref_used $fullrefname;
2193         } elsif ($here{$lref} eq $objid) {
2194             lrfetchref_used $fullrefname;
2195         } else {
2196             print STDERR \
2197                 "Not updateting $lref from $here{$lref} to $objid.\n";
2198         }
2199     });
2200 }
2201
2202 sub mergeinfo_getclogp ($) {
2203     # Ensures thit $mi->{Clogp} exists and returns it
2204     my ($mi) = @_;
2205     $mi->{Clogp} = commit_getclogp($mi->{Commit});
2206 }
2207
2208 sub mergeinfo_version ($) {
2209     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2210 }
2211
2212 sub fetch_from_archive () {
2213     ensure_setup_existing_tree();
2214
2215     # Ensures that lrref() is what is actually in the archive, one way
2216     # or another, according to us - ie this client's
2217     # appropritaely-updated archive view.  Also returns the commit id.
2218     # If there is nothing in the archive, leaves lrref alone and
2219     # returns undef.  git_fetch_us must have already been called.
2220     get_archive_dsc();
2221
2222     if ($dsc) {
2223         foreach my $field (@ourdscfield) {
2224             $dsc_hash = $dsc->{$field};
2225             last if defined $dsc_hash;
2226         }
2227         if (defined $dsc_hash) {
2228             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2229             $dsc_hash = $&;
2230             progress "last upload to archive specified git hash";
2231         } else {
2232             progress "last upload to archive has NO git hash";
2233         }
2234     } else {
2235         progress "no version available from the archive";
2236     }
2237
2238     # If the archive's .dsc has a Dgit field, there are three
2239     # relevant git commitids we need to choose between and/or merge
2240     # together:
2241     #   1. $dsc_hash: the Dgit field from the archive
2242     #   2. $lastpush_hash: the suite branch on the dgit git server
2243     #   3. $lastfetch_hash: our local tracking brach for the suite
2244     #
2245     # These may all be distinct and need not be in any fast forward
2246     # relationship:
2247     #
2248     # If the dsc was pushed to this suite, then the server suite
2249     # branch will have been updated; but it might have been pushed to
2250     # a different suite and copied by the archive.  Conversely a more
2251     # recent version may have been pushed with dgit but not appeared
2252     # in the archive (yet).
2253     #
2254     # $lastfetch_hash may be awkward because archive imports
2255     # (particularly, imports of Dgit-less .dscs) are performed only as
2256     # needed on individual clients, so different clients may perform a
2257     # different subset of them - and these imports are only made
2258     # public during push.  So $lastfetch_hash may represent a set of
2259     # imports different to a subsequent upload by a different dgit
2260     # client.
2261     #
2262     # Our approach is as follows:
2263     #
2264     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2265     # descendant of $dsc_hash, then it was pushed by a dgit user who
2266     # had based their work on $dsc_hash, so we should prefer it.
2267     # Otherwise, $dsc_hash was installed into this suite in the
2268     # archive other than by a dgit push, and (necessarily) after the
2269     # last dgit push into that suite (since a dgit push would have
2270     # been descended from the dgit server git branch); thus, in that
2271     # case, we prefer the archive's version (and produce a
2272     # pseudo-merge to overwrite the dgit server git branch).
2273     #
2274     # (If there is no Dgit field in the archive's .dsc then
2275     # generate_commit_from_dsc uses the version numbers to decide
2276     # whether the suite branch or the archive is newer.  If the suite
2277     # branch is newer it ignores the archive's .dsc; otherwise it
2278     # generates an import of the .dsc, and produces a pseudo-merge to
2279     # overwrite the suite branch with the archive contents.)
2280     #
2281     # The outcome of that part of the algorithm is the `public view',
2282     # and is same for all dgit clients: it does not depend on any
2283     # unpublished history in the local tracking branch.
2284     #
2285     # As between the public view and the local tracking branch: The
2286     # local tracking branch is only updated by dgit fetch, and
2287     # whenever dgit fetch runs it includes the public view in the
2288     # local tracking branch.  Therefore if the public view is not
2289     # descended from the local tracking branch, the local tracking
2290     # branch must contain history which was imported from the archive
2291     # but never pushed; and, its tip is now out of date.  So, we make
2292     # a pseudo-merge to overwrite the old imports and stitch the old
2293     # history in.
2294     #
2295     # Finally: we do not necessarily reify the public view (as
2296     # described above).  This is so that we do not end up stacking two
2297     # pseudo-merges.  So what we actually do is figure out the inputs
2298     # to any public view pseudo-merge and put them in @mergeinputs.
2299
2300     my @mergeinputs;
2301     # $mergeinputs[]{Commit}
2302     # $mergeinputs[]{Info}
2303     # $mergeinputs[0] is the one whose tree we use
2304     # @mergeinputs is in the order we use in the actual commit)
2305     #
2306     # Also:
2307     # $mergeinputs[]{Message} is a commit message to use
2308     # $mergeinputs[]{ReverseParents} if def specifies that parent
2309     #                                list should be in opposite order
2310     # Such an entry has no Commit or Info.  It applies only when found
2311     # in the last entry.  (This ugliness is to support making
2312     # identical imports to previous dgit versions.)
2313
2314     my $lastpush_hash = git_get_ref(lrfetchref());
2315     printdebug "previous reference hash=$lastpush_hash\n";
2316     $lastpush_mergeinput = $lastpush_hash && {
2317         Commit => $lastpush_hash,
2318         Info => "dgit suite branch on dgit git server",
2319     };
2320
2321     my $lastfetch_hash = git_get_ref(lrref());
2322     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2323     my $lastfetch_mergeinput = $lastfetch_hash && {
2324         Commit => $lastfetch_hash,
2325         Info => "dgit client's archive history view",
2326     };
2327
2328     my $dsc_mergeinput = $dsc_hash && {
2329         Commit => $dsc_hash,
2330         Info => "Dgit field in .dsc from archive",
2331     };
2332
2333     my $cwd = getcwd();
2334     my $del_lrfetchrefs = sub {
2335         changedir $cwd;
2336         my $gur;
2337         printdebug "del_lrfetchrefs...\n";
2338         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2339             my $objid = $lrfetchrefs_d{$fullrefname};
2340             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2341             if (!$gur) {
2342                 $gur ||= new IO::Handle;
2343                 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2344             }
2345             printf $gur "delete %s %s\n", $fullrefname, $objid;
2346         }
2347         if ($gur) {
2348             close $gur or failedcmd "git update-ref delete lrfetchrefs";
2349         }
2350     };
2351
2352     if (defined $dsc_hash) {
2353         fail "missing remote git history even though dsc has hash -".
2354             " could not find ref ".rref()." at ".access_giturl()
2355             unless $lastpush_hash;
2356         ensure_we_have_orig();
2357         if ($dsc_hash eq $lastpush_hash) {
2358             @mergeinputs = $dsc_mergeinput
2359         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2360             print STDERR <<END or die $!;
2361
2362 Git commit in archive is behind the last version allegedly pushed/uploaded.
2363 Commit referred to by archive: $dsc_hash
2364 Last version pushed with dgit: $lastpush_hash
2365 $later_warning_msg
2366 END
2367             @mergeinputs = ($lastpush_mergeinput);
2368         } else {
2369             # Archive has .dsc which is not a descendant of the last dgit
2370             # push.  This can happen if the archive moves .dscs about.
2371             # Just follow its lead.
2372             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2373                 progress "archive .dsc names newer git commit";
2374                 @mergeinputs = ($dsc_mergeinput);
2375             } else {
2376                 progress "archive .dsc names other git commit, fixing up";
2377                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2378             }
2379         }
2380     } elsif ($dsc) {
2381         @mergeinputs = generate_commits_from_dsc();
2382         # We have just done an import.  Now, our import algorithm might
2383         # have been improved.  But even so we do not want to generate
2384         # a new different import of the same package.  So if the
2385         # version numbers are the same, just use our existing version.
2386         # If the version numbers are different, the archive has changed
2387         # (perhaps, rewound).
2388         if ($lastfetch_mergeinput &&
2389             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2390                               (mergeinfo_version $mergeinputs[0]) )) {
2391             @mergeinputs = ($lastfetch_mergeinput);
2392         }
2393     } elsif ($lastpush_hash) {
2394         # only in git, not in the archive yet
2395         @mergeinputs = ($lastpush_mergeinput);
2396         print STDERR <<END or die $!;
2397
2398 Package not found in the archive, but has allegedly been pushed using dgit.
2399 $later_warning_msg
2400 END
2401     } else {
2402         printdebug "nothing found!\n";
2403         if (defined $skew_warning_vsn) {
2404             print STDERR <<END or die $!;
2405
2406 Warning: relevant archive skew detected.
2407 Archive allegedly contains $skew_warning_vsn
2408 But we were not able to obtain any version from the archive or git.
2409
2410 END
2411         }
2412         unshift @end, $del_lrfetchrefs;
2413         return undef;
2414     }
2415
2416     if ($lastfetch_hash &&
2417         !grep {
2418             my $h = $_->{Commit};
2419             $h and is_fast_fwd($lastfetch_hash, $h);
2420             # If true, one of the existing parents of this commit
2421             # is a descendant of the $lastfetch_hash, so we'll
2422             # be ff from that automatically.
2423         } @mergeinputs
2424         ) {
2425         # Otherwise:
2426         push @mergeinputs, $lastfetch_mergeinput;
2427     }
2428
2429     printdebug "fetch mergeinfos:\n";
2430     foreach my $mi (@mergeinputs) {
2431         if ($mi->{Info}) {
2432             printdebug " commit $mi->{Commit} $mi->{Info}\n";
2433         } else {
2434             printdebug sprintf " ReverseParents=%d Message=%s",
2435                 $mi->{ReverseParents}, $mi->{Message};
2436         }
2437     }
2438
2439     my $compat_info= pop @mergeinputs
2440         if $mergeinputs[$#mergeinputs]{Message};
2441
2442     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2443
2444     my $hash;
2445     if (@mergeinputs > 1) {
2446         # here we go, then:
2447         my $tree_commit = $mergeinputs[0]{Commit};
2448
2449         my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2450         $tree =~ m/\n\n/;  $tree = $`;
2451         $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2452         $tree = $1;
2453
2454         # We use the changelog author of the package in question the
2455         # author of this pseudo-merge.  This is (roughly) correct if
2456         # this commit is simply representing aa non-dgit upload.
2457         # (Roughly because it does not record sponsorship - but we
2458         # don't have sponsorship info because that's in the .changes,
2459         # which isn't in the archivw.)
2460         #
2461         # But, it might be that we are representing archive history
2462         # updates (including in-archive copies).  These are not really
2463         # the responsibility of the person who created the .dsc, but
2464         # there is no-one whose name we should better use.  (The
2465         # author of the .dsc-named commit is clearly worse.)
2466
2467         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2468         my $author = clogp_authline $useclogp;
2469         my $cversion = getfield $useclogp, 'Version';
2470
2471         my $mcf = ".git/dgit/mergecommit";
2472         open MC, ">", $mcf or die "$mcf $!";
2473         print MC <<END or die $!;
2474 tree $tree
2475 END
2476
2477         my @parents = grep { $_->{Commit} } @mergeinputs;
2478         @parents = reverse @parents if $compat_info->{ReverseParents};
2479         print MC <<END or die $! foreach @parents;
2480 parent $_->{Commit}
2481 END
2482
2483         print MC <<END or die $!;
2484 author $author
2485 committer $author
2486
2487 END
2488
2489         if (defined $compat_info->{Message}) {
2490             print MC $compat_info->{Message} or die $!;
2491         } else {
2492             print MC <<END or die $!;
2493 Record $package ($cversion) in archive suite $csuite
2494
2495 Record that
2496 END
2497             my $message_add_info = sub {
2498                 my ($mi) = (@_);
2499                 my $mversion = mergeinfo_version $mi;
2500                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
2501                     or die $!;
2502             };
2503
2504             $message_add_info->($mergeinputs[0]);
2505             print MC <<END or die $!;
2506 should be treated as descended from
2507 END
2508             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2509         }
2510
2511         close MC or die $!;
2512         $hash = make_commit $mcf;
2513     } else {
2514         $hash = $mergeinputs[0]{Commit};
2515     }
2516     printdebug "fetch hash=$hash\n";
2517
2518     my $chkff = sub {
2519         my ($lasth, $what) = @_;
2520         return unless $lasth;
2521         die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2522     };
2523
2524     $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2525     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2526
2527     runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2528             'DGIT_ARCHIVE', $hash;
2529     cmdoutput @git, qw(log -n2), $hash;
2530     # ... gives git a chance to complain if our commit is malformed
2531
2532     if (defined $skew_warning_vsn) {
2533         mkpath '.git/dgit';
2534         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2535         my $gotclogp = commit_getclogp($hash);
2536         my $got_vsn = getfield $gotclogp, 'Version';
2537         printdebug "SKEW CHECK GOT $got_vsn\n";
2538         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2539             print STDERR <<END or die $!;
2540
2541 Warning: archive skew detected.  Using the available version:
2542 Archive allegedly contains    $skew_warning_vsn
2543 We were able to obtain only   $got_vsn
2544
2545 END
2546         }
2547     }
2548
2549     if ($lastfetch_hash ne $hash) {
2550         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2551         if (act_local()) {
2552             cmdoutput @upd_cmd;
2553         } else {
2554             dryrun_report @upd_cmd;
2555         }
2556     }
2557
2558     lrfetchref_used lrfetchref();
2559
2560     unshift @end, $del_lrfetchrefs;
2561     return $hash;
2562 }
2563
2564 sub set_local_git_config ($$) {
2565     my ($k, $v) = @_;
2566     runcmd @git, qw(config), $k, $v;
2567 }
2568
2569 sub setup_mergechangelogs (;$) {
2570     my ($always) = @_;
2571     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2572
2573     my $driver = 'dpkg-mergechangelogs';
2574     my $cb = "merge.$driver";
2575     my $attrs = '.git/info/attributes';
2576     ensuredir '.git/info';
2577
2578     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2579     if (!open ATTRS, "<", $attrs) {
2580         $!==ENOENT or die "$attrs: $!";
2581     } else {
2582         while (<ATTRS>) {
2583             chomp;
2584             next if m{^debian/changelog\s};
2585             print NATTRS $_, "\n" or die $!;
2586         }
2587         ATTRS->error and die $!;
2588         close ATTRS;
2589     }
2590     print NATTRS "debian/changelog merge=$driver\n" or die $!;
2591     close NATTRS;
2592
2593     set_local_git_config "$cb.name", 'debian/changelog merge driver';
2594     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2595
2596     rename "$attrs.new", "$attrs" or die "$attrs: $!";
2597 }
2598
2599 sub setup_useremail (;$) {
2600     my ($always) = @_;
2601     return unless $always || access_cfg_bool(1, 'setup-useremail');
2602
2603     my $setup = sub {
2604         my ($k, $envvar) = @_;
2605         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2606         return unless defined $v;
2607         set_local_git_config "user.$k", $v;
2608     };
2609
2610     $setup->('email', 'DEBEMAIL');
2611     $setup->('name', 'DEBFULLNAME');
2612 }
2613
2614 sub ensure_setup_existing_tree () {
2615     my $k = "remote.$remotename.skipdefaultupdate";
2616     my $c = git_get_config $k;
2617     return if defined $c;
2618     set_local_git_config $k, 'true';
2619 }
2620
2621 sub setup_new_tree () {
2622     setup_mergechangelogs();
2623     setup_useremail();
2624 }
2625
2626 sub clone ($) {
2627     my ($dstdir) = @_;
2628     canonicalise_suite();
2629     badusage "dry run makes no sense with clone" unless act_local();
2630     my $hasgit = check_for_git();
2631     mkdir $dstdir or fail "create \`$dstdir': $!";
2632     changedir $dstdir;
2633     runcmd @git, qw(init -q);
2634     my $giturl = access_giturl(1);
2635     if (defined $giturl) {
2636         open H, "> .git/HEAD" or die $!;
2637         print H "ref: ".lref()."\n" or die $!;
2638         close H or die $!;
2639         runcmd @git, qw(remote add), 'origin', $giturl;
2640     }
2641     if ($hasgit) {
2642         progress "fetching existing git history";
2643         git_fetch_us();
2644         runcmd_ordryrun_local @git, qw(fetch origin);
2645     } else {
2646         progress "starting new git history";
2647     }
2648     fetch_from_archive() or no_such_package;
2649     my $vcsgiturl = $dsc->{'Vcs-Git'};
2650     if (length $vcsgiturl) {
2651         $vcsgiturl =~ s/\s+-b\s+\S+//g;
2652         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2653     }
2654     setup_new_tree();
2655     runcmd @git, qw(reset --hard), lrref();
2656     printdone "ready for work in $dstdir";
2657 }
2658
2659 sub fetch () {
2660     if (check_for_git()) {
2661         git_fetch_us();
2662     }
2663     fetch_from_archive() or no_such_package();
2664     printdone "fetched into ".lrref();
2665 }
2666
2667 sub pull () {
2668     fetch();
2669     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2670         lrref();
2671     printdone "fetched to ".lrref()." and merged into HEAD";
2672 }
2673
2674 sub check_not_dirty () {
2675     foreach my $f (qw(local-options local-patch-header)) {
2676         if (stat_exists "debian/source/$f") {
2677             fail "git tree contains debian/source/$f";
2678         }
2679     }
2680
2681     return if $ignoredirty;
2682
2683     my @cmd = (@git, qw(diff --quiet HEAD));
2684     debugcmd "+",@cmd;
2685     $!=0; $?=-1; system @cmd;
2686     return if !$?;
2687     if ($?==256) {
2688         fail "working tree is dirty (does not match HEAD)";
2689     } else {
2690         failedcmd @cmd;
2691     }
2692 }
2693
2694 sub commit_admin ($) {
2695     my ($m) = @_;
2696     progress "$m";
2697     runcmd_ordryrun_local @git, qw(commit -m), $m;
2698 }
2699
2700 sub commit_quilty_patch () {
2701     my $output = cmdoutput @git, qw(status --porcelain);
2702     my %adds;
2703     foreach my $l (split /\n/, $output) {
2704         next unless $l =~ m/\S/;
2705         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2706             $adds{$1}++;
2707         }
2708     }
2709     delete $adds{'.pc'}; # if there wasn't one before, don't add it
2710     if (!%adds) {
2711         progress "nothing quilty to commit, ok.";
2712         return;
2713     }
2714     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2715     runcmd_ordryrun_local @git, qw(add -f), @adds;
2716     commit_admin <<END
2717 Commit Debian 3.0 (quilt) metadata
2718
2719 [dgit ($our_version) quilt-fixup]
2720 END
2721 }
2722
2723 sub get_source_format () {
2724     my %options;
2725     if (open F, "debian/source/options") {
2726         while (<F>) {
2727             next if m/^\s*\#/;
2728             next unless m/\S/;
2729             s/\s+$//; # ignore missing final newline
2730             if (m/\s*\#\s*/) {
2731                 my ($k, $v) = ($`, $'); #');
2732                 $v =~ s/^"(.*)"$/$1/;
2733                 $options{$k} = $v;
2734             } else {
2735                 $options{$_} = 1;
2736             }
2737         }
2738         F->error and die $!;
2739         close F;
2740     } else {
2741         die $! unless $!==&ENOENT;
2742     }
2743
2744     if (!open F, "debian/source/format") {
2745         die $! unless $!==&ENOENT;
2746         return '';
2747     }
2748     $_ = <F>;
2749     F->error and die $!;
2750     chomp;
2751     return ($_, \%options);
2752 }
2753
2754 sub madformat_wantfixup ($) {
2755     my ($format) = @_;
2756     return 0 unless $format eq '3.0 (quilt)';
2757     our $quilt_mode_warned;
2758     if ($quilt_mode eq 'nocheck') {
2759         progress "Not doing any fixup of \`$format' due to".
2760             " ----no-quilt-fixup or --quilt=nocheck"
2761             unless $quilt_mode_warned++;
2762         return 0;
2763     }
2764     progress "Format \`$format', need to check/update patch stack"
2765         unless $quilt_mode_warned++;
2766     return 1;
2767 }
2768
2769 # An "infopair" is a tuple [ $thing, $what ]
2770 # (often $thing is a commit hash; $what is a description)
2771
2772 sub infopair_cond_equal ($$) {
2773     my ($x,$y) = @_;
2774     $x->[0] eq $y->[0] or fail <<END;
2775 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2776 END
2777 };
2778
2779 sub infopair_lrf_tag_lookup ($$) {
2780     my ($tagnames, $what) = @_;
2781     # $tagname may be an array ref
2782     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2783     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2784     foreach my $tagname (@tagnames) {
2785         my $lrefname = lrfetchrefs."/tags/$tagname";
2786         my $tagobj = $lrfetchrefs_f{$lrefname};
2787         next unless defined $tagobj;
2788         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2789         return [ git_rev_parse($tagobj), $what ];
2790     }
2791     fail @tagnames==1 ? <<END : <<END;
2792 Wanted tag $what (@tagnames) on dgit server, but not found
2793 END
2794 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2795 END
2796 }
2797
2798 sub infopair_cond_ff ($$) {
2799     my ($anc,$desc) = @_;
2800     is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2801 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2802 END
2803 };
2804
2805 sub pseudomerge_version_check ($$) {
2806     my ($clogp, $archive_hash) = @_;
2807
2808     my $arch_clogp = commit_getclogp $archive_hash;
2809     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2810                      'version currently in archive' ];
2811     if (defined $overwrite_version) {
2812         if (length $overwrite_version) {
2813             infopair_cond_equal([ $overwrite_version,
2814                                   '--overwrite= version' ],
2815                                 $i_arch_v);
2816         } else {
2817             my $v = $i_arch_v->[0];
2818             progress "Checking package changelog for archive version $v ...";
2819             eval {
2820                 my @xa = ("-f$v", "-t$v");
2821                 my $vclogp = parsechangelog @xa;
2822                 my $cv = [ (getfield $vclogp, 'Version'),
2823                            "Version field from dpkg-parsechangelog @xa" ];
2824                 infopair_cond_equal($i_arch_v, $cv);
2825             };
2826             if ($@) {
2827                 $@ =~ s/^dgit: //gm;
2828                 fail "$@".
2829                     "Perhaps debian/changelog does not mention $v ?";
2830             }
2831         }
2832     }
2833
2834     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2835     return $i_arch_v;
2836 }
2837
2838 sub pseudomerge_make_commit ($$$$ $$) {
2839     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2840         $msg_cmd, $msg_msg) = @_;
2841     progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2842
2843     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2844     my $authline = clogp_authline $clogp;
2845
2846     chomp $msg_msg;
2847     $msg_cmd .=
2848         !defined $overwrite_version ? ""
2849         : !length  $overwrite_version ? " --overwrite"
2850         : " --overwrite=".$overwrite_version;
2851
2852     mkpath '.git/dgit';
2853     my $pmf = ".git/dgit/pseudomerge";
2854     open MC, ">", $pmf or die "$pmf $!";
2855     print MC <<END or die $!;
2856 tree $tree
2857 parent $dgitview
2858 parent $archive_hash
2859 author $authline
2860 commiter $authline
2861
2862 $msg_msg
2863
2864 [$msg_cmd]
2865 END
2866     close MC or die $!;
2867
2868     return make_commit($pmf);
2869 }
2870
2871 sub splitbrain_pseudomerge ($$$$) {
2872     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2873     # => $merged_dgitview
2874     printdebug "splitbrain_pseudomerge...\n";
2875     #
2876     #     We:      debian/PREVIOUS    HEAD($maintview)
2877     # expect:          o ----------------- o
2878     #                    \                   \
2879     #                     o                   o
2880     #                 a/d/PREVIOUS        $dgitview
2881     #                $archive_hash              \
2882     #  If so,                \                   \
2883     #  we do:                 `------------------ o
2884     #   this:                                   $dgitview'
2885     #
2886
2887     printdebug "splitbrain_pseudomerge...\n";
2888
2889     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2890
2891     return $dgitview unless defined $archive_hash;
2892
2893     if (!defined $overwrite_version) {
2894         progress "Checking that HEAD inciudes all changes in archive...";
2895     }
2896
2897     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2898
2899     if (defined $overwrite_version) {
2900     } elsif (!eval {
2901         my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2902         my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2903         my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2904         my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2905         my $i_archive = [ $archive_hash, "current archive contents" ];
2906
2907         printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2908
2909         infopair_cond_equal($i_dgit, $i_archive);
2910         infopair_cond_ff($i_dep14, $i_dgit);
2911         infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2912         1;
2913     }) {
2914         print STDERR <<END;
2915 $us: check failed (maybe --overwrite is needed, consult documentation)
2916 END
2917         die "$@";
2918     }
2919
2920     my $r = pseudomerge_make_commit
2921         $clogp, $dgitview, $archive_hash, $i_arch_v,
2922         "dgit --quilt=$quilt_mode",
2923         (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2924 Declare fast forward from $i_arch_v->[0]
2925 END_OVERWR
2926 Make fast forward from $i_arch_v->[0]
2927 END_MAKEFF
2928
2929     progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2930     return $r;
2931 }
2932
2933 sub plain_overwrite_pseudomerge ($$$) {
2934     my ($clogp, $head, $archive_hash) = @_;
2935
2936     printdebug "plain_overwrite_pseudomerge...";
2937
2938     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2939
2940     return $head if is_fast_fwd $archive_hash, $head;
2941
2942     my $m = "Declare fast forward from $i_arch_v->[0]";
2943
2944     my $r = pseudomerge_make_commit
2945         $clogp, $head, $archive_hash, $i_arch_v,
2946         "dgit", $m;
2947
2948     runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2949
2950     progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2951     return $r;
2952 }
2953
2954 sub push_parse_changelog ($) {
2955     my ($clogpfn) = @_;
2956
2957     my $clogp = Dpkg::Control::Hash->new();
2958     $clogp->load($clogpfn) or die;
2959
2960     $package = getfield $clogp, 'Source';
2961     my $cversion = getfield $clogp, 'Version';
2962     my $tag = debiantag($cversion, access_basedistro);
2963     runcmd @git, qw(check-ref-format), $tag;
2964
2965     my $dscfn = dscfn($cversion);
2966
2967     return ($clogp, $cversion, $dscfn);
2968 }
2969
2970 sub push_parse_dsc ($$$) {
2971     my ($dscfn,$dscfnwhat, $cversion) = @_;
2972     $dsc = parsecontrol($dscfn,$dscfnwhat);
2973     my $dversion = getfield $dsc, 'Version';
2974     my $dscpackage = getfield $dsc, 'Source';
2975     ($dscpackage eq $package && $dversion eq $cversion) or
2976         fail "$dscfn is for $dscpackage $dversion".
2977             " but debian/changelog is for $package $cversion";
2978 }
2979
2980 sub push_tagwants ($$$$) {
2981     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2982     my @tagwants;
2983     push @tagwants, {
2984         TagFn => \&debiantag,
2985         Objid => $dgithead,
2986         TfSuffix => '',
2987         View => 'dgit',
2988     };
2989     if (defined $maintviewhead) {
2990         push @tagwants, {
2991             TagFn => \&debiantag_maintview,
2992             Objid => $maintviewhead,
2993             TfSuffix => '-maintview',
2994             View => 'maint',
2995         };
2996     }
2997     foreach my $tw (@tagwants) {
2998         $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2999         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3000     }
3001     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3002     return @tagwants;
3003 }
3004
3005 sub push_mktags ($$ $$ $) {
3006     my ($clogp,$dscfn,
3007         $changesfile,$changesfilewhat,
3008         $tagwants) = @_;
3009
3010     die unless $tagwants->[0]{View} eq 'dgit';
3011
3012     $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3013     $dsc->save("$dscfn.tmp") or die $!;
3014
3015     my $changes = parsecontrol($changesfile,$changesfilewhat);
3016     foreach my $field (qw(Source Distribution Version)) {
3017         $changes->{$field} eq $clogp->{$field} or
3018             fail "changes field $field \`$changes->{$field}'".
3019                 " does not match changelog \`$clogp->{$field}'";
3020     }
3021
3022     my $cversion = getfield $clogp, 'Version';
3023     my $clogsuite = getfield $clogp, 'Distribution';
3024
3025     # We make the git tag by hand because (a) that makes it easier
3026     # to control the "tagger" (b) we can do remote signing
3027     my $authline = clogp_authline $clogp;
3028     my $delibs = join(" ", "",@deliberatelies);
3029     my $declaredistro = access_basedistro();
3030
3031     my $mktag = sub {
3032         my ($tw) = @_;
3033         my $tfn = $tw->{Tfn};
3034         my $head = $tw->{Objid};
3035         my $tag = $tw->{Tag};
3036
3037         open TO, '>', $tfn->('.tmp') or die $!;
3038         print TO <<END or die $!;
3039 object $head
3040 type commit
3041 tag $tag
3042 tagger $authline
3043
3044 END
3045         if ($tw->{View} eq 'dgit') {
3046             print TO <<END or die $!;
3047 $package release $cversion for $clogsuite ($csuite) [dgit]
3048 [dgit distro=$declaredistro$delibs]
3049 END
3050             foreach my $ref (sort keys %previously) {
3051                 print TO <<END or die $!;
3052 [dgit previously:$ref=$previously{$ref}]
3053 END
3054             }
3055         } elsif ($tw->{View} eq 'maint') {
3056             print TO <<END or die $!;
3057 $package release $cversion for $clogsuite ($csuite)
3058 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3059 END
3060         } else {
3061             die Dumper($tw)."?";
3062         }
3063
3064         close TO or die $!;
3065
3066         my $tagobjfn = $tfn->('.tmp');
3067         if ($sign) {
3068             if (!defined $keyid) {
3069                 $keyid = access_cfg('keyid','RETURN-UNDEF');
3070             }
3071             if (!defined $keyid) {
3072                 $keyid = getfield $clogp, 'Maintainer';
3073             }
3074             unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3075             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3076             push @sign_cmd, qw(-u),$keyid if defined $keyid;
3077             push @sign_cmd, $tfn->('.tmp');
3078             runcmd_ordryrun @sign_cmd;
3079             if (act_scary()) {
3080                 $tagobjfn = $tfn->('.signed.tmp');
3081                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3082                     $tfn->('.tmp'), $tfn->('.tmp.asc');
3083             }
3084         }
3085         return $tagobjfn;
3086     };
3087
3088     my @r = map { $mktag->($_); } @$tagwants;
3089     return @r;
3090 }
3091
3092 sub sign_changes ($) {
3093     my ($changesfile) = @_;
3094     if ($sign) {
3095         my @debsign_cmd = @debsign;
3096         push @debsign_cmd, "-k$keyid" if defined $keyid;
3097         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3098         push @debsign_cmd, $changesfile;
3099         runcmd_ordryrun @debsign_cmd;
3100     }
3101 }
3102
3103 sub dopush () {
3104     printdebug "actually entering push\n";
3105
3106     supplementary_message(<<'END');
3107 Push failed, while checking state of the archive.
3108 You can retry the push, after fixing the problem, if you like.
3109 END
3110     if (check_for_git()) {
3111         git_fetch_us();
3112     }
3113     my $archive_hash = fetch_from_archive();
3114     if (!$archive_hash) {
3115         $new_package or
3116             fail "package appears to be new in this suite;".
3117                 " if this is intentional, use --new";
3118     }
3119
3120     supplementary_message(<<'END');
3121 Push failed, while preparing your push.
3122 You can retry the push, after fixing the problem, if you like.
3123 END
3124
3125     need_tagformat 'new', "quilt mode $quilt_mode"
3126         if quiltmode_splitbrain;
3127
3128     prep_ud();
3129
3130     access_giturl(); # check that success is vaguely likely
3131     select_tagformat();
3132
3133     my $clogpfn = ".git/dgit/changelog.822.tmp";
3134     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3135
3136     responder_send_file('parsed-changelog', $clogpfn);
3137
3138     my ($clogp, $cversion, $dscfn) =
3139         push_parse_changelog("$clogpfn");
3140
3141     my $dscpath = "$buildproductsdir/$dscfn";
3142     stat_exists $dscpath or
3143         fail "looked for .dsc $dscfn, but $!;".
3144             " maybe you forgot to build";
3145
3146     responder_send_file('dsc', $dscpath);
3147
3148     push_parse_dsc($dscpath, $dscfn, $cversion);
3149
3150     my $format = getfield $dsc, 'Format';
3151     printdebug "format $format\n";
3152
3153     my $actualhead = git_rev_parse('HEAD');
3154     my $dgithead = $actualhead;
3155     my $maintviewhead = undef;
3156
3157     if (madformat_wantfixup($format)) {
3158         # user might have not used dgit build, so maybe do this now:
3159         if (quiltmode_splitbrain()) {
3160             my $upstreamversion = $clogp->{Version};
3161             $upstreamversion =~ s/-[^-]*$//;
3162             changedir $ud;
3163             quilt_make_fake_dsc($upstreamversion);
3164             my $cachekey;
3165             ($dgithead, $cachekey) =
3166                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3167             $dgithead or fail
3168  "--quilt=$quilt_mode but no cached dgit view:
3169  perhaps tree changed since dgit build[-source] ?";
3170             $split_brain = 1;
3171             $dgithead = splitbrain_pseudomerge($clogp,
3172                                                $actualhead, $dgithead,
3173                                                $archive_hash);
3174             $maintviewhead = $actualhead;
3175             changedir '../../../..';
3176             prep_ud(); # so _only_subdir() works, below
3177         } else {
3178             commit_quilty_patch();
3179         }
3180     }
3181
3182     if (defined $overwrite_version && !defined $maintviewhead) {
3183         $dgithead = plain_overwrite_pseudomerge($clogp,
3184                                                 $dgithead,
3185                                                 $archive_hash);
3186     }
3187
3188     check_not_dirty();
3189
3190     my $forceflag = '';
3191     if ($archive_hash) {
3192         if (is_fast_fwd($archive_hash, $dgithead)) {
3193             # ok
3194         } elsif (deliberately_not_fast_forward) {
3195             $forceflag = '+';
3196         } else {
3197             fail "dgit push: HEAD is not a descendant".
3198                 " of the archive's version.\n".
3199                 "To overwrite the archive's contents,".
3200                 " pass --overwrite[=VERSION].\n".
3201                 "To rewind history, if permitted by the archive,".
3202                 " use --deliberately-not-fast-forward.";
3203         }
3204     }
3205
3206     changedir $ud;
3207     progress "checking that $dscfn corresponds to HEAD";
3208     runcmd qw(dpkg-source -x --),
3209         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3210     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3211     check_for_vendor_patches() if madformat($dsc->{format});
3212     changedir '../../../..';
3213     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3214     debugcmd "+",@diffcmd;
3215     $!=0; $?=-1;
3216     my $r = system @diffcmd;
3217     if ($r) {
3218         if ($r==256) {
3219             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3220             fail <<END
3221 HEAD specifies a different tree to $dscfn:
3222 $diffs
3223 Perhaps you forgot to build.  Or perhaps there is a problem with your
3224  source tree (see dgit(7) for some hints).  To see a full diff, run
3225    git diff $tree HEAD
3226 END
3227         } else {
3228             failedcmd @diffcmd;
3229         }
3230     }
3231     if (!$changesfile) {
3232         my $pat = changespat $cversion;
3233         my @cs = glob "$buildproductsdir/$pat";
3234         fail "failed to find unique changes file".
3235             " (looked for $pat in $buildproductsdir);".
3236             " perhaps you need to use dgit -C"
3237             unless @cs==1;
3238         ($changesfile) = @cs;
3239     } else {
3240         $changesfile = "$buildproductsdir/$changesfile";
3241     }
3242
3243     # Check that changes and .dsc agree enough
3244     $changesfile =~ m{[^/]*$};
3245     files_compare_inputs($dsc, parsecontrol($changesfile,$&));
3246
3247     # Checks complete, we're going to try and go ahead:
3248
3249     responder_send_file('changes',$changesfile);
3250     responder_send_command("param head $dgithead");
3251     responder_send_command("param csuite $csuite");
3252     responder_send_command("param tagformat $tagformat");
3253     if (defined $maintviewhead) {
3254         die unless ($protovsn//4) >= 4;
3255         responder_send_command("param maint-view $maintviewhead");
3256     }
3257
3258     if (deliberately_not_fast_forward) {
3259         git_for_each_ref(lrfetchrefs, sub {
3260             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3261             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3262             responder_send_command("previously $rrefname=$objid");
3263             $previously{$rrefname} = $objid;
3264         });
3265     }
3266
3267     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3268                                  ".git/dgit/tag");
3269     my @tagobjfns;
3270
3271     supplementary_message(<<'END');
3272 Push failed, while signing the tag.
3273 You can retry the push, after fixing the problem, if you like.
3274 END
3275     # If we manage to sign but fail to record it anywhere, it's fine.
3276     if ($we_are_responder) {
3277         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3278         responder_receive_files('signed-tag', @tagobjfns);
3279     } else {
3280         @tagobjfns = push_mktags($clogp,$dscpath,
3281                               $changesfile,$changesfile,
3282                               \@tagwants);
3283     }
3284     supplementary_message(<<'END');
3285 Push failed, *after* signing the tag.
3286 If you want to try again, you should use a new version number.
3287 END
3288
3289     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3290
3291     foreach my $tw (@tagwants) {
3292         my $tag = $tw->{Tag};
3293         my $tagobjfn = $tw->{TagObjFn};
3294         my $tag_obj_hash =
3295             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3296         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3297         runcmd_ordryrun_local
3298             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3299     }
3300
3301     supplementary_message(<<'END');
3302 Push failed, while updating the remote git repository - see messages above.
3303 If you want to try again, you should use a new version number.
3304 END
3305     if (!check_for_git()) {
3306         create_remote_git_repo();
3307     }
3308
3309     my @pushrefs = $forceflag.$dgithead.":".rrref();
3310     foreach my $tw (@tagwants) {
3311         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3312     }
3313
3314     runcmd_ordryrun @git,
3315         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3316     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3317
3318     supplementary_message(<<'END');
3319 Push failed, after updating the remote git repository.
3320 If you want to try again, you must use a new version number.
3321 END
3322     if ($we_are_responder) {
3323         my $dryrunsuffix = act_local() ? "" : ".tmp";
3324         responder_receive_files('signed-dsc-changes',
3325                                 "$dscpath$dryrunsuffix",
3326                                 "$changesfile$dryrunsuffix");
3327     } else {
3328         if (act_local()) {
3329             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3330         } else {
3331             progress "[new .dsc left in $dscpath.tmp]";
3332         }
3333         sign_changes $changesfile;
3334     }
3335
3336     supplementary_message(<<END);
3337 Push failed, while uploading package(s) to the archive server.
3338 You can retry the upload of exactly these same files with dput of:
3339   $changesfile
3340 If that .changes file is broken, you will need to use a new version
3341 number for your next attempt at the upload.
3342 END
3343     my $host = access_cfg('upload-host','RETURN-UNDEF');
3344     my @hostarg = defined($host) ? ($host,) : ();
3345     runcmd_ordryrun @dput, @hostarg, $changesfile;
3346     printdone "pushed and uploaded $cversion";
3347
3348     supplementary_message('');
3349     responder_send_command("complete");
3350 }
3351
3352 sub cmd_clone {
3353     parseopts();
3354     notpushing();
3355     my $dstdir;
3356     badusage "-p is not allowed with clone; specify as argument instead"
3357         if defined $package;
3358     if (@ARGV==1) {
3359         ($package) = @ARGV;
3360     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3361         ($package,$isuite) = @ARGV;
3362     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3363         ($package,$dstdir) = @ARGV;
3364     } elsif (@ARGV==3) {
3365         ($package,$isuite,$dstdir) = @ARGV;
3366     } else {
3367         badusage "incorrect arguments to dgit clone";
3368     }
3369     $dstdir ||= "$package";
3370
3371     if (stat_exists $dstdir) {
3372         fail "$dstdir already exists";
3373     }
3374
3375     my $cwd_remove;
3376     if ($rmonerror && !$dryrun_level) {
3377         $cwd_remove= getcwd();
3378         unshift @end, sub {
3379             return unless defined $cwd_remove;
3380             if (!chdir "$cwd_remove") {
3381                 return if $!==&ENOENT;
3382                 die "chdir $cwd_remove: $!";
3383             }
3384             if (stat $dstdir) {
3385                 rmtree($dstdir) or die "remove $dstdir: $!\n";
3386             } elsif (grep { $! == $_ }
3387                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3388             } else {
3389                 print STDERR "check whether to remove $dstdir: $!\n";
3390             }
3391         };
3392     }
3393
3394     clone($dstdir);
3395     $cwd_remove = undef;
3396 }
3397
3398 sub branchsuite () {
3399     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3400     if ($branch =~ m#$lbranch_re#o) {
3401         return $1;
3402     } else {
3403         return undef;
3404     }
3405 }
3406
3407 sub fetchpullargs () {
3408     notpushing();
3409     if (!defined $package) {
3410         my $sourcep = parsecontrol('debian/control','debian/control');
3411         $package = getfield $sourcep, 'Source';
3412     }
3413     if (@ARGV==0) {
3414 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
3415         if (!$isuite) {
3416             my $clogp = parsechangelog();
3417             $isuite = getfield $clogp, 'Distribution';
3418         }
3419         canonicalise_suite();
3420         progress "fetching from suite $csuite";
3421     } elsif (@ARGV==1) {
3422         ($isuite) = @ARGV;
3423         canonicalise_suite();
3424     } else {
3425         badusage "incorrect arguments to dgit fetch or dgit pull";
3426     }
3427 }
3428
3429 sub cmd_fetch {
3430     parseopts();
3431     fetchpullargs();
3432     fetch();
3433 }
3434
3435 sub cmd_pull {
3436     parseopts();
3437     fetchpullargs();
3438     pull();
3439 }
3440
3441 sub cmd_push {
3442     parseopts();
3443     pushing();
3444     badusage "-p is not allowed with dgit push" if defined $package;
3445     check_not_dirty();
3446     my $clogp = parsechangelog();
3447     $package = getfield $clogp, 'Source';
3448     my $specsuite;
3449     if (@ARGV==0) {
3450     } elsif (@ARGV==1) {
3451         ($specsuite) = (@ARGV);
3452     } else {
3453         badusage "incorrect arguments to dgit push";
3454     }
3455     $isuite = getfield $clogp, 'Distribution';
3456     if ($new_package) {
3457         local ($package) = $existing_package; # this is a hack
3458         canonicalise_suite();
3459     } else {
3460         canonicalise_suite();
3461     }
3462     if (defined $specsuite &&
3463         $specsuite ne $isuite &&
3464         $specsuite ne $csuite) {
3465             fail "dgit push: changelog specifies $isuite ($csuite)".
3466                 " but command line specifies $specsuite";
3467     }
3468     dopush();
3469 }
3470
3471 #---------- remote commands' implementation ----------
3472
3473 sub cmd_remote_push_build_host {
3474     my ($nrargs) = shift @ARGV;
3475     my (@rargs) = @ARGV[0..$nrargs-1];
3476     @ARGV = @ARGV[$nrargs..$#ARGV];
3477     die unless @rargs;
3478     my ($dir,$vsnwant) = @rargs;
3479     # vsnwant is a comma-separated list; we report which we have
3480     # chosen in our ready response (so other end can tell if they
3481     # offered several)
3482     $debugprefix = ' ';
3483     $we_are_responder = 1;
3484     $us .= " (build host)";
3485
3486     pushing();
3487
3488     open PI, "<&STDIN" or die $!;
3489     open STDIN, "/dev/null" or die $!;
3490     open PO, ">&STDOUT" or die $!;
3491     autoflush PO 1;
3492     open STDOUT, ">&STDERR" or die $!;
3493     autoflush STDOUT 1;
3494
3495     $vsnwant //= 1;
3496     ($protovsn) = grep {
3497         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3498     } @rpushprotovsn_support;
3499
3500     fail "build host has dgit rpush protocol versions ".
3501         (join ",", @rpushprotovsn_support).
3502         " but invocation host has $vsnwant"
3503         unless defined $protovsn;
3504
3505     responder_send_command("dgit-remote-push-ready $protovsn");
3506     rpush_handle_protovsn_bothends();
3507     changedir $dir;
3508     &cmd_push;
3509 }
3510
3511 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3512 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3513 #     a good error message)
3514
3515 sub rpush_handle_protovsn_bothends () {
3516     if ($protovsn < 4) {
3517         need_tagformat 'old', "rpush negotiated protocol $protovsn";
3518     }
3519     select_tagformat();
3520 }
3521
3522 our $i_tmp;
3523
3524 sub i_cleanup {
3525     local ($@, $?);
3526     my $report = i_child_report();
3527     if (defined $report) {
3528         printdebug "($report)\n";
3529     } elsif ($i_child_pid) {
3530         printdebug "(killing build host child $i_child_pid)\n";
3531         kill 15, $i_child_pid;
3532     }
3533     if (defined $i_tmp && !defined $initiator_tempdir) {
3534         changedir "/";
3535         eval { rmtree $i_tmp; };
3536     }
3537 }
3538
3539 END { i_cleanup(); }
3540
3541 sub i_method {
3542     my ($base,$selector,@args) = @_;
3543     $selector =~ s/\-/_/g;
3544     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3545 }
3546
3547 sub cmd_rpush {
3548     pushing();
3549     my $host = nextarg;
3550     my $dir;
3551     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3552         $host = $1;
3553         $dir = $'; #';
3554     } else {
3555         $dir = nextarg;
3556     }
3557     $dir =~ s{^-}{./-};
3558     my @rargs = ($dir);
3559     push @rargs, join ",", @rpushprotovsn_support;
3560     my @rdgit;
3561     push @rdgit, @dgit;
3562     push @rdgit, @ropts;
3563     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3564     push @rdgit, @ARGV;
3565     my @cmd = (@ssh, $host, shellquote @rdgit);
3566     debugcmd "+",@cmd;
3567
3568     if (defined $initiator_tempdir) {
3569         rmtree $initiator_tempdir;
3570         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3571         $i_tmp = $initiator_tempdir;
3572     } else {
3573         $i_tmp = tempdir();
3574     }
3575     $i_child_pid = open2(\*RO, \*RI, @cmd);
3576     changedir $i_tmp;
3577     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3578     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3579     $supplementary_message = '' unless $protovsn >= 3;
3580
3581     fail "rpush negotiated protocol version $protovsn".
3582         " which does not support quilt mode $quilt_mode"
3583         if quiltmode_splitbrain;
3584
3585     rpush_handle_protovsn_bothends();
3586     for (;;) {
3587         my ($icmd,$iargs) = initiator_expect {
3588             m/^(\S+)(?: (.*))?$/;
3589             ($1,$2);
3590         };
3591         i_method "i_resp", $icmd, $iargs;
3592     }
3593 }
3594
3595 sub i_resp_progress ($) {
3596     my ($rhs) = @_;
3597     my $msg = protocol_read_bytes \*RO, $rhs;
3598     progress $msg;
3599 }
3600
3601 sub i_resp_supplementary_message ($) {
3602     my ($rhs) = @_;
3603     $supplementary_message = protocol_read_bytes \*RO, $rhs;
3604 }
3605
3606 sub i_resp_complete {
3607     my $pid = $i_child_pid;
3608     $i_child_pid = undef; # prevents killing some other process with same pid
3609     printdebug "waiting for build host child $pid...\n";
3610     my $got = waitpid $pid, 0;
3611     die $! unless $got == $pid;
3612     die "build host child failed $?" if $?;
3613
3614     i_cleanup();
3615     printdebug "all done\n";
3616     exit 0;
3617 }
3618
3619 sub i_resp_file ($) {
3620     my ($keyword) = @_;
3621     my $localname = i_method "i_localname", $keyword;
3622     my $localpath = "$i_tmp/$localname";
3623     stat_exists $localpath and
3624         badproto \*RO, "file $keyword ($localpath) twice";
3625     protocol_receive_file \*RO, $localpath;
3626     i_method "i_file", $keyword;
3627 }
3628
3629 our %i_param;
3630
3631 sub i_resp_param ($) {
3632     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3633     $i_param{$1} = $2;
3634 }
3635
3636 sub i_resp_previously ($) {
3637     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3638         or badproto \*RO, "bad previously spec";
3639     my $r = system qw(git check-ref-format), $1;
3640     die "bad previously ref spec ($r)" if $r;
3641     $previously{$1} = $2;
3642 }
3643
3644 our %i_wanted;
3645
3646 sub i_resp_want ($) {
3647     my ($keyword) = @_;
3648     die "$keyword ?" if $i_wanted{$keyword}++;
3649     my @localpaths = i_method "i_want", $keyword;
3650     printdebug "[[  $keyword @localpaths\n";
3651     foreach my $localpath (@localpaths) {
3652         protocol_send_file \*RI, $localpath;
3653     }
3654     print RI "files-end\n" or die $!;
3655 }
3656
3657 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3658
3659 sub i_localname_parsed_changelog {
3660     return "remote-changelog.822";
3661 }
3662 sub i_file_parsed_changelog {
3663     ($i_clogp, $i_version, $i_dscfn) =
3664         push_parse_changelog "$i_tmp/remote-changelog.822";
3665     die if $i_dscfn =~ m#/|^\W#;
3666 }
3667
3668 sub i_localname_dsc {
3669     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3670     return $i_dscfn;
3671 }
3672 sub i_file_dsc { }
3673
3674 sub i_localname_changes {
3675     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3676     $i_changesfn = $i_dscfn;
3677     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3678     return $i_changesfn;
3679 }
3680 sub i_file_changes { }
3681
3682 sub i_want_signed_tag {
3683     printdebug Dumper(\%i_param, $i_dscfn);
3684     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3685         && defined $i_param{'csuite'}
3686         or badproto \*RO, "premature desire for signed-tag";
3687     my $head = $i_param{'head'};
3688     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3689
3690     my $maintview = $i_param{'maint-view'};
3691     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3692
3693     select_tagformat();
3694     if ($protovsn >= 4) {
3695         my $p = $i_param{'tagformat'} // '<undef>';
3696         $p eq $tagformat
3697             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3698     }
3699
3700     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3701     $csuite = $&;
3702     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3703
3704     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3705
3706     return
3707         push_mktags $i_clogp, $i_dscfn,
3708             $i_changesfn, 'remote changes',
3709             \@tagwants;
3710 }
3711
3712 sub i_want_signed_dsc_changes {
3713     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3714     sign_changes $i_changesfn;
3715     return ($i_dscfn, $i_changesfn);
3716 }
3717
3718 #---------- building etc. ----------
3719
3720 our $version;
3721 our $sourcechanges;
3722 our $dscfn;
3723
3724 #----- `3.0 (quilt)' handling -----
3725
3726 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3727
3728 sub quiltify_dpkg_commit ($$$;$) {
3729     my ($patchname,$author,$msg, $xinfo) = @_;
3730     $xinfo //= '';
3731
3732     mkpath '.git/dgit';
3733     my $descfn = ".git/dgit/quilt-description.tmp";
3734     open O, '>', $descfn or die "$descfn: $!";
3735     $msg =~ s/\n+/\n\n/;
3736     print O <<END or die $!;
3737 From: $author
3738 ${xinfo}Subject: $msg
3739 ---
3740
3741 END
3742     close O or die $!;
3743
3744     {
3745         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3746         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3747         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3748         runcmd @dpkgsource, qw(--commit .), $patchname;
3749     }