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