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