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