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: source 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
2211     return if $buildproductsdir eq '..';
2212
2213     my $warned;
2214     my $dotdot = $maindir;
2215     $dotdot =~ s{/[^/]+$}{};
2216     opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2217     while ($!=0, defined(my $leaf = readdir DD)) {
2218         {
2219             local ($debuglevel) = $debuglevel-1;
2220             printdebug "DD_BPD $leaf ?\n";
2221         }
2222         next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2223         next unless $wanted->($leaf);
2224         next if lstat "$bpd_abs/$leaf";
2225
2226         print STDERR f_
2227  "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2228             $us
2229             unless $warned++;
2230         $! == &ENOENT or fail f_
2231             "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2232         lstat "$dotdot/$leaf" or fail f_
2233             "check orig file %s in ..: %s", $leaf, $!;
2234         if (-l _) {
2235             stat "$dotdot/$leaf" or fail f_
2236                 "check targe of orig symlink %s in ..: %s", $leaf, $!;
2237             my $ltarget = readlink "$dotdot/$leaf" or
2238                 die "readlink $dotdot/$leaf: $!";
2239             if ($ltarget !~ m{^/}) {
2240                 $ltarget = "$dotdot/$ltarget";
2241             }
2242             symlink $ltarget, "$bpd_abs/$leaf"
2243                 or die "$ltarget $bpd_abs $leaf: $!";
2244             print STDERR f_
2245  "%s: cloned orig symlink from ..: %s\n",
2246                 $us, $leaf;
2247         } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2248             print STDERR f_
2249  "%s: hardlinked orig from ..: %s\n",
2250                 $us, $leaf;
2251         } elsif ($! != EXDEV) {
2252             fail f_ "failed to make %s a hardlink to %s: %s",
2253                 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2254         } else {
2255             symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2256                 or die "$bpd_abs $dotdot $leaf $!";
2257             print STDERR f_
2258  "%s: symmlinked orig from .. on other filesystem: %s\n",
2259                 $us, $leaf;
2260         }
2261     }
2262     die "$dotdot; $!" if $!;
2263     closedir DD;
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     dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2277         sub { grep { $_->{Filename} eq $_[0] } @dfi };
2278
2279     foreach my $fi (@dfi) {
2280         my $f = $fi->{Filename};
2281         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2282         my $upper_f = "$bpd_abs/$f";
2283
2284         printdebug "considering reusing $f: ";
2285
2286         if (link_ltarget "$upper_f,fetch", $f) {
2287             printdebug "linked (using ...,fetch).\n";
2288         } elsif ((printdebug "($!) "),
2289                  $! != ENOENT) {
2290             fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2291         } elsif (link_ltarget $upper_f, $f) {
2292             printdebug "linked.\n";
2293         } elsif ((printdebug "($!) "),
2294                  $! != ENOENT) {
2295             fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2296         } else {
2297             printdebug "absent.\n";
2298         }
2299
2300         my $refetched;
2301         complete_file_from_dsc('.', $fi, \$refetched)
2302             or next;
2303
2304         printdebug "considering saving $f: ";
2305
2306         if (rename_link_xf 1, $f, $upper_f) {
2307             printdebug "linked.\n";
2308         } elsif ((printdebug "($@) "),
2309                  $! != EEXIST) {
2310             fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2311         } elsif (!$refetched) {
2312             printdebug "no need.\n";
2313         } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2314             printdebug "linked (using ...,fetch).\n";
2315         } elsif ((printdebug "($@) "),
2316                  $! != EEXIST) {
2317             fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2318         } else {
2319             printdebug "cannot.\n";
2320         }
2321     }
2322
2323     # We unpack and record the orig tarballs first, so that we only
2324     # need disk space for one private copy of the unpacked source.
2325     # But we can't make them into commits until we have the metadata
2326     # from the debian/changelog, so we record the tree objects now and
2327     # make them into commits later.
2328     my @tartrees;
2329     my $orig_f_base = srcfn $upstreamv, '';
2330
2331     foreach my $fi (@dfi) {
2332         # We actually import, and record as a commit, every tarball
2333         # (unless there is only one file, in which case there seems
2334         # little point.
2335
2336         my $f = $fi->{Filename};
2337         printdebug "import considering $f ";
2338         (printdebug "only one dfi\n"), next if @dfi == 1;
2339         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2340         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2341         my $compr_ext = $1;
2342
2343         my ($orig_f_part) =
2344             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2345
2346         printdebug "Y ", (join ' ', map { $_//"(none)" }
2347                           $compr_ext, $orig_f_part
2348                          ), "\n";
2349
2350         my $input = new IO::File $f, '<' or die "$f $!";
2351         my $compr_pid;
2352         my @compr_cmd;
2353
2354         if (defined $compr_ext) {
2355             my $cname =
2356                 Dpkg::Compression::compression_guess_from_filename $f;
2357             fail "Dpkg::Compression cannot handle file $f in source package"
2358                 if defined $compr_ext && !defined $cname;
2359             my $compr_proc =
2360                 new Dpkg::Compression::Process compression => $cname;
2361             @compr_cmd = $compr_proc->get_uncompress_cmdline();
2362             my $compr_fh = new IO::Handle;
2363             my $compr_pid = open $compr_fh, "-|" // confess $!;
2364             if (!$compr_pid) {
2365                 open STDIN, "<&", $input or confess $!;
2366                 exec @compr_cmd;
2367                 die "dgit (child): exec $compr_cmd[0]: $!\n";
2368             }
2369             $input = $compr_fh;
2370         }
2371
2372         rmtree "_unpack-tar";
2373         mkdir "_unpack-tar" or confess $!;
2374         my @tarcmd = qw(tar -x -f -
2375                         --no-same-owner --no-same-permissions
2376                         --no-acls --no-xattrs --no-selinux);
2377         my $tar_pid = fork // confess $!;
2378         if (!$tar_pid) {
2379             chdir "_unpack-tar" or confess $!;
2380             open STDIN, "<&", $input or confess $!;
2381             exec @tarcmd;
2382             die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2383         }
2384         $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess $!;
2385         !$? or failedcmd @tarcmd;
2386
2387         close $input or
2388             (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2389              : confess $!);
2390         # finally, we have the results in "tarball", but maybe
2391         # with the wrong permissions
2392
2393         runcmd qw(chmod -R +rwX _unpack-tar);
2394         changedir "_unpack-tar";
2395         remove_stray_gits($f);
2396         mktree_in_ud_here();
2397
2398         my ($tree) = git_add_write_tree();
2399         my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2400         if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2401             $tree = $1;
2402             printdebug "one subtree $1\n";
2403         } else {
2404             printdebug "multiple subtrees\n";
2405         }
2406         changedir "..";
2407         rmtree "_unpack-tar";
2408
2409         my $ent = [ $f, $tree ];
2410         push @tartrees, {
2411             Orig => !!$orig_f_part,
2412             Sort => (!$orig_f_part         ? 2 :
2413                      $orig_f_part =~ m/-/g ? 1 :
2414                                              0),
2415             F => $f,
2416             Tree => $tree,
2417         };
2418     }
2419
2420     @tartrees = sort {
2421         # put any without "_" first (spec is not clear whether files
2422         # are always in the usual order).  Tarballs without "_" are
2423         # the main orig or the debian tarball.
2424         $a->{Sort} <=> $b->{Sort} or
2425         $a->{F}    cmp $b->{F}
2426     } @tartrees;
2427
2428     my $any_orig = grep { $_->{Orig} } @tartrees;
2429
2430     my $dscfn = "$package.dsc";
2431
2432     my $treeimporthow = 'package';
2433
2434     open D, ">", $dscfn or die "$dscfn: $!";
2435     print D $dscdata or die "$dscfn: $!";
2436     close D or die "$dscfn: $!";
2437     my @cmd = qw(dpkg-source);
2438     push @cmd, '--no-check' if $dsc_checked;
2439     if (madformat $dsc->{format}) {
2440         push @cmd, '--skip-patches';
2441         $treeimporthow = 'unpatched';
2442     }
2443     push @cmd, qw(-x --), $dscfn;
2444     runcmd @cmd;
2445
2446     my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2447     if (madformat $dsc->{format}) {
2448         check_for_vendor_patches();
2449     }
2450
2451     my $dappliedtree;
2452     if (madformat $dsc->{format}) {
2453         my @pcmd = qw(dpkg-source --before-build .);
2454         runcmd shell_cmd 'exec >/dev/null', @pcmd;
2455         rmtree '.pc';
2456         $dappliedtree = git_add_write_tree();
2457     }
2458
2459     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2460     my $clogp;
2461     my $r1clogp;
2462
2463     printdebug "import clog search...\n";
2464     parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2465         my ($thisstanza, $desc) = @_;
2466         no warnings qw(exiting);
2467
2468         $clogp //= $thisstanza;
2469
2470         printdebug "import clog $thisstanza->{version} $desc...\n";
2471
2472         last if !$any_orig; # we don't need $r1clogp
2473
2474         # We look for the first (most recent) changelog entry whose
2475         # version number is lower than the upstream version of this
2476         # package.  Then the last (least recent) previous changelog
2477         # entry is treated as the one which introduced this upstream
2478         # version and used for the synthetic commits for the upstream
2479         # tarballs.
2480
2481         # One might think that a more sophisticated algorithm would be
2482         # necessary.  But: we do not want to scan the whole changelog
2483         # file.  Stopping when we see an earlier version, which
2484         # necessarily then is an earlier upstream version, is the only
2485         # realistic way to do that.  Then, either the earliest
2486         # changelog entry we have seen so far is indeed the earliest
2487         # upload of this upstream version; or there are only changelog
2488         # entries relating to later upstream versions (which is not
2489         # possible unless the changelog and .dsc disagree about the
2490         # version).  Then it remains to choose between the physically
2491         # last entry in the file, and the one with the lowest version
2492         # number.  If these are not the same, we guess that the
2493         # versions were created in a non-monotonic order rather than
2494         # that the changelog entries have been misordered.
2495
2496         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2497
2498         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2499         $r1clogp = $thisstanza;
2500
2501         printdebug "import clog $r1clogp->{version} becomes r1\n";
2502     };
2503
2504     $clogp or fail __ "package changelog has no entries!";
2505
2506     my $authline = clogp_authline $clogp;
2507     my $changes = getfield $clogp, 'Changes';
2508     $changes =~ s/^\n//; # Changes: \n
2509     my $cversion = getfield $clogp, 'Version';
2510
2511     if (@tartrees) {
2512         $r1clogp //= $clogp; # maybe there's only one entry;
2513         my $r1authline = clogp_authline $r1clogp;
2514         # Strictly, r1authline might now be wrong if it's going to be
2515         # unused because !$any_orig.  Whatever.
2516
2517         printdebug "import tartrees authline   $authline\n";
2518         printdebug "import tartrees r1authline $r1authline\n";
2519
2520         foreach my $tt (@tartrees) {
2521             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2522
2523             my $mbody = f_ "Import %s", $tt->{F};
2524             $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2525 tree $tt->{Tree}
2526 author $r1authline
2527 committer $r1authline
2528
2529 $mbody
2530
2531 [dgit import orig $tt->{F}]
2532 END_O
2533 tree $tt->{Tree}
2534 author $authline
2535 committer $authline
2536
2537 $mbody
2538
2539 [dgit import tarball $package $cversion $tt->{F}]
2540 END_T
2541         }
2542     }
2543
2544     printdebug "import main commit\n";
2545
2546     open C, ">../commit.tmp" or confess $!;
2547     print C <<END or confess $!;
2548 tree $tree
2549 END
2550     print C <<END or confess $! foreach @tartrees;
2551 parent $_->{Commit}
2552 END
2553     print C <<END or confess $!;
2554 author $authline
2555 committer $authline
2556
2557 $changes
2558
2559 [dgit import $treeimporthow $package $cversion]
2560 END
2561
2562     close C or confess $!;
2563     my $rawimport_hash = make_commit qw(../commit.tmp);
2564
2565     if (madformat $dsc->{format}) {
2566         printdebug "import apply patches...\n";
2567
2568         # regularise the state of the working tree so that
2569         # the checkout of $rawimport_hash works nicely.
2570         my $dappliedcommit = make_commit_text(<<END);
2571 tree $dappliedtree
2572 author $authline
2573 committer $authline
2574
2575 [dgit dummy commit]
2576 END
2577         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2578
2579         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2580
2581         # We need the answers to be reproducible
2582         my @authline = clogp_authline($clogp);
2583         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2584         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2585         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2586         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
2587         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2588         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
2589
2590         my $path = $ENV{PATH} or die;
2591
2592         # we use ../../gbp-pq-output, which (given that we are in
2593         # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2594         # is .git/dgit.
2595
2596         foreach my $use_absurd (qw(0 1)) {
2597             runcmd @git, qw(checkout -q unpa);
2598             runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2599             local $ENV{PATH} = $path;
2600             if ($use_absurd) {
2601                 chomp $@;
2602                 progress "warning: $@";
2603                 $path = "$absurdity:$path";
2604                 progress f_ "%s: trying slow absurd-git-apply...", $us;
2605                 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2606                     or $!==ENOENT
2607                     or confess $!;
2608             }
2609             eval {
2610                 die "forbid absurd git-apply\n" if $use_absurd
2611                     && forceing [qw(import-gitapply-no-absurd)];
2612                 die "only absurd git-apply!\n" if !$use_absurd
2613                     && forceing [qw(import-gitapply-absurd)];
2614
2615                 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2616                 local $ENV{PATH} = $path                    if $use_absurd;
2617
2618                 my @showcmd = (gbp_pq, qw(import));
2619                 my @realcmd = shell_cmd
2620                     'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2621                 debugcmd "+",@realcmd;
2622                 if (system @realcmd) {
2623                     die f_ "%s failed: %s\n",
2624                         +(shellquote @showcmd),
2625                         failedcmd_waitstatus();
2626                 }
2627
2628                 my $gapplied = git_rev_parse('HEAD');
2629                 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2630                 $gappliedtree eq $dappliedtree or
2631                     fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2632 gbp-pq import and dpkg-source disagree!
2633  gbp-pq import gave commit %s
2634  gbp-pq import gave tree %s
2635  dpkg-source --before-build gave tree %s
2636 END
2637                 $rawimport_hash = $gapplied;
2638             };
2639             last unless $@;
2640         }
2641         if ($@) {
2642             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2643             die $@;
2644         }
2645     }
2646
2647     progress f_ "synthesised git commit from .dsc %s", $cversion;
2648
2649     my $rawimport_mergeinput = {
2650         Commit => $rawimport_hash,
2651         Info => __ "Import of source package",
2652     };
2653     my @output = ($rawimport_mergeinput);
2654
2655     if ($lastpush_mergeinput) {
2656         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2657         my $oversion = getfield $oldclogp, 'Version';
2658         my $vcmp =
2659             version_compare($oversion, $cversion);
2660         if ($vcmp < 0) {
2661             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2662                 { ReverseParents => 1,
2663                   Message => (f_ <<END, $package, $cversion, $csuite) });
2664 Record %s (%s) in archive suite %s
2665 END
2666         } elsif ($vcmp > 0) {
2667             print STDERR f_ <<END, $cversion, $oversion,
2668
2669 Version actually in archive:   %s (older)
2670 Last version pushed with dgit: %s (newer or same)
2671 %s
2672 END
2673                 __ $later_warning_msg or confess $!;
2674             @output = $lastpush_mergeinput;
2675         } else {
2676             # Same version.  Use what's in the server git branch,
2677             # discarding our own import.  (This could happen if the
2678             # server automatically imports all packages into git.)
2679             @output = $lastpush_mergeinput;
2680         }
2681     }
2682     changedir $maindir;
2683     rmtree $playground;
2684     return @output;
2685 }
2686
2687 sub complete_file_from_dsc ($$;$) {
2688     our ($dstdir, $fi, $refetched) = @_;
2689     # Ensures that we have, in $dstdir, the file $fi, with the correct
2690     # contents.  (Downloading it from alongside $dscurl if necessary.)
2691     # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2692     # and will set $$refetched=1 if it did so (or tried to).
2693
2694     my $f = $fi->{Filename};
2695     my $tf = "$dstdir/$f";
2696     my $downloaded = 0;
2697
2698     my $got;
2699     my $checkhash = sub {
2700         open F, "<", "$tf" or die "$tf: $!";
2701         $fi->{Digester}->reset();
2702         $fi->{Digester}->addfile(*F);
2703         F->error and confess $!;
2704         $got = $fi->{Digester}->hexdigest();
2705         return $got eq $fi->{Hash};
2706     };
2707
2708     if (stat_exists $tf) {
2709         if ($checkhash->()) {
2710             progress f_ "using existing %s", $f;
2711             return 1;
2712         }
2713         if (!$refetched) {
2714             fail f_ "file %s has hash %s but .dsc demands hash %s".
2715                     " (perhaps you should delete this file?)",
2716                     $f, $got, $fi->{Hash};
2717         }
2718         progress f_ "need to fetch correct version of %s", $f;
2719         unlink $tf or die "$tf $!";
2720         $$refetched = 1;
2721     } else {
2722         printdebug "$tf does not exist, need to fetch\n";
2723     }
2724
2725     my $furl = $dscurl;
2726     $furl =~ s{/[^/]+$}{};
2727     $furl .= "/$f";
2728     die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2729     die "$f ?" if $f =~ m#/#;
2730     runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2731     return 0 if !act_local();
2732
2733     $checkhash->() or
2734         fail f_ "file %s has hash %s but .dsc demands hash %s".
2735                 " (got wrong file from archive!)",
2736                 $f, $got, $fi->{Hash};
2737
2738     return 1;
2739 }
2740
2741 sub ensure_we_have_orig () {
2742     my @dfi = dsc_files_info();
2743     foreach my $fi (@dfi) {
2744         my $f = $fi->{Filename};
2745         next unless is_orig_file_in_dsc($f, \@dfi);
2746         complete_file_from_dsc($buildproductsdir, $fi)
2747             or next;
2748     }
2749 }
2750
2751 #---------- git fetch ----------
2752
2753 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2754 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2755
2756 # We fetch some parts of lrfetchrefs/*.  Ideally we delete these
2757 # locally fetched refs because they have unhelpful names and clutter
2758 # up gitk etc.  So we track whether we have "used up" head ref (ie,
2759 # whether we have made another local ref which refers to this object).
2760 #
2761 # (If we deleted them unconditionally, then we might end up
2762 # re-fetching the same git objects each time dgit fetch was run.)
2763 #
2764 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2765 # in git_fetch_us to fetch the refs in question, and possibly a call
2766 # to lrfetchref_used.
2767
2768 our (%lrfetchrefs_f, %lrfetchrefs_d);
2769 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2770
2771 sub lrfetchref_used ($) {
2772     my ($fullrefname) = @_;
2773     my $objid = $lrfetchrefs_f{$fullrefname};
2774     $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2775 }
2776
2777 sub git_lrfetch_sane {
2778     my ($url, $supplementary, @specs) = @_;
2779     # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2780     # at least as regards @specs.  Also leave the results in
2781     # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2782     # able to clean these up.
2783     #
2784     # With $supplementary==1, @specs must not contain wildcards
2785     # and we add to our previous fetches (non-atomically).
2786
2787     # This is rather miserable:
2788     # When git fetch --prune is passed a fetchspec ending with a *,
2789     # it does a plausible thing.  If there is no * then:
2790     # - it matches subpaths too, even if the supplied refspec
2791     #   starts refs, and behaves completely madly if the source
2792     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2793     # - if there is no matching remote ref, it bombs out the whole
2794     #   fetch.
2795     # We want to fetch a fixed ref, and we don't know in advance
2796     # if it exists, so this is not suitable.
2797     #
2798     # Our workaround is to use git ls-remote.  git ls-remote has its
2799     # own qairks.  Notably, it has the absurd multi-tail-matching
2800     # behaviour: git ls-remote R refs/foo can report refs/foo AND
2801     # refs/refs/foo etc.
2802     #
2803     # Also, we want an idempotent snapshot, but we have to make two
2804     # calls to the remote: one to git ls-remote and to git fetch.  The
2805     # solution is use git ls-remote to obtain a target state, and
2806     # git fetch to try to generate it.  If we don't manage to generate
2807     # the target state, we try again.
2808
2809     printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2810
2811     my $specre = join '|', map {
2812         my $x = $_;
2813         $x =~ s/\W/\\$&/g;
2814         my $wildcard = $x =~ s/\\\*$/.*/;
2815         die if $wildcard && $supplementary;
2816         "(?:refs/$x)";
2817     } @specs;
2818     printdebug "git_lrfetch_sane specre=$specre\n";
2819     my $wanted_rref = sub {
2820         local ($_) = @_;
2821         return m/^(?:$specre)$/;
2822     };
2823
2824     my $fetch_iteration = 0;
2825     FETCH_ITERATION:
2826     for (;;) {
2827         printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2828         if (++$fetch_iteration > 10) {
2829             fail __ "too many iterations trying to get sane fetch!";
2830         }
2831
2832         my @look = map { "refs/$_" } @specs;
2833         my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2834         debugcmd "|",@lcmd;
2835
2836         my %wantr;
2837         open GITLS, "-|", @lcmd or confess $!;
2838         while (<GITLS>) {
2839             printdebug "=> ", $_;
2840             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2841             my ($objid,$rrefname) = ($1,$2);
2842             if (!$wanted_rref->($rrefname)) {
2843                 print STDERR f_ <<END, "@look", $rrefname;
2844 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2845 END
2846                 next;
2847             }
2848             $wantr{$rrefname} = $objid;
2849         }
2850         $!=0; $?=0;
2851         close GITLS or failedcmd @lcmd;
2852
2853         # OK, now %want is exactly what we want for refs in @specs
2854         my @fspecs = map {
2855             !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2856             "+refs/$_:".lrfetchrefs."/$_";
2857         } @specs;
2858
2859         printdebug "git_lrfetch_sane fspecs @fspecs\n";
2860
2861         my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2862         runcmd_ordryrun_local @fcmd if @fspecs;
2863
2864         if (!$supplementary) {
2865             %lrfetchrefs_f = ();
2866         }
2867         my %objgot;
2868
2869         git_for_each_ref(lrfetchrefs, sub {
2870             my ($objid,$objtype,$lrefname,$reftail) = @_;
2871             $lrfetchrefs_f{$lrefname} = $objid;
2872             $objgot{$objid} = 1;
2873         });
2874
2875         if ($supplementary) {
2876             last;
2877         }
2878
2879         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2880             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2881             if (!exists $wantr{$rrefname}) {
2882                 if ($wanted_rref->($rrefname)) {
2883                     printdebug <<END;
2884 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2885 END
2886                 } else {
2887                     print STDERR f_ <<END, "@fspecs", $lrefname
2888 warning: git fetch %s created %s; this is silly, deleting it.
2889 END
2890                 }
2891                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2892                 delete $lrfetchrefs_f{$lrefname};
2893                 next;
2894             }
2895         }
2896         foreach my $rrefname (sort keys %wantr) {
2897             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2898             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2899             my $want = $wantr{$rrefname};
2900             next if $got eq $want;
2901             if (!defined $objgot{$want}) {
2902                 fail __ <<END unless act_local();
2903 --dry-run specified but we actually wanted the results of git fetch,
2904 so this is not going to work.  Try running dgit fetch first,
2905 or using --damp-run instead of --dry-run.
2906 END
2907                 print STDERR f_ <<END, $lrefname, $want;
2908 warning: git ls-remote suggests we want %s
2909 warning:  and it should refer to %s
2910 warning:  but git fetch didn't fetch that object to any relevant ref.
2911 warning:  This may be due to a race with someone updating the server.
2912 warning:  Will try again...
2913 END
2914                 next FETCH_ITERATION;
2915             }
2916             printdebug <<END;
2917 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2918 END
2919             runcmd_ordryrun_local @git, qw(update-ref -m),
2920                 "dgit fetch git fetch fixup", $lrefname, $want;
2921             $lrfetchrefs_f{$lrefname} = $want;
2922         }
2923         last;
2924     }
2925
2926     if (defined $csuite) {
2927         printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2928         git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2929             my ($objid,$objtype,$lrefname,$reftail) = @_;
2930             next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2931             runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2932         });
2933     }
2934
2935     printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2936         Dumper(\%lrfetchrefs_f);
2937 }
2938
2939 sub git_fetch_us () {
2940     # Want to fetch only what we are going to use, unless
2941     # deliberately-not-ff, in which case we must fetch everything.
2942
2943     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2944         map { "tags/$_" }
2945         (quiltmode_splitbrain
2946          ? (map { $_->('*',access_nomdistro) }
2947             \&debiantag_new, \&debiantag_maintview)
2948          : debiantags('*',access_nomdistro));
2949     push @specs, server_branch($csuite);
2950     push @specs, $rewritemap;
2951     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2952
2953     my $url = access_giturl();
2954     git_lrfetch_sane $url, 0, @specs;
2955
2956     my %here;
2957     my @tagpats = debiantags('*',access_nomdistro);
2958
2959     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2960         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2961         printdebug "currently $fullrefname=$objid\n";
2962         $here{$fullrefname} = $objid;
2963     });
2964     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2965         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2966         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2967         printdebug "offered $lref=$objid\n";
2968         if (!defined $here{$lref}) {
2969             my @upd = (@git, qw(update-ref), $lref, $objid, '');
2970             runcmd_ordryrun_local @upd;
2971             lrfetchref_used $fullrefname;
2972         } elsif ($here{$lref} eq $objid) {
2973             lrfetchref_used $fullrefname;
2974         } else {
2975             print STDERR f_ "Not updating %s from %s to %s.\n",
2976                             $lref, $here{$lref}, $objid;
2977         }
2978     });
2979 }
2980
2981 #---------- dsc and archive handling ----------
2982
2983 sub mergeinfo_getclogp ($) {
2984     # Ensures thit $mi->{Clogp} exists and returns it
2985     my ($mi) = @_;
2986     $mi->{Clogp} = commit_getclogp($mi->{Commit});
2987 }
2988
2989 sub mergeinfo_version ($) {
2990     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2991 }
2992
2993 sub fetch_from_archive_record_1 ($) {
2994     my ($hash) = @_;
2995     runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2996     cmdoutput @git, qw(log -n2), $hash;
2997     # ... gives git a chance to complain if our commit is malformed
2998 }
2999
3000 sub fetch_from_archive_record_2 ($) {
3001     my ($hash) = @_;
3002     my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
3003     if (act_local()) {
3004         cmdoutput @upd_cmd;
3005     } else {
3006         dryrun_report @upd_cmd;
3007     }
3008 }
3009
3010 sub parse_dsc_field_def_dsc_distro () {
3011     $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
3012                            dgit.default.distro);
3013 }
3014
3015 sub parse_dsc_field ($$) {
3016     my ($dsc, $what) = @_;
3017     my $f;
3018     foreach my $field (@ourdscfield) {
3019         $f = $dsc->{$field};
3020         last if defined $f;
3021     }
3022
3023     if (!defined $f) {
3024         progress f_ "%s: NO git hash", $what;
3025         parse_dsc_field_def_dsc_distro();
3026     } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3027              = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3028         progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3029         $dsc_hint_tag = [ $dsc_hint_tag ];
3030     } elsif ($f =~ m/^\w+\s*$/) {
3031         $dsc_hash = $&;
3032         parse_dsc_field_def_dsc_distro();
3033         $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3034                           $dsc_distro ];
3035         progress f_ "%s: specified git hash", $what;
3036     } else {
3037         fail f_ "%s: invalid Dgit info", $what;
3038     }
3039 }
3040
3041 sub resolve_dsc_field_commit ($$) {
3042     my ($already_distro, $already_mapref) = @_;
3043
3044     return unless defined $dsc_hash;
3045
3046     my $mapref =
3047         defined $already_mapref &&
3048         ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3049         ? $already_mapref : undef;
3050
3051     my $do_fetch;
3052     $do_fetch = sub {
3053         my ($what, @fetch) = @_;
3054
3055         local $idistro = $dsc_distro;
3056         my $lrf = lrfetchrefs;
3057
3058         if (!$chase_dsc_distro) {
3059             progress f_ "not chasing .dsc distro %s: not fetching %s",
3060                         $dsc_distro, $what;
3061             return 0;
3062         }
3063
3064         progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3065
3066         my $url = access_giturl();
3067         if (!defined $url) {
3068             defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3069 .dsc Dgit metadata is in context of distro %s
3070 for which we have no configured url and .dsc provides no hint
3071 END
3072             my $proto =
3073                 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3074                 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3075             parse_cfg_bool "dsc-url-proto-ok", 'false',
3076                 cfg("dgit.dsc-url-proto-ok.$proto",
3077                     "dgit.default.dsc-url-proto-ok")
3078                 or fail f_ <<END, $dsc_distro, $proto;
3079 .dsc Dgit metadata is in context of distro %s
3080 for which we have no configured url;
3081 .dsc provides hinted url with protocol %s which is unsafe.
3082 (can be overridden by config - consult documentation)
3083 END
3084             $url = $dsc_hint_url;
3085         }
3086
3087         git_lrfetch_sane $url, 1, @fetch;
3088
3089         return $lrf;
3090     };
3091
3092     my $rewrite_enable = do {
3093         local $idistro = $dsc_distro;
3094         access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3095     };
3096
3097     if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3098         if (!defined $mapref) {
3099             my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3100             $mapref = $lrf.'/'.$rewritemap;
3101         }
3102         my $rewritemapdata = git_cat_file $mapref.':map';
3103         if (defined $rewritemapdata
3104             && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3105             progress __
3106                 "server's git history rewrite map contains a relevant entry!";
3107
3108             $dsc_hash = $1;
3109             if (defined $dsc_hash) {
3110                 progress __ "using rewritten git hash in place of .dsc value";
3111             } else {
3112                 progress __ "server data says .dsc hash is to be disregarded";
3113             }
3114         }
3115     }
3116
3117     if (!defined git_cat_file $dsc_hash) {
3118         my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3119         my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3120             defined git_cat_file $dsc_hash
3121             or fail f_ <<END, $dsc_hash;
3122 .dsc Dgit metadata requires commit %s
3123 but we could not obtain that object anywhere.
3124 END
3125         foreach my $t (@tags) {
3126             my $fullrefname = $lrf.'/'.$t;
3127 #           print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3128             next unless $lrfetchrefs_f{$fullrefname};
3129             next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3130             lrfetchref_used $fullrefname;
3131         }
3132     }
3133 }
3134
3135 sub fetch_from_archive () {
3136     check_bpd_exists();
3137     ensure_setup_existing_tree();
3138
3139     # Ensures that lrref() is what is actually in the archive, one way
3140     # or another, according to us - ie this client's
3141     # appropritaely-updated archive view.  Also returns the commit id.
3142     # If there is nothing in the archive, leaves lrref alone and
3143     # returns undef.  git_fetch_us must have already been called.
3144     get_archive_dsc();
3145
3146     if ($dsc) {
3147         parse_dsc_field($dsc, __ 'last upload to archive');
3148         resolve_dsc_field_commit access_basedistro,
3149             lrfetchrefs."/".$rewritemap
3150     } else {
3151         progress __ "no version available from the archive";
3152     }
3153
3154     # If the archive's .dsc has a Dgit field, there are three
3155     # relevant git commitids we need to choose between and/or merge
3156     # together:
3157     #   1. $dsc_hash: the Dgit field from the archive
3158     #   2. $lastpush_hash: the suite branch on the dgit git server
3159     #   3. $lastfetch_hash: our local tracking brach for the suite
3160     #
3161     # These may all be distinct and need not be in any fast forward
3162     # relationship:
3163     #
3164     # If the dsc was pushed to this suite, then the server suite
3165     # branch will have been updated; but it might have been pushed to
3166     # a different suite and copied by the archive.  Conversely a more
3167     # recent version may have been pushed with dgit but not appeared
3168     # in the archive (yet).
3169     #
3170     # $lastfetch_hash may be awkward because archive imports
3171     # (particularly, imports of Dgit-less .dscs) are performed only as
3172     # needed on individual clients, so different clients may perform a
3173     # different subset of them - and these imports are only made
3174     # public during push.  So $lastfetch_hash may represent a set of
3175     # imports different to a subsequent upload by a different dgit
3176     # client.
3177     #
3178     # Our approach is as follows:
3179     #
3180     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3181     # descendant of $dsc_hash, then it was pushed by a dgit user who
3182     # had based their work on $dsc_hash, so we should prefer it.
3183     # Otherwise, $dsc_hash was installed into this suite in the
3184     # archive other than by a dgit push, and (necessarily) after the
3185     # last dgit push into that suite (since a dgit push would have
3186     # been descended from the dgit server git branch); thus, in that
3187     # case, we prefer the archive's version (and produce a
3188     # pseudo-merge to overwrite the dgit server git branch).
3189     #
3190     # (If there is no Dgit field in the archive's .dsc then
3191     # generate_commit_from_dsc uses the version numbers to decide
3192     # whether the suite branch or the archive is newer.  If the suite
3193     # branch is newer it ignores the archive's .dsc; otherwise it
3194     # generates an import of the .dsc, and produces a pseudo-merge to
3195     # overwrite the suite branch with the archive contents.)
3196     #
3197     # The outcome of that part of the algorithm is the `public view',
3198     # and is same for all dgit clients: it does not depend on any
3199     # unpublished history in the local tracking branch.
3200     #
3201     # As between the public view and the local tracking branch: The
3202     # local tracking branch is only updated by dgit fetch, and
3203     # whenever dgit fetch runs it includes the public view in the
3204     # local tracking branch.  Therefore if the public view is not
3205     # descended from the local tracking branch, the local tracking
3206     # branch must contain history which was imported from the archive
3207     # but never pushed; and, its tip is now out of date.  So, we make
3208     # a pseudo-merge to overwrite the old imports and stitch the old
3209     # history in.
3210     #
3211     # Finally: we do not necessarily reify the public view (as
3212     # described above).  This is so that we do not end up stacking two
3213     # pseudo-merges.  So what we actually do is figure out the inputs
3214     # to any public view pseudo-merge and put them in @mergeinputs.
3215
3216     my @mergeinputs;
3217     # $mergeinputs[]{Commit}
3218     # $mergeinputs[]{Info}
3219     # $mergeinputs[0] is the one whose tree we use
3220     # @mergeinputs is in the order we use in the actual commit)
3221     #
3222     # Also:
3223     # $mergeinputs[]{Message} is a commit message to use
3224     # $mergeinputs[]{ReverseParents} if def specifies that parent
3225     #                                list should be in opposite order
3226     # Such an entry has no Commit or Info.  It applies only when found
3227     # in the last entry.  (This ugliness is to support making
3228     # identical imports to previous dgit versions.)
3229
3230     my $lastpush_hash = git_get_ref(lrfetchref());
3231     printdebug "previous reference hash=$lastpush_hash\n";
3232     $lastpush_mergeinput = $lastpush_hash && {
3233         Commit => $lastpush_hash,
3234         Info => (__ "dgit suite branch on dgit git server"),
3235     };
3236
3237     my $lastfetch_hash = git_get_ref(lrref());
3238     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3239     my $lastfetch_mergeinput = $lastfetch_hash && {
3240         Commit => $lastfetch_hash,
3241         Info => (__ "dgit client's archive history view"),
3242     };
3243
3244     my $dsc_mergeinput = $dsc_hash && {
3245         Commit => $dsc_hash,
3246         Info => (__ "Dgit field in .dsc from archive"),
3247     };
3248
3249     my $cwd = getcwd();
3250     my $del_lrfetchrefs = sub {
3251         changedir $cwd;
3252         my $gur;
3253         printdebug "del_lrfetchrefs...\n";
3254         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3255             my $objid = $lrfetchrefs_d{$fullrefname};
3256             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3257             if (!$gur) {
3258                 $gur ||= new IO::Handle;
3259                 open $gur, "|-", qw(git update-ref --stdin) or confess $!;
3260             }
3261             printf $gur "delete %s %s\n", $fullrefname, $objid;
3262         }
3263         if ($gur) {
3264             close $gur or failedcmd "git update-ref delete lrfetchrefs";
3265         }
3266     };
3267
3268     if (defined $dsc_hash) {
3269         ensure_we_have_orig();
3270         if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3271             @mergeinputs = $dsc_mergeinput
3272         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3273             print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3274
3275 Git commit in archive is behind the last version allegedly pushed/uploaded.
3276 Commit referred to by archive: %s
3277 Last version pushed with dgit: %s
3278 %s
3279 END
3280                 __ $later_warning_msg or confess $!;
3281             @mergeinputs = ($lastpush_mergeinput);
3282         } else {
3283             # Archive has .dsc which is not a descendant of the last dgit
3284             # push.  This can happen if the archive moves .dscs about.
3285             # Just follow its lead.
3286             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3287                 progress __ "archive .dsc names newer git commit";
3288                 @mergeinputs = ($dsc_mergeinput);
3289             } else {
3290                 progress __ "archive .dsc names other git commit, fixing up";
3291                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3292             }
3293         }
3294     } elsif ($dsc) {
3295         @mergeinputs = generate_commits_from_dsc();
3296         # We have just done an import.  Now, our import algorithm might
3297         # have been improved.  But even so we do not want to generate
3298         # a new different import of the same package.  So if the
3299         # version numbers are the same, just use our existing version.
3300         # If the version numbers are different, the archive has changed
3301         # (perhaps, rewound).
3302         if ($lastfetch_mergeinput &&
3303             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3304                               (mergeinfo_version $mergeinputs[0]) )) {
3305             @mergeinputs = ($lastfetch_mergeinput);
3306         }
3307     } elsif ($lastpush_hash) {
3308         # only in git, not in the archive yet
3309         @mergeinputs = ($lastpush_mergeinput);
3310         print STDERR f_ <<END,
3311
3312 Package not found in the archive, but has allegedly been pushed using dgit.
3313 %s
3314 END
3315             __ $later_warning_msg or confess $!;
3316     } else {
3317         printdebug "nothing found!\n";
3318         if (defined $skew_warning_vsn) {
3319             print STDERR f_ <<END, $skew_warning_vsn or confess $!;
3320
3321 Warning: relevant archive skew detected.
3322 Archive allegedly contains %s
3323 But we were not able to obtain any version from the archive or git.
3324
3325 END
3326         }
3327         unshift @end, $del_lrfetchrefs;
3328         return undef;
3329     }
3330
3331     if ($lastfetch_hash &&
3332         !grep {
3333             my $h = $_->{Commit};
3334             $h and is_fast_fwd($lastfetch_hash, $h);
3335             # If true, one of the existing parents of this commit
3336             # is a descendant of the $lastfetch_hash, so we'll
3337             # be ff from that automatically.
3338         } @mergeinputs
3339         ) {
3340         # Otherwise:
3341         push @mergeinputs, $lastfetch_mergeinput;
3342     }
3343
3344     printdebug "fetch mergeinfos:\n";
3345     foreach my $mi (@mergeinputs) {
3346         if ($mi->{Info}) {
3347             printdebug " commit $mi->{Commit} $mi->{Info}\n";
3348         } else {
3349             printdebug sprintf " ReverseParents=%d Message=%s",
3350                 $mi->{ReverseParents}, $mi->{Message};
3351         }
3352     }
3353
3354     my $compat_info= pop @mergeinputs
3355         if $mergeinputs[$#mergeinputs]{Message};
3356
3357     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3358
3359     my $hash;
3360     if (@mergeinputs > 1) {
3361         # here we go, then:
3362         my $tree_commit = $mergeinputs[0]{Commit};
3363
3364         my $tree = get_tree_of_commit $tree_commit;;
3365
3366         # We use the changelog author of the package in question the
3367         # author of this pseudo-merge.  This is (roughly) correct if
3368         # this commit is simply representing aa non-dgit upload.
3369         # (Roughly because it does not record sponsorship - but we
3370         # don't have sponsorship info because that's in the .changes,
3371         # which isn't in the archivw.)
3372         #
3373         # But, it might be that we are representing archive history
3374         # updates (including in-archive copies).  These are not really
3375         # the responsibility of the person who created the .dsc, but
3376         # there is no-one whose name we should better use.  (The
3377         # author of the .dsc-named commit is clearly worse.)
3378
3379         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3380         my $author = clogp_authline $useclogp;
3381         my $cversion = getfield $useclogp, 'Version';
3382
3383         my $mcf = dgit_privdir()."/mergecommit";
3384         open MC, ">", $mcf or die "$mcf $!";
3385         print MC <<END or confess $!;
3386 tree $tree
3387 END
3388
3389         my @parents = grep { $_->{Commit} } @mergeinputs;
3390         @parents = reverse @parents if $compat_info->{ReverseParents};
3391         print MC <<END or confess $! foreach @parents;
3392 parent $_->{Commit}
3393 END
3394
3395         print MC <<END or confess $!;
3396 author $author
3397 committer $author
3398
3399 END
3400
3401         if (defined $compat_info->{Message}) {
3402             print MC $compat_info->{Message} or confess $!;
3403         } else {
3404             print MC f_ <<END, $package, $cversion, $csuite or confess $!;
3405 Record %s (%s) in archive suite %s
3406
3407 Record that
3408 END
3409             my $message_add_info = sub {
3410                 my ($mi) = (@_);
3411                 my $mversion = mergeinfo_version $mi;
3412                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
3413                     or confess $!;
3414             };
3415
3416             $message_add_info->($mergeinputs[0]);
3417             print MC __ <<END or confess $!;
3418 should be treated as descended from
3419 END
3420             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3421         }
3422
3423         close MC or confess $!;
3424         $hash = make_commit $mcf;
3425     } else {
3426         $hash = $mergeinputs[0]{Commit};
3427     }
3428     printdebug "fetch hash=$hash\n";
3429
3430     my $chkff = sub {
3431         my ($lasth, $what) = @_;
3432         return unless $lasth;
3433         confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3434     };
3435
3436     $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3437         if $lastpush_hash;
3438     $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3439
3440     fetch_from_archive_record_1($hash);
3441
3442     if (defined $skew_warning_vsn) {
3443         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3444         my $gotclogp = commit_getclogp($hash);
3445         my $got_vsn = getfield $gotclogp, 'Version';
3446         printdebug "SKEW CHECK GOT $got_vsn\n";
3447         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3448             print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess $!;
3449
3450 Warning: archive skew detected.  Using the available version:
3451 Archive allegedly contains    %s
3452 We were able to obtain only   %s
3453
3454 END
3455         }
3456     }
3457
3458     if ($lastfetch_hash ne $hash) {
3459         fetch_from_archive_record_2($hash);
3460     }
3461
3462     lrfetchref_used lrfetchref();
3463
3464     check_gitattrs($hash, __ "fetched source tree");
3465
3466     unshift @end, $del_lrfetchrefs;
3467     return $hash;
3468 }
3469
3470 sub set_local_git_config ($$) {
3471     my ($k, $v) = @_;
3472     runcmd @git, qw(config), $k, $v;
3473 }
3474
3475 sub setup_mergechangelogs (;$) {
3476     my ($always) = @_;
3477     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3478
3479     my $driver = 'dpkg-mergechangelogs';
3480     my $cb = "merge.$driver";
3481     confess unless defined $maindir;
3482     my $attrs = "$maindir_gitcommon/info/attributes";
3483     ensuredir "$maindir_gitcommon/info";
3484
3485     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3486     if (!open ATTRS, "<", $attrs) {
3487         $!==ENOENT or die "$attrs: $!";
3488     } else {
3489         while (<ATTRS>) {
3490             chomp;
3491             next if m{^debian/changelog\s};
3492             print NATTRS $_, "\n" or confess $!;
3493         }
3494         ATTRS->error and confess $!;
3495         close ATTRS;
3496     }
3497     print NATTRS "debian/changelog merge=$driver\n" or confess $!;
3498     close NATTRS;
3499
3500     set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3501     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3502
3503     rename "$attrs.new", "$attrs" or die "$attrs: $!";
3504 }
3505
3506 sub setup_useremail (;$) {
3507     my ($always) = @_;
3508     return unless $always || access_cfg_bool(1, 'setup-useremail');
3509
3510     my $setup = sub {
3511         my ($k, $envvar) = @_;
3512         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3513         return unless defined $v;
3514         set_local_git_config "user.$k", $v;
3515     };
3516
3517     $setup->('email', 'DEBEMAIL');
3518     $setup->('name', 'DEBFULLNAME');
3519 }
3520
3521 sub ensure_setup_existing_tree () {
3522     my $k = "remote.$remotename.skipdefaultupdate";
3523     my $c = git_get_config $k;
3524     return if defined $c;
3525     set_local_git_config $k, 'true';
3526 }
3527
3528 sub open_main_gitattrs () {
3529     confess 'internal error no maindir' unless defined $maindir;
3530     my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3531         or $!==ENOENT
3532         or die "open $maindir_gitcommon/info/attributes: $!";
3533     return $gai;
3534 }
3535
3536 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3537
3538 sub is_gitattrs_setup () {
3539     # return values:
3540     #  trueish
3541     #     1: gitattributes set up and should be left alone
3542     #  falseish
3543     #     0: there is a dgit-defuse-attrs but it needs fixing
3544     #     undef: there is none
3545     my $gai = open_main_gitattrs();
3546     return 0 unless $gai;
3547     while (<$gai>) {
3548         next unless m{$gitattrs_ourmacro_re};
3549         return 1 if m{\s-working-tree-encoding\s};
3550         printdebug "is_gitattrs_setup: found old macro\n";
3551         return 0;
3552     }
3553     $gai->error and confess $!;
3554     printdebug "is_gitattrs_setup: found nothing\n";
3555     return undef;
3556 }
3557
3558 sub setup_gitattrs (;$) {
3559     my ($always) = @_;
3560     return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3561
3562     my $already = is_gitattrs_setup();
3563     if ($already) {
3564         progress __ <<END;
3565 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3566  not doing further gitattributes setup
3567 END
3568         return;
3569     }
3570     my $new = "[attr]dgit-defuse-attrs  $negate_harmful_gitattrs";
3571     my $af = "$maindir_gitcommon/info/attributes";
3572     ensuredir "$maindir_gitcommon/info";
3573
3574     open GAO, "> $af.new" or confess $!;
3575     print GAO <<END, __ <<ENDT or confess $! unless defined $already;
3576 *       dgit-defuse-attrs
3577 $new
3578 END
3579 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3580 ENDT
3581     my $gai = open_main_gitattrs();
3582     if ($gai) {
3583         while (<$gai>) {
3584             if (m{$gitattrs_ourmacro_re}) {
3585                 die unless defined $already;
3586                 $_ = $new;
3587             }
3588             chomp;
3589             print GAO $_, "\n" or confess $!;
3590         }
3591         $gai->error and confess $!;
3592     }
3593     close GAO or confess $!;
3594     rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3595 }
3596
3597 sub setup_new_tree () {
3598     setup_mergechangelogs();
3599     setup_useremail();
3600     setup_gitattrs();
3601 }
3602
3603 sub check_gitattrs ($$) {
3604     my ($treeish, $what) = @_;
3605
3606     return if is_gitattrs_setup;
3607
3608     local $/="\0";
3609     my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3610     debugcmd "|",@cmd;
3611     my $gafl = new IO::File;
3612     open $gafl, "-|", @cmd or confess $!;
3613     while (<$gafl>) {
3614         chomp or die;
3615         s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3616         next if $1 == 0;
3617         next unless m{(?:^|/)\.gitattributes$};
3618
3619         # oh dear, found one
3620         print STDERR f_ <<END, $what;
3621 dgit: warning: %s contains .gitattributes
3622 dgit: .gitattributes not (fully) defused.  Recommended: dgit setup-new-tree.
3623 END
3624         close $gafl;
3625         return;
3626     }
3627     # tree contains no .gitattributes files
3628     $?=0; $!=0; close $gafl or failedcmd @cmd;
3629 }
3630
3631
3632 sub multisuite_suite_child ($$$) {
3633     my ($tsuite, $mergeinputs, $fn) = @_;
3634     # in child, sets things up, calls $fn->(), and returns undef
3635     # in parent, returns canonical suite name for $tsuite
3636     my $canonsuitefh = IO::File::new_tmpfile;
3637     my $pid = fork // confess $!;
3638     if (!$pid) {
3639         forkcheck_setup();
3640         $isuite = $tsuite;
3641         $us .= " [$isuite]";
3642         $debugprefix .= " ";
3643         progress f_ "fetching %s...", $tsuite;
3644         canonicalise_suite();
3645         print $canonsuitefh $csuite, "\n" or confess $!;
3646         close $canonsuitefh or confess $!;
3647         $fn->();
3648         return undef;
3649     }
3650     waitpid $pid,0 == $pid or confess $!;
3651     fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3652         if $? && $?!=256*4;
3653     seek $canonsuitefh,0,0 or confess $!;
3654     local $csuite = <$canonsuitefh>;
3655     confess $! unless defined $csuite && chomp $csuite;
3656     if ($? == 256*4) {
3657         printdebug "multisuite $tsuite missing\n";
3658         return $csuite;
3659     }
3660     printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3661     push @$mergeinputs, {
3662         Ref => lrref,
3663         Info => $csuite,
3664     };
3665     return $csuite;
3666 }
3667
3668 sub fork_for_multisuite ($) {
3669     my ($before_fetch_merge) = @_;
3670     # if nothing unusual, just returns ''
3671     #
3672     # if multisuite:
3673     # returns 0 to caller in child, to do first of the specified suites
3674     # in child, $csuite is not yet set
3675     #
3676     # returns 1 to caller in parent, to finish up anything needed after
3677     # in parent, $csuite is set to canonicalised portmanteau
3678
3679     my $org_isuite = $isuite;
3680     my @suites = split /\,/, $isuite;
3681     return '' unless @suites > 1;
3682     printdebug "fork_for_multisuite: @suites\n";
3683
3684     my @mergeinputs;
3685
3686     my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3687                                             sub { });
3688     return 0 unless defined $cbasesuite;
3689
3690     fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3691         unless @mergeinputs;
3692
3693     my @csuites = ($cbasesuite);
3694
3695     $before_fetch_merge->();
3696
3697     foreach my $tsuite (@suites[1..$#suites]) {
3698         $tsuite =~ s/^-/$cbasesuite-/;
3699         my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3700                                                sub {
3701             @end = ();
3702             fetch_one();
3703             finish 0;
3704         });
3705
3706         $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3707         push @csuites, $csubsuite;
3708     }
3709
3710     foreach my $mi (@mergeinputs) {
3711         my $ref = git_get_ref $mi->{Ref};
3712         die "$mi->{Ref} ?" unless length $ref;
3713         $mi->{Commit} = $ref;
3714     }
3715
3716     $csuite = join ",", @csuites;
3717
3718     my $previous = git_get_ref lrref;
3719     if ($previous) {
3720         unshift @mergeinputs, {
3721             Commit => $previous,
3722             Info => (__ "local combined tracking branch"),
3723             Warning => (__
3724  "archive seems to have rewound: local tracking branch is ahead!"),
3725         };
3726     }
3727
3728     foreach my $ix (0..$#mergeinputs) {
3729         $mergeinputs[$ix]{Index} = $ix;
3730     }
3731
3732     @mergeinputs = sort {
3733         -version_compare(mergeinfo_version $a,
3734                          mergeinfo_version $b) # highest version first
3735             or
3736         $a->{Index} <=> $b->{Index}; # earliest in spec first
3737     } @mergeinputs;
3738
3739     my @needed;
3740
3741   NEEDED:
3742     foreach my $mi (@mergeinputs) {
3743         printdebug "multisuite merge check $mi->{Info}\n";
3744         foreach my $previous (@needed) {
3745             next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3746             printdebug "multisuite merge un-needed $previous->{Info}\n";
3747             next NEEDED;
3748         }
3749         push @needed, $mi;
3750         printdebug "multisuite merge this-needed\n";
3751         $mi->{Character} = '+';
3752     }
3753
3754     $needed[0]{Character} = '*';
3755
3756     my $output = $needed[0]{Commit};
3757
3758     if (@needed > 1) {
3759         printdebug "multisuite merge nontrivial\n";
3760         my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3761
3762         my $commit = "tree $tree\n";
3763         my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3764                      "Input branches:\n",
3765                      $csuite;
3766
3767         foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3768             printdebug "multisuite merge include $mi->{Info}\n";
3769             $mi->{Character} //= ' ';
3770             $commit .= "parent $mi->{Commit}\n";
3771             $msg .= sprintf " %s  %-25s %s\n",
3772                 $mi->{Character},
3773                 (mergeinfo_version $mi),
3774                 $mi->{Info};
3775         }
3776         my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3777         $msg .= __ "\nKey\n".
3778             " * marks the highest version branch, which choose to use\n".
3779             " + marks each branch which was not already an ancestor\n\n";
3780         $msg .=
3781             "[dgit multi-suite $csuite]\n";
3782         $commit .=
3783             "author $authline\n".
3784             "committer $authline\n\n";
3785         $output = make_commit_text $commit.$msg;
3786         printdebug "multisuite merge generated $output\n";
3787     }
3788
3789     fetch_from_archive_record_1($output);
3790     fetch_from_archive_record_2($output);
3791
3792     progress f_ "calculated combined tracking suite %s", $csuite;
3793
3794     return 1;
3795 }
3796
3797 sub clone_set_head () {
3798     open H, "> .git/HEAD" or confess $!;
3799     print H "ref: ".lref()."\n" or confess $!;
3800     close H or confess $!;
3801 }
3802 sub clone_finish ($) {
3803     my ($dstdir) = @_;
3804     runcmd @git, qw(reset --hard), lrref();
3805     runcmd qw(bash -ec), <<'END';
3806         set -o pipefail
3807         git ls-tree -r --name-only -z HEAD | \
3808         xargs -0r touch -h -r . --
3809 END
3810     printdone f_ "ready for work in %s", $dstdir;
3811 }
3812
3813 sub clone ($) {
3814     # in multisuite, returns twice!
3815     # once in parent after first suite fetched,
3816     # and then again in child after everything is finished
3817     my ($dstdir) = @_;
3818     badusage __ "dry run makes no sense with clone" unless act_local();
3819
3820     my $multi_fetched = fork_for_multisuite(sub {
3821         printdebug "multi clone before fetch merge\n";
3822         changedir $dstdir;
3823         record_maindir();
3824     });
3825     if ($multi_fetched) {
3826         printdebug "multi clone after fetch merge\n";
3827         clone_set_head();
3828         clone_finish($dstdir);
3829         return;
3830     }
3831     printdebug "clone main body\n";
3832
3833     mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3834     changedir $dstdir;
3835     check_bpd_exists();
3836
3837     canonicalise_suite();
3838     my $hasgit = check_for_git();
3839
3840     runcmd @git, qw(init -q);
3841     record_maindir();
3842     setup_new_tree();
3843     clone_set_head();
3844     my $giturl = access_giturl(1);
3845     if (defined $giturl) {
3846         runcmd @git, qw(remote add), 'origin', $giturl;
3847     }
3848     if ($hasgit) {
3849         progress __ "fetching existing git history";
3850         git_fetch_us();
3851         runcmd_ordryrun_local @git, qw(fetch origin);
3852     } else {
3853         progress __ "starting new git history";
3854     }
3855     fetch_from_archive() or no_such_package;
3856     my $vcsgiturl = $dsc->{'Vcs-Git'};
3857     if (length $vcsgiturl) {
3858         $vcsgiturl =~ s/\s+-b\s+\S+//g;
3859         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3860     }
3861     clone_finish($dstdir);
3862 }
3863
3864 sub fetch_one () {
3865     canonicalise_suite();
3866     if (check_for_git()) {
3867         git_fetch_us();
3868     }
3869     fetch_from_archive() or no_such_package();
3870
3871     my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3872     if (length $vcsgiturl and
3873         (grep { $csuite eq $_ }
3874          split /\;/,
3875          cfg 'dgit.vcs-git.suites')) {
3876         my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3877         if (defined $current && $current ne $vcsgiturl) {
3878             print STDERR f_ <<END, $csuite;
3879 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3880  Your vcs-git remote url may be out of date.  Use dgit update-vcs-git ?
3881 END
3882         }
3883     }
3884     printdone f_ "fetched into %s", lrref();
3885 }
3886
3887 sub dofetch () {
3888     my $multi_fetched = fork_for_multisuite(sub { });
3889     fetch_one() unless $multi_fetched; # parent
3890     finish 0 if $multi_fetched eq '0'; # child
3891 }
3892
3893 sub pull () {
3894     dofetch();
3895     runcmd_ordryrun_local @git, qw(merge -m),
3896         (f_ "Merge from %s [dgit]", $csuite),
3897         lrref();
3898     printdone f_ "fetched to %s and merged into HEAD", lrref();
3899 }
3900
3901 sub check_not_dirty () {
3902     my @forbid = qw(local-options local-patch-header);
3903     @forbid = map { "debian/source/$_" } @forbid;
3904     foreach my $f (@forbid) {
3905         if (stat_exists $f) {
3906             fail f_ "git tree contains %s", $f;
3907         }
3908     }
3909
3910     my @cmd = (@git, qw(status -uall --ignored --porcelain));
3911     push @cmd, qw(debian/source/format debian/source/options);
3912     push @cmd, @forbid;
3913
3914     my $bad = cmdoutput @cmd;
3915     if (length $bad) {
3916         fail +(__
3917  "you have uncommitted changes to critical files, cannot continue:\n").
3918               $bad;
3919     }
3920
3921     return if $includedirty;
3922
3923     git_check_unmodified();
3924 }
3925
3926 sub commit_admin ($) {
3927     my ($m) = @_;
3928     progress "$m";
3929     runcmd_ordryrun_local @git, qw(commit -m), $m;
3930 }
3931
3932 sub quiltify_nofix_bail ($$) {
3933     my ($headinfo, $xinfo) = @_;
3934     if ($quilt_mode eq 'nofix') {
3935         fail f_
3936             "quilt fixup required but quilt mode is \`nofix'\n".
3937             "HEAD commit%s differs from tree implied by debian/patches%s",
3938             $headinfo, $xinfo;
3939     }
3940 }
3941
3942 sub commit_quilty_patch () {
3943     my $output = cmdoutput @git, qw(status --ignored --porcelain);
3944     my %adds;
3945     foreach my $l (split /\n/, $output) {
3946         next unless $l =~ m/\S/;
3947         if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3948             $adds{$1}++;
3949         }
3950     }
3951     delete $adds{'.pc'}; # if there wasn't one before, don't add it
3952     if (!%adds) {
3953         progress __ "nothing quilty to commit, ok.";
3954         return;
3955     }
3956     quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3957     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3958     runcmd_ordryrun_local @git, qw(add -f), @adds;
3959     commit_admin +(__ <<ENDT).<<END
3960 Commit Debian 3.0 (quilt) metadata
3961
3962 ENDT
3963 [dgit ($our_version) quilt-fixup]
3964 END
3965 }
3966
3967 sub get_source_format () {
3968     my %options;
3969     if (open F, "debian/source/options") {
3970         while (<F>) {
3971             next if m/^\s*\#/;
3972             next unless m/\S/;
3973             s/\s+$//; # ignore missing final newline
3974             if (m/\s*\#\s*/) {
3975                 my ($k, $v) = ($`, $'); #');
3976                 $v =~ s/^"(.*)"$/$1/;
3977                 $options{$k} = $v;
3978             } else {
3979                 $options{$_} = 1;
3980             }
3981         }
3982         F->error and confess $!;
3983         close F;
3984     } else {
3985         confess $! unless $!==&ENOENT;
3986     }
3987
3988     if (!open F, "debian/source/format") {
3989         confess $! unless $!==&ENOENT;
3990         return '';
3991     }
3992     $_ = <F>;
3993     F->error and confess $!;
3994     chomp;
3995     return ($_, \%options);
3996 }
3997
3998 sub madformat_wantfixup ($) {
3999     my ($format) = @_;
4000     return 0 unless $format eq '3.0 (quilt)';
4001     our $quilt_mode_warned;
4002     if ($quilt_mode eq 'nocheck') {
4003         progress f_ "Not doing any fixup of \`%s'".
4004             " due to ----no-quilt-fixup or --quilt=nocheck", $format
4005             unless $quilt_mode_warned++;
4006         return 0;
4007     }
4008     progress f_ "Format \`%s', need to check/update patch stack", $format
4009         unless $quilt_mode_warned++;
4010     return 1;
4011 }
4012
4013 sub maybe_split_brain_save ($$$) {
4014     my ($headref, $dgitview, $msg) = @_;
4015     # => message fragment "$saved" describing disposition of $dgitview
4016     #    (used inside parens, in the English texts)
4017     my $save = $internal_object_save{'dgit-view'};
4018     return f_ "commit id %s", $dgitview unless defined $save;
4019     my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4020                git_update_ref_cmd
4021                "dgit --dgit-view-save $msg HEAD=$headref",
4022                $save, $dgitview);
4023     runcmd @cmd;
4024     return f_ "and left in %s", $save;
4025 }
4026
4027 # An "infopair" is a tuple [ $thing, $what ]
4028 # (often $thing is a commit hash; $what is a description)
4029
4030 sub infopair_cond_equal ($$) {
4031     my ($x,$y) = @_;
4032     $x->[0] eq $y->[0] or fail <<END;
4033 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4034 END
4035 };
4036
4037 sub infopair_lrf_tag_lookup ($$) {
4038     my ($tagnames, $what) = @_;
4039     # $tagname may be an array ref
4040     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4041     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4042     foreach my $tagname (@tagnames) {
4043         my $lrefname = lrfetchrefs."/tags/$tagname";
4044         my $tagobj = $lrfetchrefs_f{$lrefname};
4045         next unless defined $tagobj;
4046         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4047         return [ git_rev_parse($tagobj), $what ];
4048     }
4049     fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4050 Wanted tag %s (%s) on dgit server, but not found
4051 END
4052                       : (f_ <<END, $what, "@tagnames");
4053 Wanted tag %s (one of: %s) on dgit server, but not found
4054 END
4055 }
4056
4057 sub infopair_cond_ff ($$) {
4058     my ($anc,$desc) = @_;
4059     is_fast_fwd($anc->[0], $desc->[0]) or
4060         fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4061 %s (%s) .. %s (%s) is not fast forward
4062 END
4063 };
4064
4065 sub pseudomerge_version_check ($$) {
4066     my ($clogp, $archive_hash) = @_;
4067
4068     my $arch_clogp = commit_getclogp $archive_hash;
4069     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4070                      __ 'version currently in archive' ];
4071     if (defined $overwrite_version) {
4072         if (length $overwrite_version) {
4073             infopair_cond_equal([ $overwrite_version,
4074                                   '--overwrite= version' ],
4075                                 $i_arch_v);
4076         } else {
4077             my $v = $i_arch_v->[0];
4078             progress f_
4079                 "Checking package changelog for archive version %s ...", $v;
4080             my $cd;
4081             eval {
4082                 my @xa = ("-f$v", "-t$v");
4083                 my $vclogp = parsechangelog @xa;
4084                 my $gf = sub {
4085                     my ($fn) = @_;
4086                     [ (getfield $vclogp, $fn),
4087                       (f_ "%s field from dpkg-parsechangelog %s",
4088                           $fn, "@xa") ];
4089                 };
4090                 my $cv = $gf->('Version');
4091                 infopair_cond_equal($i_arch_v, $cv);
4092                 $cd = $gf->('Distribution');
4093             };
4094             if ($@) {
4095                 $@ =~ s/^dgit: //gm;
4096                 fail "$@".
4097                     f_ "Perhaps debian/changelog does not mention %s ?", $v;
4098             }
4099             fail f_ <<END, $cd->[1], $cd->[0], $v
4100 %s is %s
4101 Your tree seems to based on earlier (not uploaded) %s.
4102 END
4103                 if $cd->[0] =~ m/UNRELEASED/;
4104         }
4105     }
4106
4107     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4108     return $i_arch_v;
4109 }
4110
4111 sub pseudomerge_make_commit ($$$$ $$) {
4112     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4113         $msg_cmd, $msg_msg) = @_;
4114     progress f_ "Declaring that HEAD includes all changes in %s...",
4115                  $i_arch_v->[0];
4116
4117     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4118     my $authline = clogp_authline $clogp;
4119
4120     chomp $msg_msg;
4121     $msg_cmd .=
4122         !defined $overwrite_version ? ""
4123         : !length  $overwrite_version ? " --overwrite"
4124         : " --overwrite=".$overwrite_version;
4125
4126     # Contributing parent is the first parent - that makes
4127     # git rev-list --first-parent DTRT.
4128     my $pmf = dgit_privdir()."/pseudomerge";
4129     open MC, ">", $pmf or die "$pmf $!";
4130     print MC <<END or confess $!;
4131 tree $tree
4132 parent $dgitview
4133 parent $archive_hash
4134 author $authline
4135 committer $authline
4136
4137 $msg_msg
4138
4139 [$msg_cmd]
4140 END
4141     close MC or confess $!;
4142
4143     return make_commit($pmf);
4144 }
4145
4146 sub splitbrain_pseudomerge ($$$$) {
4147     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4148     # => $merged_dgitview
4149     printdebug "splitbrain_pseudomerge...\n";
4150     #
4151     #     We:      debian/PREVIOUS    HEAD($maintview)
4152     # expect:          o ----------------- o
4153     #                    \                   \
4154     #                     o                   o
4155     #                 a/d/PREVIOUS        $dgitview
4156     #                $archive_hash              \
4157     #  If so,                \                   \
4158     #  we do:                 `------------------ o
4159     #   this:                                   $dgitview'
4160     #
4161
4162     return $dgitview unless defined $archive_hash;
4163     return $dgitview if deliberately_not_fast_forward();
4164
4165     printdebug "splitbrain_pseudomerge...\n";
4166
4167     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4168
4169     if (!defined $overwrite_version) {
4170         progress __ "Checking that HEAD includes all changes in archive...";
4171     }
4172
4173     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4174
4175     if (defined $overwrite_version) {
4176     } elsif (!eval {
4177         my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4178         my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4179                                               __ "maintainer view tag");
4180         my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4181         my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4182         my $i_archive = [ $archive_hash, __ "current archive contents" ];
4183
4184         printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4185
4186         infopair_cond_equal($i_dgit, $i_archive);
4187         infopair_cond_ff($i_dep14, $i_dgit);
4188         infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4189         1;
4190     }) {
4191         $@ =~ s/^\n//; chomp $@;
4192         print STDERR <<END.(__ <<ENDT);
4193 $@
4194 END
4195 | Not fast forward; maybe --overwrite is needed ?  Please see dgit(1).
4196 ENDT
4197         finish -1;
4198     }
4199
4200     my $arch_v = $i_arch_v->[0];
4201     my $r = pseudomerge_make_commit
4202         $clogp, $dgitview, $archive_hash, $i_arch_v,
4203         "dgit --quilt=$quilt_mode",
4204         (defined $overwrite_version
4205          ? f_ "Declare fast forward from %s\n", $arch_v
4206          : f_ "Make fast forward from %s\n",    $arch_v);
4207
4208     maybe_split_brain_save $maintview, $r, "pseudomerge";
4209
4210     progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4211     return $r;
4212 }
4213
4214 sub plain_overwrite_pseudomerge ($$$) {
4215     my ($clogp, $head, $archive_hash) = @_;
4216
4217     printdebug "plain_overwrite_pseudomerge...";
4218
4219     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4220
4221     return $head if is_fast_fwd $archive_hash, $head;
4222
4223     my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4224
4225     my $r = pseudomerge_make_commit
4226         $clogp, $head, $archive_hash, $i_arch_v,
4227         "dgit", $m;
4228
4229     runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4230
4231     progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4232     return $r;
4233 }
4234
4235 sub push_parse_changelog ($) {
4236     my ($clogpfn) = @_;
4237
4238     my $clogp = Dpkg::Control::Hash->new();
4239     $clogp->load($clogpfn) or die;
4240
4241     my $clogpackage = getfield $clogp, 'Source';
4242     $package //= $clogpackage;
4243     fail f_ "-p specified %s but changelog specified %s",
4244             $package, $clogpackage
4245         unless $package eq $clogpackage;
4246     my $cversion = getfield $clogp, 'Version';
4247
4248     if (!$we_are_initiator) {
4249         # rpush initiator can't do this because it doesn't have $isuite yet
4250         my $tag = debiantag($cversion, access_nomdistro);
4251         runcmd @git, qw(check-ref-format), $tag;
4252     }
4253
4254     my $dscfn = dscfn($cversion);
4255
4256     return ($clogp, $cversion, $dscfn);
4257 }
4258
4259 sub push_parse_dsc ($$$) {
4260     my ($dscfn,$dscfnwhat, $cversion) = @_;
4261     $dsc = parsecontrol($dscfn,$dscfnwhat);
4262     my $dversion = getfield $dsc, 'Version';
4263     my $dscpackage = getfield $dsc, 'Source';
4264     ($dscpackage eq $package && $dversion eq $cversion) or
4265         fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4266                 $dscfn, $dscpackage, $dversion,
4267                         $package,    $cversion;
4268 }
4269
4270 sub push_tagwants ($$$$) {
4271     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4272     my @tagwants;
4273     push @tagwants, {
4274         TagFn => \&debiantag,
4275         Objid => $dgithead,
4276         TfSuffix => '',
4277         View => 'dgit',
4278     };
4279     if (defined $maintviewhead) {
4280         push @tagwants, {
4281             TagFn => \&debiantag_maintview,
4282             Objid => $maintviewhead,
4283             TfSuffix => '-maintview',
4284             View => 'maint',
4285         };
4286     } elsif ($dodep14tag eq 'no' ? 0
4287              : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4288              : $dodep14tag eq 'always'
4289              ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4290 --dep14tag-always (or equivalent in config) means server must support
4291  both "new" and "maint" tag formats, but config says it doesn't.
4292 END
4293             : die "$dodep14tag ?") {
4294         push @tagwants, {
4295             TagFn => \&debiantag_maintview,
4296             Objid => $dgithead,
4297             TfSuffix => '-dgit',
4298             View => 'dgit',
4299         };
4300     };
4301     foreach my $tw (@tagwants) {
4302         $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4303         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4304     }
4305     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4306     return @tagwants;
4307 }
4308
4309 sub push_mktags ($$ $$ $) {
4310     my ($clogp,$dscfn,
4311         $changesfile,$changesfilewhat,
4312         $tagwants) = @_;
4313
4314     die unless $tagwants->[0]{View} eq 'dgit';
4315
4316     my $declaredistro = access_nomdistro();
4317     my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4318     $dsc->{$ourdscfield[0]} = join " ",
4319         $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4320         $reader_giturl;
4321     $dsc->save("$dscfn.tmp") or confess $!;
4322
4323     my $changes = parsecontrol($changesfile,$changesfilewhat);
4324     foreach my $field (qw(Source Distribution Version)) {
4325         $changes->{$field} eq $clogp->{$field} or
4326             fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4327                     $field, $changes->{$field}, $clogp->{$field};
4328     }
4329
4330     my $cversion = getfield $clogp, 'Version';
4331     my $clogsuite = getfield $clogp, 'Distribution';
4332
4333     # We make the git tag by hand because (a) that makes it easier
4334     # to control the "tagger" (b) we can do remote signing
4335     my $authline = clogp_authline $clogp;
4336     my $delibs = join(" ", "",@deliberatelies);
4337
4338     my $mktag = sub {
4339         my ($tw) = @_;
4340         my $tfn = $tw->{Tfn};
4341         my $head = $tw->{Objid};
4342         my $tag = $tw->{Tag};
4343
4344         open TO, '>', $tfn->('.tmp') or confess $!;
4345         print TO <<END or confess $!;
4346 object $head
4347 type commit
4348 tag $tag
4349 tagger $authline
4350
4351 END
4352         if ($tw->{View} eq 'dgit') {
4353             print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4354 %s release %s for %s (%s) [dgit]
4355 ENDT
4356                 or confess $!;
4357             print TO <<END or confess $!;
4358 [dgit distro=$declaredistro$delibs]
4359 END
4360             foreach my $ref (sort keys %previously) {
4361                 print TO <<END or confess $!;
4362 [dgit previously:$ref=$previously{$ref}]
4363 END
4364             }
4365         } elsif ($tw->{View} eq 'maint') {
4366             print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4367 %s release %s for %s (%s)
4368 (maintainer view tag generated by dgit --quilt=%s)
4369 END
4370                 $quilt_mode
4371                 or confess $!;
4372         } else {
4373             confess Dumper($tw)."?";
4374         }
4375
4376         close TO or confess $!;
4377
4378         my $tagobjfn = $tfn->('.tmp');
4379         if ($sign) {
4380             if (!defined $keyid) {
4381                 $keyid = access_cfg('keyid','RETURN-UNDEF');
4382             }
4383             if (!defined $keyid) {
4384                 $keyid = getfield $clogp, 'Maintainer';
4385             }
4386             unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess $!;
4387             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4388             push @sign_cmd, qw(-u),$keyid if defined $keyid;
4389             push @sign_cmd, $tfn->('.tmp');
4390             runcmd_ordryrun @sign_cmd;
4391             if (act_scary()) {
4392                 $tagobjfn = $tfn->('.signed.tmp');
4393                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4394                     $tfn->('.tmp'), $tfn->('.tmp.asc');
4395             }
4396         }
4397         return $tagobjfn;
4398     };
4399
4400     my @r = map { $mktag->($_); } @$tagwants;
4401     return @r;
4402 }
4403
4404 sub sign_changes ($) {
4405     my ($changesfile) = @_;
4406     if ($sign) {
4407         my @debsign_cmd = @debsign;
4408         push @debsign_cmd, "-k$keyid" if defined $keyid;
4409         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4410         push @debsign_cmd, $changesfile;
4411         runcmd_ordryrun @debsign_cmd;
4412     }
4413 }
4414
4415 sub dopush () {
4416     printdebug "actually entering push\n";
4417
4418     supplementary_message(__ <<'END');
4419 Push failed, while checking state of the archive.
4420 You can retry the push, after fixing the problem, if you like.
4421 END
4422     if (check_for_git()) {
4423         git_fetch_us();
4424     }
4425     my $archive_hash = fetch_from_archive();
4426     if (!$archive_hash) {
4427         $new_package or
4428             fail __ "package appears to be new in this suite;".
4429                     " if this is intentional, use --new";
4430     }
4431
4432     supplementary_message(__ <<'END');
4433 Push failed, while preparing your push.
4434 You can retry the push, after fixing the problem, if you like.
4435 END
4436
4437     need_tagformat 'new', "quilt mode $quilt_mode"
4438         if quiltmode_splitbrain;
4439
4440     prep_ud();
4441
4442     access_giturl(); # check that success is vaguely likely
4443     rpush_handle_protovsn_bothends() if $we_are_initiator;
4444     select_tagformat();
4445
4446     my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4447     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4448
4449     responder_send_file('parsed-changelog', $clogpfn);
4450
4451     my ($clogp, $cversion, $dscfn) =
4452         push_parse_changelog("$clogpfn");
4453
4454     my $dscpath = "$buildproductsdir/$dscfn";
4455     stat_exists $dscpath or
4456         fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4457                 $dscpath, $!;
4458
4459     responder_send_file('dsc', $dscpath);
4460
4461     push_parse_dsc($dscpath, $dscfn, $cversion);
4462
4463     my $format = getfield $dsc, 'Format';
4464     printdebug "format $format\n";
4465
4466     my $symref = git_get_symref();
4467     my $actualhead = git_rev_parse('HEAD');
4468
4469     if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4470         if (quiltmode_splitbrain()) {
4471             my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4472             fail f_ <<END, $ffq_prev, $quilt_mode;
4473 Branch is managed by git-debrebase (%s
4474 exists), but quilt mode (%s) implies a split view.
4475 Pass the right --quilt option or adjust your git config.
4476 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4477 END
4478         }
4479         runcmd_ordryrun_local @git_debrebase, 'stitch';
4480         $actualhead = git_rev_parse('HEAD');
4481     }
4482
4483     my $dgithead = $actualhead;
4484     my $maintviewhead = undef;
4485
4486     my $upstreamversion = upstreamversion $clogp->{Version};
4487
4488     if (madformat_wantfixup($format)) {
4489         # user might have not used dgit build, so maybe do this now:
4490         if (quiltmode_splitbrain()) {
4491             changedir $playground;
4492             quilt_make_fake_dsc($upstreamversion);
4493             my $cachekey;
4494             ($dgithead, $cachekey) =
4495                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4496             $dgithead or fail f_
4497  "--quilt=%s but no cached dgit view:
4498  perhaps HEAD changed since dgit build[-source] ?",
4499                               $quilt_mode;
4500             $split_brain = 1;
4501             $dgithead = splitbrain_pseudomerge($clogp,
4502                                                $actualhead, $dgithead,
4503                                                $archive_hash);
4504             $maintviewhead = $actualhead;
4505             changedir $maindir;
4506             prep_ud(); # so _only_subdir() works, below
4507         } else {
4508             commit_quilty_patch();
4509         }
4510     }
4511
4512     if (defined $overwrite_version && !defined $maintviewhead
4513         && $archive_hash) {
4514         $dgithead = plain_overwrite_pseudomerge($clogp,
4515                                                 $dgithead,
4516                                                 $archive_hash);
4517     }
4518
4519     check_not_dirty();
4520
4521     my $forceflag = '';
4522     if ($archive_hash) {
4523         if (is_fast_fwd($archive_hash, $dgithead)) {
4524             # ok
4525         } elsif (deliberately_not_fast_forward) {
4526             $forceflag = '+';
4527         } else {
4528             fail __ "dgit push: HEAD is not a descendant".
4529                 " of the archive's version.\n".
4530                 "To overwrite the archive's contents,".
4531                 " pass --overwrite[=VERSION].\n".
4532                 "To rewind history, if permitted by the archive,".
4533                 " use --deliberately-not-fast-forward.";
4534         }
4535     }
4536
4537     changedir $playground;
4538     progress f_ "checking that %s corresponds to HEAD", $dscfn;
4539     runcmd qw(dpkg-source -x --),
4540         $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4541     my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4542     check_for_vendor_patches() if madformat($dsc->{format});
4543     changedir $maindir;
4544     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4545     debugcmd "+",@diffcmd;
4546     $!=0; $?=-1;
4547     my $r = system @diffcmd;
4548     if ($r) {
4549         if ($r==256) {
4550             my $referent = $split_brain ? $dgithead : 'HEAD';
4551             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4552
4553             my @mode_changes;
4554             my $raw = cmdoutput @git,
4555                 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4556             my $changed;
4557             foreach (split /\0/, $raw) {
4558                 if (defined $changed) {
4559                     push @mode_changes, "$changed: $_\n" if $changed;
4560                     $changed = undef;
4561                     next;
4562                 } elsif (m/^:0+ 0+ /) {
4563                     $changed = '';
4564                 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4565                     $changed = "Mode change from $1 to $2"
4566                 } else {
4567                     die "$_ ?";
4568                 }
4569             }
4570             if (@mode_changes) {
4571                 fail +(f_ <<ENDT, $dscfn).<<END
4572 HEAD specifies a different tree to %s:
4573 ENDT
4574 $diffs
4575 END
4576                     .(join '', @mode_changes)
4577                     .(f_ <<ENDT, $tree, $referent);
4578 There is a problem with your source tree (see dgit(7) for some hints).
4579 To see a full diff, run git diff %s %s
4580 ENDT
4581             }
4582
4583             fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4584 HEAD specifies a different tree to %s:
4585 ENDT
4586 $diffs
4587 END
4588 Perhaps you forgot to build.  Or perhaps there is a problem with your
4589  source tree (see dgit(7) for some hints).  To see a full diff, run
4590    git diff %s %s
4591 ENDT
4592         } else {
4593             failedcmd @diffcmd;
4594         }
4595     }
4596     if (!$changesfile) {
4597         my $pat = changespat $cversion;
4598         my @cs = glob "$buildproductsdir/$pat";
4599         fail f_ "failed to find unique changes file".
4600                 " (looked for %s in %s);".
4601                 " perhaps you need to use dgit -C",
4602                 $pat, $buildproductsdir
4603             unless @cs==1;
4604         ($changesfile) = @cs;
4605     } else {
4606         $changesfile = "$buildproductsdir/$changesfile";
4607     }
4608
4609     # Check that changes and .dsc agree enough
4610     $changesfile =~ m{[^/]*$};
4611     my $changes = parsecontrol($changesfile,$&);
4612     files_compare_inputs($dsc, $changes)
4613         unless forceing [qw(dsc-changes-mismatch)];
4614
4615     # Check whether this is a source only upload
4616     my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4617     my $sourceonlypolicy = access_cfg 'source-only-uploads';
4618     if ($sourceonlypolicy eq 'ok') {
4619     } elsif ($sourceonlypolicy eq 'always') {
4620         forceable_fail [qw(uploading-binaries)],
4621             __ "uploading binaries, although distro policy is source only"
4622             if $hasdebs;
4623     } elsif ($sourceonlypolicy eq 'never') {
4624         forceable_fail [qw(uploading-source-only)],
4625             __ "source-only upload, although distro policy requires .debs"
4626             if !$hasdebs;
4627     } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4628         forceable_fail [qw(uploading-source-only)],
4629             f_ "source-only upload, even though package is entirely NEW\n".
4630                "(this is contrary to policy in %s)",
4631                access_nomdistro()
4632             if !$hasdebs
4633             && $new_package
4634             && !(archive_query('package_not_wholly_new', $package) // 1);
4635     } else {
4636         badcfg f_ "unknown source-only-uploads policy \`%s'",
4637                   $sourceonlypolicy;
4638     }
4639
4640     # Perhaps adjust .dsc to contain right set of origs
4641     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4642                                   $changesfile)
4643         unless forceing [qw(changes-origs-exactly)];
4644
4645     # Checks complete, we're going to try and go ahead:
4646
4647     responder_send_file('changes',$changesfile);
4648     responder_send_command("param head $dgithead");
4649     responder_send_command("param csuite $csuite");
4650     responder_send_command("param isuite $isuite");
4651     responder_send_command("param tagformat $tagformat");
4652     if (defined $maintviewhead) {
4653         confess "internal error (protovsn=$protovsn)"
4654             if defined $protovsn and $protovsn < 4;
4655         responder_send_command("param maint-view $maintviewhead");
4656     }
4657
4658     # Perhaps send buildinfo(s) for signing
4659     my $changes_files = getfield $changes, 'Files';
4660     my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4661     foreach my $bi (@buildinfos) {
4662         responder_send_command("param buildinfo-filename $bi");
4663         responder_send_file('buildinfo', "$buildproductsdir/$bi");
4664     }
4665
4666     if (deliberately_not_fast_forward) {
4667         git_for_each_ref(lrfetchrefs, sub {
4668             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4669             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4670             responder_send_command("previously $rrefname=$objid");
4671             $previously{$rrefname} = $objid;
4672         });
4673     }
4674
4675     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4676                                  dgit_privdir()."/tag");
4677     my @tagobjfns;
4678
4679     supplementary_message(__ <<'END');
4680 Push failed, while signing the tag.
4681 You can retry the push, after fixing the problem, if you like.
4682 END
4683     # If we manage to sign but fail to record it anywhere, it's fine.
4684     if ($we_are_responder) {
4685         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4686         responder_receive_files('signed-tag', @tagobjfns);
4687     } else {
4688         @tagobjfns = push_mktags($clogp,$dscpath,
4689                               $changesfile,$changesfile,
4690                               \@tagwants);
4691     }
4692     supplementary_message(__ <<'END');
4693 Push failed, *after* signing the tag.
4694 If you want to try again, you should use a new version number.
4695 END
4696
4697     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4698
4699     foreach my $tw (@tagwants) {
4700         my $tag = $tw->{Tag};
4701         my $tagobjfn = $tw->{TagObjFn};
4702         my $tag_obj_hash =
4703             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4704         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4705         runcmd_ordryrun_local
4706             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4707     }
4708
4709     supplementary_message(__ <<'END');
4710 Push failed, while updating the remote git repository - see messages above.
4711 If you want to try again, you should use a new version number.
4712 END
4713     if (!check_for_git()) {
4714         create_remote_git_repo();
4715     }
4716
4717     my @pushrefs = $forceflag.$dgithead.":".rrref();
4718     foreach my $tw (@tagwants) {
4719         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4720     }
4721
4722     runcmd_ordryrun @git,
4723         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4724     runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4725
4726     supplementary_message(__ <<'END');
4727 Push failed, while obtaining signatures on the .changes and .dsc.
4728 If it was just that the signature failed, you may try again by using
4729 debsign by hand to sign the changes file (see the command dgit tried,
4730 above), and then dput that changes file to complete the upload.
4731 If you need to change the package, you must use a new version number.
4732 END
4733     if ($we_are_responder) {
4734         my $dryrunsuffix = act_local() ? "" : ".tmp";
4735         my @rfiles = ($dscpath, $changesfile);
4736         push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4737         responder_receive_files('signed-dsc-changes',
4738                                 map { "$_$dryrunsuffix" } @rfiles);
4739     } else {
4740         if (act_local()) {
4741             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4742         } else {
4743             progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4744         }
4745         sign_changes $changesfile;
4746     }
4747
4748     supplementary_message(f_ <<END, $changesfile);
4749 Push failed, while uploading package(s) to the archive server.
4750 You can retry the upload of exactly these same files with dput of:
4751   %s
4752 If that .changes file is broken, you will need to use a new version
4753 number for your next attempt at the upload.
4754 END
4755     my $host = access_cfg('upload-host','RETURN-UNDEF');
4756     my @hostarg = defined($host) ? ($host,) : ();
4757     runcmd_ordryrun @dput, @hostarg, $changesfile;
4758     printdone f_ "pushed and uploaded %s", $cversion;
4759
4760     supplementary_message('');
4761     responder_send_command("complete");
4762 }
4763
4764 sub pre_clone () {
4765     not_necessarily_a_tree();
4766 }
4767 sub cmd_clone {
4768     parseopts();
4769     my $dstdir;
4770     badusage __ "-p is not allowed with clone; specify as argument instead"
4771         if defined $package;
4772     if (@ARGV==1) {
4773         ($package) = @ARGV;
4774     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4775         ($package,$isuite) = @ARGV;
4776     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4777         ($package,$dstdir) = @ARGV;
4778     } elsif (@ARGV==3) {
4779         ($package,$isuite,$dstdir) = @ARGV;
4780     } else {
4781         badusage __ "incorrect arguments to dgit clone";
4782     }
4783     notpushing();
4784
4785     $dstdir ||= "$package";
4786     if (stat_exists $dstdir) {
4787         fail f_ "%s already exists", $dstdir;
4788     }
4789
4790     my $cwd_remove;
4791     if ($rmonerror && !$dryrun_level) {
4792         $cwd_remove= getcwd();
4793         unshift @end, sub {
4794             return unless defined $cwd_remove;
4795             if (!chdir "$cwd_remove") {
4796                 return if $!==&ENOENT;
4797                 confess "chdir $cwd_remove: $!";
4798             }
4799             printdebug "clone rmonerror removing $dstdir\n";
4800             if (stat $dstdir) {
4801                 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4802             } elsif (grep { $! == $_ }
4803                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4804             } else {
4805                 print STDERR f_ "check whether to remove %s: %s\n",
4806                                 $dstdir, $!;
4807             }
4808         };
4809     }
4810
4811     clone($dstdir);
4812     $cwd_remove = undef;
4813 }
4814
4815 sub branchsuite () {
4816     my $branch = git_get_symref();
4817     if (defined $branch && $branch =~ m#$lbranch_re#o) {
4818         return $1;
4819     } else {
4820         return undef;
4821     }
4822 }
4823
4824 sub package_from_d_control () {
4825     if (!defined $package) {
4826         my $sourcep = parsecontrol('debian/control','debian/control');
4827         $package = getfield $sourcep, 'Source';
4828     }
4829 }
4830
4831 sub fetchpullargs () {
4832     package_from_d_control();
4833     if (@ARGV==0) {
4834         $isuite = branchsuite();
4835         if (!$isuite) {
4836             my $clogp = parsechangelog();
4837             my $clogsuite = getfield $clogp, 'Distribution';
4838             $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4839         }
4840     } elsif (@ARGV==1) {
4841         ($isuite) = @ARGV;
4842     } else {
4843         badusage __ "incorrect arguments to dgit fetch or dgit pull";
4844     }
4845     notpushing();
4846 }
4847
4848 sub cmd_fetch {
4849     parseopts();
4850     fetchpullargs();
4851     dofetch();
4852 }
4853
4854 sub cmd_pull {
4855     parseopts();
4856     fetchpullargs();
4857     if (quiltmode_splitbrain()) {
4858         my ($format, $fopts) = get_source_format();
4859         madformat($format) and fail f_ <<END, $quilt_mode
4860 dgit pull not yet supported in split view mode (--quilt=%s)
4861 END
4862     }
4863     pull();
4864 }
4865
4866 sub cmd_checkout {
4867     parseopts();
4868     package_from_d_control();
4869     @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4870     ($isuite) = @ARGV;
4871     notpushing();
4872
4873     foreach my $canon (qw(0 1)) {
4874         if (!$canon) {
4875             $csuite= $isuite;
4876         } else {
4877             undef $csuite;
4878             canonicalise_suite();
4879         }
4880         if (length git_get_ref lref()) {
4881             # local branch already exists, yay
4882             last;
4883         }
4884         if (!length git_get_ref lrref()) {
4885             if (!$canon) {
4886                 # nope
4887                 next;
4888             }
4889             dofetch();
4890         }
4891         # now lrref exists
4892         runcmd (@git, qw(update-ref), lref(), lrref(), '');
4893         last;
4894     }
4895     local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4896         "dgit checkout $isuite";
4897     runcmd (@git, qw(checkout), lbranch());
4898 }
4899
4900 sub cmd_update_vcs_git () {
4901     my $specsuite;
4902     if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4903         ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4904     } else {
4905         ($specsuite) = (@ARGV);
4906         shift @ARGV;
4907     }
4908     my $dofetch=1;
4909     if (@ARGV) {
4910         if ($ARGV[0] eq '-') {
4911             $dofetch = 0;
4912         } elsif ($ARGV[0] eq '-') {
4913             shift;
4914         }
4915     }
4916
4917     package_from_d_control();
4918     my $ctrl;
4919     if ($specsuite eq '.') {
4920         $ctrl = parsecontrol 'debian/control', 'debian/control';
4921     } else {
4922         $isuite = $specsuite;
4923         get_archive_dsc();
4924         $ctrl = $dsc;
4925     }
4926     my $url = getfield $ctrl, 'Vcs-Git';
4927
4928     my @cmd;
4929     my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4930     if (!defined $orgurl) {
4931         print STDERR f_ "setting up vcs-git: %s\n", $url;
4932         @cmd = (@git, qw(remote add vcs-git), $url);
4933     } elsif ($orgurl eq $url) {
4934         print STDERR f_ "vcs git already configured: %s\n", $url;
4935     } else {
4936         print STDERR f_ "changing vcs-git url to: %s\n", $url;
4937         @cmd = (@git, qw(remote set-url vcs-git), $url);
4938     }
4939     runcmd_ordryrun_local @cmd;
4940     if ($dofetch) {
4941         print f_ "fetching (%s)\n", "@ARGV";
4942         runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4943     }
4944 }
4945
4946 sub prep_push () {
4947     parseopts();
4948     build_or_push_prep_early();
4949     pushing();
4950     check_not_dirty();
4951     my $specsuite;
4952     if (@ARGV==0) {
4953     } elsif (@ARGV==1) {
4954         ($specsuite) = (@ARGV);
4955     } else {
4956         badusage f_ "incorrect arguments to dgit %s", $subcommand;
4957     }
4958     if ($new_package) {
4959         local ($package) = $existing_package; # this is a hack
4960         canonicalise_suite();
4961     } else {
4962         canonicalise_suite();
4963     }
4964     if (defined $specsuite &&
4965         $specsuite ne $isuite &&
4966         $specsuite ne $csuite) {
4967             fail f_ "dgit %s: changelog specifies %s (%s)".
4968                     " but command line specifies %s",
4969                     $subcommand, $isuite, $csuite, $specsuite;
4970     }
4971 }
4972
4973 sub cmd_push {
4974     prep_push();
4975     dopush();
4976 }
4977
4978 #---------- remote commands' implementation ----------
4979
4980 sub pre_remote_push_build_host {
4981     my ($nrargs) = shift @ARGV;
4982     my (@rargs) = @ARGV[0..$nrargs-1];
4983     @ARGV = @ARGV[$nrargs..$#ARGV];
4984     die unless @rargs;
4985     my ($dir,$vsnwant) = @rargs;
4986     # vsnwant is a comma-separated list; we report which we have
4987     # chosen in our ready response (so other end can tell if they
4988     # offered several)
4989     $debugprefix = ' ';
4990     $we_are_responder = 1;
4991     $us .= " (build host)";
4992
4993     open PI, "<&STDIN" or confess $!;
4994     open STDIN, "/dev/null" or confess $!;
4995     open PO, ">&STDOUT" or confess $!;
4996     autoflush PO 1;
4997     open STDOUT, ">&STDERR" or confess $!;
4998     autoflush STDOUT 1;
4999
5000     $vsnwant //= 1;
5001     ($protovsn) = grep {
5002         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
5003     } @rpushprotovsn_support;
5004
5005     fail f_ "build host has dgit rpush protocol versions %s".
5006             " but invocation host has %s",
5007             (join ",", @rpushprotovsn_support), $vsnwant
5008         unless defined $protovsn;
5009
5010     changedir $dir;
5011 }
5012 sub cmd_remote_push_build_host {
5013     responder_send_command("dgit-remote-push-ready $protovsn");
5014     &cmd_push;
5015 }
5016
5017 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5018 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5019 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5020 #     a good error message)
5021
5022 sub rpush_handle_protovsn_bothends () {
5023     if ($protovsn < 4) {
5024         need_tagformat 'old', "rpush negotiated protocol $protovsn";
5025     }
5026     select_tagformat();
5027 }
5028
5029 our $i_tmp;
5030
5031 sub i_cleanup {
5032     local ($@, $?);
5033     my $report = i_child_report();
5034     if (defined $report) {
5035         printdebug "($report)\n";
5036     } elsif ($i_child_pid) {
5037         printdebug "(killing build host child $i_child_pid)\n";
5038         kill 15, $i_child_pid;
5039     }
5040     if (defined $i_tmp && !defined $initiator_tempdir) {
5041         changedir "/";
5042         eval { rmtree $i_tmp; };
5043     }
5044 }
5045
5046 END {
5047     return unless forkcheck_mainprocess();
5048     i_cleanup();
5049 }
5050
5051 sub i_method {
5052     my ($base,$selector,@args) = @_;
5053     $selector =~ s/\-/_/g;
5054     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5055 }
5056
5057 sub pre_rpush () {
5058     not_necessarily_a_tree();
5059 }
5060 sub cmd_rpush {
5061     my $host = nextarg;
5062     my $dir;
5063     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5064         $host = $1;
5065         $dir = $'; #';
5066     } else {
5067         $dir = nextarg;
5068     }
5069     $dir =~ s{^-}{./-};
5070     my @rargs = ($dir);
5071     push @rargs, join ",", @rpushprotovsn_support;
5072     my @rdgit;
5073     push @rdgit, @dgit;
5074     push @rdgit, @ropts;
5075     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5076     push @rdgit, @ARGV;
5077     my @cmd = (@ssh, $host, shellquote @rdgit);
5078     debugcmd "+",@cmd;
5079
5080     $we_are_initiator=1;
5081
5082     if (defined $initiator_tempdir) {
5083         rmtree $initiator_tempdir;
5084         mkdir $initiator_tempdir, 0700
5085             or fail f_ "create %s: %s", $initiator_tempdir, $!;
5086         $i_tmp = $initiator_tempdir;
5087     } else {
5088         $i_tmp = tempdir();
5089     }
5090     $i_child_pid = open2(\*RO, \*RI, @cmd);
5091     changedir $i_tmp;
5092     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5093     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5094     $supplementary_message = '' unless $protovsn >= 3;
5095
5096     for (;;) {
5097         my ($icmd,$iargs) = initiator_expect {
5098             m/^(\S+)(?: (.*))?$/;
5099             ($1,$2);
5100         };
5101         i_method "i_resp", $icmd, $iargs;
5102     }
5103 }
5104
5105 sub i_resp_progress ($) {
5106     my ($rhs) = @_;
5107     my $msg = protocol_read_bytes \*RO, $rhs;
5108     progress $msg;
5109 }
5110
5111 sub i_resp_supplementary_message ($) {
5112     my ($rhs) = @_;
5113     $supplementary_message = protocol_read_bytes \*RO, $rhs;
5114 }
5115
5116 sub i_resp_complete {
5117     my $pid = $i_child_pid;
5118     $i_child_pid = undef; # prevents killing some other process with same pid
5119     printdebug "waiting for build host child $pid...\n";
5120     my $got = waitpid $pid, 0;
5121     confess $! unless $got == $pid;
5122     fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5123
5124     i_cleanup();
5125     printdebug __ "all done\n";
5126     finish 0;
5127 }
5128
5129 sub i_resp_file ($) {
5130     my ($keyword) = @_;
5131     my $localname = i_method "i_localname", $keyword;
5132     my $localpath = "$i_tmp/$localname";
5133     stat_exists $localpath and
5134         badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5135     protocol_receive_file \*RO, $localpath;
5136     i_method "i_file", $keyword;
5137 }
5138
5139 our %i_param;
5140
5141 sub i_resp_param ($) {
5142     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5143     $i_param{$1} = $2;
5144 }
5145
5146 sub i_resp_previously ($) {
5147     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5148         or badproto \*RO, __ "bad previously spec";
5149     my $r = system qw(git check-ref-format), $1;
5150     confess "bad previously ref spec ($r)" if $r;
5151     $previously{$1} = $2;
5152 }
5153
5154 our %i_wanted;
5155
5156 sub i_resp_want ($) {
5157     my ($keyword) = @_;
5158     die "$keyword ?" if $i_wanted{$keyword}++;
5159
5160     defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5161     $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5162     die unless $isuite =~ m/^$suite_re$/;
5163
5164     pushing();
5165     rpush_handle_protovsn_bothends();
5166
5167     fail f_ "rpush negotiated protocol version %s".
5168         " which does not support quilt mode %s",
5169         $protovsn, $quilt_mode
5170         if quiltmode_splitbrain;
5171
5172     my @localpaths = i_method "i_want", $keyword;
5173     printdebug "[[  $keyword @localpaths\n";
5174     foreach my $localpath (@localpaths) {
5175         protocol_send_file \*RI, $localpath;
5176     }
5177     print RI "files-end\n" or confess $!;
5178 }
5179
5180 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5181
5182 sub i_localname_parsed_changelog {
5183     return "remote-changelog.822";
5184 }
5185 sub i_file_parsed_changelog {
5186     ($i_clogp, $i_version, $i_dscfn) =
5187         push_parse_changelog "$i_tmp/remote-changelog.822";
5188     die if $i_dscfn =~ m#/|^\W#;
5189 }
5190
5191 sub i_localname_dsc {
5192     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5193     return $i_dscfn;
5194 }
5195 sub i_file_dsc { }
5196
5197 sub i_localname_buildinfo ($) {
5198     my $bi = $i_param{'buildinfo-filename'};
5199     defined $bi or badproto \*RO, "buildinfo before filename";
5200     defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5201     $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5202         or badproto \*RO, "improper buildinfo filename";
5203     return $&;
5204 }
5205 sub i_file_buildinfo {
5206     my $bi = $i_param{'buildinfo-filename'};
5207     my $bd = parsecontrol "$i_tmp/$bi", $bi;
5208     my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5209     if (!forceing [qw(buildinfo-changes-mismatch)]) {
5210         files_compare_inputs($bd, $ch);
5211         (getfield $bd, $_) eq (getfield $ch, $_) or
5212             fail f_ "buildinfo mismatch in field %s", $_
5213             foreach qw(Source Version);
5214         !defined $bd->{$_} or
5215             fail f_ "buildinfo contains forbidden field %s", $_
5216             foreach qw(Changes Changed-by Distribution);
5217     }
5218     push @i_buildinfos, $bi;
5219     delete $i_param{'buildinfo-filename'};
5220 }
5221
5222 sub i_localname_changes {
5223     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5224     $i_changesfn = $i_dscfn;
5225     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5226     return $i_changesfn;
5227 }
5228 sub i_file_changes { }
5229
5230 sub i_want_signed_tag {
5231     printdebug Dumper(\%i_param, $i_dscfn);
5232     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5233         && defined $i_param{'csuite'}
5234         or badproto \*RO, "premature desire for signed-tag";
5235     my $head = $i_param{'head'};
5236     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5237
5238     my $maintview = $i_param{'maint-view'};
5239     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5240
5241     select_tagformat();
5242     if ($protovsn >= 4) {
5243         my $p = $i_param{'tagformat'} // '<undef>';
5244         $p eq $tagformat
5245             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5246     }
5247
5248     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5249     $csuite = $&;
5250     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5251
5252     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5253
5254     return
5255         push_mktags $i_clogp, $i_dscfn,
5256             $i_changesfn, (__ 'remote changes file'),
5257             \@tagwants;
5258 }
5259
5260 sub i_want_signed_dsc_changes {
5261     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5262     sign_changes $i_changesfn;
5263     return ($i_dscfn, $i_changesfn, @i_buildinfos);
5264 }
5265
5266 #---------- building etc. ----------
5267
5268 our $version;
5269 our $sourcechanges;
5270 our $dscfn;
5271
5272 #----- `3.0 (quilt)' handling -----
5273
5274 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5275
5276 sub quiltify_dpkg_commit ($$$;$) {
5277     my ($patchname,$author,$msg, $xinfo) = @_;
5278     $xinfo //= '';
5279
5280     mkpath '.git/dgit'; # we are in playtree
5281     my $descfn = ".git/dgit/quilt-description.tmp";
5282     open O, '>', $descfn or confess "$descfn: $!";
5283     $msg =~ s/\n+/\n\n/;
5284     print O <<END or confess $!;
5285 From: $author
5286 ${xinfo}Subject: $msg
5287 ---
5288
5289 END
5290     close O or confess $!;
5291
5292     {
5293         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5294         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5295         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5296         runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5297     }
5298 }
5299
5300 sub quiltify_trees_differ ($$;$$$) {
5301     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5302     # returns true iff the two tree objects differ other than in debian/
5303     # with $finegrained,
5304     # returns bitmask 01 - differ in upstream files except .gitignore
5305     #                 02 - differ in .gitignore
5306     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5307     #  is set for each modified .gitignore filename $fn
5308     # if $unrepres is defined, array ref to which is appeneded
5309     #  a list of unrepresentable changes (removals of upstream files
5310     #  (as messages)
5311     local $/=undef;
5312     my @cmd = (@git, qw(diff-tree -z --no-renames));
5313     push @cmd, qw(--name-only) unless $unrepres;
5314     push @cmd, qw(-r) if $finegrained || $unrepres;
5315     push @cmd, $x, $y;
5316     my $diffs= cmdoutput @cmd;
5317     my $r = 0;
5318     my @lmodes;
5319     foreach my $f (split /\0/, $diffs) {
5320         if ($unrepres && !@lmodes) {
5321             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5322             next;
5323         }
5324         my ($oldmode,$newmode) = @lmodes;
5325         @lmodes = ();
5326
5327         next if $f =~ m#^debian(?:/.*)?$#s;
5328
5329         if ($unrepres) {
5330             eval {
5331                 die __ "not a plain file or symlink\n"
5332                     unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5333                            $oldmode =~ m/^(?:10|12)\d{4}$/;
5334                 if ($oldmode =~ m/[^0]/ &&
5335                     $newmode =~ m/[^0]/) {
5336                     # both old and new files exist
5337                     die __ "mode or type changed\n" if $oldmode ne $newmode;
5338                     die __ "modified symlink\n" unless $newmode =~ m/^10/;
5339                 } elsif ($oldmode =~ m/[^0]/) {
5340                     # deletion
5341                     die __ "deletion of symlink\n"
5342                         unless $oldmode =~ m/^10/;
5343                 } else {
5344                     # creation
5345                     die __ "creation with non-default mode\n"
5346                         unless $newmode =~ m/^100644$/ or
5347                                $newmode =~ m/^120000$/;
5348                 }
5349             };
5350             if ($@) {
5351                 local $/="\n"; chomp $@;
5352                 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5353             }
5354         }
5355
5356         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5357         $r |= $isignore ? 02 : 01;
5358         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5359     }
5360     printdebug "quiltify_trees_differ $x $y => $r\n";
5361     return $r;
5362 }
5363
5364 sub quiltify_tree_sentinelfiles ($) {
5365     # lists the `sentinel' files present in the tree
5366     my ($x) = @_;
5367     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5368         qw(-- debian/rules debian/control);
5369     $r =~ s/\n/,/g;
5370     return $r;
5371 }
5372
5373 sub quiltify_splitbrain_needed () {
5374     if (!$split_brain) {
5375         progress __ "dgit view: changes are required...";
5376         runcmd @git, qw(checkout -q -b dgit-view);
5377         $split_brain = 1;
5378     }
5379 }
5380
5381 sub quiltify_splitbrain ($$$$$$$) {
5382     my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5383         $editedignores, $cachekey) = @_;
5384     my $gitignore_special = 1;
5385     if ($quilt_mode !~ m/gbp|dpm/) {
5386         # treat .gitignore just like any other upstream file
5387         $diffbits = { %$diffbits };
5388         $_ = !!$_ foreach values %$diffbits;
5389         $gitignore_special = 0;
5390     }
5391     # We would like any commits we generate to be reproducible
5392     my @authline = clogp_authline($clogp);
5393     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
5394     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5395     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
5396     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
5397     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5398     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
5399
5400     my $fulldiffhint = sub {
5401         my ($x,$y) = @_;
5402         my $cmd = "git diff $x $y -- :/ ':!debian'";
5403         $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5404         return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5405                   $cmd;
5406     };
5407
5408     if ($quilt_mode =~ m/gbp|unapplied/ &&
5409         ($diffbits->{O2H} & 01)) {
5410         my $msg = f_
5411  "--quilt=%s specified, implying patches-unapplied git tree\n".
5412  " but git tree differs from orig in upstream files.",
5413                      $quilt_mode;
5414         $msg .= $fulldiffhint->($unapplied, 'HEAD');
5415         if (!stat_exists "debian/patches") {
5416             $msg .= __
5417  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5418         }
5419         fail $msg;
5420     }
5421     if ($quilt_mode =~ m/dpm/ &&
5422         ($diffbits->{H2A} & 01)) {
5423         fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5424 --quilt=%s specified, implying patches-applied git tree
5425  but git tree differs from result of applying debian/patches to upstream
5426 END
5427     }
5428     if ($quilt_mode =~ m/gbp|unapplied/ &&
5429         ($diffbits->{O2A} & 01)) { # some patches
5430         quiltify_splitbrain_needed();
5431         progress __ "dgit view: creating patches-applied version using gbp pq";
5432         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5433         # gbp pq import creates a fresh branch; push back to dgit-view
5434         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5435         runcmd @git, qw(checkout -q dgit-view);
5436     }
5437     if ($quilt_mode =~ m/gbp|dpm/ &&
5438         ($diffbits->{O2A} & 02)) {
5439         fail f_ <<END, $quilt_mode;
5440 --quilt=%s specified, implying that HEAD is for use with a
5441  tool which does not create patches for changes to upstream
5442  .gitignores: but, such patches exist in debian/patches.
5443 END
5444     }
5445     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5446         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5447         quiltify_splitbrain_needed();
5448         progress __
5449             "dgit view: creating patch to represent .gitignore changes";
5450         ensuredir "debian/patches";
5451         my $gipatch = "debian/patches/auto-gitignore";
5452         open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5453         stat GIPATCH or confess "$gipatch: $!";
5454         fail f_ "%s already exists; but want to create it".
5455                 " to record .gitignore changes",
5456                 $gipatch
5457             if (stat _)[7];
5458         print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5459 Subject: Update .gitignore from Debian packaging branch
5460
5461 The Debian packaging git branch contains these updates to the upstream
5462 .gitignore file(s).  This patch is autogenerated, to provide these
5463 updates to users of the official Debian archive view of the package.
5464 END
5465
5466 [dgit ($our_version) update-gitignore]
5467 ---
5468 ENDU
5469         close GIPATCH or die "$gipatch: $!";
5470         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5471             $unapplied, $headref, "--", sort keys %$editedignores;
5472         open SERIES, "+>>", "debian/patches/series" or confess $!;
5473         defined seek SERIES, -1, 2 or $!==EINVAL or confess $!;
5474         my $newline;
5475         defined read SERIES, $newline, 1 or confess $!;
5476         print SERIES "\n" or confess $! unless $newline eq "\n";
5477         print SERIES "auto-gitignore\n" or confess $!;
5478         close SERIES or die  $!;
5479         runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5480         commit_admin +(__ <<END).<<ENDU
5481 Commit patch to update .gitignore
5482 END
5483
5484 [dgit ($our_version) update-gitignore-quilt-fixup]
5485 ENDU
5486     }
5487
5488     my $dgitview = git_rev_parse 'HEAD';
5489
5490     changedir $maindir;
5491     reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5492
5493     changedir "$playground/work";
5494
5495     my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5496     progress f_ "dgit view: created (%s)", $saved;
5497 }
5498
5499 sub quiltify ($$$$) {
5500     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5501
5502     # Quilt patchification algorithm
5503     #
5504     # We search backwards through the history of the main tree's HEAD
5505     # (T) looking for a start commit S whose tree object is identical
5506     # to to the patch tip tree (ie the tree corresponding to the
5507     # current dpkg-committed patch series).  For these purposes
5508     # `identical' disregards anything in debian/ - this wrinkle is
5509     # necessary because dpkg-source treates debian/ specially.
5510     #
5511     # We can only traverse edges where at most one of the ancestors'
5512     # trees differs (in changes outside in debian/).  And we cannot
5513     # handle edges which change .pc/ or debian/patches.  To avoid
5514     # going down a rathole we avoid traversing edges which introduce
5515     # debian/rules or debian/control.  And we set a limit on the
5516     # number of edges we are willing to look at.
5517     #
5518     # If we succeed, we walk forwards again.  For each traversed edge
5519     # PC (with P parent, C child) (starting with P=S and ending with
5520     # C=T) to we do this:
5521     #  - git checkout C
5522     #  - dpkg-source --commit with a patch name and message derived from C
5523     # After traversing PT, we git commit the changes which
5524     # should be contained within debian/patches.
5525
5526     # The search for the path S..T is breadth-first.  We maintain a
5527     # todo list containing search nodes.  A search node identifies a
5528     # commit, and looks something like this:
5529     #  $p = {
5530     #      Commit => $git_commit_id,
5531     #      Child => $c,                          # or undef if P=T
5532     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
5533     #      Nontrivial => true iff $p..$c has relevant changes
5534     #  };
5535
5536     my @todo;
5537     my @nots;
5538     my $sref_S;
5539     my $max_work=100;
5540     my %considered; # saves being exponential on some weird graphs
5541
5542     my $t_sentinels = quiltify_tree_sentinelfiles $target;
5543
5544     my $not = sub {
5545         my ($search,$whynot) = @_;
5546         printdebug " search NOT $search->{Commit} $whynot\n";
5547         $search->{Whynot} = $whynot;
5548         push @nots, $search;
5549         no warnings qw(exiting);
5550         next;
5551     };
5552
5553     push @todo, {
5554         Commit => $target,
5555     };
5556
5557     while (@todo) {
5558         my $c = shift @todo;
5559         next if $considered{$c->{Commit}}++;
5560
5561         $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5562
5563         printdebug "quiltify investigate $c->{Commit}\n";
5564
5565         # are we done?
5566         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5567             printdebug " search finished hooray!\n";
5568             $sref_S = $c;
5569             last;
5570         }
5571
5572         quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5573         if ($quilt_mode eq 'smash') {
5574             printdebug " search quitting smash\n";
5575             last;
5576         }
5577
5578         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5579         $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5580             if $c_sentinels ne $t_sentinels;
5581
5582         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5583         $commitdata =~ m/\n\n/;
5584         $commitdata =~ $`;
5585         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5586         @parents = map { { Commit => $_, Child => $c } } @parents;
5587
5588         $not->($c, __ "root commit") if !@parents;
5589
5590         foreach my $p (@parents) {
5591             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5592         }
5593         my $ndiffers = grep { $_->{Nontrivial} } @parents;
5594         $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5595             if $ndiffers > 1;
5596
5597         foreach my $p (@parents) {
5598             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5599
5600             my @cmd= (@git, qw(diff-tree -r --name-only),
5601                       $p->{Commit},$c->{Commit},
5602                       qw(-- debian/patches .pc debian/source/format));
5603             my $patchstackchange = cmdoutput @cmd;
5604             if (length $patchstackchange) {
5605                 $patchstackchange =~ s/\n/,/g;
5606                 $not->($p, f_ "changed %s", $patchstackchange);
5607             }
5608
5609             printdebug " search queue P=$p->{Commit} ",
5610                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5611             push @todo, $p;
5612         }
5613     }
5614
5615     if (!$sref_S) {
5616         printdebug "quiltify want to smash\n";
5617
5618         my $abbrev = sub {
5619             my $x = $_[0]{Commit};
5620             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5621             return $x;
5622         };
5623         if ($quilt_mode eq 'linear') {
5624             print STDERR f_
5625                 "\n%s: error: quilt fixup cannot be linear.  Stopped at:\n",
5626                 $us;
5627             my $all_gdr = !!@nots;
5628             foreach my $notp (@nots) {
5629                 my $c = $notp->{Child};
5630                 my $cprange = $abbrev->($notp);
5631                 $cprange .= "..".$abbrev->($c) if $c;
5632                 print STDERR f_ "%s:  %s: %s\n",
5633                     $us, $cprange, $notp->{Whynot};
5634                 $all_gdr &&= $notp->{Child} &&
5635                     (git_cat_file $notp->{Child}{Commit}, 'commit')
5636                     =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5637             }
5638             print STDERR "\n";
5639             $failsuggestion =
5640                 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5641                 if $all_gdr;
5642             print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5643             fail __
5644  "quilt history linearisation failed.  Search \`quilt fixup' in dgit(7).\n";
5645         } elsif ($quilt_mode eq 'smash') {
5646         } elsif ($quilt_mode eq 'auto') {
5647             progress __ "quilt fixup cannot be linear, smashing...";
5648         } else {
5649             confess "$quilt_mode ?";
5650         }
5651
5652         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5653         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5654         my $ncommits = 3;
5655         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5656
5657         quiltify_dpkg_commit "auto-$version-$target-$time",
5658             (getfield $clogp, 'Maintainer'),
5659             (f_ "Automatically generated patch (%s)\n".
5660              "Last (up to) %s git changes, FYI:\n\n",
5661              $clogp->{Version}, $ncommits).
5662              $msg;
5663         return;
5664     }
5665
5666     progress __ "quiltify linearisation planning successful, executing...";
5667
5668     for (my $p = $sref_S;
5669          my $c = $p->{Child};
5670          $p = $p->{Child}) {
5671         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5672         next unless $p->{Nontrivial};
5673
5674         my $cc = $c->{Commit};
5675
5676         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5677         $commitdata =~ m/\n\n/ or die "$c ?";
5678         $commitdata = $`;
5679         my $msg = $'; #';
5680         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5681         my $author = $1;
5682
5683         my $commitdate = cmdoutput
5684             @git, qw(log -n1 --pretty=format:%aD), $cc;
5685
5686         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5687
5688         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5689         $strip_nls->();
5690
5691         my $title = $1;
5692         my $patchname;
5693         my $patchdir;
5694
5695         my $gbp_check_suitable = sub {
5696             $_ = shift;
5697             my ($what) = @_;
5698
5699             eval {
5700                 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5701                 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5702                 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5703                 die __ "is series file\n" if m{$series_filename_re}o;
5704                 die __ "too long\n" if length > 200;
5705             };
5706             return $_ unless $@;
5707             print STDERR f_
5708                 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5709                 $cc, $what, $@;
5710             return undef;
5711         };
5712
5713         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5714                            gbp-pq-name: \s* )
5715                        (\S+) \s* \n //ixm) {
5716             $patchname = $gbp_check_suitable->($1, 'Name');
5717         }
5718         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5719                            gbp-pq-topic: \s* )
5720                        (\S+) \s* \n //ixm) {
5721             $patchdir = $gbp_check_suitable->($1, 'Topic');
5722         }
5723
5724         $strip_nls->();
5725
5726         if (!defined $patchname) {
5727             $patchname = $title;
5728             $patchname =~ s/[.:]$//;
5729             use Text::Iconv;
5730             eval {
5731                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5732                 my $translitname = $converter->convert($patchname);
5733                 die unless defined $translitname;
5734                 $patchname = $translitname;
5735             };
5736             print STDERR
5737                 +(f_ "dgit: patch title transliteration error: %s", $@)
5738                 if $@;
5739             $patchname =~ y/ A-Z/-a-z/;
5740             $patchname =~ y/-a-z0-9_.+=~//cd;
5741             $patchname =~ s/^\W/x-$&/;
5742             $patchname = substr($patchname,0,40);
5743             $patchname .= ".patch";
5744         }
5745         if (!defined $patchdir) {
5746             $patchdir = '';
5747         }
5748         if (length $patchdir) {
5749             $patchname = "$patchdir/$patchname";
5750         }
5751         if ($patchname =~ m{^(.*)/}) {
5752             mkpath "debian/patches/$1";
5753         }
5754
5755         my $index;
5756         for ($index='';
5757              stat "debian/patches/$patchname$index";
5758              $index++) { }
5759         $!==ENOENT or confess "$patchname$index $!";
5760
5761         runcmd @git, qw(checkout -q), $cc;
5762
5763         # We use the tip's changelog so that dpkg-source doesn't
5764         # produce complaining messages from dpkg-parsechangelog.  None
5765         # of the information dpkg-source gets from the changelog is
5766         # actually relevant - it gets put into the original message
5767         # which dpkg-source provides our stunt editor, and then
5768         # overwritten.
5769         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5770
5771         quiltify_dpkg_commit "$patchname$index", $author, $msg,
5772             "Date: $commitdate\n".
5773             "X-Dgit-Generated: $clogp->{Version} $cc\n";
5774
5775         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5776     }
5777
5778     runcmd @git, qw(checkout -q master);
5779 }
5780
5781 sub build_maybe_quilt_fixup () {
5782     my ($format,$fopts) = get_source_format;
5783     return unless madformat_wantfixup $format;
5784     # sigh
5785
5786     check_for_vendor_patches();
5787
5788     if (quiltmode_splitbrain) {
5789         fail <<END unless access_cfg_tagformats_can_splitbrain;
5790 quilt mode $quilt_mode requires split view so server needs to support
5791  both "new" and "maint" tag formats, but config says it doesn't.
5792 END
5793     }
5794
5795     my $clogp = parsechangelog();
5796     my $headref = git_rev_parse('HEAD');
5797     my $symref = git_get_symref();
5798
5799     if ($quilt_mode eq 'linear'
5800         && !$fopts->{'single-debian-patch'}
5801         && branch_is_gdr($headref)) {
5802         # This is much faster.  It also makes patches that gdr
5803         # likes better for future updates without laundering.
5804         #
5805         # However, it can fail in some casses where we would
5806         # succeed: if there are existing patches, which correspond
5807         # to a prefix of the branch, but are not in gbp/gdr
5808         # format, gdr will fail (exiting status 7), but we might
5809         # be able to figure out where to start linearising.  That
5810         # will be slower so hopefully there's not much to do.
5811         my @cmd = (@git_debrebase,
5812                    qw(--noop-ok -funclean-mixed -funclean-ordering
5813                       make-patches --quiet-would-amend));
5814         # We tolerate soe snags that gdr wouldn't, by default.
5815         if (act_local()) {
5816             debugcmd "+",@cmd;
5817             $!=0; $?=-1;
5818             failedcmd @cmd
5819                 if system @cmd
5820                 and not ($? == 7*256 or
5821                          $? == -1 && $!==ENOENT);
5822         } else {
5823             dryrun_report @cmd;
5824         }
5825         $headref = git_rev_parse('HEAD');
5826     }
5827
5828     prep_ud();
5829     changedir $playground;
5830
5831     my $upstreamversion = upstreamversion $version;
5832
5833     if ($fopts->{'single-debian-patch'}) {
5834         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5835     } else {
5836         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5837     }
5838
5839     changedir $maindir;
5840     runcmd_ordryrun_local
5841         @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5842 }
5843
5844 sub unpack_playtree_mkwork ($) {
5845     my ($headref) = @_;
5846
5847     mkdir "work" or confess $!;
5848     changedir "work";
5849     mktree_in_ud_here();
5850     runcmd @git, qw(reset -q --hard), $headref;
5851 }
5852
5853 sub unpack_playtree_linkorigs ($$) {
5854     my ($upstreamversion, $fn) = @_;
5855     # calls $fn->($leafname);
5856
5857     my $bpd_abs = bpd_abs();
5858
5859     dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5860
5861     opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5862     while ($!=0, defined(my $leaf = readdir QFD)) {
5863         my $f = bpd_abs()."/".$leaf;
5864         {
5865             local ($debuglevel) = $debuglevel-1;
5866             printdebug "QF linkorigs bpd $leaf, $f ?\n";
5867         }
5868         next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5869         printdebug "QF linkorigs $leaf, $f Y\n";
5870         link_ltarget $f, $leaf or die "$leaf $!";
5871         $fn->($leaf);
5872     }
5873     die "$buildproductsdir: $!" if $!;
5874     closedir QFD;
5875 }
5876
5877 sub quilt_fixup_delete_pc () {
5878     runcmd @git, qw(rm -rqf .pc);
5879     commit_admin +(__ <<END).<<ENDU
5880 Commit removal of .pc (quilt series tracking data)
5881 END
5882
5883 [dgit ($our_version) upgrade quilt-remove-pc]
5884 ENDU
5885 }
5886
5887 sub quilt_fixup_singlepatch ($$$) {
5888     my ($clogp, $headref, $upstreamversion) = @_;
5889
5890     progress __ "starting quiltify (single-debian-patch)";
5891
5892     # dpkg-source --commit generates new patches even if
5893     # single-debian-patch is in debian/source/options.  In order to
5894     # get it to generate debian/patches/debian-changes, it is
5895     # necessary to build the source package.
5896
5897     unpack_playtree_linkorigs($upstreamversion, sub { });
5898     unpack_playtree_mkwork($headref);
5899
5900     rmtree("debian/patches");
5901
5902     runcmd @dpkgsource, qw(-b .);
5903     changedir "..";
5904     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5905     rename srcfn("$upstreamversion", "/debian/patches"),
5906         "work/debian/patches"
5907         or $!==ENOENT
5908         or confess "install d/patches: $!";
5909
5910     changedir "work";
5911     commit_quilty_patch();
5912 }
5913
5914 sub quilt_make_fake_dsc ($) {
5915     my ($upstreamversion) = @_;
5916
5917     my $fakeversion="$upstreamversion-~~DGITFAKE";
5918
5919     my $fakedsc=new IO::File 'fake.dsc', '>' or confess $!;
5920     print $fakedsc <<END or confess $!;
5921 Format: 3.0 (quilt)
5922 Source: $package
5923 Version: $fakeversion
5924 Files:
5925 END
5926
5927     my $dscaddfile=sub {
5928         my ($leaf) = @_;
5929
5930         my $md = new Digest::MD5;
5931
5932         my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5933         stat $fh or confess $!;
5934         my $size = -s _;
5935
5936         $md->addfile($fh);
5937         print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess $!;
5938     };
5939
5940     unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5941
5942     my @files=qw(debian/source/format debian/rules
5943                  debian/control debian/changelog);
5944     foreach my $maybe (qw(debian/patches debian/source/options
5945                           debian/tests/control)) {
5946         next unless stat_exists "$maindir/$maybe";
5947         push @files, $maybe;
5948     }
5949
5950     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5951     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5952
5953     $dscaddfile->($debtar);
5954     close $fakedsc or confess $!;
5955 }
5956
5957 sub quilt_fakedsc2unapplied ($$) {
5958     my ($headref, $upstreamversion) = @_;
5959     # must be run in the playground
5960     # quilt_make_fake_dsc must have been called
5961
5962     runcmd qw(sh -ec),
5963         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5964
5965     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5966     rename $fakexdir, "fake" or die "$fakexdir $!";
5967
5968     changedir 'fake';
5969
5970     remove_stray_gits(__ "source package");
5971     mktree_in_ud_here();
5972
5973     rmtree '.pc';
5974
5975     rmtree 'debian'; # git checkout commitish paths does not delete!
5976     runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5977     my $unapplied=git_add_write_tree();
5978     printdebug "fake orig tree object $unapplied\n";
5979     return $unapplied;
5980 }
5981
5982 sub quilt_check_splitbrain_cache ($$) {
5983     my ($headref, $upstreamversion) = @_;
5984     # Called only if we are in (potentially) split brain mode.
5985     # Called in playground.
5986     # Computes the cache key and looks in the cache.
5987     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5988
5989     my $splitbrain_cachekey;
5990
5991     progress f_
5992  "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5993                 $quilt_mode;
5994     # we look in the reflog of dgit-intern/quilt-cache
5995     # we look for an entry whose message is the key for the cache lookup
5996     my @cachekey = (qw(dgit), $our_version);
5997     push @cachekey, $upstreamversion;
5998     push @cachekey, $quilt_mode;
5999     push @cachekey, $headref;
6000
6001     push @cachekey, hashfile('fake.dsc');
6002
6003     my $srcshash = Digest::SHA->new(256);
6004     my %sfs = ( %INC, '$0(dgit)' => $0 );
6005     foreach my $sfk (sort keys %sfs) {
6006         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6007         $srcshash->add($sfk,"  ");
6008         $srcshash->add(hashfile($sfs{$sfk}));
6009         $srcshash->add("\n");
6010     }
6011     push @cachekey, $srcshash->hexdigest();
6012     $splitbrain_cachekey = "@cachekey";
6013
6014     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6015
6016     my $cachehit = reflog_cache_lookup
6017         "refs/$splitbraincache", $splitbrain_cachekey;
6018
6019     if ($cachehit) {
6020         unpack_playtree_mkwork($headref);
6021         my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6022         if ($cachehit ne $headref) {
6023             progress f_ "dgit view: found cached (%s)", $saved;
6024             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6025             $split_brain = 1;
6026             return ($cachehit, $splitbrain_cachekey);
6027         }
6028         progress __ "dgit view: found cached, no changes required";
6029         return ($headref, $splitbrain_cachekey);
6030     }
6031
6032     printdebug "splitbrain cache miss\n";
6033     return (undef, $splitbrain_cachekey);
6034 }
6035
6036 sub quilt_fixup_multipatch ($$$) {
6037     my ($clogp, $headref, $upstreamversion) = @_;
6038
6039     progress f_ "examining quilt state (multiple patches, %s mode)",
6040                 $quilt_mode;
6041
6042     # Our objective is:
6043     #  - honour any existing .pc in case it has any strangeness
6044     #  - determine the git commit corresponding to the tip of
6045     #    the patch stack (if there is one)
6046     #  - if there is such a git commit, convert each subsequent
6047     #    git commit into a quilt patch with dpkg-source --commit
6048     #  - otherwise convert all the differences in the tree into
6049     #    a single git commit
6050     #
6051     # To do this we:
6052
6053     # Our git tree doesn't necessarily contain .pc.  (Some versions of
6054     # dgit would include the .pc in the git tree.)  If there isn't
6055     # one, we need to generate one by unpacking the patches that we
6056     # have.
6057     #
6058     # We first look for a .pc in the git tree.  If there is one, we
6059     # will use it.  (This is not the normal case.)
6060     #
6061     # Otherwise need to regenerate .pc so that dpkg-source --commit
6062     # can work.  We do this as follows:
6063     #     1. Collect all relevant .orig from parent directory
6064     #     2. Generate a debian.tar.gz out of
6065     #         debian/{patches,rules,source/format,source/options}
6066     #     3. Generate a fake .dsc containing just these fields:
6067     #          Format Source Version Files
6068     #     4. Extract the fake .dsc
6069     #        Now the fake .dsc has a .pc directory.
6070     # (In fact we do this in every case, because in future we will
6071     # want to search for a good base commit for generating patches.)
6072     #
6073     # Then we can actually do the dpkg-source --commit
6074     #     1. Make a new working tree with the same object
6075     #        store as our main tree and check out the main
6076     #        tree's HEAD.
6077     #     2. Copy .pc from the fake's extraction, if necessary
6078     #     3. Run dpkg-source --commit
6079     #     4. If the result has changes to debian/, then
6080     #          - git add them them
6081     #          - git add .pc if we had a .pc in-tree
6082     #          - git commit
6083     #     5. If we had a .pc in-tree, delete it, and git commit
6084     #     6. Back in the main tree, fast forward to the new HEAD
6085
6086     # Another situation we may have to cope with is gbp-style
6087     # patches-unapplied trees.
6088     #
6089     # We would want to detect these, so we know to escape into
6090     # quilt_fixup_gbp.  However, this is in general not possible.
6091     # Consider a package with a one patch which the dgit user reverts
6092     # (with git revert or the moral equivalent).
6093     #
6094     # That is indistinguishable in contents from a patches-unapplied
6095     # tree.  And looking at the history to distinguish them is not
6096     # useful because the user might have made a confusing-looking git
6097     # history structure (which ought to produce an error if dgit can't
6098     # cope, not a silent reintroduction of an unwanted patch).
6099     #
6100     # So gbp users will have to pass an option.  But we can usually
6101     # detect their failure to do so: if the tree is not a clean
6102     # patches-applied tree, quilt linearisation fails, but the tree
6103     # _is_ a clean patches-unapplied tree, we can suggest that maybe
6104     # they want --quilt=unapplied.
6105     #
6106     # To help detect this, when we are extracting the fake dsc, we
6107     # first extract it with --skip-patches, and then apply the patches
6108     # afterwards with dpkg-source --before-build.  That lets us save a
6109     # tree object corresponding to .origs.
6110
6111     my $splitbrain_cachekey;
6112
6113     quilt_make_fake_dsc($upstreamversion);
6114
6115     if (quiltmode_splitbrain()) {
6116         my $cachehit;
6117         ($cachehit, $splitbrain_cachekey) =
6118             quilt_check_splitbrain_cache($headref, $upstreamversion);
6119         return if $cachehit;
6120     }
6121     my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6122
6123     ensuredir '.pc';
6124
6125     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6126     $!=0; $?=-1;
6127     if (system @bbcmd) {
6128         failedcmd @bbcmd if $? < 0;
6129         fail __ <<END;
6130 failed to apply your git tree's patch stack (from debian/patches/) to
6131  the corresponding upstream tarball(s).  Your source tree and .orig
6132  are probably too inconsistent.  dgit can only fix up certain kinds of
6133  anomaly (depending on the quilt mode).  Please see --quilt= in dgit(1).
6134 END
6135     }
6136
6137     changedir '..';
6138
6139     unpack_playtree_mkwork($headref);
6140
6141     my $mustdeletepc=0;
6142     if (stat_exists ".pc") {
6143         -d _ or die;
6144         progress __ "Tree already contains .pc - will use it then delete it.";
6145         $mustdeletepc=1;
6146     } else {
6147         rename '../fake/.pc','.pc' or confess $!;
6148     }
6149
6150     changedir '../fake';
6151     rmtree '.pc';
6152     my $oldtiptree=git_add_write_tree();
6153     printdebug "fake o+d/p tree object $unapplied\n";
6154     changedir '../work';
6155
6156
6157     # We calculate some guesswork now about what kind of tree this might
6158     # be.  This is mostly for error reporting.
6159
6160     my %editedignores;
6161     my @unrepres;
6162     my $diffbits = {
6163         # H = user's HEAD
6164         # O = orig, without patches applied
6165         # A = "applied", ie orig with H's debian/patches applied
6166         O2H => quiltify_trees_differ($unapplied,$headref,   1,
6167                                      \%editedignores, \@unrepres),
6168         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
6169         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6170     };
6171
6172     my @dl;
6173     foreach my $bits (qw(01 02)) {
6174         foreach my $v (qw(O2H O2A H2A)) {
6175             push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6176         }
6177     }
6178     printdebug "differences \@dl @dl.\n";
6179
6180     progress f_
6181 "%s: base trees orig=%.20s o+d/p=%.20s",
6182               $us, $unapplied, $oldtiptree;
6183     progress f_
6184 "%s: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
6185 "%s: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
6186   $us,                      $dl[0], $dl[1],              $dl[3], $dl[4],
6187   $us,                          $dl[2],                     $dl[5];
6188
6189     if (@unrepres) {
6190         print STDERR f_ "dgit:  cannot represent change: %s: %s\n",
6191                         $_->[1], $_->[0]
6192             foreach @unrepres;
6193         forceable_fail [qw(unrepresentable)], __ <<END;
6194 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6195 END
6196     }
6197
6198     my @failsuggestion;
6199     if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6200         push @failsuggestion, [ 'unapplied', __
6201  "This might be a patches-unapplied branch." ];
6202     } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6203         push @failsuggestion, [ 'applied', __
6204  "This might be a patches-applied branch." ];
6205     }
6206     push @failsuggestion, [ 'quilt-mode', __
6207  "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6208
6209     push @failsuggestion, [ 'gitattrs', __
6210  "Warning: Tree has .gitattributes.  See GITATTRIBUTES in dgit(7)." ]
6211         if stat_exists '.gitattributes';
6212
6213     push @failsuggestion, [ 'origs', __
6214  "Maybe orig tarball(s) are not identical to git representation?" ];
6215
6216     if (quiltmode_splitbrain()) {
6217         quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6218                             $diffbits, \%editedignores,
6219                             $splitbrain_cachekey);
6220         return;
6221     }
6222
6223     progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6224     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6225
6226     if (!open P, '>>', ".pc/applied-patches") {
6227         $!==&ENOENT or confess $!;
6228     } else {
6229         close P;
6230     }
6231
6232     commit_quilty_patch();
6233
6234     if ($mustdeletepc) {
6235         quilt_fixup_delete_pc();
6236     }
6237 }
6238
6239 sub quilt_fixup_editor () {
6240     my $descfn = $ENV{$fakeeditorenv};
6241     my $editing = $ARGV[$#ARGV];
6242     open I1, '<', $descfn or confess "$descfn: $!";
6243     open I2, '<', $editing or confess "$editing: $!";
6244     unlink $editing or confess "$editing: $!";
6245     open O, '>', $editing or confess "$editing: $!";
6246     while (<I1>) { print O or confess $!; } I1->error and confess $!;
6247     my $copying = 0;
6248     while (<I2>) {
6249         $copying ||= m/^\-\-\- /;
6250         next unless $copying;
6251         print O or confess $!;
6252     }
6253     I2->error and confess $!;
6254     close O or die $1;
6255     finish 0;
6256 }
6257
6258 sub maybe_apply_patches_dirtily () {
6259     return unless $quilt_mode =~ m/gbp|unapplied/;
6260     print STDERR __ <<END or confess $!;
6261
6262 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6263 dgit: Have to apply the patches - making the tree dirty.
6264 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6265
6266 END
6267     $patches_applied_dirtily = 01;
6268     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6269     runcmd qw(dpkg-source --before-build .);
6270 }
6271
6272 sub maybe_unapply_patches_again () {
6273     progress __ "dgit: Unapplying patches again to tidy up the tree."
6274         if $patches_applied_dirtily;
6275     runcmd qw(dpkg-source --after-build .)
6276         if $patches_applied_dirtily & 01;
6277     rmtree '.pc'
6278         if $patches_applied_dirtily & 02;
6279     $patches_applied_dirtily = 0;
6280 }
6281
6282 #----- other building -----
6283
6284 sub clean_tree_check_git ($$$) {
6285     my ($honour_ignores, $message, $ignmessage) = @_;
6286     my @cmd = (@git, qw(clean -dn));
6287     push @cmd, qw(-x) unless $honour_ignores;
6288     my $leftovers = cmdoutput @cmd;
6289     if (length $leftovers) {
6290         print STDERR $leftovers, "\n" or confess $!;
6291         $message .= $ignmessage if $honour_ignores;
6292         fail $message;
6293     }
6294 }
6295
6296 sub clean_tree_check_git_wd ($) {
6297     my ($message) = @_;
6298     return if $cleanmode =~ m{no-check};
6299     return if $patches_applied_dirtily; # yuk
6300     clean_tree_check_git +($cleanmode !~ m{all-check}),
6301         $message, "\n".__ <<END;
6302 If this is just missing .gitignore entries, use a different clean
6303 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6304 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6305 END
6306 }
6307
6308 sub clean_tree_check () {
6309     # This function needs to not care about modified but tracked files.
6310     # That was done by check_not_dirty, and by now we may have run
6311     # the rules clean target which might modify tracked files (!)
6312     if ($cleanmode =~ m{^check}) {
6313         clean_tree_check_git +($cleanmode =~ m{ignores}), __
6314  "tree contains uncommitted files and --clean=check specified", '';
6315     } elsif ($cleanmode =~ m{^dpkg-source}) {
6316         clean_tree_check_git_wd __
6317  "tree contains uncommitted files (NB dgit didn't run rules clean)";
6318     } elsif ($cleanmode =~ m{^git}) {
6319         clean_tree_check_git 1, __
6320  "tree contains uncommited, untracked, unignored files\n".
6321  "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6322     } elsif ($cleanmode eq 'none') {
6323     } else {
6324         confess "$cleanmode ?";
6325     }
6326 }
6327
6328 sub clean_tree () {
6329     # We always clean the tree ourselves, rather than leave it to the
6330     # builder (dpkg-source, or soemthing which calls dpkg-source).
6331     if ($cleanmode =~ m{^dpkg-source}) {
6332         my @cmd = @dpkgbuildpackage;
6333         push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6334         push @cmd, qw(-T clean);
6335         maybe_apply_patches_dirtily();
6336         runcmd_ordryrun_local @cmd;
6337         clean_tree_check_git_wd __
6338  "tree contains uncommitted files (after running rules clean)";
6339     } elsif ($cleanmode =~ m{^git(?!-)}) {
6340         runcmd_ordryrun_local @git, qw(clean -xdf);
6341     } elsif ($cleanmode =~ m{^git-ff}) {
6342         runcmd_ordryrun_local @git, qw(clean -xdff);
6343     } elsif ($cleanmode =~ m{^check}) {
6344         clean_tree_check();
6345     } elsif ($cleanmode eq 'none') {
6346     } else {
6347         confess "$cleanmode ?";
6348     }
6349 }
6350
6351 sub cmd_clean () {
6352     badusage __ "clean takes no additional arguments" if @ARGV;
6353     notpushing();
6354     clean_tree();
6355     maybe_unapply_patches_again();
6356 }
6357
6358 # return values from massage_dbp_args are one or both of these flags
6359 sub WANTSRC_SOURCE  () { 01; } # caller should build source (separately)
6360 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6361
6362 sub build_or_push_prep_early () {
6363     our $build_or_push_prep_early_done //= 0;
6364     return if $build_or_push_prep_early_done++;
6365     badusage f_ "-p is not allowed with dgit %s", $subcommand
6366         if defined $package;
6367     my $clogp = parsechangelog();
6368     $isuite = getfield $clogp, 'Distribution';
6369     $package = getfield $clogp, 'Source';
6370     $version = getfield $clogp, 'Version';
6371     $dscfn = dscfn($version);
6372 }
6373
6374 sub build_prep_early () {
6375     build_or_push_prep_early();
6376     notpushing();
6377     check_not_dirty();
6378 }
6379
6380 sub build_prep ($) {
6381     my ($wantsrc) = @_;
6382     build_prep_early();
6383     check_bpd_exists();
6384     if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6385         # Clean the tree because we're going to use the contents of
6386         # $maindir.  (We trying to include dirty changes in the source
6387         # package, or we are running the builder in $maindir.)
6388         || $cleanmode =~ m{always}) {
6389         # Or because the user asked us to.
6390         clean_tree();
6391     } else {
6392         # We don't actually need to do anything in $maindir, but we
6393         # should do some kind of cleanliness check because (i) the
6394         # user may have forgotten a `git add', and (ii) if the user
6395         # said -wc we should still do the check.
6396         clean_tree_check();
6397     }
6398     build_maybe_quilt_fixup();
6399     if ($rmchanges) {
6400         my $pat = changespat $version;
6401         foreach my $f (glob "$buildproductsdir/$pat") {
6402             if (act_local()) {
6403                 unlink $f or
6404                     fail f_ "remove old changes file %s: %s", $f, $!;
6405             } else {
6406                 progress f_ "would remove %s", $f;
6407             }
6408         }
6409     }
6410 }
6411
6412 sub changesopts_initial () {
6413     my @opts =@changesopts[1..$#changesopts];
6414 }
6415
6416 sub changesopts_version () {
6417     if (!defined $changes_since_version) {
6418         my @vsns;
6419         unless (eval {
6420             @vsns = archive_query('archive_query');
6421             my @quirk = access_quirk();
6422             if ($quirk[0] eq 'backports') {
6423                 local $isuite = $quirk[2];
6424                 local $csuite;
6425                 canonicalise_suite();
6426                 push @vsns, archive_query('archive_query');
6427             }
6428             1;
6429         }) {
6430             print STDERR $@;
6431             fail __
6432  "archive query failed (queried because --since-version not specified)";
6433         }
6434         if (@vsns) {
6435             @vsns = map { $_->[0] } @vsns;
6436             @vsns = sort { -version_compare($a, $b) } @vsns;
6437             $changes_since_version = $vsns[0];
6438             progress f_ "changelog will contain changes since %s", $vsns[0];
6439         } else {
6440             $changes_since_version = '_';
6441             progress __ "package seems new, not specifying -v<version>";
6442         }
6443     }
6444     if ($changes_since_version ne '_') {
6445         return ("-v$changes_since_version");
6446     } else {
6447         return ();
6448     }
6449 }
6450
6451 sub changesopts () {
6452     return (changesopts_initial(), changesopts_version());
6453 }
6454
6455 sub massage_dbp_args ($;$) {
6456     my ($cmd,$xargs) = @_;
6457     # Since we split the source build out so we can do strange things
6458     # to it, massage the arguments to dpkg-buildpackage so that the
6459     # main build doessn't build source (or add an argument to stop it
6460     # building source by default).
6461     debugcmd '#massaging#', @$cmd if $debuglevel>1;
6462     # -nc has the side effect of specifying -b if nothing else specified
6463     # and some combinations of -S, -b, et al, are errors, rather than
6464     # later simply overriding earlie.  So we need to:
6465     #  - search the command line for these options
6466     #  - pick the last one
6467     #  - perhaps add our own as a default
6468     #  - perhaps adjust it to the corresponding non-source-building version
6469     my $dmode = '-F';
6470     foreach my $l ($cmd, $xargs) {
6471         next unless $l;
6472         @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6473     }
6474     push @$cmd, '-nc';
6475 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6476     my $r = WANTSRC_BUILDER;
6477     printdebug "massage split $dmode.\n";
6478     if ($dmode =~ s/^--build=//) {
6479         $r = 0;
6480         my @d = split /,/, $dmode;
6481         $r |= WANTSRC_SOURCE  if grep { s/^full$/binary/ } @d;
6482         $r |= WANTSRC_SOURCE  if grep { s/^source$// } @d;
6483         $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6484         fail __ "Wanted to build nothing!" unless $r;
6485         $dmode = '--build='. join ',', grep m/./, @d;
6486     } else {
6487         $r =
6488           $dmode =~ m/[S]/     ?  WANTSRC_SOURCE :
6489           $dmode =~ y/gGF/ABb/ ?  WANTSRC_SOURCE | WANTSRC_BUILDER :
6490           $dmode =~ m/[ABb]/   ?                   WANTSRC_BUILDER :
6491           confess "$dmode ?";
6492     }
6493     printdebug "massage done $r $dmode.\n";
6494     push @$cmd, $dmode;
6495 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6496     return $r;
6497 }
6498
6499 sub in_bpd (&) {
6500     my ($fn) = @_;
6501     my $wasdir = must_getcwd();
6502     changedir $buildproductsdir;
6503     $fn->();
6504     changedir $wasdir;
6505 }
6506
6507 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6508 sub postbuild_mergechanges ($) {
6509     my ($msg_if_onlyone) = @_;
6510     # If there is only one .changes file, fail with $msg_if_onlyone,
6511     # or if that is undef, be a no-op.
6512     # Returns the changes file to report to the user.
6513     my $pat = changespat $version;
6514     my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6515     @changesfiles = sort {
6516         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6517             or $a cmp $b
6518     } @changesfiles;
6519     my $result;
6520     if (@changesfiles==1) {
6521         fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6522 only one changes file from build (%s)
6523 END
6524             if defined $msg_if_onlyone;
6525         $result = $changesfiles[0];
6526     } elsif (@changesfiles==2) {
6527         my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6528         foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6529             fail f_ "%s found in binaries changes file %s", $l, $binchanges
6530                 if $l =~ m/\.dsc$/;
6531         }
6532         runcmd_ordryrun_local @mergechanges, @changesfiles;
6533         my $multichanges = changespat $version,'multi';
6534         if (act_local()) {
6535             stat_exists $multichanges or fail f_
6536                 "%s unexpectedly not created by build", $multichanges;
6537             foreach my $cf (glob $pat) {
6538                 next if $cf eq $multichanges;
6539                 rename "$cf", "$cf.inmulti" or fail f_
6540                     "install new changes %s\{,.inmulti}: %s", $cf, $!;
6541             }
6542         }
6543         $result = $multichanges;
6544     } else {
6545         fail f_ "wrong number of different changes files (%s)",
6546                 "@changesfiles";
6547     }
6548     printdone f_ "build successful, results in %s\n", $result
6549         or confess $!;
6550 }
6551
6552 sub midbuild_checkchanges () {
6553     my $pat = changespat $version;
6554     return if $rmchanges;
6555     my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6556     @unwanted = grep {
6557         $_ ne changespat $version,'source' and
6558         $_ ne changespat $version,'multi'
6559     } @unwanted;
6560     fail +(f_ <<END, $pat, "@unwanted")
6561 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6562 Suggest you delete %s.
6563 END
6564         if @unwanted;
6565 }
6566
6567 sub midbuild_checkchanges_vanilla ($) {
6568     my ($wantsrc) = @_;
6569     midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6570 }
6571
6572 sub postbuild_mergechanges_vanilla ($) {
6573     my ($wantsrc) = @_;
6574     if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6575         in_bpd {
6576             postbuild_mergechanges(undef);
6577         };
6578     } else {
6579         printdone __ "build successful\n";
6580     }
6581 }
6582
6583 sub cmd_build {
6584     build_prep_early();
6585     $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6586 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6587 %s: warning: build-products-dir will be ignored; files will go to ..
6588 END
6589     $buildproductsdir = '..';
6590     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6591     my $wantsrc = massage_dbp_args \@dbp;
6592     build_prep($wantsrc);
6593     if ($wantsrc & WANTSRC_SOURCE) {
6594         build_source();
6595         midbuild_checkchanges_vanilla $wantsrc;
6596     }
6597     if ($wantsrc & WANTSRC_BUILDER) {
6598         push @dbp, changesopts_version();
6599         maybe_apply_patches_dirtily();
6600         runcmd_ordryrun_local @dbp;
6601     }
6602     maybe_unapply_patches_again();
6603     postbuild_mergechanges_vanilla $wantsrc;
6604 }
6605
6606 sub pre_gbp_build {
6607     $quilt_mode //= 'gbp';
6608 }
6609
6610 sub cmd_gbp_build {
6611     build_prep_early();
6612
6613     # gbp can make .origs out of thin air.  In my tests it does this
6614     # even for a 1.0 format package, with no origs present.  So I
6615     # guess it keys off just the version number.  We don't know
6616     # exactly what .origs ought to exist, but let's assume that we
6617     # should run gbp if: the version has an upstream part and the main
6618     # orig is absent.
6619     my $upstreamversion = upstreamversion $version;
6620     my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6621     my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6622
6623     if ($gbp_make_orig) {
6624         clean_tree();
6625         $cleanmode = 'none'; # don't do it again
6626     }
6627
6628     my @dbp = @dpkgbuildpackage;
6629
6630     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6631
6632     if (!length $gbp_build[0]) {
6633         if (length executable_on_path('git-buildpackage')) {
6634             $gbp_build[0] = qw(git-buildpackage);
6635         } else {
6636             $gbp_build[0] = 'gbp buildpackage';
6637         }
6638     }
6639     my @cmd = opts_opt_multi_cmd [], @gbp_build;
6640
6641     push @cmd, (qw(-us -uc --git-no-sign-tags),
6642                 "--git-builder=".(shellquote @dbp));
6643
6644     if ($gbp_make_orig) {
6645         my $priv = dgit_privdir();
6646         my $ok = "$priv/origs-gen-ok";
6647         unlink $ok or $!==&ENOENT or confess $!;
6648         my @origs_cmd = @cmd;
6649         push @origs_cmd, qw(--git-cleaner=true);
6650         push @origs_cmd, "--git-prebuild=".
6651             "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6652         push @origs_cmd, @ARGV;
6653         if (act_local()) {
6654             debugcmd @origs_cmd;
6655             system @origs_cmd;
6656             do { local $!; stat_exists $ok; }
6657                 or failedcmd @origs_cmd;
6658         } else {
6659             dryrun_report @origs_cmd;
6660         }
6661     }
6662
6663     build_prep($wantsrc);
6664     if ($wantsrc & WANTSRC_SOURCE) {
6665         build_source();
6666         midbuild_checkchanges_vanilla $wantsrc;
6667     } else {
6668         push @cmd, '--git-cleaner=true';
6669     }
6670     maybe_unapply_patches_again();
6671     if ($wantsrc & WANTSRC_BUILDER) {
6672         push @cmd, changesopts();
6673         runcmd_ordryrun_local @cmd, @ARGV;
6674     }
6675     postbuild_mergechanges_vanilla $wantsrc;
6676 }
6677 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6678
6679 sub building_source_in_playtree {
6680     # If $includedirty, we have to build the source package from the
6681     # working tree, not a playtree, so that uncommitted changes are
6682     # included (copying or hardlinking them into the playtree could
6683     # cause trouble).
6684     #
6685     # Note that if we are building a source package in split brain
6686     # mode we do not support including uncommitted changes, because
6687     # that makes quilt fixup too hard.  I.e. ($split_brain && (dgit is
6688     # building a source package)) => !$includedirty
6689     return !$includedirty;
6690 }
6691
6692 sub build_source {
6693     $sourcechanges = changespat $version,'source';
6694     if (act_local()) {
6695         unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6696             or fail f_ "remove %s: %s", $sourcechanges, $!;
6697     }
6698     my @cmd = (@dpkgsource, qw(-b --));
6699     my $leafdir;
6700     if (building_source_in_playtree()) {
6701         $leafdir = 'work';
6702         my $headref = git_rev_parse('HEAD');
6703         # If we are in split brain, there is already a playtree with
6704         # the thing we should package into a .dsc (thanks to quilt
6705         # fixup).  If not, make a playtree
6706         prep_ud() unless $split_brain;
6707         changedir $playground;
6708         unless ($split_brain) {
6709             my $upstreamversion = upstreamversion $version;
6710             unpack_playtree_linkorigs($upstreamversion, sub { });
6711             unpack_playtree_mkwork($headref);
6712             changedir '..';
6713         }
6714     } else {
6715         $leafdir = basename $maindir;
6716
6717         if ($buildproductsdir ne '..') {
6718             # Well, we are going to run dpkg-source -b which consumes
6719             # origs from .. and generates output there.  To make this
6720             # work when the bpd is not .. , we would have to (i) link
6721             # origs from bpd to .. , (ii) check for files that
6722             # dpkg-source -b would/might overwrite, and afterwards
6723             # (iii) move all the outputs back to the bpd (iv) except
6724             # for the origs which should be deleted from .. if they
6725             # weren't there beforehand.  And if there is an error and
6726             # we don't run to completion we would necessarily leave a
6727             # mess.  This is too much.  The real way to fix this
6728             # is for dpkg-source to have bpd support.
6729             confess unless $includedirty;
6730             fail __
6731  "--include-dirty not supported with --build-products-dir, sorry";
6732         }
6733
6734         changedir '..';
6735     }
6736     runcmd_ordryrun_local @cmd, $leafdir;
6737
6738     changedir $leafdir;
6739     runcmd_ordryrun_local qw(sh -ec),
6740       'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6741       @dpkggenchanges, qw(-S), changesopts();
6742     changedir '..';
6743
6744     printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6745     $dsc = parsecontrol($dscfn, "source package");
6746
6747     my $mv = sub {
6748         my ($why, $l) = @_;
6749         printdebug " renaming ($why) $l\n";
6750         rename_link_xf 0, "$l", bpd_abs()."/$l"
6751             or fail f_ "put in place new built file (%s): %s", $l, $@;
6752     };
6753     foreach my $l (split /\n/, getfield $dsc, 'Files') {
6754         $l =~ m/\S+$/ or next;
6755         $mv->('Files', $&);
6756     }
6757     $mv->('dsc', $dscfn);
6758     $mv->('changes', $sourcechanges);
6759
6760     changedir $maindir;
6761 }
6762
6763 sub cmd_build_source {
6764     badusage __ "build-source takes no additional arguments" if @ARGV;
6765     build_prep(WANTSRC_SOURCE);
6766     build_source();
6767     maybe_unapply_patches_again();
6768     printdone f_ "source built, results in %s and %s",
6769                  $dscfn, $sourcechanges;
6770 }
6771
6772 sub cmd_push_source {
6773     prep_push();
6774     fail __
6775         "dgit push-source: --include-dirty/--ignore-dirty does not make".
6776         "sense with push-source!"
6777         if $includedirty;
6778     build_maybe_quilt_fixup();
6779     if ($changesfile) {
6780         my $changes = parsecontrol("$buildproductsdir/$changesfile",
6781                                    __ "source changes file");
6782         unless (test_source_only_changes($changes)) {
6783             fail __ "user-specified changes file is not source-only";
6784         }
6785     } else {
6786         # Building a source package is very fast, so just do it
6787         build_source();
6788         confess "er, patches are applied dirtily but shouldn't be.."
6789             if $patches_applied_dirtily;
6790         $changesfile = $sourcechanges;
6791     }
6792     dopush();
6793 }
6794
6795 sub binary_builder {
6796     my ($bbuilder, $pbmc_msg, @args) = @_;
6797     build_prep(WANTSRC_SOURCE);
6798     build_source();
6799     midbuild_checkchanges();
6800     in_bpd {
6801         if (act_local()) {
6802             stat_exists $dscfn or fail f_
6803                 "%s (in build products dir): %s", $dscfn, $!;
6804             stat_exists $sourcechanges or fail f_
6805                 "%s (in build products dir): %s", $sourcechanges, $!;
6806         }
6807         runcmd_ordryrun_local @$bbuilder, @args;
6808     };
6809     maybe_unapply_patches_again();
6810     in_bpd {
6811         postbuild_mergechanges($pbmc_msg);
6812     };
6813 }
6814
6815 sub cmd_sbuild {
6816     build_prep_early();
6817     binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6818 perhaps you need to pass -A ?  (sbuild's default is to build only
6819 arch-specific binaries; dgit 1.4 used to override that.)
6820 END
6821 }
6822
6823 sub pbuilder ($) {
6824     my ($pbuilder) = @_;
6825     build_prep_early();
6826     # @ARGV is allowed to contain only things that should be passed to
6827     # pbuilder under debbuildopts; just massage those
6828     my $wantsrc = massage_dbp_args \@ARGV;
6829     fail __
6830         "you asked for a builder but your debbuildopts didn't ask for".
6831         " any binaries -- is this really what you meant?"
6832         unless $wantsrc & WANTSRC_BUILDER;
6833     fail __
6834         "we must build a .dsc to pass to the builder but your debbuiltopts".
6835         " forbids the building of a source package; cannot continue"
6836       unless $wantsrc & WANTSRC_SOURCE;
6837     # We do not want to include the verb "build" in @pbuilder because
6838     # the user can customise @pbuilder and they shouldn't be required
6839     # to include "build" in their customised value.  However, if the
6840     # user passes any additional args to pbuilder using the dgit
6841     # option --pbuilder:foo, such args need to come after the "build"
6842     # verb.  opts_opt_multi_cmd does all of that.
6843     binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6844                    qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6845                    $dscfn);
6846 }
6847
6848 sub cmd_pbuilder {
6849     pbuilder(\@pbuilder);
6850 }
6851
6852 sub cmd_cowbuilder {
6853     pbuilder(\@cowbuilder);
6854 }
6855
6856 sub cmd_quilt_fixup {
6857     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6858     build_prep_early();
6859     clean_tree();
6860     build_maybe_quilt_fixup();
6861 }
6862
6863 sub cmd_print_unapplied_treeish {
6864     badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6865         if @ARGV;
6866     my $headref = git_rev_parse('HEAD');
6867     my $clogp = commit_getclogp $headref;
6868     $package = getfield $clogp, 'Source';
6869     $version = getfield $clogp, 'Version';
6870     $isuite = getfield $clogp, 'Distribution';
6871     $csuite = $isuite; # we want this to be offline!
6872     notpushing();
6873
6874     prep_ud();
6875     changedir $playground;
6876     my $uv = upstreamversion $version;
6877     quilt_make_fake_dsc($uv);
6878     my $u = quilt_fakedsc2unapplied($headref, $uv);
6879     print $u, "\n" or confess $!;
6880 }
6881
6882 sub import_dsc_result {
6883     my ($dstref, $newhash, $what_log, $what_msg) = @_;
6884     my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6885     runcmd @cmd;
6886     check_gitattrs($newhash, __ "source tree");
6887
6888     progress f_ "dgit: import-dsc: %s", $what_msg;
6889 }
6890
6891 sub cmd_import_dsc {
6892     my $needsig = 0;
6893
6894     while (@ARGV) {
6895         last unless $ARGV[0] =~ m/^-/;
6896         $_ = shift @ARGV;
6897         last if m/^--?$/;
6898         if (m/^--require-valid-signature$/) {
6899             $needsig = 1;
6900         } else {
6901             badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6902         }
6903     }
6904
6905     badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6906         unless @ARGV==2;
6907     my ($dscfn, $dstbranch) = @ARGV;
6908
6909     badusage __ "dry run makes no sense with import-dsc"
6910         unless act_local();
6911
6912     my $force = $dstbranch =~ s/^\+//   ? +1 :
6913                 $dstbranch =~ s/^\.\.// ? -1 :
6914                                            0;
6915     my $info = $force ? " $&" : '';
6916     $info = "$dscfn$info";
6917
6918     my $specbranch = $dstbranch;
6919     $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6920     $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6921
6922     my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6923     my $chead = cmdoutput_errok @symcmd;
6924     defined $chead or $?==256 or failedcmd @symcmd;
6925
6926     fail f_ "%s is checked out - will not update it", $dstbranch
6927         if defined $chead and $chead eq $dstbranch;
6928
6929     my $oldhash = git_get_ref $dstbranch;
6930
6931     open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6932     $dscdata = do { local $/ = undef; <D>; };
6933     D->error and fail f_ "read %s: %s", $dscfn, $!;
6934     close C;
6935
6936     # we don't normally need this so import it here
6937     use Dpkg::Source::Package;
6938     my $dp = new Dpkg::Source::Package filename => $dscfn,
6939         require_valid_signature => $needsig;
6940     {
6941         local $SIG{__WARN__} = sub {
6942             print STDERR $_[0];
6943             return unless $needsig;
6944             fail __ "import-dsc signature check failed";
6945         };
6946         if (!$dp->is_signed()) {
6947             warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6948         } else {
6949             my $r = $dp->check_signature();
6950             confess "->check_signature => $r" if $needsig && $r;
6951         }
6952     }
6953
6954     parse_dscdata();
6955
6956     $package = getfield $dsc, 'Source';
6957
6958     parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6959         unless forceing [qw(import-dsc-with-dgit-field)];
6960     parse_dsc_field_def_dsc_distro();
6961
6962     $isuite = 'DGIT-IMPORT-DSC';
6963     $idistro //= $dsc_distro;
6964
6965     notpushing();
6966
6967     if (defined $dsc_hash) {
6968         progress __
6969             "dgit: import-dsc of .dsc with Dgit field, using git hash";
6970         resolve_dsc_field_commit undef, undef;
6971     }
6972     if (defined $dsc_hash) {
6973         my @cmd = (qw(sh -ec),
6974                    "echo $dsc_hash | git cat-file --batch-check");
6975         my $objgot = cmdoutput @cmd;
6976         if ($objgot =~ m#^\w+ missing\b#) {
6977             fail f_ <<END, $dsc_hash
6978 .dsc contains Dgit field referring to object %s
6979 Your git tree does not have that object.  Try `git fetch' from a
6980 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
6981 END
6982         }
6983         if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6984             if ($force > 0) {
6985                 progress __ "Not fast forward, forced update.";
6986             } else {
6987                 fail f_ "Not fast forward to %s", $dsc_hash;
6988             }
6989         }
6990         import_dsc_result $dstbranch, $dsc_hash,
6991             "dgit import-dsc (Dgit): $info",
6992             f_ "updated git ref %s", $dstbranch;
6993         return 0;
6994     }
6995
6996     fail f_ <<END, $dstbranch, $specbranch, $specbranch
6997 Branch %s already exists
6998 Specify ..%s for a pseudo-merge, binding in existing history
6999 Specify  +%s to overwrite, discarding existing history
7000 END
7001         if $oldhash && !$force;
7002
7003     my @dfi = dsc_files_info();
7004     foreach my $fi (@dfi) {
7005         my $f = $fi->{Filename};
7006         my $here = "$buildproductsdir/$f";
7007         if (lstat $here) {
7008             next if stat $here;
7009             fail f_ "lstat %s works but stat gives %s !", $here, $!;
7010         }
7011         fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7012         my $there = $dscfn;
7013         if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
7014             $there = $';
7015         } elsif ($dscfn =~ m#^/#) {
7016             $there = $dscfn;
7017         } else {
7018             fail f_
7019                 "cannot import %s which seems to be inside working tree!",
7020                 $dscfn;
7021         }
7022         $there =~ s#/+[^/]+$## or fail f_
7023             "import %s requires .../%s, but it does not exist",
7024             $dscfn, $f;
7025         $there .= "/$f";
7026         my $test = $there =~ m{^/} ? $there : "../$there";
7027         stat $test or fail f_
7028             "import %s requires %s, but: %s", $dscfn, $test, $!;
7029         symlink $there, $here or fail f_
7030             "symlink %s to %s: %s", $there, $here, $!;
7031         progress f_ "made symlink %s -> %s", $here, $there;
7032 #       print STDERR Dumper($fi);
7033     }
7034     my @mergeinputs = generate_commits_from_dsc();
7035     die unless @mergeinputs == 1;
7036
7037     my $newhash = $mergeinputs[0]{Commit};
7038
7039     if ($oldhash) {
7040         if ($force > 0) {
7041             progress __
7042                 "Import, forced update - synthetic orphan git history.";
7043         } elsif ($force < 0) {
7044             progress __ "Import, merging.";
7045             my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7046             my $version = getfield $dsc, 'Version';
7047             my $clogp = commit_getclogp $newhash;
7048             my $authline = clogp_authline $clogp;
7049             $newhash = make_commit_text <<ENDU
7050 tree $tree
7051 parent $newhash
7052 parent $oldhash
7053 author $authline
7054 committer $authline
7055
7056 ENDU
7057                 .(f_ <<END, $package, $version, $dstbranch);
7058 Merge %s (%s) import into %s
7059 END
7060         } else {
7061             die; # caught earlier
7062         }
7063     }
7064
7065     import_dsc_result $dstbranch, $newhash,
7066         "dgit import-dsc: $info",
7067         f_ "results are in git ref %s", $dstbranch;
7068 }
7069
7070 sub pre_archive_api_query () {
7071     not_necessarily_a_tree();
7072 }
7073 sub cmd_archive_api_query {
7074     badusage __ "need only 1 subpath argument" unless @ARGV==1;
7075     my ($subpath) = @ARGV;
7076     local $isuite = 'DGIT-API-QUERY-CMD';
7077     my @cmd = archive_api_query_cmd($subpath);
7078     push @cmd, qw(-f);
7079     debugcmd ">",@cmd;
7080     exec @cmd or fail f_ "exec curl: %s\n", $!;
7081 }
7082
7083 sub repos_server_url () {
7084     $package = '_dgit-repos-server';
7085     local $access_forpush = 1;
7086     local $isuite = 'DGIT-REPOS-SERVER';
7087     my $url = access_giturl();
7088 }
7089
7090 sub pre_clone_dgit_repos_server () {
7091     not_necessarily_a_tree();
7092 }
7093 sub cmd_clone_dgit_repos_server {
7094     badusage __ "need destination argument" unless @ARGV==1;
7095     my ($destdir) = @ARGV;
7096     my $url = repos_server_url();
7097     my @cmd = (@git, qw(clone), $url, $destdir);
7098     debugcmd ">",@cmd;
7099     exec @cmd or fail f_ "exec git clone: %s\n", $!;
7100 }
7101
7102 sub pre_print_dgit_repos_server_source_url () {
7103     not_necessarily_a_tree();
7104 }
7105 sub cmd_print_dgit_repos_server_source_url {
7106     badusage __
7107         "no arguments allowed to dgit print-dgit-repos-server-source-url"
7108         if @ARGV;
7109     my $url = repos_server_url();
7110     print $url, "\n" or confess $!;
7111 }
7112
7113 sub pre_print_dpkg_source_ignores {
7114     not_necessarily_a_tree();
7115 }
7116 sub cmd_print_dpkg_source_ignores {
7117     badusage __
7118         "no arguments allowed to dgit print-dpkg-source-ignores"
7119         if @ARGV;
7120     print "@dpkg_source_ignores\n" or confess $!;
7121 }
7122
7123 sub cmd_setup_mergechangelogs {
7124     badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7125         if @ARGV;
7126     local $isuite = 'DGIT-SETUP-TREE';
7127     setup_mergechangelogs(1);
7128 }
7129
7130 sub cmd_setup_useremail {
7131     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7132     local $isuite = 'DGIT-SETUP-TREE';
7133     setup_useremail(1);
7134 }
7135
7136 sub cmd_setup_gitattributes {
7137     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7138     local $isuite = 'DGIT-SETUP-TREE';
7139     setup_gitattrs(1);
7140 }
7141
7142 sub cmd_setup_new_tree {
7143     badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7144     local $isuite = 'DGIT-SETUP-TREE';
7145     setup_new_tree();
7146 }
7147
7148 #---------- argument parsing and main program ----------
7149
7150 sub cmd_version {
7151     print "dgit version $our_version\n" or confess $!;
7152     finish 0;
7153 }
7154
7155 our (%valopts_long, %valopts_short);
7156 our (%funcopts_long);
7157 our @rvalopts;
7158 our (@modeopt_cfgs);
7159
7160 sub defvalopt ($$$$) {
7161     my ($long,$short,$val_re,$how) = @_;
7162     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7163     $valopts_long{$long} = $oi;
7164     $valopts_short{$short} = $oi;
7165     # $how subref should:
7166     #   do whatever assignemnt or thing it likes with $_[0]
7167     #   if the option should not be passed on to remote, @rvalopts=()
7168     # or $how can be a scalar ref, meaning simply assign the value
7169 }
7170
7171 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7172 defvalopt '--distro',        '-d', '.+',      \$idistro;
7173 defvalopt '',                '-k', '.+',      \$keyid;
7174 defvalopt '--existing-package','', '.*',      \$existing_package;
7175 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
7176 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
7177 defvalopt '--package',   '-p',   $package_re, \$package;
7178 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
7179
7180 defvalopt '', '-C', '.+', sub {
7181     ($changesfile) = (@_);
7182     if ($changesfile =~ s#^(.*)/##) {
7183         $buildproductsdir = $1;
7184     }
7185 };
7186
7187 defvalopt '--initiator-tempdir','','.*', sub {
7188     ($initiator_tempdir) = (@_);
7189     $initiator_tempdir =~ m#^/# or
7190         badusage __ "--initiator-tempdir must be used specify an".
7191                     " absolute, not relative, directory."
7192 };
7193
7194 sub defoptmodes ($@) {
7195     my ($varref, $cfgkey, $default, %optmap) = @_;
7196     my %permit;
7197     while (my ($opt,$val) = each %optmap) {
7198         $funcopts_long{$opt} = sub { $$varref = $val; };
7199         $permit{$val} = $val;
7200     }
7201     push @modeopt_cfgs, {
7202         Var => $varref,
7203         Key => $cfgkey,
7204         Default => $default,
7205         Vals => \%permit
7206     };
7207 }
7208
7209 defoptmodes \$dodep14tag, qw( dep14tag          want
7210                               --dep14tag        want
7211                               --no-dep14tag     no
7212                               --always-dep14tag always );
7213
7214 sub parseopts () {
7215     my $om;
7216
7217     if (defined $ENV{'DGIT_SSH'}) {
7218         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7219     } elsif (defined $ENV{'GIT_SSH'}) {
7220         @ssh = ($ENV{'GIT_SSH'});
7221     }
7222
7223     my $oi;
7224     my $val;
7225     my $valopt = sub {
7226         my ($what) = @_;
7227         @rvalopts = ($_);
7228         if (!defined $val) {
7229             badusage f_ "%s needs a value", $what unless @ARGV;
7230             $val = shift @ARGV;
7231             push @rvalopts, $val;
7232         }
7233         badusage f_ "bad value \`%s' for %s", $val, $what unless
7234             $val =~ m/^$oi->{Re}$(?!\n)/s;
7235         my $how = $oi->{How};
7236         if (ref($how) eq 'SCALAR') {
7237             $$how = $val;
7238         } else {
7239             $how->($val);
7240         }
7241         push @ropts, @rvalopts;
7242     };
7243
7244     while (@ARGV) {
7245         last unless $ARGV[0] =~ m/^-/;
7246         $_ = shift @ARGV;
7247         last if m/^--?$/;
7248         if (m/^--/) {
7249             if (m/^--dry-run$/) {
7250                 push @ropts, $_;
7251                 $dryrun_level=2;
7252             } elsif (m/^--damp-run$/) {
7253                 push @ropts, $_;
7254                 $dryrun_level=1;
7255             } elsif (m/^--no-sign$/) {
7256                 push @ropts, $_;
7257                 $sign=0;
7258             } elsif (m/^--help$/) {
7259                 cmd_help();
7260             } elsif (m/^--version$/) {
7261                 cmd_version();
7262             } elsif (m/^--new$/) {
7263                 push @ropts, $_;
7264                 $new_package=1;
7265             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7266                      ($om = $opts_opt_map{$1}) &&
7267                      length $om->[0]) {
7268                 push @ropts, $_;
7269                 $om->[0] = $2;
7270             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7271                      !$opts_opt_cmdonly{$1} &&
7272                      ($om = $opts_opt_map{$1})) {
7273                 push @ropts, $_;
7274                 push @$om, $2;
7275             } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7276                      !$opts_opt_cmdonly{$1} &&
7277                      ($om = $opts_opt_map{$1})) {
7278                 push @ropts, $_;
7279                 my $cmd = shift @$om;
7280                 @$om = ($cmd, grep { $_ ne $2 } @$om);
7281             } elsif (m/^--(gbp|dpm)$/s) {
7282                 push @ropts, "--quilt=$1";
7283                 $quilt_mode = $1;
7284             } elsif (m/^--(?:ignore|include)-dirty$/s) {
7285                 push @ropts, $_;
7286                 $includedirty = 1;
7287             } elsif (m/^--no-quilt-fixup$/s) {
7288                 push @ropts, $_;
7289                 $quilt_mode = 'nocheck';
7290             } elsif (m/^--no-rm-on-error$/s) {
7291                 push @ropts, $_;
7292                 $rmonerror = 0;
7293             } elsif (m/^--no-chase-dsc-distro$/s) {
7294                 push @ropts, $_;
7295                 $chase_dsc_distro = 0;
7296             } elsif (m/^--overwrite$/s) {
7297                 push @ropts, $_;
7298                 $overwrite_version = '';
7299             } elsif (m/^--overwrite=(.+)$/s) {
7300                 push @ropts, $_;
7301                 $overwrite_version = $1;
7302             } elsif (m/^--delayed=(\d+)$/s) {
7303                 push @ropts, $_;
7304                 push @dput, $_;
7305             } elsif (my ($k,$v) =
7306                      m/^--save-(dgit-view)=(.+)$/s ||
7307                      m/^--(dgit-view)-save=(.+)$/s
7308                      ) {
7309                 push @ropts, $_;
7310                 $v =~ s#^(?!refs/)#refs/heads/#;
7311                 $internal_object_save{$k} = $v;
7312             } elsif (m/^--(no-)?rm-old-changes$/s) {
7313                 push @ropts, $_;
7314                 $rmchanges = !$1;
7315             } elsif (m/^--deliberately-($deliberately_re)$/s) {
7316                 push @ropts, $_;
7317                 push @deliberatelies, $&;
7318             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7319                 push @ropts, $&;
7320                 $forceopts{$1} = 1;
7321                 $_='';
7322             } elsif (m/^--force-/) {
7323                 print STDERR
7324                     f_ "%s: warning: ignoring unknown force option %s\n",
7325                        $us, $_;
7326                 $_='';
7327             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7328                 # undocumented, for testing
7329                 push @ropts, $_;
7330                 $tagformat_want = [ $1, 'command line', 1 ];
7331                 # 1 menas overrides distro configuration
7332             } elsif (m/^--config-lookup-explode=(.+)$/s) {
7333                 # undocumented, for testing
7334                 push @ropts, $_;
7335                 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7336                 # ^ it's supposed to be an array ref
7337             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7338                 $val = $2 ? $' : undef; #';
7339                 $valopt->($oi->{Long});
7340             } elsif ($funcopts_long{$_}) {
7341                 push @ropts, $_;
7342                 $funcopts_long{$_}();
7343             } else {
7344                 badusage f_ "unknown long option \`%s'", $_;
7345             }
7346         } else {
7347             while (m/^-./s) {
7348                 if (s/^-n/-/) {
7349                     push @ropts, $&;
7350                     $dryrun_level=2;
7351                 } elsif (s/^-L/-/) {
7352                     push @ropts, $&;
7353                     $dryrun_level=1;
7354                 } elsif (s/^-h/-/) {
7355                     cmd_help();
7356                 } elsif (s/^-D/-/) {
7357                     push @ropts, $&;
7358                     $debuglevel++;
7359                     enabledebug();
7360                 } elsif (s/^-N/-/) {
7361                     push @ropts, $&;
7362                     $new_package=1;
7363                 } elsif (m/^-m/) {
7364                     push @ropts, $&;
7365                     push @changesopts, $_;
7366                     $_ = '';
7367                 } elsif (s/^-wn$//s) {
7368                     push @ropts, $&;
7369                     $cleanmode = 'none';
7370                 } elsif (s/^-wg(f?)(a?)$//s) {
7371                     push @ropts, $&;
7372                     $cleanmode = 'git';
7373                     $cleanmode .= '-ff' if $1;
7374                     $cleanmode .= ',always' if $2;
7375                 } elsif (s/^-wd(d?)([na]?)$//s) {
7376                     push @ropts, $&;
7377                     $cleanmode = 'dpkg-source';
7378                     $cleanmode .= '-d' if $1;
7379                     $cleanmode .= ',no-check' if $2 eq 'n';
7380                     $cleanmode .= ',all-check' if $2 eq 'a';
7381                 } elsif (s/^-wc$//s) {
7382                     push @ropts, $&;
7383                     $cleanmode = 'check';
7384                 } elsif (s/^-wci$//s) {
7385                     push @ropts, $&;
7386                     $cleanmode = 'check,ignores';
7387                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7388                     push @git, '-c', $&;
7389                     $gitcfgs{cmdline}{$1} = [ $2 ];
7390                 } elsif (s/^-c([^=]+)$//s) {
7391                     push @git, '-c', $&;
7392                     $gitcfgs{cmdline}{$1} = [ 'true' ];
7393                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7394                     $val = $'; #';
7395                     $val = undef unless length $val;
7396                     $valopt->($oi->{Short});
7397                     $_ = '';
7398                 } else {
7399                     badusage f_ "unknown short option \`%s'", $_;
7400                 }
7401             }
7402         }
7403     }
7404 }
7405
7406 sub check_env_sanity () {
7407     my $blocked = new POSIX::SigSet;
7408     sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess $!;
7409
7410     eval {
7411         foreach my $name (qw(PIPE CHLD)) {
7412             my $signame = "SIG$name";
7413             my $signum = eval "POSIX::$signame" // die;
7414             die f_ "%s is set to something other than SIG_DFL\n",
7415                 $signame
7416                 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7417             $blocked->ismember($signum) and
7418                 die f_ "%s is blocked\n", $signame;
7419         }
7420     };
7421     return unless $@;
7422     chomp $@;
7423     fail f_ <<END, $@;
7424 On entry to dgit, %s
7425 This is a bug produced by something in your execution environment.
7426 Giving up.
7427 END
7428 }
7429
7430
7431 sub parseopts_late_defaults () {
7432     $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7433         if defined $idistro;
7434     $isuite //= cfg('dgit.default.default-suite');
7435
7436     foreach my $k (keys %opts_opt_map) {
7437         my $om = $opts_opt_map{$k};
7438
7439         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7440         if (defined $v) {
7441             badcfg f_ "cannot set command for %s", $k
7442                 unless length $om->[0];
7443             $om->[0] = $v;
7444         }
7445
7446         foreach my $c (access_cfg_cfgs("opts-$k")) {
7447             my @vl =
7448                 map { $_ ? @$_ : () }
7449                 map { $gitcfgs{$_}{$c} }
7450                 reverse @gitcfgsources;
7451             printdebug "CL $c ", (join " ", map { shellquote } @vl),
7452                 "\n" if $debuglevel >= 4;
7453             next unless @vl;
7454             badcfg f_ "cannot configure options for %s", $k
7455                 if $opts_opt_cmdonly{$k};
7456             my $insertpos = $opts_cfg_insertpos{$k};
7457             @$om = ( @$om[0..$insertpos-1],
7458                      @vl,
7459                      @$om[$insertpos..$#$om] );
7460         }
7461     }
7462
7463     if (!defined $rmchanges) {
7464         local $access_forpush;
7465         $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7466     }
7467
7468     if (!defined $quilt_mode) {
7469         local $access_forpush;
7470         $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7471             // access_cfg('quilt-mode', 'RETURN-UNDEF')
7472             // 'linear';
7473         $quilt_mode =~ m/^($quilt_modes_re)$/
7474             or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7475         $quilt_mode = $1;
7476     }
7477
7478     foreach my $moc (@modeopt_cfgs) {
7479         local $access_forpush;
7480         my $vr = $moc->{Var};
7481         next if defined $$vr;
7482         $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7483         my $v = $moc->{Vals}{$$vr};
7484         badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7485             unless defined $v;
7486         $$vr = $v;
7487     }
7488
7489     fail __ "dgit: --include-dirty is not supported in split view quilt mode"
7490         if $split_brain && $includedirty;
7491
7492     if (!defined $cleanmode) {
7493         local $access_forpush;
7494         $cleanmode = access_cfg('clean-mode-newer', 'RETURN-UNDEF');
7495         $cleanmode = undef if $cleanmode && $cleanmode !~ m/^$cleanmode_re$/;
7496
7497         $cleanmode //= access_cfg('clean-mode', 'RETURN-UNDEF');
7498         $cleanmode //= 'dpkg-source';
7499
7500         badcfg f_ "unknown clean-mode \`%s'", $cleanmode unless
7501             $cleanmode =~ m/$cleanmode_re/;
7502     }
7503
7504     $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7505     $buildproductsdir //= '..';
7506     $bpd_glob = $buildproductsdir;
7507     $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7508 }
7509
7510 setlocale(LC_MESSAGES, "");
7511 textdomain("dgit");
7512
7513 if ($ENV{$fakeeditorenv}) {
7514     git_slurp_config();
7515     quilt_fixup_editor();
7516 }
7517
7518 parseopts();
7519 check_env_sanity();
7520
7521 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7522 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7523     if $dryrun_level == 1;
7524 if (!@ARGV) {
7525     print STDERR __ $helpmsg or confess $!;
7526     finish 8;
7527 }
7528 $cmd = $subcommand = shift @ARGV;
7529 $cmd =~ y/-/_/;
7530
7531 my $pre_fn = ${*::}{"pre_$cmd"};
7532 $pre_fn->() if $pre_fn;
7533
7534 if ($invoked_in_git_tree) {
7535     changedir_git_toplevel();
7536     record_maindir();
7537 }
7538 git_slurp_config();
7539
7540 my $fn = ${*::}{"cmd_$cmd"};
7541 $fn or badusage f_ "unknown operation %s", $cmd;
7542 $fn->();
7543
7544 finish 0;