dgit

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