dgit

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