dgit

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