dgit

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