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 changes-origs-exactly
  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         unless forceing [qw(changes-origs-exactly)];
3458
3459     # Checks complete, we're going to try and go ahead:
3460
3461     responder_send_file('changes',$changesfile);
3462     responder_send_command("param head $dgithead");
3463     responder_send_command("param csuite $csuite");
3464     responder_send_command("param tagformat $tagformat");
3465     if (defined $maintviewhead) {
3466         die unless ($protovsn//4) >= 4;
3467         responder_send_command("param maint-view $maintviewhead");
3468     }
3469
3470     if (deliberately_not_fast_forward) {
3471         git_for_each_ref(lrfetchrefs, sub {
3472             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3473             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3474             responder_send_command("previously $rrefname=$objid");
3475             $previously{$rrefname} = $objid;
3476         });
3477     }
3478
3479     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3480                                  ".git/dgit/tag");
3481     my @tagobjfns;
3482
3483     supplementary_message(<<'END');
3484 Push failed, while signing the tag.
3485 You can retry the push, after fixing the problem, if you like.
3486 END
3487     # If we manage to sign but fail to record it anywhere, it's fine.
3488     if ($we_are_responder) {
3489         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3490         responder_receive_files('signed-tag', @tagobjfns);
3491     } else {
3492         @tagobjfns = push_mktags($clogp,$dscpath,
3493                               $changesfile,$changesfile,
3494                               \@tagwants);
3495     }
3496     supplementary_message(<<'END');
3497 Push failed, *after* signing the tag.
3498 If you want to try again, you should use a new version number.
3499 END
3500
3501     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3502
3503     foreach my $tw (@tagwants) {
3504         my $tag = $tw->{Tag};
3505         my $tagobjfn = $tw->{TagObjFn};
3506         my $tag_obj_hash =
3507             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3508         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3509         runcmd_ordryrun_local
3510             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3511     }
3512
3513     supplementary_message(<<'END');
3514 Push failed, while updating the remote git repository - see messages above.
3515 If you want to try again, you should use a new version number.
3516 END
3517     if (!check_for_git()) {
3518         create_remote_git_repo();
3519     }
3520
3521     my @pushrefs = $forceflag.$dgithead.":".rrref();
3522     foreach my $tw (@tagwants) {
3523         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3524     }
3525
3526     runcmd_ordryrun @git,
3527         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3528     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3529
3530     supplementary_message(<<'END');
3531 Push failed, after updating the remote git repository.
3532 If you want to try again, you must use a new version number.
3533 END
3534     if ($we_are_responder) {
3535         my $dryrunsuffix = act_local() ? "" : ".tmp";
3536         responder_receive_files('signed-dsc-changes',
3537                                 "$dscpath$dryrunsuffix",
3538                                 "$changesfile$dryrunsuffix");
3539     } else {
3540         if (act_local()) {
3541             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3542         } else {
3543             progress "[new .dsc left in $dscpath.tmp]";
3544         }
3545         sign_changes $changesfile;
3546     }
3547
3548     supplementary_message(<<END);
3549 Push failed, while uploading package(s) to the archive server.
3550 You can retry the upload of exactly these same files with dput of:
3551   $changesfile
3552 If that .changes file is broken, you will need to use a new version
3553 number for your next attempt at the upload.
3554 END
3555     my $host = access_cfg('upload-host','RETURN-UNDEF');
3556     my @hostarg = defined($host) ? ($host,) : ();
3557     runcmd_ordryrun @dput, @hostarg, $changesfile;
3558     printdone "pushed and uploaded $cversion";
3559
3560     supplementary_message('');
3561     responder_send_command("complete");
3562 }
3563
3564 sub cmd_clone {
3565     parseopts();
3566     notpushing();
3567     my $dstdir;
3568     badusage "-p is not allowed with clone; specify as argument instead"
3569         if defined $package;
3570     if (@ARGV==1) {
3571         ($package) = @ARGV;
3572     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3573         ($package,$isuite) = @ARGV;
3574     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3575         ($package,$dstdir) = @ARGV;
3576     } elsif (@ARGV==3) {
3577         ($package,$isuite,$dstdir) = @ARGV;
3578     } else {
3579         badusage "incorrect arguments to dgit clone";
3580     }
3581     $dstdir ||= "$package";
3582
3583     if (stat_exists $dstdir) {
3584         fail "$dstdir already exists";
3585     }
3586
3587     my $cwd_remove;
3588     if ($rmonerror && !$dryrun_level) {
3589         $cwd_remove= getcwd();
3590         unshift @end, sub {
3591             return unless defined $cwd_remove;
3592             if (!chdir "$cwd_remove") {
3593                 return if $!==&ENOENT;
3594                 die "chdir $cwd_remove: $!";
3595             }
3596             if (stat $dstdir) {
3597                 rmtree($dstdir) or die "remove $dstdir: $!\n";
3598             } elsif (grep { $! == $_ }
3599                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3600             } else {
3601                 print STDERR "check whether to remove $dstdir: $!\n";
3602             }
3603         };
3604     }
3605
3606     clone($dstdir);
3607     $cwd_remove = undef;
3608 }
3609
3610 sub branchsuite () {
3611     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3612     if ($branch =~ m#$lbranch_re#o) {
3613         return $1;
3614     } else {
3615         return undef;
3616     }
3617 }
3618
3619 sub fetchpullargs () {
3620     notpushing();
3621     if (!defined $package) {
3622         my $sourcep = parsecontrol('debian/control','debian/control');
3623         $package = getfield $sourcep, 'Source';
3624     }
3625     if (@ARGV==0) {
3626 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
3627         if (!$isuite) {
3628             my $clogp = parsechangelog();
3629             $isuite = getfield $clogp, 'Distribution';
3630         }
3631         canonicalise_suite();
3632         progress "fetching from suite $csuite";
3633     } elsif (@ARGV==1) {
3634         ($isuite) = @ARGV;
3635         canonicalise_suite();
3636     } else {
3637         badusage "incorrect arguments to dgit fetch or dgit pull";
3638     }
3639 }
3640
3641 sub cmd_fetch {
3642     parseopts();
3643     fetchpullargs();
3644     fetch();
3645 }
3646
3647 sub cmd_pull {
3648     parseopts();
3649     fetchpullargs();
3650     pull();
3651 }
3652
3653 sub cmd_push {
3654     parseopts();
3655     pushing();
3656     badusage "-p is not allowed with dgit push" if defined $package;
3657     check_not_dirty();
3658     my $clogp = parsechangelog();
3659     $package = getfield $clogp, 'Source';
3660     my $specsuite;
3661     if (@ARGV==0) {
3662     } elsif (@ARGV==1) {
3663         ($specsuite) = (@ARGV);
3664     } else {
3665         badusage "incorrect arguments to dgit push";
3666     }
3667     $isuite = getfield $clogp, 'Distribution';
3668     if ($new_package) {
3669         local ($package) = $existing_package; # this is a hack
3670         canonicalise_suite();
3671     } else {
3672         canonicalise_suite();
3673     }
3674     if (defined $specsuite &&
3675         $specsuite ne $isuite &&
3676         $specsuite ne $csuite) {
3677             fail "dgit push: changelog specifies $isuite ($csuite)".
3678                 " but command line specifies $specsuite";
3679     }
3680     dopush();
3681 }
3682
3683 #---------- remote commands' implementation ----------
3684
3685 sub cmd_remote_push_build_host {
3686     my ($nrargs) = shift @ARGV;
3687     my (@rargs) = @ARGV[0..$nrargs-1];
3688     @ARGV = @ARGV[$nrargs..$#ARGV];
3689     die unless @rargs;
3690     my ($dir,$vsnwant) = @rargs;
3691     # vsnwant is a comma-separated list; we report which we have
3692     # chosen in our ready response (so other end can tell if they
3693     # offered several)
3694     $debugprefix = ' ';
3695     $we_are_responder = 1;
3696     $us .= " (build host)";
3697
3698     pushing();
3699
3700     open PI, "<&STDIN" or die $!;
3701     open STDIN, "/dev/null" or die $!;
3702     open PO, ">&STDOUT" or die $!;
3703     autoflush PO 1;
3704     open STDOUT, ">&STDERR" or die $!;
3705     autoflush STDOUT 1;
3706
3707     $vsnwant //= 1;
3708     ($protovsn) = grep {
3709         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3710     } @rpushprotovsn_support;
3711
3712     fail "build host has dgit rpush protocol versions ".
3713         (join ",", @rpushprotovsn_support).
3714         " but invocation host has $vsnwant"
3715         unless defined $protovsn;
3716
3717     responder_send_command("dgit-remote-push-ready $protovsn");
3718     rpush_handle_protovsn_bothends();
3719     changedir $dir;
3720     &cmd_push;
3721 }
3722
3723 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3724 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3725 #     a good error message)
3726
3727 sub rpush_handle_protovsn_bothends () {
3728     if ($protovsn < 4) {
3729         need_tagformat 'old', "rpush negotiated protocol $protovsn";
3730     }
3731     select_tagformat();
3732 }
3733
3734 our $i_tmp;
3735
3736 sub i_cleanup {
3737     local ($@, $?);
3738     my $report = i_child_report();
3739     if (defined $report) {
3740         printdebug "($report)\n";
3741     } elsif ($i_child_pid) {
3742         printdebug "(killing build host child $i_child_pid)\n";
3743         kill 15, $i_child_pid;
3744     }
3745     if (defined $i_tmp && !defined $initiator_tempdir) {
3746         changedir "/";
3747         eval { rmtree $i_tmp; };
3748     }
3749 }
3750
3751 END { i_cleanup(); }
3752
3753 sub i_method {
3754     my ($base,$selector,@args) = @_;
3755     $selector =~ s/\-/_/g;
3756     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3757 }
3758
3759 sub cmd_rpush {
3760     pushing();
3761     my $host = nextarg;
3762     my $dir;
3763     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3764         $host = $1;
3765         $dir = $'; #';
3766     } else {
3767         $dir = nextarg;
3768     }
3769     $dir =~ s{^-}{./-};
3770     my @rargs = ($dir);
3771     push @rargs, join ",", @rpushprotovsn_support;
3772     my @rdgit;
3773     push @rdgit, @dgit;
3774     push @rdgit, @ropts;
3775     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3776     push @rdgit, @ARGV;
3777     my @cmd = (@ssh, $host, shellquote @rdgit);
3778     debugcmd "+",@cmd;
3779
3780     if (defined $initiator_tempdir) {
3781         rmtree $initiator_tempdir;
3782         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3783         $i_tmp = $initiator_tempdir;
3784     } else {
3785         $i_tmp = tempdir();
3786     }
3787     $i_child_pid = open2(\*RO, \*RI, @cmd);
3788     changedir $i_tmp;
3789     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3790     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3791     $supplementary_message = '' unless $protovsn >= 3;
3792
3793     fail "rpush negotiated protocol version $protovsn".
3794         " which does not support quilt mode $quilt_mode"
3795         if quiltmode_splitbrain;
3796
3797     rpush_handle_protovsn_bothends();
3798     for (;;) {
3799         my ($icmd,$iargs) = initiator_expect {
3800             m/^(\S+)(?: (.*))?$/;
3801             ($1,$2);
3802         };
3803         i_method "i_resp", $icmd, $iargs;
3804     }
3805 }
3806
3807 sub i_resp_progress ($) {
3808     my ($rhs) = @_;
3809     my $msg = protocol_read_bytes \*RO, $rhs;
3810     progress $msg;
3811 }
3812
3813 sub i_resp_supplementary_message ($) {
3814     my ($rhs) = @_;
3815     $supplementary_message = protocol_read_bytes \*RO, $rhs;
3816 }
3817
3818 sub i_resp_complete {
3819     my $pid = $i_child_pid;
3820     $i_child_pid = undef; # prevents killing some other process with same pid
3821     printdebug "waiting for build host child $pid...\n";
3822     my $got = waitpid $pid, 0;
3823     die $! unless $got == $pid;
3824     die "build host child failed $?" if $?;
3825
3826     i_cleanup();
3827     printdebug "all done\n";
3828     exit 0;
3829 }
3830
3831 sub i_resp_file ($) {
3832     my ($keyword) = @_;
3833     my $localname = i_method "i_localname", $keyword;
3834     my $localpath = "$i_tmp/$localname";
3835     stat_exists $localpath and
3836         badproto \*RO, "file $keyword ($localpath) twice";
3837     protocol_receive_file \*RO, $localpath;
3838     i_method "i_file", $keyword;
3839 }
3840
3841 our %i_param;
3842
3843 sub i_resp_param ($) {
3844     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3845     $i_param{$1} = $2;
3846 }
3847
3848 sub i_resp_previously ($) {
3849     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3850         or badproto \*RO, "bad previously spec";
3851     my $r = system qw(git check-ref-format), $1;
3852     die "bad previously ref spec ($r)" if $r;
3853     $previously{$1} = $2;
3854 }
3855
3856 our %i_wanted;
3857
3858 sub i_resp_want ($) {
3859     my ($keyword) = @_;
3860     die "$keyword ?" if $i_wanted{$keyword}++;
3861     my @localpaths = i_method "i_want", $keyword;
3862     printdebug "[[  $keyword @localpaths\n";
3863     foreach my $localpath (@localpaths) {
3864         protocol_send_file \*RI, $localpath;
3865     }
3866     print RI "files-end\n" or die $!;
3867 }
3868
3869 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3870
3871 sub i_localname_parsed_changelog {
3872     return "remote-changelog.822";
3873 }
3874 sub i_file_parsed_changelog {
3875     ($i_clogp, $i_version, $i_dscfn) =
3876         push_parse_changelog "$i_tmp/remote-changelog.822";
3877     die if $i_dscfn =~ m#/|^\W#;
3878 }
3879
3880 sub i_localname_dsc {
3881     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3882     return $i_dscfn;
3883 }
3884 sub i_file_dsc { }
3885
3886 sub i_localname_changes {
3887     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3888     $i_changesfn = $i_dscfn;
3889     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3890     return $i_changesfn;
3891 }
3892 sub i_file_changes { }
3893
3894 sub i_want_signed_tag {
3895     printdebug Dumper(\%i_param, $i_dscfn);
3896     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3897         && defined $i_param{'csuite'}
3898         or badproto \*RO, "premature desire for signed-tag";
3899     my $head = $i_param{'head'};
3900     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3901
3902     my $maintview = $i_param{'maint-view'};
3903     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3904
3905     select_tagformat();
3906     if ($protovsn >= 4) {
3907         my $p = $i_param{'tagformat'} // '<undef>';
3908         $p eq $tagformat
3909             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3910     }
3911
3912     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3913     $csuite = $&;
3914     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3915
3916     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3917
3918     return
3919         push_mktags $i_clogp, $i_dscfn,
3920             $i_changesfn, 'remote changes',
3921             \@tagwants;
3922 }
3923
3924 sub i_want_signed_dsc_changes {
3925     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3926     sign_changes $i_changesfn;
3927     return ($i_dscfn, $i_changesfn);
3928 }
3929
3930 #---------- building etc. ----------
3931
3932 our $version;
3933 our $sourcechanges;
3934 our $dscfn;
3935
3936 #----- `3.0 (quilt)' handling -----
3937
3938 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3939
3940 sub quiltify_dpkg_commit ($$$;$) {
3941     my ($patchname,$author,$msg, $xinfo) = @_;
3942     $xinfo //= '';
3943
3944     mkpath '.git/dgit';
3945     my $descfn = ".git/dgit/quilt-description.tmp";
3946     open O, '>', $descfn or die "$descfn: $!";
3947     $msg =~ s/\n+/\n\n/;
3948     print O <<END or die $!;
3949 From: $author
3950 ${xinfo}Subject: $msg
3951 ---
3952
3953 END
3954     close O or die $!;
3955
3956     {
3957         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3958         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3959         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3960         runcmd @dpkgsource, qw(--commit .), $patchname;
3961     }
3962 }
3963
3964 sub quiltify_trees_differ ($$;$$$) {
3965     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
3966     # returns true iff the two tree objects differ other than in debian/
3967     # with $finegrained,
3968     # returns bitmask 01 - differ in upstream files except .gitignore
3969     #                 02 - differ in .gitignore
3970     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3971     #  is set for each modified .gitignore filename $fn
3972     # if $unrepres is defined, array ref to which is appeneded
3973     #  a list of unrepresentable changes (removals of upstream files
3974     #  (as messages)
3975     local $/=undef;
3976     my @cmd = (@git, qw(diff-tree -z));
3977     push @cmd, qw(--name-only) unless $unrepres;
3978     push @cmd, qw(-r) if $finegrained || $unrepres;
3979     push @cmd, $x, $y;
3980     my $diffs= cmdoutput @cmd;
3981     my $r = 0;
3982     my @lmodes;
3983     foreach my $f (split /\0/, $diffs) {
3984         if ($unrepres && !@lmodes) {
3985             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
3986             next;
3987         }
3988         my ($oldmode,$newmode) = @lmodes;
3989         @lmodes = ();
3990
3991         next if $f =~ m#^debian(?:/.*)?$#s;
3992
3993         if ($unrepres) {
3994             eval {
3995                 die "deleted\n" unless $newmode =~ m/[^0]/;
3996                 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
3997                 if ($oldmode =~ m/[^0]/) {
3998                     die "mode changed\n" if $oldmode ne $newmode;
3999                 } else {
4000                     die "non-default mode\n" unless $newmode =~ m/^100644$/;
4001                 }
4002             };
4003             if ($@) {
4004                 local $/="\n"; chomp $@;
4005                 push @$unrepres, [ $f, $@ ];
4006             }
4007         }
4008
4009         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4010         $r |= $isignore ? 02 : 01;
4011         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4012     }
4013     printdebug "quiltify_trees_differ $x $y => $r\n";
4014     return $r;
4015 }
4016
4017 sub quiltify_tree_sentinelfiles ($) {
4018     # lists the `sentinel' files present in the tree
4019     my ($x) = @_;
4020     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4021         qw(-- debian/rules debian/control);
4022     $r =~ s/\n/,/g;
4023     return $r;
4024 }
4025
4026 sub quiltify_splitbrain_needed () {
4027     if (!$split_brain) {
4028         progress "dgit view: changes are required...";
4029         runcmd @git, qw(checkout -q -b dgit-view);
4030         $split_brain = 1;
4031     }
4032 }
4033
4034 sub quiltify_splitbrain ($$$$$$) {
4035     my ($clogp, $unapplied, $headref, $diffbits,
4036         $editedignores, $cachekey) = @_;
4037     if ($quilt_mode !~ m/gbp|dpm/) {
4038         # treat .gitignore just like any other upstream file
4039         $diffbits = { %$diffbits };
4040         $_ = !!$_ foreach values %$diffbits;
4041     }
4042     # We would like any commits we generate to be reproducible
4043     my @authline = clogp_authline($clogp);
4044     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
4045     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4046     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
4047     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
4048     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4049     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
4050
4051     if ($quilt_mode =~ m/gbp|unapplied/ &&
4052         ($diffbits->{O2H} & 01)) {
4053         my $msg =
4054  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4055  " but git tree differs from orig in upstream files.";
4056         if (!stat_exists "debian/patches") {
4057             $msg .=
4058  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4059         }
4060         fail $msg;
4061     }
4062     if ($quilt_mode =~ m/dpm/ &&
4063         ($diffbits->{H2A} & 01)) {
4064         fail <<END;
4065 --quilt=$quilt_mode specified, implying patches-applied git tree
4066  but git tree differs from result of applying debian/patches to upstream
4067 END
4068     }
4069     if ($quilt_mode =~ m/gbp|unapplied/ &&
4070         ($diffbits->{O2A} & 01)) { # some patches
4071         quiltify_splitbrain_needed();
4072         progress "dgit view: creating patches-applied version using gbp pq";
4073         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4074         # gbp pq import creates a fresh branch; push back to dgit-view
4075         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4076         runcmd @git, qw(checkout -q dgit-view);
4077     }
4078     if ($quilt_mode =~ m/gbp|dpm/ &&
4079         ($diffbits->{O2A} & 02)) {
4080         fail <<END
4081 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4082  tool which does not create patches for changes to upstream
4083  .gitignores: but, such patches exist in debian/patches.
4084 END
4085     }
4086     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4087         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4088         quiltify_splitbrain_needed();
4089         progress "dgit view: creating patch to represent .gitignore changes";
4090         ensuredir "debian/patches";
4091         my $gipatch = "debian/patches/auto-gitignore";
4092         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4093         stat GIPATCH or die "$gipatch: $!";
4094         fail "$gipatch already exists; but want to create it".
4095             " to record .gitignore changes" if (stat _)[7];
4096         print GIPATCH <<END or die "$gipatch: $!";
4097 Subject: Update .gitignore from Debian packaging branch
4098
4099 The Debian packaging git branch contains these updates to the upstream
4100 .gitignore file(s).  This patch is autogenerated, to provide these
4101 updates to users of the official Debian archive view of the package.
4102
4103 [dgit ($our_version) update-gitignore]
4104 ---
4105 END
4106         close GIPATCH or die "$gipatch: $!";
4107         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4108             $unapplied, $headref, "--", sort keys %$editedignores;
4109         open SERIES, "+>>", "debian/patches/series" or die $!;
4110         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4111         my $newline;
4112         defined read SERIES, $newline, 1 or die $!;
4113         print SERIES "\n" or die $! unless $newline eq "\n";
4114         print SERIES "auto-gitignore\n" or die $!;
4115         close SERIES or die  $!;
4116         runcmd @git, qw(add -- debian/patches/series), $gipatch;
4117         commit_admin <<END
4118 Commit patch to update .gitignore
4119
4120 [dgit ($our_version) update-gitignore-quilt-fixup]
4121 END
4122     }
4123
4124     my $dgitview = git_rev_parse 'HEAD';
4125
4126     changedir '../../../..';
4127     # When we no longer need to support squeeze, use --create-reflog
4128     # instead of this:
4129     ensuredir ".git/logs/refs/dgit-intern";
4130     my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4131       or die $!;
4132
4133     my $oldcache = git_get_ref "refs/$splitbraincache";
4134     if ($oldcache eq $dgitview) {
4135         my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4136         # git update-ref doesn't always update, in this case.  *sigh*
4137         my $dummy = make_commit_text <<END;
4138 tree $tree
4139 parent $dgitview
4140 author Dgit <dgit\@example.com> 1000000000 +0000
4141 committer Dgit <dgit\@example.com> 1000000000 +0000
4142
4143 Dummy commit - do not use
4144 END
4145         runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4146             "refs/$splitbraincache", $dummy;
4147     }
4148     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4149         $dgitview;
4150
4151     progress "dgit view: created (commit id $dgitview)";
4152
4153     changedir '.git/dgit/unpack/work';
4154 }
4155
4156 sub quiltify ($$$$) {
4157     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4158
4159     # Quilt patchification algorithm
4160     #
4161     # We search backwards through the history of the main tree's HEAD
4162     # (T) looking for a start commit S whose tree object is identical
4163     # to to the patch tip tree (ie the tree corresponding to the
4164     # current dpkg-committed patch series).  For these purposes
4165     # `identical' disregards anything in debian/ - this wrinkle is
4166     # necessary because dpkg-source treates debian/ specially.
4167     #
4168     # We can only traverse edges where at most one of the ancestors'
4169     # trees differs (in changes outside in debian/).  And we cannot
4170     # handle edges which change .pc/ or debian/patches.  To avoid
4171     # going down a rathole we avoid traversing edges which introduce
4172     # debian/rules or debian/control.  And we set a limit on the
4173     # number of edges we are willing to look at.
4174     #
4175     # If we succeed, we walk forwards again.  For each traversed edge
4176     # PC (with P parent, C child) (starting with P=S and ending with
4177     # C=T) to we do this:
4178     #  - git checkout C
4179     #  - dpkg-source --commit with a patch name and message derived from C
4180     # After traversing PT, we git commit the changes which
4181     # should be contained within debian/patches.
4182
4183     # The search for the path S..T is breadth-first.  We maintain a
4184     # todo list containing search nodes.  A search node identifies a
4185     # commit, and looks something like this:
4186     #  $p = {
4187     #      Commit => $git_commit_id,
4188     #      Child => $c,                          # or undef if P=T
4189     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
4190     #      Nontrivial => true iff $p..$c has relevant changes
4191     #  };
4192
4193     my @todo;
4194     my @nots;
4195     my $sref_S;
4196     my $max_work=100;
4197     my %considered; # saves being exponential on some weird graphs
4198
4199     my $t_sentinels = quiltify_tree_sentinelfiles $target;
4200
4201     my $not = sub {
4202         my ($search,$whynot) = @_;
4203         printdebug " search NOT $search->{Commit} $whynot\n";
4204         $search->{Whynot} = $whynot;
4205         push @nots, $search;
4206         no warnings qw(exiting);
4207         next;
4208     };
4209
4210     push @todo, {
4211         Commit => $target,
4212     };
4213
4214     while (@todo) {
4215         my $c = shift @todo;
4216         next if $considered{$c->{Commit}}++;
4217
4218         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4219
4220         printdebug "quiltify investigate $c->{Commit}\n";
4221
4222         # are we done?
4223         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4224             printdebug " search finished hooray!\n";
4225             $sref_S = $c;
4226             last;
4227         }
4228
4229         if ($quilt_mode eq 'nofix') {
4230             fail "quilt fixup required but quilt mode is \`nofix'\n".
4231                 "HEAD commit $c->{Commit} differs from tree implied by ".
4232                 " debian/patches (tree object $oldtiptree)";
4233         }
4234         if ($quilt_mode eq 'smash') {
4235             printdebug " search quitting smash\n";
4236             last;
4237         }
4238
4239         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4240         $not->($c, "has $c_sentinels not $t_sentinels")
4241             if $c_sentinels ne $t_sentinels;
4242
4243         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4244         $commitdata =~ m/\n\n/;
4245         $commitdata =~ $`;
4246         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4247         @parents = map { { Commit => $_, Child => $c } } @parents;
4248
4249         $not->($c, "root commit") if !@parents;
4250
4251         foreach my $p (@parents) {
4252             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4253         }
4254         my $ndiffers = grep { $_->{Nontrivial} } @parents;
4255         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4256
4257         foreach my $p (@parents) {
4258             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4259
4260             my @cmd= (@git, qw(diff-tree -r --name-only),
4261                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4262             my $patchstackchange = cmdoutput @cmd;
4263             if (length $patchstackchange) {
4264                 $patchstackchange =~ s/\n/,/g;
4265                 $not->($p, "changed $patchstackchange");
4266             }
4267
4268             printdebug " search queue P=$p->{Commit} ",
4269                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4270             push @todo, $p;
4271         }
4272     }
4273
4274     if (!$sref_S) {
4275         printdebug "quiltify want to smash\n";
4276
4277         my $abbrev = sub {
4278             my $x = $_[0]{Commit};
4279             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4280             return $x;
4281         };
4282         my $reportnot = sub {
4283             my ($notp) = @_;
4284             my $s = $abbrev->($notp);
4285             my $c = $notp->{Child};
4286             $s .= "..".$abbrev->($c) if $c;
4287             $s .= ": ".$notp->{Whynot};
4288             return $s;
4289         };
4290         if ($quilt_mode eq 'linear') {
4291             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
4292             foreach my $notp (@nots) {
4293                 print STDERR "$us:  ", $reportnot->($notp), "\n";
4294             }
4295             print STDERR "$us: $_\n" foreach @$failsuggestion;
4296             fail "quilt fixup naive history linearisation failed.\n".
4297  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4298         } elsif ($quilt_mode eq 'smash') {
4299         } elsif ($quilt_mode eq 'auto') {
4300             progress "quilt fixup cannot be linear, smashing...";
4301         } else {
4302             die "$quilt_mode ?";
4303         }
4304
4305         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4306         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4307         my $ncommits = 3;
4308         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4309
4310         quiltify_dpkg_commit "auto-$version-$target-$time",
4311             (getfield $clogp, 'Maintainer'),
4312             "Automatically generated patch ($clogp->{Version})\n".
4313             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4314         return;
4315     }
4316
4317     progress "quiltify linearisation planning successful, executing...";
4318
4319     for (my $p = $sref_S;
4320          my $c = $p->{Child};
4321          $p = $p->{Child}) {
4322         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4323         next unless $p->{Nontrivial};
4324
4325         my $cc = $c->{Commit};
4326
4327         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4328         $commitdata =~ m/\n\n/ or die "$c ?";
4329         $commitdata = $`;
4330         my $msg = $'; #';
4331         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4332         my $author = $1;
4333
4334         my $commitdate = cmdoutput
4335             @git, qw(log -n1 --pretty=format:%aD), $cc;
4336
4337         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4338
4339         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4340         $strip_nls->();
4341
4342         my $title = $1;
4343         my $patchname;
4344         my $patchdir;
4345
4346         my $gbp_check_suitable = sub {
4347             $_ = shift;
4348             my ($what) = @_;
4349
4350             eval {
4351                 die "contains unexpected slashes\n" if m{//} || m{/$};
4352                 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4353                 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4354                 die "too long" if length > 200;
4355             };
4356             return $_ unless $@;
4357             print STDERR "quiltifying commit $cc:".
4358                 " ignoring/dropping Gbp-Pq $what: $@";
4359             return undef;
4360         };
4361
4362         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4363                            gbp-pq-name: \s* )
4364                        (\S+) \s* \n //ixm) {
4365             $patchname = $gbp_check_suitable->($1, 'Name');
4366         }
4367         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4368                            gbp-pq-topic: \s* )
4369                        (\S+) \s* \n //ixm) {
4370             $patchdir = $gbp_check_suitable->($1, 'Topic');
4371         }
4372
4373         $strip_nls->();
4374
4375         if (!defined $patchname) {
4376             $patchname = $title;
4377             $patchname =~ s/[.:]$//;
4378             use Text::Iconv;
4379             eval {
4380                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4381                 my $translitname = $converter->convert($patchname);
4382                 die unless defined $translitname;
4383                 $patchname = $translitname;
4384             };
4385             print STDERR
4386                 "dgit: patch title transliteration error: $@"
4387                 if $@;
4388             $patchname =~ y/ A-Z/-a-z/;
4389             $patchname =~ y/-a-z0-9_.+=~//cd;
4390             $patchname =~ s/^\W/x-$&/;
4391             $patchname = substr($patchname,0,40);
4392         }
4393         if (!defined $patchdir) {
4394             $patchdir = '';
4395         }
4396         if (length $patchdir) {
4397             $patchname = "$patchdir/$patchname";
4398         }
4399         if ($patchname =~ m{^(.*)/}) {
4400             mkpath "debian/patches/$1";
4401         }
4402
4403         my $index;
4404         for ($index='';
4405              stat "debian/patches/$patchname$index";
4406              $index++) { }
4407         $!==ENOENT or die "$patchname$index $!";
4408
4409         runcmd @git, qw(checkout -q), $cc;
4410
4411         # We use the tip's changelog so that dpkg-source doesn't
4412         # produce complaining messages from dpkg-parsechangelog.  None
4413         # of the information dpkg-source gets from the changelog is
4414         # actually relevant - it gets put into the original message
4415         # which dpkg-source provides our stunt editor, and then
4416         # overwritten.
4417         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4418
4419         quiltify_dpkg_commit "$patchname$index", $author, $msg,
4420             "Date: $commitdate\n".
4421             "X-Dgit-Generated: $clogp->{Version} $cc\n";
4422
4423         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4424     }
4425
4426     runcmd @git, qw(checkout -q master);
4427 }
4428
4429 sub build_maybe_quilt_fixup () {
4430     my ($format,$fopts) = get_source_format;
4431     return unless madformat_wantfixup $format;
4432     # sigh
4433
4434     check_for_vendor_patches();
4435
4436     if (quiltmode_splitbrain) {
4437         foreach my $needtf (qw(new maint)) {
4438             next if grep { $_ eq $needtf } access_cfg_tagformats;
4439             fail <<END
4440 quilt mode $quilt_mode requires split view so server needs to support
4441  both "new" and "maint" tag formats, but config says it doesn't.
4442 END
4443         }
4444     }
4445
4446     my $clogp = parsechangelog();
4447     my $headref = git_rev_parse('HEAD');
4448
4449     prep_ud();
4450     changedir $ud;
4451
4452     my $upstreamversion=$version;
4453     $upstreamversion =~ s/-[^-]*$//;
4454
4455     if ($fopts->{'single-debian-patch'}) {
4456         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4457     } else {
4458         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4459     }
4460
4461     die 'bug' if $split_brain && !$need_split_build_invocation;
4462
4463     changedir '../../../..';
4464     runcmd_ordryrun_local
4465         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4466 }
4467
4468 sub quilt_fixup_mkwork ($) {
4469     my ($headref) = @_;
4470
4471     mkdir "work" or die $!;
4472     changedir "work";
4473     mktree_in_ud_here();
4474     runcmd @git, qw(reset -q --hard), $headref;
4475 }
4476
4477 sub quilt_fixup_linkorigs ($$) {
4478     my ($upstreamversion, $fn) = @_;
4479     # calls $fn->($leafname);
4480
4481     foreach my $f (<../../../../*>) { #/){
4482         my $b=$f; $b =~ s{.*/}{};
4483         {
4484             local ($debuglevel) = $debuglevel-1;
4485             printdebug "QF linkorigs $b, $f ?\n";
4486         }
4487         next unless is_orig_file_of_vsn $b, $upstreamversion;
4488         printdebug "QF linkorigs $b, $f Y\n";
4489         link_ltarget $f, $b or die "$b $!";
4490         $fn->($b);
4491     }
4492 }
4493
4494 sub quilt_fixup_delete_pc () {
4495     runcmd @git, qw(rm -rqf .pc);
4496     commit_admin <<END
4497 Commit removal of .pc (quilt series tracking data)
4498
4499 [dgit ($our_version) upgrade quilt-remove-pc]
4500 END
4501 }
4502
4503 sub quilt_fixup_singlepatch ($$$) {
4504     my ($clogp, $headref, $upstreamversion) = @_;
4505
4506     progress "starting quiltify (single-debian-patch)";
4507
4508     # dpkg-source --commit generates new patches even if
4509     # single-debian-patch is in debian/source/options.  In order to
4510     # get it to generate debian/patches/debian-changes, it is
4511     # necessary to build the source package.
4512
4513     quilt_fixup_linkorigs($upstreamversion, sub { });
4514     quilt_fixup_mkwork($headref);
4515
4516     rmtree("debian/patches");
4517
4518     runcmd @dpkgsource, qw(-b .);
4519     changedir "..";
4520     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4521     rename srcfn("$upstreamversion", "/debian/patches"),
4522            "work/debian/patches";
4523
4524     changedir "work";
4525     commit_quilty_patch();
4526 }
4527
4528 sub quilt_make_fake_dsc ($) {
4529     my ($upstreamversion) = @_;
4530
4531     my $fakeversion="$upstreamversion-~~DGITFAKE";
4532
4533     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4534     print $fakedsc <<END or die $!;
4535 Format: 3.0 (quilt)
4536 Source: $package
4537 Version: $fakeversion
4538 Files:
4539 END
4540
4541     my $dscaddfile=sub {
4542         my ($b) = @_;
4543
4544         my $md = new Digest::MD5;
4545
4546         my $fh = new IO::File $b, '<' or die "$b $!";
4547         stat $fh or die $!;
4548         my $size = -s _;
4549
4550         $md->addfile($fh);
4551         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4552     };
4553
4554     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4555
4556     my @files=qw(debian/source/format debian/rules
4557                  debian/control debian/changelog);
4558     foreach my $maybe (qw(debian/patches debian/source/options
4559                           debian/tests/control)) {
4560         next unless stat_exists "../../../$maybe";
4561         push @files, $maybe;
4562     }
4563
4564     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4565     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4566
4567     $dscaddfile->($debtar);
4568     close $fakedsc or die $!;
4569 }
4570
4571 sub quilt_check_splitbrain_cache ($$) {
4572     my ($headref, $upstreamversion) = @_;
4573     # Called only if we are in (potentially) split brain mode.
4574     # Called in $ud.
4575     # Computes the cache key and looks in the cache.
4576     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4577
4578     my $splitbrain_cachekey;
4579
4580     progress
4581  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4582     # we look in the reflog of dgit-intern/quilt-cache
4583     # we look for an entry whose message is the key for the cache lookup
4584     my @cachekey = (qw(dgit), $our_version);
4585     push @cachekey, $upstreamversion;
4586     push @cachekey, $quilt_mode;
4587     push @cachekey, $headref;
4588
4589     push @cachekey, hashfile('fake.dsc');
4590
4591     my $srcshash = Digest::SHA->new(256);
4592     my %sfs = ( %INC, '$0(dgit)' => $0 );
4593     foreach my $sfk (sort keys %sfs) {
4594         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4595         $srcshash->add($sfk,"  ");
4596         $srcshash->add(hashfile($sfs{$sfk}));
4597         $srcshash->add("\n");
4598     }
4599     push @cachekey, $srcshash->hexdigest();
4600     $splitbrain_cachekey = "@cachekey";
4601
4602     my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4603                $splitbraincache);
4604     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4605     debugcmd "|(probably)",@cmd;
4606     my $child = open GC, "-|";  defined $child or die $!;
4607     if (!$child) {
4608         chdir '../../..' or die $!;
4609         if (!stat ".git/logs/refs/$splitbraincache") {
4610             $! == ENOENT or die $!;
4611             printdebug ">(no reflog)\n";
4612             exit 0;
4613         }
4614         exec @cmd; die $!;
4615     }
4616     while (<GC>) {
4617         chomp;
4618         printdebug ">| ", $_, "\n" if $debuglevel > 1;
4619         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4620
4621         my $cachehit = $1;
4622         quilt_fixup_mkwork($headref);
4623         if ($cachehit ne $headref) {
4624             progress "dgit view: found cached (commit id $cachehit)";
4625             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4626             $split_brain = 1;
4627             return ($cachehit, $splitbrain_cachekey);
4628         }
4629         progress "dgit view: found cached, no changes required";
4630         return ($headref, $splitbrain_cachekey);
4631     }
4632     die $! if GC->error;
4633     failedcmd unless close GC;
4634
4635     printdebug "splitbrain cache miss\n";
4636     return (undef, $splitbrain_cachekey);
4637 }
4638
4639 sub quilt_fixup_multipatch ($$$) {
4640     my ($clogp, $headref, $upstreamversion) = @_;
4641
4642     progress "examining quilt state (multiple patches, $quilt_mode mode)";
4643
4644     # Our objective is:
4645     #  - honour any existing .pc in case it has any strangeness
4646     #  - determine the git commit corresponding to the tip of
4647     #    the patch stack (if there is one)
4648     #  - if there is such a git commit, convert each subsequent
4649     #    git commit into a quilt patch with dpkg-source --commit
4650     #  - otherwise convert all the differences in the tree into
4651     #    a single git commit
4652     #
4653     # To do this we:
4654
4655     # Our git tree doesn't necessarily contain .pc.  (Some versions of
4656     # dgit would include the .pc in the git tree.)  If there isn't
4657     # one, we need to generate one by unpacking the patches that we
4658     # have.
4659     #
4660     # We first look for a .pc in the git tree.  If there is one, we
4661     # will use it.  (This is not the normal case.)
4662     #
4663     # Otherwise need to regenerate .pc so that dpkg-source --commit
4664     # can work.  We do this as follows:
4665     #     1. Collect all relevant .orig from parent directory
4666     #     2. Generate a debian.tar.gz out of
4667     #         debian/{patches,rules,source/format,source/options}
4668     #     3. Generate a fake .dsc containing just these fields:
4669     #          Format Source Version Files
4670     #     4. Extract the fake .dsc
4671     #        Now the fake .dsc has a .pc directory.
4672     # (In fact we do this in every case, because in future we will
4673     # want to search for a good base commit for generating patches.)
4674     #
4675     # Then we can actually do the dpkg-source --commit
4676     #     1. Make a new working tree with the same object
4677     #        store as our main tree and check out the main
4678     #        tree's HEAD.
4679     #     2. Copy .pc from the fake's extraction, if necessary
4680     #     3. Run dpkg-source --commit
4681     #     4. If the result has changes to debian/, then
4682     #          - git add them them
4683     #          - git add .pc if we had a .pc in-tree
4684     #          - git commit
4685     #     5. If we had a .pc in-tree, delete it, and git commit
4686     #     6. Back in the main tree, fast forward to the new HEAD
4687
4688     # Another situation we may have to cope with is gbp-style
4689     # patches-unapplied trees.
4690     #
4691     # We would want to detect these, so we know to escape into
4692     # quilt_fixup_gbp.  However, this is in general not possible.
4693     # Consider a package with a one patch which the dgit user reverts
4694     # (with git revert or the moral equivalent).
4695     #
4696     # That is indistinguishable in contents from a patches-unapplied
4697     # tree.  And looking at the history to distinguish them is not
4698     # useful because the user might have made a confusing-looking git
4699     # history structure (which ought to produce an error if dgit can't
4700     # cope, not a silent reintroduction of an unwanted patch).
4701     #
4702     # So gbp users will have to pass an option.  But we can usually
4703     # detect their failure to do so: if the tree is not a clean
4704     # patches-applied tree, quilt linearisation fails, but the tree
4705     # _is_ a clean patches-unapplied tree, we can suggest that maybe
4706     # they want --quilt=unapplied.
4707     #
4708     # To help detect this, when we are extracting the fake dsc, we
4709     # first extract it with --skip-patches, and then apply the patches
4710     # afterwards with dpkg-source --before-build.  That lets us save a
4711     # tree object corresponding to .origs.
4712
4713     my $splitbrain_cachekey;
4714
4715     quilt_make_fake_dsc($upstreamversion);
4716
4717     if (quiltmode_splitbrain()) {
4718         my $cachehit;
4719         ($cachehit, $splitbrain_cachekey) =
4720             quilt_check_splitbrain_cache($headref, $upstreamversion);
4721         return if $cachehit;
4722     }
4723
4724     runcmd qw(sh -ec),
4725         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4726
4727     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4728     rename $fakexdir, "fake" or die "$fakexdir $!";
4729
4730     changedir 'fake';
4731
4732     remove_stray_gits();
4733     mktree_in_ud_here();
4734
4735     rmtree '.pc';
4736
4737     runcmd @git, qw(add -Af .);
4738     my $unapplied=git_write_tree();
4739     printdebug "fake orig tree object $unapplied\n";
4740
4741     ensuredir '.pc';
4742
4743     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4744     $!=0; $?=-1;
4745     if (system @bbcmd) {
4746         failedcmd @bbcmd if $? < 0;
4747         fail <<END;
4748 failed to apply your git tree's patch stack (from debian/patches/) to
4749  the corresponding upstream tarball(s).  Your source tree and .orig
4750  are probably too inconsistent.  dgit can only fix up certain kinds of
4751  anomaly (depending on the quilt mode).  See --quilt= in dgit(1).
4752 END
4753     }
4754
4755     changedir '..';
4756
4757     quilt_fixup_mkwork($headref);
4758
4759     my $mustdeletepc=0;
4760     if (stat_exists ".pc") {
4761         -d _ or die;
4762         progress "Tree already contains .pc - will use it then delete it.";
4763         $mustdeletepc=1;
4764     } else {
4765         rename '../fake/.pc','.pc' or die $!;
4766     }
4767
4768     changedir '../fake';
4769     rmtree '.pc';
4770     runcmd @git, qw(add -Af .);
4771     my $oldtiptree=git_write_tree();
4772     printdebug "fake o+d/p tree object $unapplied\n";
4773     changedir '../work';
4774
4775
4776     # We calculate some guesswork now about what kind of tree this might
4777     # be.  This is mostly for error reporting.
4778
4779     my %editedignores;
4780     my @unrepres;
4781     my $diffbits = {
4782         # H = user's HEAD
4783         # O = orig, without patches applied
4784         # A = "applied", ie orig with H's debian/patches applied
4785         O2H => quiltify_trees_differ($unapplied,$headref,   1,
4786                                      \%editedignores, \@unrepres),
4787         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
4788         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4789     };
4790
4791     my @dl;
4792     foreach my $b (qw(01 02)) {
4793         foreach my $v (qw(O2H O2A H2A)) {
4794             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4795         }
4796     }
4797     printdebug "differences \@dl @dl.\n";
4798
4799     progress sprintf
4800 "$us: base trees orig=%.20s o+d/p=%.20s",
4801               $unapplied, $oldtiptree;
4802     progress sprintf
4803 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
4804 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
4805                              $dl[0], $dl[1],              $dl[3], $dl[4],
4806                                  $dl[2],                     $dl[5];
4807
4808     if (@unrepres) {
4809         print STDERR "dgit:  cannot represent change: $_->[1]: $_->[0]\n"
4810             foreach @unrepres;
4811         forceable_fail [qw(unrepresentable)], <<END;
4812 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4813 END
4814     }
4815
4816     my @failsuggestion;
4817     if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4818         push @failsuggestion, "This might be a patches-unapplied branch.";
4819     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4820         push @failsuggestion, "This might be a patches-applied branch.";
4821     }
4822     push @failsuggestion, "Maybe you need to specify one of".
4823         " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
4824
4825     if (quiltmode_splitbrain()) {
4826         quiltify_splitbrain($clogp, $unapplied, $headref,
4827                             $diffbits, \%editedignores,
4828                             $splitbrain_cachekey);
4829         return;
4830     }
4831
4832     progress "starting quiltify (multiple patches, $quilt_mode mode)";
4833     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4834
4835     if (!open P, '>>', ".pc/applied-patches") {
4836         $!==&ENOENT or die $!;
4837     } else {
4838         close P;
4839     }
4840
4841     commit_quilty_patch();
4842
4843     if ($mustdeletepc) {
4844         quilt_fixup_delete_pc();
4845     }
4846 }
4847
4848 sub quilt_fixup_editor () {
4849     my $descfn = $ENV{$fakeeditorenv};
4850     my $editing = $ARGV[$#ARGV];
4851     open I1, '<', $descfn or die "$descfn: $!";
4852     open I2, '<', $editing or die "$editing: $!";
4853     unlink $editing or die "$editing: $!";
4854     open O, '>', $editing or die "$editing: $!";
4855     while (<I1>) { print O or die $!; } I1->error and die $!;
4856     my $copying = 0;
4857     while (<I2>) {
4858         $copying ||= m/^\-\-\- /;
4859         next unless $copying;
4860         print O or die $!;
4861     }
4862     I2->error and die $!;
4863     close O or die $1;
4864     exit 0;
4865 }
4866
4867 sub maybe_apply_patches_dirtily () {
4868     return unless $quilt_mode =~ m/gbp|unapplied/;
4869     print STDERR <<END or die $!;
4870
4871 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4872 dgit: Have to apply the patches - making the tree dirty.
4873 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4874
4875 END
4876     $patches_applied_dirtily = 01;
4877     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4878     runcmd qw(dpkg-source --before-build .);
4879 }
4880
4881 sub maybe_unapply_patches_again () {
4882     progress "dgit: Unapplying patches again to tidy up the tree."
4883         if $patches_applied_dirtily;
4884     runcmd qw(dpkg-source --after-build .)
4885         if $patches_applied_dirtily & 01;
4886     rmtree '.pc'
4887         if $patches_applied_dirtily & 02;
4888     $patches_applied_dirtily = 0;
4889 }
4890
4891 #----- other building -----
4892
4893 our $clean_using_builder;
4894 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4895 #   clean the tree before building (perhaps invoked indirectly by
4896 #   whatever we are using to run the build), rather than separately
4897 #   and explicitly by us.
4898
4899 sub clean_tree () {
4900     return if $clean_using_builder;
4901     if ($cleanmode eq 'dpkg-source') {
4902         maybe_apply_patches_dirtily();
4903         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4904     } elsif ($cleanmode eq 'dpkg-source-d') {
4905         maybe_apply_patches_dirtily();
4906         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4907     } elsif ($cleanmode eq 'git') {
4908         runcmd_ordryrun_local @git, qw(clean -xdf);
4909     } elsif ($cleanmode eq 'git-ff') {
4910         runcmd_ordryrun_local @git, qw(clean -xdff);
4911     } elsif ($cleanmode eq 'check') {
4912         my $leftovers = cmdoutput @git, qw(clean -xdn);
4913         if (length $leftovers) {
4914             print STDERR $leftovers, "\n" or die $!;
4915             fail "tree contains uncommitted files and --clean=check specified";
4916         }
4917     } elsif ($cleanmode eq 'none') {
4918     } else {
4919         die "$cleanmode ?";
4920     }
4921 }
4922
4923 sub cmd_clean () {
4924     badusage "clean takes no additional arguments" if @ARGV;
4925     notpushing();
4926     clean_tree();
4927     maybe_unapply_patches_again();
4928 }
4929
4930 sub build_prep () {
4931     notpushing();
4932     badusage "-p is not allowed when building" if defined $package;
4933     check_not_dirty();
4934     clean_tree();
4935     my $clogp = parsechangelog();
4936     $isuite = getfield $clogp, 'Distribution';
4937     $package = getfield $clogp, 'Source';
4938     $version = getfield $clogp, 'Version';
4939     build_maybe_quilt_fixup();
4940     if ($rmchanges) {
4941         my $pat = changespat $version;
4942         foreach my $f (glob "$buildproductsdir/$pat") {
4943             if (act_local()) {
4944                 unlink $f or fail "remove old changes file $f: $!";
4945             } else {
4946                 progress "would remove $f";
4947             }
4948         }
4949     }
4950 }
4951
4952 sub changesopts_initial () {
4953     my @opts =@changesopts[1..$#changesopts];
4954 }
4955
4956 sub changesopts_version () {
4957     if (!defined $changes_since_version) {
4958         my @vsns = archive_query('archive_query');
4959         my @quirk = access_quirk();
4960         if ($quirk[0] eq 'backports') {
4961             local $isuite = $quirk[2];
4962             local $csuite;
4963             canonicalise_suite();
4964             push @vsns, archive_query('archive_query');
4965         }
4966         if (@vsns) {
4967             @vsns = map { $_->[0] } @vsns;
4968             @vsns = sort { -version_compare($a, $b) } @vsns;
4969             $changes_since_version = $vsns[0];
4970             progress "changelog will contain changes since $vsns[0]";
4971         } else {
4972             $changes_since_version = '_';
4973             progress "package seems new, not specifying -v<version>";
4974         }
4975     }
4976     if ($changes_since_version ne '_') {
4977         return ("-v$changes_since_version");
4978     } else {
4979         return ();
4980     }
4981 }
4982
4983 sub changesopts () {
4984     return (changesopts_initial(), changesopts_version());
4985 }
4986
4987 sub massage_dbp_args ($;$) {
4988     my ($cmd,$xargs) = @_;
4989     # We need to:
4990     #
4991     #  - if we're going to split the source build out so we can
4992     #    do strange things to it, massage the arguments to dpkg-buildpackage
4993     #    so that the main build doessn't build source (or add an argument
4994     #    to stop it building source by default).
4995     #
4996     #  - add -nc to stop dpkg-source cleaning the source tree,
4997     #    unless we're not doing a split build and want dpkg-source
4998     #    as cleanmode, in which case we can do nothing
4999     #
5000     # return values:
5001     #    0 - source will NOT need to be built separately by caller
5002     #   +1 - source will need to be built separately by caller
5003     #   +2 - source will need to be built separately by caller AND
5004     #        dpkg-buildpackage should not in fact be run at all!
5005     debugcmd '#massaging#', @$cmd if $debuglevel>1;
5006 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5007     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5008         $clean_using_builder = 1;
5009         return 0;
5010     }
5011     # -nc has the side effect of specifying -b if nothing else specified
5012     # and some combinations of -S, -b, et al, are errors, rather than
5013     # later simply overriding earlie.  So we need to:
5014     #  - search the command line for these options
5015     #  - pick the last one
5016     #  - perhaps add our own as a default
5017     #  - perhaps adjust it to the corresponding non-source-building version
5018     my $dmode = '-F';
5019     foreach my $l ($cmd, $xargs) {
5020         next unless $l;
5021         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5022     }
5023     push @$cmd, '-nc';
5024 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5025     my $r = 0;
5026     if ($need_split_build_invocation) {
5027         printdebug "massage split $dmode.\n";
5028         $r = $dmode =~ m/[S]/     ? +2 :
5029              $dmode =~ y/gGF/ABb/ ? +1 :
5030              $dmode =~ m/[ABb]/   ?  0 :
5031              die "$dmode ?";
5032     }
5033     printdebug "massage done $r $dmode.\n";
5034     push @$cmd, $dmode;
5035 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5036     return $r;
5037 }
5038
5039 sub in_parent (&) {
5040     my ($fn) = @_;
5041     my $wasdir = must_getcwd();
5042     changedir "..";
5043     $fn->();
5044     changedir $wasdir;
5045 }
5046
5047 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5048     my ($msg_if_onlyone) = @_;
5049     # If there is only one .changes file, fail with $msg_if_onlyone,
5050     # or if that is undef, be a no-op.
5051     # Returns the changes file to report to the user.
5052     my $pat = changespat $version;
5053     my @changesfiles = glob $pat;
5054     @changesfiles = sort {
5055         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5056             or $a cmp $b
5057     } @changesfiles;
5058     my $result;
5059     if (@changesfiles==1) {
5060         fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5061 only one changes file from build (@changesfiles)
5062 END
5063         $result = $changesfiles[0];
5064     } elsif (@changesfiles==2) {
5065         my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5066         foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5067             fail "$l found in binaries changes file $binchanges"
5068                 if $l =~ m/\.dsc$/;
5069         }
5070         runcmd_ordryrun_local @mergechanges, @changesfiles;
5071         my $multichanges = changespat $version,'multi';
5072         if (act_local()) {
5073             stat_exists $multichanges or fail "$multichanges: $!";
5074             foreach my $cf (glob $pat) {
5075                 next if $cf eq $multichanges;
5076                 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5077             }
5078         }
5079         $result = $multichanges;
5080     } else {
5081         fail "wrong number of different changes files (@changesfiles)";
5082     }
5083     printdone "build successful, results in $result\n" or die $!;
5084 }
5085
5086 sub midbuild_checkchanges () {
5087     my $pat = changespat $version;
5088     return if $rmchanges;
5089     my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5090     @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5091     fail <<END
5092 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5093 Suggest you delete @unwanted.
5094 END
5095         if @unwanted;
5096 }
5097
5098 sub midbuild_checkchanges_vanilla ($) {
5099     my ($wantsrc) = @_;
5100     midbuild_checkchanges() if $wantsrc == 1;
5101 }
5102
5103 sub postbuild_mergechanges_vanilla ($) {
5104     my ($wantsrc) = @_;
5105     if ($wantsrc == 1) {
5106         in_parent {
5107             postbuild_mergechanges(undef);
5108         };
5109     } else {
5110         printdone "build successful\n";
5111     }
5112 }
5113
5114 sub cmd_build {
5115     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5116     my $wantsrc = massage_dbp_args \@dbp;
5117     if ($wantsrc > 0) {
5118         build_source();
5119         midbuild_checkchanges_vanilla $wantsrc;
5120     } else {
5121         build_prep();
5122     }
5123     if ($wantsrc < 2) {
5124         push @dbp, changesopts_version();
5125         maybe_apply_patches_dirtily();
5126         runcmd_ordryrun_local @dbp;
5127     }
5128     maybe_unapply_patches_again();
5129     postbuild_mergechanges_vanilla $wantsrc;
5130 }
5131
5132 sub pre_gbp_build {
5133     $quilt_mode //= 'gbp';
5134 }
5135
5136 sub cmd_gbp_build {
5137     my @dbp = @dpkgbuildpackage;
5138
5139     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5140
5141     if (!length $gbp_build[0]) {
5142         if (length executable_on_path('git-buildpackage')) {
5143             $gbp_build[0] = qw(git-buildpackage);
5144         } else {
5145             $gbp_build[0] = 'gbp buildpackage';
5146         }
5147     }
5148     my @cmd = opts_opt_multi_cmd @gbp_build;
5149
5150     push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5151
5152     if ($wantsrc > 0) {
5153         build_source();
5154         midbuild_checkchanges_vanilla $wantsrc;
5155     } else {
5156         if (!$clean_using_builder) {
5157             push @cmd, '--git-cleaner=true';
5158         }
5159         build_prep();
5160     }
5161     maybe_unapply_patches_again();
5162     if ($wantsrc < 2) {
5163         push @cmd, changesopts();
5164         runcmd_ordryrun_local @cmd, @ARGV;
5165     }
5166     postbuild_mergechanges_vanilla $wantsrc;
5167 }
5168 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5169
5170 sub build_source {
5171     my $our_cleanmode = $cleanmode;
5172     if ($need_split_build_invocation) {
5173         # Pretend that clean is being done some other way.  This
5174         # forces us not to try to use dpkg-buildpackage to clean and
5175         # build source all in one go; and instead we run dpkg-source
5176         # (and build_prep() will do the clean since $clean_using_builder
5177         # is false).
5178         $our_cleanmode = 'ELSEWHERE';
5179     }
5180     if ($our_cleanmode =~ m/^dpkg-source/) {
5181         # dpkg-source invocation (below) will clean, so build_prep shouldn't
5182         $clean_using_builder = 1;
5183     }
5184     build_prep();
5185     $sourcechanges = changespat $version,'source';
5186     if (act_local()) {
5187         unlink "../$sourcechanges" or $!==ENOENT
5188             or fail "remove $sourcechanges: $!";
5189     }
5190     $dscfn = dscfn($version);
5191     if ($our_cleanmode eq 'dpkg-source') {
5192         maybe_apply_patches_dirtily();
5193         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5194             changesopts();
5195     } elsif ($our_cleanmode eq 'dpkg-source-d') {
5196         maybe_apply_patches_dirtily();
5197         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5198             changesopts();
5199     } else {
5200         my @cmd = (@dpkgsource, qw(-b --));
5201         if ($split_brain) {
5202             changedir $ud;
5203             runcmd_ordryrun_local @cmd, "work";
5204             my @udfiles = <${package}_*>;
5205             changedir "../../..";
5206             foreach my $f (@udfiles) {
5207                 printdebug "source copy, found $f\n";
5208                 next unless
5209                     $f eq $dscfn or
5210                     ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5211                      $f eq srcfn($version, $&));
5212                 printdebug "source copy, found $f - renaming\n";
5213                 rename "$ud/$f", "../$f" or $!==ENOENT
5214                     or fail "put in place new source file ($f): $!";
5215             }
5216         } else {
5217             my $pwd = must_getcwd();
5218             my $leafdir = basename $pwd;
5219             changedir "..";
5220             runcmd_ordryrun_local @cmd, $leafdir;
5221             changedir $pwd;
5222         }
5223         runcmd_ordryrun_local qw(sh -ec),
5224             'exec >$1; shift; exec "$@"','x',
5225             "../$sourcechanges",
5226             @dpkggenchanges, qw(-S), changesopts();
5227     }
5228 }
5229
5230 sub cmd_build_source {
5231     badusage "build-source takes no additional arguments" if @ARGV;
5232     build_source();
5233     maybe_unapply_patches_again();
5234     printdone "source built, results in $dscfn and $sourcechanges";
5235 }
5236
5237 sub cmd_sbuild {
5238     build_source();
5239     midbuild_checkchanges();
5240     in_parent {
5241         if (act_local()) {
5242             stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5243             stat_exists $sourcechanges
5244                 or fail "$sourcechanges (in parent directory): $!";
5245         }
5246         runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5247     };
5248     maybe_unapply_patches_again();
5249     in_parent {
5250         postbuild_mergechanges(<<END);
5251 perhaps you need to pass -A ?  (sbuild's default is to build only
5252 arch-specific binaries; dgit 1.4 used to override that.)
5253 END
5254     };
5255 }
5256
5257 sub cmd_quilt_fixup {
5258     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5259     my $clogp = parsechangelog();
5260     $version = getfield $clogp, 'Version';
5261     $package = getfield $clogp, 'Source';
5262     check_not_dirty();
5263     clean_tree();
5264     build_maybe_quilt_fixup();
5265 }
5266
5267 sub cmd_archive_api_query {
5268     badusage "need only 1 subpath argument" unless @ARGV==1;
5269     my ($subpath) = @ARGV;
5270     my @cmd = archive_api_query_cmd($subpath);
5271     push @cmd, qw(-f);
5272     debugcmd ">",@cmd;
5273     exec @cmd or fail "exec curl: $!\n";
5274 }
5275
5276 sub cmd_clone_dgit_repos_server {
5277     badusage "need destination argument" unless @ARGV==1;
5278     my ($destdir) = @ARGV;
5279     $package = '_dgit-repos-server';
5280     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5281     debugcmd ">",@cmd;
5282     exec @cmd or fail "exec git clone: $!\n";
5283 }
5284
5285 sub cmd_setup_mergechangelogs {
5286     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5287     setup_mergechangelogs(1);
5288 }
5289
5290 sub cmd_setup_useremail {
5291     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5292     setup_useremail(1);
5293 }
5294
5295 sub cmd_setup_new_tree {
5296     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5297     setup_new_tree();
5298 }
5299
5300 #---------- argument parsing and main program ----------
5301
5302 sub cmd_version {
5303     print "dgit version $our_version\n" or die $!;
5304     exit 0;
5305 }
5306
5307 our (%valopts_long, %valopts_short);
5308 our @rvalopts;
5309
5310 sub defvalopt ($$$$) {
5311     my ($long,$short,$val_re,$how) = @_;
5312     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5313     $valopts_long{$long} = $oi;
5314     $valopts_short{$short} = $oi;
5315     # $how subref should:
5316     #   do whatever assignemnt or thing it likes with $_[0]
5317     #   if the option should not be passed on to remote, @rvalopts=()
5318     # or $how can be a scalar ref, meaning simply assign the value
5319 }
5320
5321 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5322 defvalopt '--distro',        '-d', '.+',      \$idistro;
5323 defvalopt '',                '-k', '.+',      \$keyid;
5324 defvalopt '--existing-package','', '.*',      \$existing_package;
5325 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
5326 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
5327 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
5328
5329 defvalopt '', '-C', '.+', sub {
5330     ($changesfile) = (@_);
5331     if ($changesfile =~ s#^(.*)/##) {
5332         $buildproductsdir = $1;
5333     }
5334 };
5335
5336 defvalopt '--initiator-tempdir','','.*', sub {
5337     ($initiator_tempdir) = (@_);
5338     $initiator_tempdir =~ m#^/# or
5339         badusage "--initiator-tempdir must be used specify an".
5340         " absolute, not relative, directory."
5341 };
5342
5343 sub parseopts () {
5344     my $om;
5345
5346     if (defined $ENV{'DGIT_SSH'}) {
5347         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5348     } elsif (defined $ENV{'GIT_SSH'}) {
5349         @ssh = ($ENV{'GIT_SSH'});
5350     }
5351
5352     my $oi;
5353     my $val;
5354     my $valopt = sub {
5355         my ($what) = @_;
5356         @rvalopts = ($_);
5357         if (!defined $val) {
5358             badusage "$what needs a value" unless @ARGV;
5359             $val = shift @ARGV;
5360             push @rvalopts, $val;
5361         }
5362         badusage "bad value \`$val' for $what" unless
5363             $val =~ m/^$oi->{Re}$(?!\n)/s;
5364         my $how = $oi->{How};
5365         if (ref($how) eq 'SCALAR') {
5366             $$how = $val;
5367         } else {
5368             $how->($val);
5369         }
5370         push @ropts, @rvalopts;
5371     };
5372
5373     while (@ARGV) {
5374         last unless $ARGV[0] =~ m/^-/;
5375         $_ = shift @ARGV;
5376         last if m/^--?$/;
5377         if (m/^--/) {
5378             if (m/^--dry-run$/) {
5379                 push @ropts, $_;
5380                 $dryrun_level=2;
5381             } elsif (m/^--damp-run$/) {
5382                 push @ropts, $_;
5383                 $dryrun_level=1;
5384             } elsif (m/^--no-sign$/) {
5385                 push @ropts, $_;
5386                 $sign=0;
5387             } elsif (m/^--help$/) {
5388                 cmd_help();
5389             } elsif (m/^--version$/) {
5390                 cmd_version();
5391             } elsif (m/^--new$/) {
5392                 push @ropts, $_;
5393                 $new_package=1;
5394             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5395                      ($om = $opts_opt_map{$1}) &&
5396                      length $om->[0]) {
5397                 push @ropts, $_;
5398                 $om->[0] = $2;
5399             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5400                      !$opts_opt_cmdonly{$1} &&
5401                      ($om = $opts_opt_map{$1})) {
5402                 push @ropts, $_;
5403                 push @$om, $2;
5404             } elsif (m/^--(gbp|dpm)$/s) {
5405                 push @ropts, "--quilt=$1";
5406                 $quilt_mode = $1;
5407             } elsif (m/^--ignore-dirty$/s) {
5408                 push @ropts, $_;
5409                 $ignoredirty = 1;
5410             } elsif (m/^--no-quilt-fixup$/s) {
5411                 push @ropts, $_;
5412                 $quilt_mode = 'nocheck';
5413             } elsif (m/^--no-rm-on-error$/s) {
5414                 push @ropts, $_;
5415                 $rmonerror = 0;
5416             } elsif (m/^--overwrite$/s) {
5417                 push @ropts, $_;
5418                 $overwrite_version = '';
5419             } elsif (m/^--overwrite=(.+)$/s) {
5420                 push @ropts, $_;
5421                 $overwrite_version = $1;
5422             } elsif (m/^--(no-)?rm-old-changes$/s) {
5423                 push @ropts, $_;
5424                 $rmchanges = !$1;
5425             } elsif (m/^--deliberately-($deliberately_re)$/s) {
5426                 push @ropts, $_;
5427                 push @deliberatelies, $&;
5428             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
5429                 push @ropts, $&;
5430                 $forceopts{$1} = 1;
5431                 $_='';
5432             } elsif (m/^--force-/) {
5433                 print STDERR
5434                     "$us: warning: ignoring unknown force option $_\n";
5435                 $_='';
5436             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5437                 # undocumented, for testing
5438                 push @ropts, $_;
5439                 $tagformat_want = [ $1, 'command line', 1 ];
5440                 # 1 menas overrides distro configuration
5441             } elsif (m/^--always-split-source-build$/s) {
5442                 # undocumented, for testing
5443                 push @ropts, $_;
5444                 $need_split_build_invocation = 1;
5445             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5446                 $val = $2 ? $' : undef; #';
5447                 $valopt->($oi->{Long});
5448             } else {
5449                 badusage "unknown long option \`$_'";
5450             }
5451         } else {
5452             while (m/^-./s) {
5453                 if (s/^-n/-/) {
5454                     push @ropts, $&;
5455                     $dryrun_level=2;
5456                 } elsif (s/^-L/-/) {
5457                     push @ropts, $&;
5458                     $dryrun_level=1;
5459                 } elsif (s/^-h/-/) {
5460                     cmd_help();
5461                 } elsif (s/^-D/-/) {
5462                     push @ropts, $&;
5463                     $debuglevel++;
5464                     enabledebug();
5465                 } elsif (s/^-N/-/) {
5466                     push @ropts, $&;
5467                     $new_package=1;
5468                 } elsif (m/^-m/) {
5469                     push @ropts, $&;
5470                     push @changesopts, $_;
5471                     $_ = '';
5472                 } elsif (s/^-wn$//s) {
5473                     push @ropts, $&;
5474                     $cleanmode = 'none';
5475                 } elsif (s/^-wg$//s) {
5476                     push @ropts, $&;
5477                     $cleanmode = 'git';
5478                 } elsif (s/^-wgf$//s) {
5479                     push @ropts, $&;
5480                     $cleanmode = 'git-ff';
5481                 } elsif (s/^-wd$//s) {
5482                     push @ropts, $&;
5483                     $cleanmode = 'dpkg-source';
5484                 } elsif (s/^-wdd$//s) {
5485                     push @ropts, $&;
5486                     $cleanmode = 'dpkg-source-d';
5487                 } elsif (s/^-wc$//s) {
5488                     push @ropts, $&;
5489                     $cleanmode = 'check';
5490                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5491                     push @git, '-c', $&;
5492                     $gitcfgs{cmdline}{$1} = [ $2 ];
5493                 } elsif (s/^-c([^=]+)$//s) {
5494                     push @git, '-c', $&;
5495                     $gitcfgs{cmdline}{$1} = [ 'true' ];
5496                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5497                     $val = $'; #';
5498                     $val = undef unless length $val;
5499                     $valopt->($oi->{Short});
5500                     $_ = '';
5501                 } else {
5502                     badusage "unknown short option \`$_'";
5503                 }
5504             }
5505         }
5506     }
5507 }
5508
5509 sub check_env_sanity () {
5510     my $blocked = new POSIX::SigSet;
5511     sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5512
5513     eval {
5514         foreach my $name (qw(PIPE CHLD)) {
5515             my $signame = "SIG$name";
5516             my $signum = eval "POSIX::$signame" // die;
5517             ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5518                 die "$signame is set to something other than SIG_DFL\n";
5519             $blocked->ismember($signum) and
5520                 die "$signame is blocked\n";
5521         }
5522     };
5523     return unless $@;
5524     chomp $@;
5525     fail <<END;
5526 On entry to dgit, $@
5527 This is a bug produced by something in in your execution environment.
5528 Giving up.
5529 END
5530 }
5531
5532
5533 sub finalise_opts_opts () {
5534     foreach my $k (keys %opts_opt_map) {
5535         my $om = $opts_opt_map{$k};
5536
5537         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5538         if (defined $v) {
5539             badcfg "cannot set command for $k"
5540                 unless length $om->[0];
5541             $om->[0] = $v;
5542         }
5543
5544         foreach my $c (access_cfg_cfgs("opts-$k")) {
5545             my @vl =
5546                 map { $_ ? @$_ : () }
5547                 map { $gitcfgs{$_}{$c} }
5548                 reverse @gitcfgsources;
5549             printdebug "CL $c ", (join " ", map { shellquote } @vl),
5550                 "\n" if $debuglevel >= 4;
5551             next unless @vl;
5552             badcfg "cannot configure options for $k"
5553                 if $opts_opt_cmdonly{$k};
5554             my $insertpos = $opts_cfg_insertpos{$k};
5555             @$om = ( @$om[0..$insertpos-1],
5556                      @vl,
5557                      @$om[$insertpos..$#$om] );
5558         }
5559     }
5560 }
5561
5562 if ($ENV{$fakeeditorenv}) {
5563     git_slurp_config();
5564     quilt_fixup_editor();
5565 }
5566
5567 parseopts();
5568 check_env_sanity();
5569 git_slurp_config();
5570
5571 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5572 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5573     if $dryrun_level == 1;
5574 if (!@ARGV) {
5575     print STDERR $helpmsg or die $!;
5576     exit 8;
5577 }
5578 my $cmd = shift @ARGV;
5579 $cmd =~ y/-/_/;
5580
5581 my $pre_fn = ${*::}{"pre_$cmd"};
5582 $pre_fn->() if $pre_fn;
5583
5584 if (!defined $rmchanges) {
5585     local $access_forpush;
5586     $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5587 }
5588
5589 if (!defined $quilt_mode) {
5590     local $access_forpush;
5591     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5592         // access_cfg('quilt-mode', 'RETURN-UNDEF')
5593         // 'linear';
5594     $quilt_mode =~ m/^($quilt_modes_re)$/
5595         or badcfg "unknown quilt-mode \`$quilt_mode'";
5596     $quilt_mode = $1;
5597 }
5598
5599 $need_split_build_invocation ||= quiltmode_splitbrain();
5600
5601 if (!defined $cleanmode) {
5602     local $access_forpush;
5603     $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5604     $cleanmode //= 'dpkg-source';
5605
5606     badcfg "unknown clean-mode \`$cleanmode'" unless
5607         $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5608 }
5609
5610 my $fn = ${*::}{"cmd_$cmd"};
5611 $fn or badusage "unknown operation $cmd";
5612 $fn->();