dgit

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