dgit

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