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     foreach my $f (qw(local-options local-patch-header)) {
3821         if (stat_exists "debian/source/$f") {
3822             fail f_ "git tree contains debian/source/%s", $f;
3823         }
3824     }
3825
3826     return if $includedirty;
3827
3828     git_check_unmodified();
3829 }
3830
3831 sub commit_admin ($) {
3832     my ($m) = @_;
3833     progress "$m";
3834     runcmd_ordryrun_local @git, qw(commit -m), $m;
3835 }
3836
3837 sub quiltify_nofix_bail ($$) {
3838     my ($headinfo, $xinfo) = @_;
3839     if ($quilt_mode eq 'nofix') {
3840         fail f_
3841             "quilt fixup required but quilt mode is \`nofix'\n".
3842             "HEAD commit%s differs from tree implied by debian/patches%s",
3843             $headinfo, $xinfo;
3844     }
3845 }
3846
3847 sub commit_quilty_patch () {
3848     my $output = cmdoutput @git, qw(status --ignored --porcelain);
3849     my %adds;
3850     foreach my $l (split /\n/, $output) {
3851         next unless $l =~ m/\S/;
3852         if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3853             $adds{$1}++;
3854         }
3855     }
3856     delete $adds{'.pc'}; # if there wasn't one before, don't add it
3857     if (!%adds) {
3858         progress __ "nothing quilty to commit, ok.";
3859         return;
3860     }
3861     quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3862     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3863     runcmd_ordryrun_local @git, qw(add -f), @adds;
3864     commit_admin +(__ <<ENDT).<<END
3865 Commit Debian 3.0 (quilt) metadata
3866
3867 ENDT
3868 [dgit ($our_version) quilt-fixup]
3869 END
3870 }
3871
3872 sub get_source_format () {
3873     my %options;
3874     if (open F, "debian/source/options") {
3875         while (<F>) {
3876             next if m/^\s*\#/;
3877             next unless m/\S/;
3878             s/\s+$//; # ignore missing final newline
3879             if (m/\s*\#\s*/) {
3880                 my ($k, $v) = ($`, $'); #');
3881                 $v =~ s/^"(.*)"$/$1/;
3882                 $options{$k} = $v;
3883             } else {
3884                 $options{$_} = 1;
3885             }
3886         }
3887         F->error and confess $!;
3888         close F;
3889     } else {
3890         confess $! unless $!==&ENOENT;
3891     }
3892
3893     if (!open F, "debian/source/format") {
3894         confess $! unless $!==&ENOENT;
3895         return '';
3896     }
3897     $_ = <F>;
3898     F->error and confess $!;
3899     chomp;
3900     return ($_, \%options);
3901 }
3902
3903 sub madformat_wantfixup ($) {
3904     my ($format) = @_;
3905     return 0 unless $format eq '3.0 (quilt)';
3906     our $quilt_mode_warned;
3907     if ($quilt_mode eq 'nocheck') {
3908         progress f_ "Not doing any fixup of \`%s'".
3909             " due to ----no-quilt-fixup or --quilt=nocheck", $format
3910             unless $quilt_mode_warned++;
3911         return 0;
3912     }
3913     progress f_ "Format \`%s', need to check/update patch stack", $format
3914         unless $quilt_mode_warned++;
3915     return 1;
3916 }
3917
3918 sub maybe_split_brain_save ($$$) {
3919     my ($headref, $dgitview, $msg) = @_;
3920     # => message fragment "$saved" describing disposition of $dgitview
3921     #    (used inside parens, in the English texts)
3922     my $save = $internal_object_save{'dgit-view'};
3923     return f_ "commit id %s", $dgitview unless defined $save;
3924     my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3925                git_update_ref_cmd
3926                "dgit --dgit-view-save $msg HEAD=$headref",
3927                $save, $dgitview);
3928     runcmd @cmd;
3929     return f_ "and left in %s", $save;
3930 }
3931
3932 # An "infopair" is a tuple [ $thing, $what ]
3933 # (often $thing is a commit hash; $what is a description)
3934
3935 sub infopair_cond_equal ($$) {
3936     my ($x,$y) = @_;
3937     $x->[0] eq $y->[0] or fail <<END;
3938 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3939 END
3940 };
3941
3942 sub infopair_lrf_tag_lookup ($$) {
3943     my ($tagnames, $what) = @_;
3944     # $tagname may be an array ref
3945     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3946     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3947     foreach my $tagname (@tagnames) {
3948         my $lrefname = lrfetchrefs."/tags/$tagname";
3949         my $tagobj = $lrfetchrefs_f{$lrefname};
3950         next unless defined $tagobj;
3951         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3952         return [ git_rev_parse($tagobj), $what ];
3953     }
3954     fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
3955 Wanted tag %s (%s) on dgit server, but not found
3956 END
3957                       : (f_ <<END, $what, "@tagnames");
3958 Wanted tag %s (one of: %s) on dgit server, but not found
3959 END
3960 }
3961
3962 sub infopair_cond_ff ($$) {
3963     my ($anc,$desc) = @_;
3964     is_fast_fwd($anc->[0], $desc->[0]) or
3965         fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
3966 %s (%s) .. %s (%s) is not fast forward
3967 END
3968 };
3969
3970 sub pseudomerge_version_check ($$) {
3971     my ($clogp, $archive_hash) = @_;
3972
3973     my $arch_clogp = commit_getclogp $archive_hash;
3974     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3975                      __ 'version currently in archive' ];
3976     if (defined $overwrite_version) {
3977         if (length $overwrite_version) {
3978             infopair_cond_equal([ $overwrite_version,
3979                                   '--overwrite= version' ],
3980                                 $i_arch_v);
3981         } else {
3982             my $v = $i_arch_v->[0];
3983             progress f_
3984                 "Checking package changelog for archive version %s ...", $v;
3985             my $cd;
3986             eval {
3987                 my @xa = ("-f$v", "-t$v");
3988                 my $vclogp = parsechangelog @xa;
3989                 my $gf = sub {
3990                     my ($fn) = @_;
3991                     [ (getfield $vclogp, $fn),
3992                       (f_ "%s field from dpkg-parsechangelog %s",
3993                           $fn, "@xa") ];
3994                 };
3995                 my $cv = $gf->('Version');
3996                 infopair_cond_equal($i_arch_v, $cv);
3997                 $cd = $gf->('Distribution');
3998             };
3999             if ($@) {
4000                 $@ =~ s/^dgit: //gm;
4001                 fail "$@".
4002                     f_ "Perhaps debian/changelog does not mention %s ?", $v;
4003             }
4004             fail f_ <<END, $cd->[1], $cd->[0], $v
4005 %s is %s
4006 Your tree seems to based on earlier (not uploaded) %s.
4007 END
4008                 if $cd->[0] =~ m/UNRELEASED/;
4009         }
4010     }
4011
4012     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4013     return $i_arch_v;
4014 }
4015
4016 sub pseudomerge_make_commit ($$$$ $$) {
4017     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4018         $msg_cmd, $msg_msg) = @_;
4019     progress f_ "Declaring that HEAD includes all changes in %s...",
4020                  $i_arch_v->[0];
4021
4022     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4023     my $authline = clogp_authline $clogp;
4024
4025     chomp $msg_msg;
4026     $msg_cmd .=
4027         !defined $overwrite_version ? ""
4028         : !length  $overwrite_version ? " --overwrite"
4029         : " --overwrite=".$overwrite_version;
4030
4031     # Contributing parent is the first parent - that makes
4032     # git rev-list --first-parent DTRT.
4033     my $pmf = dgit_privdir()."/pseudomerge";
4034     open MC, ">", $pmf or die "$pmf $!";
4035     print MC <<END or confess $!;
4036 tree $tree
4037 parent $dgitview
4038 parent $archive_hash
4039 author $authline
4040 committer $authline
4041
4042 $msg_msg
4043
4044 [$msg_cmd]
4045 END
4046     close MC or confess $!;
4047
4048     return make_commit($pmf);
4049 }
4050
4051 sub splitbrain_pseudomerge ($$$$) {
4052     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4053     # => $merged_dgitview
4054     printdebug "splitbrain_pseudomerge...\n";
4055     #
4056     #     We:      debian/PREVIOUS    HEAD($maintview)
4057     # expect:          o ----------------- o
4058     #                    \                   \
4059     #                     o                   o
4060     #                 a/d/PREVIOUS        $dgitview
4061     #                $archive_hash              \
4062     #  If so,                \                   \
4063     #  we do:                 `------------------ o
4064     #   this:                                   $dgitview'
4065     #
4066
4067     return $dgitview unless defined $archive_hash;
4068     return $dgitview if deliberately_not_fast_forward();
4069
4070     printdebug "splitbrain_pseudomerge...\n";
4071
4072     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4073
4074     if (!defined $overwrite_version) {
4075         progress __ "Checking that HEAD includes all changes in archive...";
4076     }
4077
4078     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4079
4080     if (defined $overwrite_version) {
4081     } elsif (!eval {
4082         my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4083         my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4084                                               __ "maintainer view tag");
4085         my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4086         my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4087         my $i_archive = [ $archive_hash, __ "current archive contents" ];
4088
4089         printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4090
4091         infopair_cond_equal($i_dgit, $i_archive);
4092         infopair_cond_ff($i_dep14, $i_dgit);
4093         infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4094         1;
4095     }) {
4096         $@ =~ s/^\n//; chomp $@;
4097         print STDERR <<END.(__ <<ENDT);
4098 $@
4099 END
4100 | Not fast forward; maybe --overwrite is needed ?  Please see dgit(1).
4101 ENDT
4102         finish -1;
4103     }
4104
4105     my $arch_v = $i_arch_v->[0];
4106     my $r = pseudomerge_make_commit
4107         $clogp, $dgitview, $archive_hash, $i_arch_v,
4108         "dgit --quilt=$quilt_mode",
4109         (defined $overwrite_version
4110          ? f_ "Declare fast forward from %s\n", $arch_v
4111          : f_ "Make fast forward from %s\n",    $arch_v);
4112
4113     maybe_split_brain_save $maintview, $r, "pseudomerge";
4114
4115     progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4116     return $r;
4117 }
4118
4119 sub plain_overwrite_pseudomerge ($$$) {
4120     my ($clogp, $head, $archive_hash) = @_;
4121
4122     printdebug "plain_overwrite_pseudomerge...";
4123
4124     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4125
4126     return $head if is_fast_fwd $archive_hash, $head;
4127
4128     my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4129
4130     my $r = pseudomerge_make_commit
4131         $clogp, $head, $archive_hash, $i_arch_v,
4132         "dgit", $m;
4133
4134     runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4135
4136     progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4137     return $r;
4138 }
4139
4140 sub push_parse_changelog ($) {
4141     my ($clogpfn) = @_;
4142
4143     my $clogp = Dpkg::Control::Hash->new();
4144     $clogp->load($clogpfn) or die;
4145
4146     my $clogpackage = getfield $clogp, 'Source';
4147     $package //= $clogpackage;
4148     fail f_ "-p specified %s but changelog specified %s",
4149             $package, $clogpackage
4150         unless $package eq $clogpackage;
4151     my $cversion = getfield $clogp, 'Version';
4152
4153     if (!$we_are_initiator) {
4154         # rpush initiator can't do this because it doesn't have $isuite yet
4155         my $tag = debiantag($cversion, access_nomdistro);
4156         runcmd @git, qw(check-ref-format), $tag;
4157     }
4158
4159     my $dscfn = dscfn($cversion);
4160
4161     return ($clogp, $cversion, $dscfn);
4162 }
4163
4164 sub push_parse_dsc ($$$) {
4165     my ($dscfn,$dscfnwhat, $cversion) = @_;
4166     $dsc = parsecontrol($dscfn,$dscfnwhat);
4167     my $dversion = getfield $dsc, 'Version';
4168     my $dscpackage = getfield $dsc, 'Source';
4169     ($dscpackage eq $package && $dversion eq $cversion) or
4170         fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4171                 $dscfn, $dscpackage, $dversion,
4172                         $package,    $cversion;
4173 }
4174
4175 sub push_tagwants ($$$$) {
4176     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4177     my @tagwants;
4178     push @tagwants, {
4179         TagFn => \&debiantag,
4180         Objid => $dgithead,
4181         TfSuffix => '',
4182         View => 'dgit',
4183     };
4184     if (defined $maintviewhead) {
4185         push @tagwants, {
4186             TagFn => \&debiantag_maintview,
4187             Objid => $maintviewhead,
4188             TfSuffix => '-maintview',
4189             View => 'maint',
4190         };
4191     } elsif ($dodep14tag eq 'no' ? 0
4192              : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4193              : $dodep14tag eq 'always'
4194              ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4195 --dep14tag-always (or equivalent in config) means server must support
4196  both "new" and "maint" tag formats, but config says it doesn't.
4197 END
4198             : die "$dodep14tag ?") {
4199         push @tagwants, {
4200             TagFn => \&debiantag_maintview,
4201             Objid => $dgithead,
4202             TfSuffix => '-dgit',
4203             View => 'dgit',
4204         };
4205     };
4206     foreach my $tw (@tagwants) {
4207         $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4208         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4209     }
4210     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4211     return @tagwants;
4212 }
4213
4214 sub push_mktags ($$ $$ $) {
4215     my ($clogp,$dscfn,
4216         $changesfile,$changesfilewhat,
4217         $tagwants) = @_;
4218
4219     die unless $tagwants->[0]{View} eq 'dgit';
4220
4221     my $declaredistro = access_nomdistro();
4222     my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4223     $dsc->{$ourdscfield[0]} = join " ",
4224         $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4225         $reader_giturl;
4226     $dsc->save("$dscfn.tmp") or confess $!;
4227
4228     my $changes = parsecontrol($changesfile,$changesfilewhat);
4229     foreach my $field (qw(Source Distribution Version)) {
4230         $changes->{$field} eq $clogp->{$field} or
4231             fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4232                     $field, $changes->{$field}, $clogp->{$field};
4233     }
4234
4235     my $cversion = getfield $clogp, 'Version';
4236     my $clogsuite = getfield $clogp, 'Distribution';
4237
4238     # We make the git tag by hand because (a) that makes it easier
4239     # to control the "tagger" (b) we can do remote signing
4240     my $authline = clogp_authline $clogp;
4241     my $delibs = join(" ", "",@deliberatelies);
4242
4243     my $mktag = sub {
4244         my ($tw) = @_;
4245         my $tfn = $tw->{Tfn};
4246         my $head = $tw->{Objid};
4247         my $tag = $tw->{Tag};
4248
4249         open TO, '>', $tfn->('.tmp') or confess $!;
4250         print TO <<END or confess $!;
4251 object $head
4252 type commit
4253 tag $tag
4254 tagger $authline
4255
4256 END
4257         if ($tw->{View} eq 'dgit') {
4258             print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4259 %s release %s for %s (%s) [dgit]
4260 ENDT
4261                 or confess $!;
4262             print TO <<END or confess $!;
4263 [dgit distro=$declaredistro$delibs]
4264 END
4265             foreach my $ref (sort keys %previously) {
4266                 print TO <<END or confess $!;
4267 [dgit previously:$ref=$previously{$ref}]
4268 END
4269             }
4270         } elsif ($tw->{View} eq 'maint') {
4271             print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4272 %s release %s for %s (%s)
4273 (maintainer view tag generated by dgit --quilt=%s)
4274 END
4275                 $quilt_mode
4276                 or confess $!;
4277         } else {
4278             confess Dumper($tw)."?";
4279         }
4280
4281         close TO or confess $!;
4282
4283         my $tagobjfn = $tfn->('.tmp');
4284         if ($sign) {
4285             if (!defined $keyid) {
4286                 $keyid = access_cfg('keyid','RETURN-UNDEF');
4287             }
4288             if (!defined $keyid) {
4289                 $keyid = getfield $clogp, 'Maintainer';
4290             }
4291             unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess $!;
4292             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4293             push @sign_cmd, qw(-u),$keyid if defined $keyid;
4294             push @sign_cmd, $tfn->('.tmp');
4295             runcmd_ordryrun @sign_cmd;
4296             if (act_scary()) {
4297                 $tagobjfn = $tfn->('.signed.tmp');
4298                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4299                     $tfn->('.tmp'), $tfn->('.tmp.asc');
4300             }
4301         }
4302         return $tagobjfn;
4303     };
4304
4305     my @r = map { $mktag->($_); } @$tagwants;
4306     return @r;
4307 }
4308
4309 sub sign_changes ($) {
4310     my ($changesfile) = @_;
4311     if ($sign) {
4312         my @debsign_cmd = @debsign;
4313         push @debsign_cmd, "-k$keyid" if defined $keyid;
4314         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4315         push @debsign_cmd, $changesfile;
4316         runcmd_ordryrun @debsign_cmd;
4317     }
4318 }
4319
4320 sub dopush () {
4321     printdebug "actually entering push\n";
4322
4323     supplementary_message(__ <<'END');
4324 Push failed, while checking state of the archive.
4325 You can retry the push, after fixing the problem, if you like.
4326 END
4327     if (check_for_git()) {
4328         git_fetch_us();
4329     }
4330     my $archive_hash = fetch_from_archive();
4331     if (!$archive_hash) {
4332         $new_package or
4333             fail __ "package appears to be new in this suite;".
4334                     " if this is intentional, use --new";
4335     }
4336
4337     supplementary_message(__ <<'END');
4338 Push failed, while preparing your push.
4339 You can retry the push, after fixing the problem, if you like.
4340 END
4341
4342     need_tagformat 'new', "quilt mode $quilt_mode"
4343         if quiltmode_splitbrain;
4344
4345     prep_ud();
4346
4347     access_giturl(); # check that success is vaguely likely
4348     rpush_handle_protovsn_bothends() if $we_are_initiator;
4349     select_tagformat();
4350
4351     my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4352     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4353
4354     responder_send_file('parsed-changelog', $clogpfn);
4355
4356     my ($clogp, $cversion, $dscfn) =
4357         push_parse_changelog("$clogpfn");
4358
4359     my $dscpath = "$buildproductsdir/$dscfn";
4360     stat_exists $dscpath or
4361         fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4362                 $dscpath, $!;
4363
4364     responder_send_file('dsc', $dscpath);
4365
4366     push_parse_dsc($dscpath, $dscfn, $cversion);
4367
4368     my $format = getfield $dsc, 'Format';
4369     printdebug "format $format\n";
4370
4371     my $symref = git_get_symref();
4372     my $actualhead = git_rev_parse('HEAD');
4373
4374     if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4375         if (quiltmode_splitbrain()) {
4376             my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4377             fail f_ <<END, $ffq_prev, $quilt_mode;
4378 Branch is managed by git-debrebase (%s
4379 exists), but quilt mode (%s) implies a split view.
4380 Pass the right --quilt option or adjust your git config.
4381 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4382 END
4383         }
4384         runcmd_ordryrun_local @git_debrebase, 'stitch';
4385         $actualhead = git_rev_parse('HEAD');
4386     }
4387
4388     my $dgithead = $actualhead;
4389     my $maintviewhead = undef;
4390
4391     my $upstreamversion = upstreamversion $clogp->{Version};
4392
4393     if (madformat_wantfixup($format)) {
4394         # user might have not used dgit build, so maybe do this now:
4395         if (quiltmode_splitbrain()) {
4396             changedir $playground;
4397             quilt_make_fake_dsc($upstreamversion);
4398             my $cachekey;
4399             ($dgithead, $cachekey) =
4400                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4401             $dgithead or fail f_
4402  "--quilt=%s but no cached dgit view:
4403  perhaps HEAD changed since dgit build[-source] ?",
4404                               $quilt_mode;
4405             $split_brain = 1;
4406             $dgithead = splitbrain_pseudomerge($clogp,
4407                                                $actualhead, $dgithead,
4408                                                $archive_hash);
4409             $maintviewhead = $actualhead;
4410             changedir $maindir;
4411             prep_ud(); # so _only_subdir() works, below
4412         } else {
4413             commit_quilty_patch();
4414         }
4415     }
4416
4417     if (defined $overwrite_version && !defined $maintviewhead
4418         && $archive_hash) {
4419         $dgithead = plain_overwrite_pseudomerge($clogp,
4420                                                 $dgithead,
4421                                                 $archive_hash);
4422     }
4423
4424     check_not_dirty();
4425
4426     my $forceflag = '';
4427     if ($archive_hash) {
4428         if (is_fast_fwd($archive_hash, $dgithead)) {
4429             # ok
4430         } elsif (deliberately_not_fast_forward) {
4431             $forceflag = '+';
4432         } else {
4433             fail __ "dgit push: HEAD is not a descendant".
4434                 " of the archive's version.\n".
4435                 "To overwrite the archive's contents,".
4436                 " pass --overwrite[=VERSION].\n".
4437                 "To rewind history, if permitted by the archive,".
4438                 " use --deliberately-not-fast-forward.";
4439         }
4440     }
4441
4442     changedir $playground;
4443     progress f_ "checking that %s corresponds to HEAD", $dscfn;
4444     runcmd qw(dpkg-source -x --),
4445         $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4446     my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4447     check_for_vendor_patches() if madformat($dsc->{format});
4448     changedir $maindir;
4449     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4450     debugcmd "+",@diffcmd;
4451     $!=0; $?=-1;
4452     my $r = system @diffcmd;
4453     if ($r) {
4454         if ($r==256) {
4455             my $referent = $split_brain ? $dgithead : 'HEAD';
4456             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4457
4458             my @mode_changes;
4459             my $raw = cmdoutput @git,
4460                 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4461             my $changed;
4462             foreach (split /\0/, $raw) {
4463                 if (defined $changed) {
4464                     push @mode_changes, "$changed: $_\n" if $changed;
4465                     $changed = undef;
4466                     next;
4467                 } elsif (m/^:0+ 0+ /) {
4468                     $changed = '';
4469                 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4470                     $changed = "Mode change from $1 to $2"
4471                 } else {
4472                     die "$_ ?";
4473                 }
4474             }
4475             if (@mode_changes) {
4476                 fail +(f_ <<ENDT, $dscfn).<<END
4477 HEAD specifies a different tree to %s:
4478 ENDT
4479 $diffs
4480 END
4481                     .(join '', @mode_changes)
4482                     .(f_ <<ENDT, $tree, $referent);
4483 There is a problem with your source tree (see dgit(7) for some hints).
4484 To see a full diff, run git diff %s %s
4485 ENDT
4486             }
4487
4488             fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4489 HEAD specifies a different tree to %s:
4490 ENDT
4491 $diffs
4492 END
4493 Perhaps you forgot to build.  Or perhaps there is a problem with your
4494  source tree (see dgit(7) for some hints).  To see a full diff, run
4495    git diff %s %s
4496 ENDT
4497         } else {
4498             failedcmd @diffcmd;
4499         }
4500     }
4501     if (!$changesfile) {
4502         my $pat = changespat $cversion;
4503         my @cs = glob "$buildproductsdir/$pat";
4504         fail f_ "failed to find unique changes file".
4505                 " (looked for %s in %s);".
4506                 " perhaps you need to use dgit -C",
4507                 $pat, $buildproductsdir
4508             unless @cs==1;
4509         ($changesfile) = @cs;
4510     } else {
4511         $changesfile = "$buildproductsdir/$changesfile";
4512     }
4513
4514     # Check that changes and .dsc agree enough
4515     $changesfile =~ m{[^/]*$};
4516     my $changes = parsecontrol($changesfile,$&);
4517     files_compare_inputs($dsc, $changes)
4518         unless forceing [qw(dsc-changes-mismatch)];
4519
4520     # Check whether this is a source only upload
4521     my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4522     my $sourceonlypolicy = access_cfg 'source-only-uploads';
4523     if ($sourceonlypolicy eq 'ok') {
4524     } elsif ($sourceonlypolicy eq 'always') {
4525         forceable_fail [qw(uploading-binaries)],
4526             __ "uploading binaries, although distro policy is source only"
4527             if $hasdebs;
4528     } elsif ($sourceonlypolicy eq 'never') {
4529         forceable_fail [qw(uploading-source-only)],
4530             __ "source-only upload, although distro policy requires .debs"
4531             if !$hasdebs;
4532     } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4533         forceable_fail [qw(uploading-source-only)],
4534             f_ "source-only upload, even though package is entirely NEW\n".
4535                "(this is contrary to policy in %s)",
4536                access_nomdistro()
4537             if !$hasdebs
4538             && $new_package
4539             && !(archive_query('package_not_wholly_new', $package) // 1);
4540     } else {
4541         badcfg f_ "unknown source-only-uploads policy \`%s'",
4542                   $sourceonlypolicy;
4543     }
4544
4545     # Perhaps adjust .dsc to contain right set of origs
4546     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4547                                   $changesfile)
4548         unless forceing [qw(changes-origs-exactly)];
4549
4550     # Checks complete, we're going to try and go ahead:
4551
4552     responder_send_file('changes',$changesfile);
4553     responder_send_command("param head $dgithead");
4554     responder_send_command("param csuite $csuite");
4555     responder_send_command("param isuite $isuite");
4556     responder_send_command("param tagformat $tagformat");
4557     if (defined $maintviewhead) {
4558         confess "internal error (protovsn=$protovsn)"
4559             if defined $protovsn and $protovsn < 4;
4560         responder_send_command("param maint-view $maintviewhead");
4561     }
4562
4563     # Perhaps send buildinfo(s) for signing
4564     my $changes_files = getfield $changes, 'Files';
4565     my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4566     foreach my $bi (@buildinfos) {
4567         responder_send_command("param buildinfo-filename $bi");
4568         responder_send_file('buildinfo', "$buildproductsdir/$bi");
4569     }
4570
4571     if (deliberately_not_fast_forward) {
4572         git_for_each_ref(lrfetchrefs, sub {
4573             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4574             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4575             responder_send_command("previously $rrefname=$objid");
4576             $previously{$rrefname} = $objid;
4577         });
4578     }
4579
4580     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4581                                  dgit_privdir()."/tag");
4582     my @tagobjfns;
4583
4584     supplementary_message(__ <<'END');
4585 Push failed, while signing the tag.
4586 You can retry the push, after fixing the problem, if you like.
4587 END
4588     # If we manage to sign but fail to record it anywhere, it's fine.
4589     if ($we_are_responder) {
4590         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4591         responder_receive_files('signed-tag', @tagobjfns);
4592     } else {
4593         @tagobjfns = push_mktags($clogp,$dscpath,
4594                               $changesfile,$changesfile,
4595                               \@tagwants);
4596     }
4597     supplementary_message(__ <<'END');
4598 Push failed, *after* signing the tag.
4599 If you want to try again, you should use a new version number.
4600 END
4601
4602     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4603
4604     foreach my $tw (@tagwants) {
4605         my $tag = $tw->{Tag};
4606         my $tagobjfn = $tw->{TagObjFn};
4607         my $tag_obj_hash =
4608             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4609         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4610         runcmd_ordryrun_local
4611             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4612     }
4613
4614     supplementary_message(__ <<'END');
4615 Push failed, while updating the remote git repository - see messages above.
4616 If you want to try again, you should use a new version number.
4617 END
4618     if (!check_for_git()) {
4619         create_remote_git_repo();
4620     }
4621
4622     my @pushrefs = $forceflag.$dgithead.":".rrref();
4623     foreach my $tw (@tagwants) {
4624         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4625     }
4626
4627     runcmd_ordryrun @git,
4628         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4629     runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4630
4631     supplementary_message(__ <<'END');
4632 Push failed, while obtaining signatures on the .changes and .dsc.
4633 If it was just that the signature failed, you may try again by using
4634 debsign by hand to sign the changes file (see the command dgit tried,
4635 above), and then dput that changes file to complete the upload.
4636 If you need to change the package, you must use a new version number.
4637 END
4638     if ($we_are_responder) {
4639         my $dryrunsuffix = act_local() ? "" : ".tmp";
4640         my @rfiles = ($dscpath, $changesfile);
4641         push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4642         responder_receive_files('signed-dsc-changes',
4643                                 map { "$_$dryrunsuffix" } @rfiles);
4644     } else {
4645         if (act_local()) {
4646             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4647         } else {
4648             progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4649         }
4650         sign_changes $changesfile;
4651     }
4652
4653     supplementary_message(f_ <<END, $changesfile);
4654 Push failed, while uploading package(s) to the archive server.
4655 You can retry the upload of exactly these same files with dput of:
4656   %s
4657 If that .changes file is broken, you will need to use a new version
4658 number for your next attempt at the upload.
4659 END
4660     my $host = access_cfg('upload-host','RETURN-UNDEF');
4661     my @hostarg = defined($host) ? ($host,) : ();
4662     runcmd_ordryrun @dput, @hostarg, $changesfile;
4663     printdone f_ "pushed and uploaded %s", $cversion;
4664
4665     supplementary_message('');
4666     responder_send_command("complete");
4667 }
4668
4669 sub pre_clone () {
4670     not_necessarily_a_tree();
4671 }
4672 sub cmd_clone {
4673     parseopts();
4674     my $dstdir;
4675     badusage __ "-p is not allowed with clone; specify as argument instead"
4676         if defined $package;
4677     if (@ARGV==1) {
4678         ($package) = @ARGV;
4679     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4680         ($package,$isuite) = @ARGV;
4681     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4682         ($package,$dstdir) = @ARGV;
4683     } elsif (@ARGV==3) {
4684         ($package,$isuite,$dstdir) = @ARGV;
4685     } else {
4686         badusage __ "incorrect arguments to dgit clone";
4687     }
4688     notpushing();
4689
4690     $dstdir ||= "$package";
4691     if (stat_exists $dstdir) {
4692         fail f_ "%s already exists", $dstdir;
4693     }
4694
4695     my $cwd_remove;
4696     if ($rmonerror && !$dryrun_level) {
4697         $cwd_remove= getcwd();
4698         unshift @end, sub {
4699             return unless defined $cwd_remove;
4700             if (!chdir "$cwd_remove") {
4701                 return if $!==&ENOENT;
4702                 confess "chdir $cwd_remove: $!";
4703             }
4704             printdebug "clone rmonerror removing $dstdir\n";
4705             if (stat $dstdir) {
4706                 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4707             } elsif (grep { $! == $_ }
4708                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4709             } else {
4710                 print STDERR f_ "check whether to remove %s: %s\n",
4711                                 $dstdir, $!;
4712             }
4713         };
4714     }
4715
4716     clone($dstdir);
4717     $cwd_remove = undef;
4718 }
4719
4720 sub branchsuite () {
4721     my $branch = git_get_symref();
4722     if (defined $branch && $branch =~ m#$lbranch_re#o) {
4723         return $1;
4724     } else {
4725         return undef;
4726     }
4727 }
4728
4729 sub package_from_d_control () {
4730     if (!defined $package) {
4731         my $sourcep = parsecontrol('debian/control','debian/control');
4732         $package = getfield $sourcep, 'Source';
4733     }
4734 }
4735
4736 sub fetchpullargs () {
4737     package_from_d_control();
4738     if (@ARGV==0) {
4739         $isuite = branchsuite();
4740         if (!$isuite) {
4741             my $clogp = parsechangelog();
4742             my $clogsuite = getfield $clogp, 'Distribution';
4743             $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4744         }
4745     } elsif (@ARGV==1) {
4746         ($isuite) = @ARGV;
4747     } else {
4748         badusage __ "incorrect arguments to dgit fetch or dgit pull";
4749     }
4750     notpushing();
4751 }
4752
4753 sub cmd_fetch {
4754     parseopts();
4755     fetchpullargs();
4756     dofetch();
4757 }
4758
4759 sub cmd_pull {
4760     parseopts();
4761     fetchpullargs();
4762     if (quiltmode_splitbrain()) {
4763         my ($format, $fopts) = get_source_format();
4764         madformat($format) and fail f_ <<END, $quilt_mode
4765 dgit pull not yet supported in split view mode (--quilt=%s)
4766 END
4767     }
4768     pull();
4769 }
4770
4771 sub cmd_checkout {
4772     parseopts();
4773     package_from_d_control();
4774     @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4775     ($isuite) = @ARGV;
4776     notpushing();
4777
4778     foreach my $canon (qw(0 1)) {
4779         if (!$canon) {
4780             $csuite= $isuite;
4781         } else {
4782             undef $csuite;
4783             canonicalise_suite();
4784         }
4785         if (length git_get_ref lref()) {
4786             # local branch already exists, yay
4787             last;
4788         }
4789         if (!length git_get_ref lrref()) {
4790             if (!$canon) {
4791                 # nope
4792                 next;
4793             }
4794             dofetch();
4795         }
4796         # now lrref exists
4797         runcmd (@git, qw(update-ref), lref(), lrref(), '');
4798         last;
4799     }
4800     local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4801         "dgit checkout $isuite";
4802     runcmd (@git, qw(checkout), lbranch());
4803 }
4804
4805 sub cmd_update_vcs_git () {
4806     my $specsuite;
4807     if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4808         ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4809     } else {
4810         ($specsuite) = (@ARGV);
4811         shift @ARGV;
4812     }
4813     my $dofetch=1;
4814     if (@ARGV) {
4815         if ($ARGV[0] eq '-') {
4816             $dofetch = 0;
4817         } elsif ($ARGV[0] eq '-') {
4818             shift;
4819         }
4820     }
4821
4822     package_from_d_control();
4823     my $ctrl;
4824     if ($specsuite eq '.') {
4825         $ctrl = parsecontrol 'debian/control', 'debian/control';
4826     } else {
4827         $isuite = $specsuite;
4828         get_archive_dsc();
4829         $ctrl = $dsc;
4830     }
4831     my $url = getfield $ctrl, 'Vcs-Git';
4832
4833     my @cmd;
4834     my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4835     if (!defined $orgurl) {
4836         print STDERR f_ "setting up vcs-git: %s\n", $url;
4837         @cmd = (@git, qw(remote add vcs-git), $url);
4838     } elsif ($orgurl eq $url) {
4839         print STDERR f_ "vcs git already configured: %s\n", $url;
4840     } else {
4841         print STDERR f_ "changing vcs-git url to: %s\n", $url;
4842         @cmd = (@git, qw(remote set-url vcs-git), $url);
4843     }
4844     runcmd_ordryrun_local @cmd;
4845     if ($dofetch) {
4846         print f_ "fetching (%s)\n", "@ARGV";
4847         runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4848     }
4849 }
4850
4851 sub prep_push () {
4852     parseopts();
4853     build_or_push_prep_early();
4854     pushing();
4855     check_not_dirty();
4856     my $specsuite;
4857     if (@ARGV==0) {
4858     } elsif (@ARGV==1) {
4859         ($specsuite) = (@ARGV);
4860     } else {
4861         badusage f_ "incorrect arguments to dgit %s", $subcommand;
4862     }
4863     if ($new_package) {
4864         local ($package) = $existing_package; # this is a hack
4865         canonicalise_suite();
4866     } else {
4867         canonicalise_suite();
4868     }
4869     if (defined $specsuite &&
4870         $specsuite ne $isuite &&
4871         $specsuite ne $csuite) {
4872             fail f_ "dgit %s: changelog specifies %s (%s)".
4873                     " but command line specifies %s",
4874                     $subcommand, $isuite, $csuite, $specsuite;
4875     }
4876 }
4877
4878 sub cmd_push {
4879     prep_push();
4880     dopush();
4881 }
4882
4883 #---------- remote commands' implementation ----------
4884
4885 sub pre_remote_push_build_host {
4886     my ($nrargs) = shift @ARGV;
4887     my (@rargs) = @ARGV[0..$nrargs-1];
4888     @ARGV = @ARGV[$nrargs..$#ARGV];
4889     die unless @rargs;
4890     my ($dir,$vsnwant) = @rargs;
4891     # vsnwant is a comma-separated list; we report which we have
4892     # chosen in our ready response (so other end can tell if they
4893     # offered several)
4894     $debugprefix = ' ';
4895     $we_are_responder = 1;
4896     $us .= " (build host)";
4897
4898     open PI, "<&STDIN" or confess $!;
4899     open STDIN, "/dev/null" or confess $!;
4900     open PO, ">&STDOUT" or confess $!;
4901     autoflush PO 1;
4902     open STDOUT, ">&STDERR" or confess $!;
4903     autoflush STDOUT 1;
4904
4905     $vsnwant //= 1;
4906     ($protovsn) = grep {
4907         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4908     } @rpushprotovsn_support;
4909
4910     fail f_ "build host has dgit rpush protocol versions %s".
4911             " but invocation host has %s",
4912             (join ",", @rpushprotovsn_support), $vsnwant
4913         unless defined $protovsn;
4914
4915     changedir $dir;
4916 }
4917 sub cmd_remote_push_build_host {
4918     responder_send_command("dgit-remote-push-ready $protovsn");
4919     &cmd_push;
4920 }
4921
4922 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4923 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4924 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4925 #     a good error message)
4926
4927 sub rpush_handle_protovsn_bothends () {
4928     if ($protovsn < 4) {
4929         need_tagformat 'old', "rpush negotiated protocol $protovsn";
4930     }
4931     select_tagformat();
4932 }
4933
4934 our $i_tmp;
4935
4936 sub i_cleanup {
4937     local ($@, $?);
4938     my $report = i_child_report();
4939     if (defined $report) {
4940         printdebug "($report)\n";
4941     } elsif ($i_child_pid) {
4942         printdebug "(killing build host child $i_child_pid)\n";
4943         kill 15, $i_child_pid;
4944     }
4945     if (defined $i_tmp && !defined $initiator_tempdir) {
4946         changedir "/";
4947         eval { rmtree $i_tmp; };
4948     }
4949 }
4950
4951 END {
4952     return unless forkcheck_mainprocess();
4953     i_cleanup();
4954 }
4955
4956 sub i_method {
4957     my ($base,$selector,@args) = @_;
4958     $selector =~ s/\-/_/g;
4959     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4960 }
4961
4962 sub pre_rpush () {
4963     not_necessarily_a_tree();
4964 }
4965 sub cmd_rpush {
4966     my $host = nextarg;
4967     my $dir;
4968     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4969         $host = $1;
4970         $dir = $'; #';
4971     } else {
4972         $dir = nextarg;
4973     }
4974     $dir =~ s{^-}{./-};
4975     my @rargs = ($dir);
4976     push @rargs, join ",", @rpushprotovsn_support;
4977     my @rdgit;
4978     push @rdgit, @dgit;
4979     push @rdgit, @ropts;
4980     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4981     push @rdgit, @ARGV;
4982     my @cmd = (@ssh, $host, shellquote @rdgit);
4983     debugcmd "+",@cmd;
4984
4985     $we_are_initiator=1;
4986
4987     if (defined $initiator_tempdir) {
4988         rmtree $initiator_tempdir;
4989         mkdir $initiator_tempdir, 0700
4990             or fail f_ "create %s: %s", $initiator_tempdir, $!;
4991         $i_tmp = $initiator_tempdir;
4992     } else {
4993         $i_tmp = tempdir();
4994     }
4995     $i_child_pid = open2(\*RO, \*RI, @cmd);
4996     changedir $i_tmp;
4997     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4998     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4999     $supplementary_message = '' unless $protovsn >= 3;
5000
5001     for (;;) {
5002         my ($icmd,$iargs) = initiator_expect {
5003             m/^(\S+)(?: (.*))?$/;
5004             ($1,$2);
5005         };
5006         i_method "i_resp", $icmd, $iargs;
5007     }
5008 }
5009
5010 sub i_resp_progress ($) {
5011     my ($rhs) = @_;
5012     my $msg = protocol_read_bytes \*RO, $rhs;
5013     progress $msg;
5014 }
5015
5016 sub i_resp_supplementary_message ($) {
5017     my ($rhs) = @_;
5018     $supplementary_message = protocol_read_bytes \*RO, $rhs;
5019 }
5020
5021 sub i_resp_complete {
5022     my $pid = $i_child_pid;
5023     $i_child_pid = undef; # prevents killing some other process with same pid
5024     printdebug "waiting for build host child $pid...\n";
5025     my $got = waitpid $pid, 0;
5026     confess $! unless $got == $pid;
5027     fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5028
5029     i_cleanup();
5030     printdebug __ "all done\n";
5031     finish 0;
5032 }
5033
5034 sub i_resp_file ($) {
5035     my ($keyword) = @_;
5036     my $localname = i_method "i_localname", $keyword;
5037     my $localpath = "$i_tmp/$localname";
5038     stat_exists $localpath and
5039         badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5040     protocol_receive_file \*RO, $localpath;
5041     i_method "i_file", $keyword;
5042 }
5043
5044 our %i_param;
5045
5046 sub i_resp_param ($) {
5047     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5048     $i_param{$1} = $2;
5049 }
5050
5051 sub i_resp_previously ($) {
5052     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5053         or badproto \*RO, __ "bad previously spec";
5054     my $r = system qw(git check-ref-format), $1;
5055     confess "bad previously ref spec ($r)" if $r;
5056     $previously{$1} = $2;
5057 }
5058
5059 our %i_wanted;
5060
5061 sub i_resp_want ($) {
5062     my ($keyword) = @_;
5063     die "$keyword ?" if $i_wanted{$keyword}++;
5064
5065     defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5066     $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5067     die unless $isuite =~ m/^$suite_re$/;
5068
5069     pushing();
5070     rpush_handle_protovsn_bothends();
5071
5072     fail f_ "rpush negotiated protocol version %s".
5073         " which does not support quilt mode %s",
5074         $protovsn, $quilt_mode
5075         if quiltmode_splitbrain;
5076
5077     my @localpaths = i_method "i_want", $keyword;
5078     printdebug "[[  $keyword @localpaths\n";
5079     foreach my $localpath (@localpaths) {
5080         protocol_send_file \*RI, $localpath;
5081     }
5082     print RI "files-end\n" or confess $!;
5083 }
5084
5085 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5086
5087 sub i_localname_parsed_changelog {
5088     return "remote-changelog.822";
5089 }
5090 sub i_file_parsed_changelog {
5091     ($i_clogp, $i_version, $i_dscfn) =
5092         push_parse_changelog "$i_tmp/remote-changelog.822";
5093     die if $i_dscfn =~ m#/|^\W#;
5094 }
5095
5096 sub i_localname_dsc {
5097     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5098     return $i_dscfn;
5099 }
5100 sub i_file_dsc { }
5101
5102 sub i_localname_buildinfo ($) {
5103     my $bi = $i_param{'buildinfo-filename'};
5104     defined $bi or badproto \*RO, "buildinfo before filename";
5105     defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5106     $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5107         or badproto \*RO, "improper buildinfo filename";
5108     return $&;
5109 }
5110 sub i_file_buildinfo {
5111     my $bi = $i_param{'buildinfo-filename'};
5112     my $bd = parsecontrol "$i_tmp/$bi", $bi;
5113     my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5114     if (!forceing [qw(buildinfo-changes-mismatch)]) {
5115         files_compare_inputs($bd, $ch);
5116         (getfield $bd, $_) eq (getfield $ch, $_) or
5117             fail f_ "buildinfo mismatch in field %s", $_
5118             foreach qw(Source Version);
5119         !defined $bd->{$_} or
5120             fail f_ "buildinfo contains forbidden field %s", $_
5121             foreach qw(Changes Changed-by Distribution);
5122     }
5123     push @i_buildinfos, $bi;
5124     delete $i_param{'buildinfo-filename'};
5125 }
5126
5127 sub i_localname_changes {
5128     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5129     $i_changesfn = $i_dscfn;
5130     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5131     return $i_changesfn;
5132 }
5133 sub i_file_changes { }
5134
5135 sub i_want_signed_tag {
5136     printdebug Dumper(\%i_param, $i_dscfn);
5137     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5138         && defined $i_param{'csuite'}
5139         or badproto \*RO, "premature desire for signed-tag";
5140     my $head = $i_param{'head'};
5141     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5142
5143     my $maintview = $i_param{'maint-view'};
5144     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5145
5146     select_tagformat();
5147     if ($protovsn >= 4) {
5148         my $p = $i_param{'tagformat'} // '<undef>';
5149         $p eq $tagformat
5150             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5151     }
5152
5153     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5154     $csuite = $&;
5155     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5156
5157     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5158
5159     return
5160         push_mktags $i_clogp, $i_dscfn,
5161             $i_changesfn, (__ 'remote changes file'),
5162             \@tagwants;
5163 }
5164
5165 sub i_want_signed_dsc_changes {
5166     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5167     sign_changes $i_changesfn;
5168     return ($i_dscfn, $i_changesfn, @i_buildinfos);
5169 }
5170
5171 #---------- building etc. ----------
5172
5173 our $version;
5174 our $sourcechanges;
5175 our $dscfn;
5176
5177 #----- `3.0 (quilt)' handling -----
5178
5179 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5180
5181 sub quiltify_dpkg_commit ($$$;$) {
5182     my ($patchname,$author,$msg, $xinfo) = @_;
5183     $xinfo //= '';
5184
5185     mkpath '.git/dgit'; # we are in playtree
5186     my $descfn = ".git/dgit/quilt-description.tmp";
5187     open O, '>', $descfn or confess "$descfn: $!";
5188     $msg =~ s/\n+/\n\n/;
5189     print O <<END or confess $!;
5190 From: $author
5191 ${xinfo}Subject: $msg
5192 ---
5193
5194 END
5195     close O or confess $!;
5196
5197     {
5198         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5199         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5200         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5201         runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5202     }
5203 }
5204
5205 sub quiltify_trees_differ ($$;$$$) {
5206     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5207     # returns true iff the two tree objects differ other than in debian/
5208     # with $finegrained,
5209     # returns bitmask 01 - differ in upstream files except .gitignore
5210     #                 02 - differ in .gitignore
5211     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5212     #  is set for each modified .gitignore filename $fn
5213     # if $unrepres is defined, array ref to which is appeneded
5214     #  a list of unrepresentable changes (removals of upstream files
5215     #  (as messages)
5216     local $/=undef;
5217     my @cmd = (@git, qw(diff-tree -z --no-renames));
5218     push @cmd, qw(--name-only) unless $unrepres;
5219     push @cmd, qw(-r) if $finegrained || $unrepres;
5220     push @cmd, $x, $y;
5221     my $diffs= cmdoutput @cmd;
5222     my $r = 0;
5223     my @lmodes;
5224     foreach my $f (split /\0/, $diffs) {
5225         if ($unrepres && !@lmodes) {
5226             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5227             next;
5228         }
5229         my ($oldmode,$newmode) = @lmodes;
5230         @lmodes = ();
5231
5232         next if $f =~ m#^debian(?:/.*)?$#s;
5233
5234         if ($unrepres) {
5235             eval {
5236                 die __ "not a plain file or symlink\n"
5237                     unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5238                            $oldmode =~ m/^(?:10|12)\d{4}$/;
5239                 if ($oldmode =~ m/[^0]/ &&
5240                     $newmode =~ m/[^0]/) {
5241                     # both old and new files exist
5242                     die __ "mode or type changed\n" if $oldmode ne $newmode;
5243                     die __ "modified symlink\n" unless $newmode =~ m/^10/;
5244                 } elsif ($oldmode =~ m/[^0]/) {
5245                     # deletion
5246                     die __ "deletion of symlink\n"
5247                         unless $oldmode =~ m/^10/;
5248                 } else {
5249                     # creation
5250                     die __ "creation with non-default mode\n"
5251                         unless $newmode =~ m/^100644$/ or
5252                                $newmode =~ m/^120000$/;
5253                 }
5254             };
5255             if ($@) {
5256                 local $/="\n"; chomp $@;
5257                 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5258             }
5259         }
5260
5261         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5262         $r |= $isignore ? 02 : 01;
5263         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5264     }
5265     printdebug "quiltify_trees_differ $x $y => $r\n";
5266     return $r;
5267 }
5268
5269 sub quiltify_tree_sentinelfiles ($) {
5270     # lists the `sentinel' files present in the tree
5271     my ($x) = @_;
5272     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5273         qw(-- debian/rules debian/control);
5274     $r =~ s/\n/,/g;
5275     return $r;
5276 }
5277
5278 sub quiltify_splitbrain_needed () {
5279     if (!$split_brain) {
5280         progress __ "dgit view: changes are required...";
5281         runcmd @git, qw(checkout -q -b dgit-view);
5282         $split_brain = 1;
5283     }
5284 }
5285
5286 sub quiltify_splitbrain ($$$$$$$) {
5287     my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5288         $editedignores, $cachekey) = @_;
5289     my $gitignore_special = 1;
5290     if ($quilt_mode !~ m/gbp|dpm/) {
5291         # treat .gitignore just like any other upstream file
5292         $diffbits = { %$diffbits };
5293         $_ = !!$_ foreach values %$diffbits;
5294         $gitignore_special = 0;
5295     }
5296     # We would like any commits we generate to be reproducible
5297     my @authline = clogp_authline($clogp);
5298     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
5299     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5300     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
5301     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
5302     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5303     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
5304
5305     my $fulldiffhint = sub {
5306         my ($x,$y) = @_;
5307         my $cmd = "git diff $x $y -- :/ ':!debian'";
5308         $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5309         return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5310                   $cmd;
5311     };
5312
5313     if ($quilt_mode =~ m/gbp|unapplied/ &&
5314         ($diffbits->{O2H} & 01)) {
5315         my $msg = f_
5316  "--quilt=%s specified, implying patches-unapplied git tree\n".
5317  " but git tree differs from orig in upstream files.",
5318                      $quilt_mode;
5319         $msg .= $fulldiffhint->($unapplied, 'HEAD');
5320         if (!stat_exists "debian/patches") {
5321             $msg .= __
5322  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5323         }
5324         fail $msg;
5325     }
5326     if ($quilt_mode =~ m/dpm/ &&
5327         ($diffbits->{H2A} & 01)) {
5328         fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5329 --quilt=%s specified, implying patches-applied git tree
5330  but git tree differs from result of applying debian/patches to upstream
5331 END
5332     }
5333     if ($quilt_mode =~ m/gbp|unapplied/ &&
5334         ($diffbits->{O2A} & 01)) { # some patches
5335         quiltify_splitbrain_needed();
5336         progress __ "dgit view: creating patches-applied version using gbp pq";
5337         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5338         # gbp pq import creates a fresh branch; push back to dgit-view
5339         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5340         runcmd @git, qw(checkout -q dgit-view);
5341     }
5342     if ($quilt_mode =~ m/gbp|dpm/ &&
5343         ($diffbits->{O2A} & 02)) {
5344         fail f_ <<END, $quilt_mode;
5345 --quilt=%s specified, implying that HEAD is for use with a
5346  tool which does not create patches for changes to upstream
5347  .gitignores: but, such patches exist in debian/patches.
5348 END
5349     }
5350     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5351         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5352         quiltify_splitbrain_needed();
5353         progress __
5354             "dgit view: creating patch to represent .gitignore changes";
5355         ensuredir "debian/patches";
5356         my $gipatch = "debian/patches/auto-gitignore";
5357         open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5358         stat GIPATCH or confess "$gipatch: $!";
5359         fail f_ "%s already exists; but want to create it".
5360                 " to record .gitignore changes",
5361                 $gipatch
5362             if (stat _)[7];
5363         print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5364 Subject: Update .gitignore from Debian packaging branch
5365
5366 The Debian packaging git branch contains these updates to the upstream
5367 .gitignore file(s).  This patch is autogenerated, to provide these
5368 updates to users of the official Debian archive view of the package.
5369 END
5370
5371 [dgit ($our_version) update-gitignore]
5372 ---
5373 ENDU
5374         close GIPATCH or die "$gipatch: $!";
5375         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5376             $unapplied, $headref, "--", sort keys %$editedignores;
5377         open SERIES, "+>>", "debian/patches/series" or confess $!;
5378         defined seek SERIES, -1, 2 or $!==EINVAL or confess $!;
5379         my $newline;
5380         defined read SERIES, $newline, 1 or confess $!;
5381         print SERIES "\n" or confess $! unless $newline eq "\n";
5382         print SERIES "auto-gitignore\n" or confess $!;
5383         close SERIES or die  $!;
5384         runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5385         commit_admin +(__ <<END).<<ENDU
5386 Commit patch to update .gitignore
5387 END
5388
5389 [dgit ($our_version) update-gitignore-quilt-fixup]
5390 ENDU
5391     }
5392
5393     my $dgitview = git_rev_parse 'HEAD';
5394
5395     changedir $maindir;
5396     reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5397
5398     changedir "$playground/work";
5399
5400     my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5401     progress f_ "dgit view: created (%s)", $saved;
5402 }
5403
5404 sub quiltify ($$$$) {
5405     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5406
5407     # Quilt patchification algorithm
5408     #
5409     # We search backwards through the history of the main tree's HEAD
5410     # (T) looking for a start commit S whose tree object is identical
5411     # to to the patch tip tree (ie the tree corresponding to the
5412     # current dpkg-committed patch series).  For these purposes
5413     # `identical' disregards anything in debian/ - this wrinkle is
5414     # necessary because dpkg-source treates debian/ specially.
5415     #
5416     # We can only traverse edges where at most one of the ancestors'
5417     # trees differs (in changes outside in debian/).  And we cannot
5418     # handle edges which change .pc/ or debian/patches.  To avoid
5419     # going down a rathole we avoid traversing edges which introduce
5420     # debian/rules or debian/control.  And we set a limit on the
5421     # number of edges we are willing to look at.
5422     #
5423     # If we succeed, we walk forwards again.  For each traversed edge
5424     # PC (with P parent, C child) (starting with P=S and ending with
5425     # C=T) to we do this:
5426     #  - git checkout C
5427     #  - dpkg-source --commit with a patch name and message derived from C
5428     # After traversing PT, we git commit the changes which
5429     # should be contained within debian/patches.
5430
5431     # The search for the path S..T is breadth-first.  We maintain a
5432     # todo list containing search nodes.  A search node identifies a
5433     # commit, and looks something like this:
5434     #  $p = {
5435     #      Commit => $git_commit_id,
5436     #      Child => $c,                          # or undef if P=T
5437     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
5438     #      Nontrivial => true iff $p..$c has relevant changes
5439     #  };
5440
5441     my @todo;
5442     my @nots;
5443     my $sref_S;
5444     my $max_work=100;
5445     my %considered; # saves being exponential on some weird graphs
5446
5447     my $t_sentinels = quiltify_tree_sentinelfiles $target;
5448
5449     my $not = sub {
5450         my ($search,$whynot) = @_;
5451         printdebug " search NOT $search->{Commit} $whynot\n";
5452         $search->{Whynot} = $whynot;
5453         push @nots, $search;
5454         no warnings qw(exiting);
5455         next;
5456     };
5457
5458     push @todo, {
5459         Commit => $target,
5460     };
5461
5462     while (@todo) {
5463         my $c = shift @todo;
5464         next if $considered{$c->{Commit}}++;
5465
5466         $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5467
5468         printdebug "quiltify investigate $c->{Commit}\n";
5469
5470         # are we done?
5471         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5472             printdebug " search finished hooray!\n";
5473             $sref_S = $c;
5474             last;
5475         }
5476
5477         quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5478         if ($quilt_mode eq 'smash') {
5479             printdebug " search quitting smash\n";
5480             last;
5481         }
5482
5483         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5484         $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5485             if $c_sentinels ne $t_sentinels;
5486
5487         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5488         $commitdata =~ m/\n\n/;
5489         $commitdata =~ $`;
5490         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5491         @parents = map { { Commit => $_, Child => $c } } @parents;
5492
5493         $not->($c, __ "root commit") if !@parents;
5494
5495         foreach my $p (@parents) {
5496             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5497         }
5498         my $ndiffers = grep { $_->{Nontrivial} } @parents;
5499         $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5500             if $ndiffers > 1;
5501
5502         foreach my $p (@parents) {
5503             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5504
5505             my @cmd= (@git, qw(diff-tree -r --name-only),
5506                       $p->{Commit},$c->{Commit},
5507                       qw(-- debian/patches .pc debian/source/format));
5508             my $patchstackchange = cmdoutput @cmd;
5509             if (length $patchstackchange) {
5510                 $patchstackchange =~ s/\n/,/g;
5511                 $not->($p, f_ "changed %s", $patchstackchange);
5512             }
5513
5514             printdebug " search queue P=$p->{Commit} ",
5515                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5516             push @todo, $p;
5517         }
5518     }
5519
5520     if (!$sref_S) {
5521         printdebug "quiltify want to smash\n";
5522
5523         my $abbrev = sub {
5524             my $x = $_[0]{Commit};
5525             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5526             return $x;
5527         };
5528         if ($quilt_mode eq 'linear') {
5529             print STDERR f_
5530                 "\n%s: error: quilt fixup cannot be linear.  Stopped at:\n",
5531                 $us;
5532             my $all_gdr = !!@nots;
5533             foreach my $notp (@nots) {
5534                 my $c = $notp->{Child};
5535                 my $cprange = $abbrev->($notp);
5536                 $cprange .= "..".$abbrev->($c) if $c;
5537                 print STDERR f_ "%s:  %s: %s\n",
5538                     $us, $cprange, $notp->{Whynot};
5539                 $all_gdr &&= $notp->{Child} &&
5540                     (git_cat_file $notp->{Child}{Commit}, 'commit')
5541                     =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5542             }
5543             print STDERR "\n";
5544             $failsuggestion =
5545                 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5546                 if $all_gdr;
5547             print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5548             fail __
5549  "quilt history linearisation failed.  Search \`quilt fixup' in dgit(7).\n";
5550         } elsif ($quilt_mode eq 'smash') {
5551         } elsif ($quilt_mode eq 'auto') {
5552             progress __ "quilt fixup cannot be linear, smashing...";
5553         } else {
5554             confess "$quilt_mode ?";
5555         }
5556
5557         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5558         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5559         my $ncommits = 3;
5560         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5561
5562         quiltify_dpkg_commit "auto-$version-$target-$time",
5563             (getfield $clogp, 'Maintainer'),
5564             (f_ "Automatically generated patch (%s)\n".
5565              "Last (up to) %s git changes, FYI:\n\n",
5566              $clogp->{Version}, $ncommits).
5567              $msg;
5568         return;
5569     }
5570
5571     progress __ "quiltify linearisation planning successful, executing...";
5572
5573     for (my $p = $sref_S;
5574          my $c = $p->{Child};
5575          $p = $p->{Child}) {
5576         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5577         next unless $p->{Nontrivial};
5578
5579         my $cc = $c->{Commit};
5580
5581         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5582         $commitdata =~ m/\n\n/ or die "$c ?";
5583         $commitdata = $`;
5584         my $msg = $'; #';
5585         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5586         my $author = $1;
5587
5588         my $commitdate = cmdoutput
5589             @git, qw(log -n1 --pretty=format:%aD), $cc;
5590
5591         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5592
5593         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5594         $strip_nls->();
5595
5596         my $title = $1;
5597         my $patchname;
5598         my $patchdir;
5599
5600         my $gbp_check_suitable = sub {
5601             $_ = shift;
5602             my ($what) = @_;
5603
5604             eval {
5605                 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5606                 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5607                 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5608                 die __ "is series file\n" if m{$series_filename_re}o;
5609                 die __ "too long\n" if length > 200;
5610             };
5611             return $_ unless $@;
5612             print STDERR f_
5613                 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5614                 $cc, $what, $@;
5615             return undef;
5616         };
5617
5618         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5619                            gbp-pq-name: \s* )
5620                        (\S+) \s* \n //ixm) {
5621             $patchname = $gbp_check_suitable->($1, 'Name');
5622         }
5623         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5624                            gbp-pq-topic: \s* )
5625                        (\S+) \s* \n //ixm) {
5626             $patchdir = $gbp_check_suitable->($1, 'Topic');
5627         }
5628
5629         $strip_nls->();
5630
5631         if (!defined $patchname) {
5632             $patchname = $title;
5633             $patchname =~ s/[.:]$//;
5634             use Text::Iconv;
5635             eval {
5636                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5637                 my $translitname = $converter->convert($patchname);
5638                 die unless defined $translitname;
5639                 $patchname = $translitname;
5640             };
5641             print STDERR
5642                 +(f_ "dgit: patch title transliteration error: %s", $@)
5643                 if $@;
5644             $patchname =~ y/ A-Z/-a-z/;
5645             $patchname =~ y/-a-z0-9_.+=~//cd;
5646             $patchname =~ s/^\W/x-$&/;
5647             $patchname = substr($patchname,0,40);
5648             $patchname .= ".patch";
5649         }
5650         if (!defined $patchdir) {
5651             $patchdir = '';
5652         }
5653         if (length $patchdir) {
5654             $patchname = "$patchdir/$patchname";
5655         }
5656         if ($patchname =~ m{^(.*)/}) {
5657             mkpath "debian/patches/$1";
5658         }
5659
5660         my $index;
5661         for ($index='';
5662              stat "debian/patches/$patchname$index";
5663              $index++) { }
5664         $!==ENOENT or confess "$patchname$index $!";
5665
5666         runcmd @git, qw(checkout -q), $cc;
5667
5668         # We use the tip's changelog so that dpkg-source doesn't
5669         # produce complaining messages from dpkg-parsechangelog.  None
5670         # of the information dpkg-source gets from the changelog is
5671         # actually relevant - it gets put into the original message
5672         # which dpkg-source provides our stunt editor, and then
5673         # overwritten.
5674         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5675
5676         quiltify_dpkg_commit "$patchname$index", $author, $msg,
5677             "Date: $commitdate\n".
5678             "X-Dgit-Generated: $clogp->{Version} $cc\n";
5679
5680         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5681     }
5682
5683     runcmd @git, qw(checkout -q master);
5684 }
5685
5686 sub build_maybe_quilt_fixup () {
5687     my ($format,$fopts) = get_source_format;
5688     return unless madformat_wantfixup $format;
5689     # sigh
5690
5691     check_for_vendor_patches();
5692
5693     if (quiltmode_splitbrain) {
5694         fail <<END unless access_cfg_tagformats_can_splitbrain;
5695 quilt mode $quilt_mode requires split view so server needs to support
5696  both "new" and "maint" tag formats, but config says it doesn't.
5697 END
5698     }
5699
5700     my $clogp = parsechangelog();
5701     my $headref = git_rev_parse('HEAD');
5702     my $symref = git_get_symref();
5703
5704     if ($quilt_mode eq 'linear'
5705         && !$fopts->{'single-debian-patch'}
5706         && branch_is_gdr($headref)) {
5707         # This is much faster.  It also makes patches that gdr
5708         # likes better for future updates without laundering.
5709         #
5710         # However, it can fail in some casses where we would
5711         # succeed: if there are existing patches, which correspond
5712         # to a prefix of the branch, but are not in gbp/gdr
5713         # format, gdr will fail (exiting status 7), but we might
5714         # be able to figure out where to start linearising.  That
5715         # will be slower so hopefully there's not much to do.
5716         my @cmd = (@git_debrebase,
5717                    qw(--noop-ok -funclean-mixed -funclean-ordering
5718                       make-patches --quiet-would-amend));
5719         # We tolerate soe snags that gdr wouldn't, by default.
5720         if (act_local()) {
5721             debugcmd "+",@cmd;
5722             $!=0; $?=-1;
5723             failedcmd @cmd
5724                 if system @cmd
5725                 and not ($? == 7*256 or
5726                          $? == -1 && $!==ENOENT);
5727         } else {
5728             dryrun_report @cmd;
5729         }
5730         $headref = git_rev_parse('HEAD');
5731     }
5732
5733     prep_ud();
5734     changedir $playground;
5735
5736     my $upstreamversion = upstreamversion $version;
5737
5738     if ($fopts->{'single-debian-patch'}) {
5739         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5740     } else {
5741         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5742     }
5743
5744     changedir $maindir;
5745     runcmd_ordryrun_local
5746         @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5747 }
5748
5749 sub unpack_playtree_mkwork ($) {
5750     my ($headref) = @_;
5751
5752     mkdir "work" or confess $!;
5753     changedir "work";
5754     mktree_in_ud_here();
5755     runcmd @git, qw(reset -q --hard), $headref;
5756 }
5757
5758 sub unpack_playtree_linkorigs ($$) {
5759     my ($upstreamversion, $fn) = @_;
5760     # calls $fn->($leafname);
5761
5762     my $bpd_abs = bpd_abs();
5763     opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5764     while ($!=0, defined(my $b = readdir QFD)) {
5765         my $f = bpd_abs()."/".$b;
5766         {
5767             local ($debuglevel) = $debuglevel-1;
5768             printdebug "QF linkorigs $b, $f ?\n";
5769         }
5770         next unless is_orig_file_of_vsn $b, $upstreamversion;
5771         printdebug "QF linkorigs $b, $f Y\n";
5772         link_ltarget $f, $b or die "$b $!";
5773         $fn->($b);
5774     }
5775     die "$buildproductsdir: $!" if $!;
5776     closedir QFD;
5777 }
5778
5779 sub quilt_fixup_delete_pc () {
5780     runcmd @git, qw(rm -rqf .pc);
5781     commit_admin +(__ <<END).<<ENDU
5782 Commit removal of .pc (quilt series tracking data)
5783 END
5784
5785 [dgit ($our_version) upgrade quilt-remove-pc]
5786 ENDU
5787 }
5788
5789 sub quilt_fixup_singlepatch ($$$) {
5790     my ($clogp, $headref, $upstreamversion) = @_;
5791
5792     progress __ "starting quiltify (single-debian-patch)";
5793
5794     # dpkg-source --commit generates new patches even if
5795     # single-debian-patch is in debian/source/options.  In order to
5796     # get it to generate debian/patches/debian-changes, it is
5797     # necessary to build the source package.
5798
5799     unpack_playtree_linkorigs($upstreamversion, sub { });
5800     unpack_playtree_mkwork($headref);
5801
5802     rmtree("debian/patches");
5803
5804     runcmd @dpkgsource, qw(-b .);
5805     changedir "..";
5806     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5807     rename srcfn("$upstreamversion", "/debian/patches"),
5808            "work/debian/patches";
5809
5810     changedir "work";
5811     commit_quilty_patch();
5812 }
5813
5814 sub quilt_make_fake_dsc ($) {
5815     my ($upstreamversion) = @_;
5816
5817     my $fakeversion="$upstreamversion-~~DGITFAKE";
5818
5819     my $fakedsc=new IO::File 'fake.dsc', '>' or confess $!;
5820     print $fakedsc <<END or confess $!;
5821 Format: 3.0 (quilt)
5822 Source: $package
5823 Version: $fakeversion
5824 Files:
5825 END
5826
5827     my $dscaddfile=sub {
5828         my ($b) = @_;
5829
5830         my $md = new Digest::MD5;
5831
5832         my $fh = new IO::File $b, '<' or die "$b $!";
5833         stat $fh or confess $!;
5834         my $size = -s _;
5835
5836         $md->addfile($fh);
5837         print $fakedsc " ".$md->hexdigest." $size $b\n" or confess $!;
5838     };
5839
5840     unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5841
5842     my @files=qw(debian/source/format debian/rules
5843                  debian/control debian/changelog);
5844     foreach my $maybe (qw(debian/patches debian/source/options
5845                           debian/tests/control)) {
5846         next unless stat_exists "$maindir/$maybe";
5847         push @files, $maybe;
5848     }
5849
5850     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5851     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5852
5853     $dscaddfile->($debtar);
5854     close $fakedsc or confess $!;
5855 }
5856
5857 sub quilt_fakedsc2unapplied ($$) {
5858     my ($headref, $upstreamversion) = @_;
5859     # must be run in the playground
5860     # quilt_make_fake_dsc must have been called
5861
5862     runcmd qw(sh -ec),
5863         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5864
5865     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5866     rename $fakexdir, "fake" or die "$fakexdir $!";
5867
5868     changedir 'fake';
5869
5870     remove_stray_gits(__ "source package");
5871     mktree_in_ud_here();
5872
5873     rmtree '.pc';
5874
5875     rmtree 'debian'; # git checkout commitish paths does not delete!
5876     runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5877     my $unapplied=git_add_write_tree();
5878     printdebug "fake orig tree object $unapplied\n";
5879     return $unapplied;
5880 }
5881
5882 sub quilt_check_splitbrain_cache ($$) {
5883     my ($headref, $upstreamversion) = @_;
5884     # Called only if we are in (potentially) split brain mode.
5885     # Called in playground.
5886     # Computes the cache key and looks in the cache.
5887     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5888
5889     my $splitbrain_cachekey;
5890
5891     progress f_
5892  "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5893                 $quilt_mode;
5894     # we look in the reflog of dgit-intern/quilt-cache
5895     # we look for an entry whose message is the key for the cache lookup
5896     my @cachekey = (qw(dgit), $our_version);
5897     push @cachekey, $upstreamversion;
5898     push @cachekey, $quilt_mode;
5899     push @cachekey, $headref;
5900
5901     push @cachekey, hashfile('fake.dsc');
5902
5903     my $srcshash = Digest::SHA->new(256);
5904     my %sfs = ( %INC, '$0(dgit)' => $0 );
5905     foreach my $sfk (sort keys %sfs) {
5906         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5907         $srcshash->add($sfk,"  ");
5908         $srcshash->add(hashfile($sfs{$sfk}));
5909         $srcshash->add("\n");
5910     }
5911     push @cachekey, $srcshash->hexdigest();
5912     $splitbrain_cachekey = "@cachekey";
5913
5914     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5915
5916     my $cachehit = reflog_cache_lookup
5917         "refs/$splitbraincache", $splitbrain_cachekey;
5918
5919     if ($cachehit) {
5920         unpack_playtree_mkwork($headref);
5921         my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5922         if ($cachehit ne $headref) {
5923             progress f_ "dgit view: found cached (%s)", $saved;
5924             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5925             $split_brain = 1;
5926             return ($cachehit, $splitbrain_cachekey);
5927         }
5928         progress __ "dgit view: found cached, no changes required";
5929         return ($headref, $splitbrain_cachekey);
5930     }
5931
5932     printdebug "splitbrain cache miss\n";
5933     return (undef, $splitbrain_cachekey);
5934 }
5935
5936 sub quilt_fixup_multipatch ($$$) {
5937     my ($clogp, $headref, $upstreamversion) = @_;
5938
5939     progress f_ "examining quilt state (multiple patches, %s mode)",
5940                 $quilt_mode;
5941
5942     # Our objective is:
5943     #  - honour any existing .pc in case it has any strangeness
5944     #  - determine the git commit corresponding to the tip of
5945     #    the patch stack (if there is one)
5946     #  - if there is such a git commit, convert each subsequent
5947     #    git commit into a quilt patch with dpkg-source --commit
5948     #  - otherwise convert all the differences in the tree into
5949     #    a single git commit
5950     #
5951     # To do this we:
5952
5953     # Our git tree doesn't necessarily contain .pc.  (Some versions of
5954     # dgit would include the .pc in the git tree.)  If there isn't
5955     # one, we need to generate one by unpacking the patches that we
5956     # have.
5957     #
5958     # We first look for a .pc in the git tree.  If there is one, we
5959     # will use it.  (This is not the normal case.)
5960     #
5961     # Otherwise need to regenerate .pc so that dpkg-source --commit
5962     # can work.  We do this as follows:
5963     #     1. Collect all relevant .orig from parent directory
5964     #     2. Generate a debian.tar.gz out of
5965     #         debian/{patches,rules,source/format,source/options}
5966     #     3. Generate a fake .dsc containing just these fields:
5967     #          Format Source Version Files
5968     #     4. Extract the fake .dsc
5969     #        Now the fake .dsc has a .pc directory.
5970     # (In fact we do this in every case, because in future we will
5971     # want to search for a good base commit for generating patches.)
5972     #
5973     # Then we can actually do the dpkg-source --commit
5974     #     1. Make a new working tree with the same object
5975     #        store as our main tree and check out the main
5976     #        tree's HEAD.
5977     #     2. Copy .pc from the fake's extraction, if necessary
5978     #     3. Run dpkg-source --commit
5979     #     4. If the result has changes to debian/, then
5980     #          - git add them them
5981     #          - git add .pc if we had a .pc in-tree
5982     #          - git commit
5983     #     5. If we had a .pc in-tree, delete it, and git commit
5984     #     6. Back in the main tree, fast forward to the new HEAD
5985
5986     # Another situation we may have to cope with is gbp-style
5987     # patches-unapplied trees.
5988     #
5989     # We would want to detect these, so we know to escape into
5990     # quilt_fixup_gbp.  However, this is in general not possible.
5991     # Consider a package with a one patch which the dgit user reverts
5992     # (with git revert or the moral equivalent).
5993     #
5994     # That is indistinguishable in contents from a patches-unapplied
5995     # tree.  And looking at the history to distinguish them is not
5996     # useful because the user might have made a confusing-looking git
5997     # history structure (which ought to produce an error if dgit can't
5998     # cope, not a silent reintroduction of an unwanted patch).
5999     #
6000     # So gbp users will have to pass an option.  But we can usually
6001     # detect their failure to do so: if the tree is not a clean
6002     # patches-applied tree, quilt linearisation fails, but the tree
6003     # _is_ a clean patches-unapplied tree, we can suggest that maybe
6004     # they want --quilt=unapplied.
6005     #
6006     # To help detect this, when we are extracting the fake dsc, we
6007     # first extract it with --skip-patches, and then apply the patches
6008     # afterwards with dpkg-source --before-build.  That lets us save a
6009     # tree object corresponding to .origs.
6010
6011     my $splitbrain_cachekey;
6012
6013     quilt_make_fake_dsc($upstreamversion);
6014
6015     if (quiltmode_splitbrain()) {
6016         my $cachehit;
6017         ($cachehit, $splitbrain_cachekey) =
6018             quilt_check_splitbrain_cache($headref, $upstreamversion);
6019         return if $cachehit;
6020     }
6021     my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6022
6023     ensuredir '.pc';
6024
6025     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6026     $!=0; $?=-1;
6027     if (system @bbcmd) {
6028         failedcmd @bbcmd if $? < 0;
6029         fail __ <<END;
6030 failed to apply your git tree's patch stack (from debian/patches/) to
6031  the corresponding upstream tarball(s).  Your source tree and .orig
6032  are probably too inconsistent.  dgit can only fix up certain kinds of
6033  anomaly (depending on the quilt mode).  Please see --quilt= in dgit(1).
6034 END
6035     }
6036
6037     changedir '..';
6038
6039     unpack_playtree_mkwork($headref);
6040
6041     my $mustdeletepc=0;
6042     if (stat_exists ".pc") {
6043         -d _ or die;
6044         progress __ "Tree already contains .pc - will use it then delete it.";
6045         $mustdeletepc=1;
6046     } else {
6047         rename '../fake/.pc','.pc' or confess $!;
6048     }
6049
6050     changedir '../fake';
6051     rmtree '.pc';
6052     my $oldtiptree=git_add_write_tree();
6053     printdebug "fake o+d/p tree object $unapplied\n";
6054     changedir '../work';
6055
6056
6057     # We calculate some guesswork now about what kind of tree this might
6058     # be.  This is mostly for error reporting.
6059
6060     my %editedignores;
6061     my @unrepres;
6062     my $diffbits = {
6063         # H = user's HEAD
6064         # O = orig, without patches applied
6065         # A = "applied", ie orig with H's debian/patches applied
6066         O2H => quiltify_trees_differ($unapplied,$headref,   1,
6067                                      \%editedignores, \@unrepres),
6068         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
6069         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6070     };
6071
6072     my @dl;
6073     foreach my $b (qw(01 02)) {
6074         foreach my $v (qw(O2H O2A H2A)) {
6075             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
6076         }
6077     }
6078     printdebug "differences \@dl @dl.\n";
6079
6080     progress f_
6081 "%s: base trees orig=%.20s o+d/p=%.20s",
6082               $us, $unapplied, $oldtiptree;
6083     progress f_
6084 "%s: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
6085 "%s: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
6086   $us,                      $dl[0], $dl[1],              $dl[3], $dl[4],
6087   $us,                          $dl[2],                     $dl[5];
6088
6089     if (@unrepres) {
6090         print STDERR f_ "dgit:  cannot represent change: %s: %s\n",
6091                         $_->[1], $_->[0]
6092             foreach @unrepres;
6093         forceable_fail [qw(unrepresentable)], __ <<END;
6094 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6095 END
6096     }
6097
6098     my @failsuggestion;
6099     if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6100         push @failsuggestion, [ 'unapplied', __
6101  "This might be a patches-unapplied branch." ];
6102     } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6103         push @failsuggestion, [ 'applied', __
6104  "This might be a patches-applied branch." ];
6105     }
6106     push @failsuggestion, [ 'quilt-mode', __
6107  "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6108
6109     push @failsuggestion, [ 'gitattrs', __
6110  "Warning: Tree has .gitattributes.  See GITATTRIBUTES in dgit(7)." ]
6111         if stat_exists '.gitattributes';
6112
6113     push @failsuggestion, [ 'origs', __
6114  "Maybe orig tarball(s) are not identical to git representation?" ];
6115
6116     if (quiltmode_splitbrain()) {
6117         quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6118                             $diffbits, \%editedignores,
6119                             $splitbrain_cachekey);
6120         return;
6121     }
6122
6123     progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6124     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6125
6126     if (!open P, '>>', ".pc/applied-patches") {
6127         $!==&ENOENT or confess $!;
6128     } else {
6129         close P;
6130     }
6131
6132     commit_quilty_patch();
6133
6134     if ($mustdeletepc) {
6135         quilt_fixup_delete_pc();
6136     }
6137 }
6138
6139 sub quilt_fixup_editor () {
6140     my $descfn = $ENV{$fakeeditorenv};
6141     my $editing = $ARGV[$#ARGV];
6142     open I1, '<', $descfn or confess "$descfn: $!";
6143     open I2, '<', $editing or confess "$editing: $!";
6144     unlink $editing or confess "$editing: $!";
6145     open O, '>', $editing or confess "$editing: $!";
6146     while (<I1>) { print O or confess $!; } I1->error and confess $!;
6147     my $copying = 0;
6148     while (<I2>) {
6149         $copying ||= m/^\-\-\- /;
6150         next unless $copying;
6151         print O or confess $!;
6152     }
6153     I2->error and confess $!;
6154     close O or die $1;
6155     finish 0;
6156 }
6157
6158 sub maybe_apply_patches_dirtily () {
6159     return unless $quilt_mode =~ m/gbp|unapplied/;
6160     print STDERR __ <<END or confess $!;
6161
6162 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6163 dgit: Have to apply the patches - making the tree dirty.
6164 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6165
6166 END
6167     $patches_applied_dirtily = 01;
6168     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6169     runcmd qw(dpkg-source --before-build .);
6170 }
6171
6172 sub maybe_unapply_patches_again () {
6173     progress __ "dgit: Unapplying patches again to tidy up the tree."
6174         if $patches_applied_dirtily;
6175     runcmd qw(dpkg-source --after-build .)
6176         if $patches_applied_dirtily & 01;
6177     rmtree '.pc'
6178         if $patches_applied_dirtily & 02;
6179     $patches_applied_dirtily = 0;
6180 }
6181
6182 #----- other building -----
6183
6184 our $clean_using_builder;
6185 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6186 #   clean the tree before building (perhaps invoked indirectly by
6187 #   whatever we are using to run the build), rather than separately
6188 #   and explicitly by us.
6189
6190 sub clean_tree () {
6191     return if $clean_using_builder;
6192     if ($cleanmode eq 'dpkg-source') {
6193         maybe_apply_patches_dirtily();
6194         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6195     } elsif ($cleanmode eq 'dpkg-source-d') {
6196         maybe_apply_patches_dirtily();
6197         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6198     } elsif ($cleanmode eq 'git') {
6199         runcmd_ordryrun_local @git, qw(clean -xdf);
6200     } elsif ($cleanmode eq 'git-ff') {
6201         runcmd_ordryrun_local @git, qw(clean -xdff);
6202     } elsif ($cleanmode eq 'check') {
6203         my $leftovers = cmdoutput @git, qw(clean -xdn);
6204         if (length $leftovers) {
6205             print STDERR $leftovers, "\n" or confess $!;
6206             fail __
6207  "tree contains uncommitted files and --clean=check specified";
6208         }
6209     } elsif ($cleanmode eq 'none') {
6210     } else {
6211         die "$cleanmode ?";
6212     }
6213 }
6214
6215 sub cmd_clean () {
6216     badusage __ "clean takes no additional arguments" if @ARGV;
6217     notpushing();
6218     clean_tree();
6219     maybe_unapply_patches_again();
6220 }
6221
6222 # return values from massage_dbp_args are one or both of these flags
6223 sub WANTSRC_SOURCE  () { 01; } # caller should build source (separately)
6224 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6225
6226 sub build_or_push_prep_early () {
6227     our $build_or_push_prep_early_done //= 0;
6228     return if $build_or_push_prep_early_done++;
6229     badusage f_ "-p is not allowed with dgit %s", $subcommand
6230         if defined $package;
6231     my $clogp = parsechangelog();
6232     $isuite = getfield $clogp, 'Distribution';
6233     $package = getfield $clogp, 'Source';
6234     $version = getfield $clogp, 'Version';
6235     $dscfn = dscfn($version);
6236 }
6237
6238 sub build_prep_early () {
6239     build_or_push_prep_early();
6240     notpushing();
6241     check_not_dirty();
6242 }
6243
6244 sub build_prep ($) {
6245     my ($wantsrc) = @_;
6246     build_prep_early();
6247     # clean the tree if we're trying to include dirty changes in the
6248     # source package, or we are running the builder in $maindir
6249     clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
6250     build_maybe_quilt_fixup();
6251     if ($rmchanges) {
6252         my $pat = changespat $version;
6253         foreach my $f (glob "$buildproductsdir/$pat") {
6254             if (act_local()) {
6255                 unlink $f or
6256                     fail f_ "remove old changes file %s: %s", $f, $!;
6257             } else {
6258                 progress f_ "would remove %s", $f;
6259             }
6260         }
6261     }
6262 }
6263
6264 sub changesopts_initial () {
6265     my @opts =@changesopts[1..$#changesopts];
6266 }
6267
6268 sub changesopts_version () {
6269     if (!defined $changes_since_version) {
6270         my @vsns;
6271         unless (eval {
6272             @vsns = archive_query('archive_query');
6273             my @quirk = access_quirk();
6274             if ($quirk[0] eq 'backports') {
6275                 local $isuite = $quirk[2];
6276                 local $csuite;
6277                 canonicalise_suite();
6278                 push @vsns, archive_query('archive_query');
6279             }
6280             1;
6281         }) {
6282             print STDERR $@;
6283             fail __
6284  "archive query failed (queried because --since-version not specified)";
6285         }
6286         if (@vsns) {
6287             @vsns = map { $_->[0] } @vsns;
6288             @vsns = sort { -version_compare($a, $b) } @vsns;
6289             $changes_since_version = $vsns[0];
6290             progress f_ "changelog will contain changes since %s", $vsns[0];
6291         } else {
6292             $changes_since_version = '_';
6293             progress __ "package seems new, not specifying -v<version>";
6294         }
6295     }
6296     if ($changes_since_version ne '_') {
6297         return ("-v$changes_since_version");
6298     } else {
6299         return ();
6300     }
6301 }
6302
6303 sub changesopts () {
6304     return (changesopts_initial(), changesopts_version());
6305 }
6306
6307 sub massage_dbp_args ($;$) {
6308     my ($cmd,$xargs) = @_;
6309     # Since we split the source build out so we can do strange things
6310     # to it, massage the arguments to dpkg-buildpackage so that the
6311     # main build doessn't build source (or add an argument to stop it
6312     # building source by default).
6313     debugcmd '#massaging#', @$cmd if $debuglevel>1;
6314     # -nc has the side effect of specifying -b if nothing else specified
6315     # and some combinations of -S, -b, et al, are errors, rather than
6316     # later simply overriding earlie.  So we need to:
6317     #  - search the command line for these options
6318     #  - pick the last one
6319     #  - perhaps add our own as a default
6320     #  - perhaps adjust it to the corresponding non-source-building version
6321     my $dmode = '-F';
6322     foreach my $l ($cmd, $xargs) {
6323         next unless $l;
6324         @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6325     }
6326     push @$cmd, '-nc';
6327 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6328     my $r = WANTSRC_BUILDER;
6329     printdebug "massage split $dmode.\n";
6330     if ($dmode =~ s/^--build=//) {
6331         $r = 0;
6332         my @d = split /,/, $dmode;
6333         $r |= WANTSRC_SOURCE  if grep { s/^full$/binary/ } @d;
6334         $r |= WANTSRC_SOURCE  if grep { s/^source$// } @d;
6335         $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6336         fail __ "Wanted to build nothing!" unless $r;
6337         $dmode = '--build='. join ',', grep m/./, @d;
6338     } else {
6339         $r =
6340           $dmode =~ m/[S]/     ?  WANTSRC_SOURCE :
6341           $dmode =~ y/gGF/ABb/ ?  WANTSRC_SOURCE | WANTSRC_BUILDER :
6342           $dmode =~ m/[ABb]/   ?                   WANTSRC_BUILDER :
6343           confess "$dmode ?";
6344     }
6345     printdebug "massage done $r $dmode.\n";
6346     push @$cmd, $dmode;
6347 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6348     return $r;
6349 }
6350
6351 sub in_bpd (&) {
6352     my ($fn) = @_;
6353     my $wasdir = must_getcwd();
6354     changedir $buildproductsdir;
6355     $fn->();
6356     changedir $wasdir;
6357 }
6358
6359 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6360 sub postbuild_mergechanges ($) {
6361     my ($msg_if_onlyone) = @_;
6362     # If there is only one .changes file, fail with $msg_if_onlyone,
6363     # or if that is undef, be a no-op.
6364     # Returns the changes file to report to the user.
6365     my $pat = changespat $version;
6366     my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6367     @changesfiles = sort {
6368         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6369             or $a cmp $b
6370     } @changesfiles;
6371     my $result;
6372     if (@changesfiles==1) {
6373         fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6374 only one changes file from build (%s)
6375 END
6376             if defined $msg_if_onlyone;
6377         $result = $changesfiles[0];
6378     } elsif (@changesfiles==2) {
6379         my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6380         foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6381             fail f_ "%s found in binaries changes file %s", $l, $binchanges
6382                 if $l =~ m/\.dsc$/;
6383         }
6384         runcmd_ordryrun_local @mergechanges, @changesfiles;
6385         my $multichanges = changespat $version,'multi';
6386         if (act_local()) {
6387             stat_exists $multichanges or fail f_
6388                 "%s unexpectedly not created by build", $multichanges;
6389             foreach my $cf (glob $pat) {
6390                 next if $cf eq $multichanges;
6391                 rename "$cf", "$cf.inmulti" or fail f_
6392                     "install new changes %s\{,.inmulti}: %s", $cf, $!;
6393             }
6394         }
6395         $result = $multichanges;
6396     } else {
6397         fail f_ "wrong number of different changes files (%s)",
6398                 "@changesfiles";
6399     }
6400     printdone f_ "build successful, results in %s\n", $result
6401         or confess $!;
6402 }
6403
6404 sub midbuild_checkchanges () {
6405     my $pat = changespat $version;
6406     return if $rmchanges;
6407     my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6408     @unwanted = grep {
6409         $_ ne changespat $version,'source' and
6410         $_ ne changespat $version,'multi'
6411     } @unwanted;
6412     fail +(f_ <<END, $pat, "@unwanted")
6413 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6414 Suggest you delete %s.
6415 END
6416         if @unwanted;
6417 }
6418
6419 sub midbuild_checkchanges_vanilla ($) {
6420     my ($wantsrc) = @_;
6421     midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6422 }
6423
6424 sub postbuild_mergechanges_vanilla ($) {
6425     my ($wantsrc) = @_;
6426     if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6427         in_bpd {
6428             postbuild_mergechanges(undef);
6429         };
6430     } else {
6431         printdone __ "build successful\n";
6432     }
6433 }
6434
6435 sub cmd_build {
6436     build_prep_early();
6437     $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6438 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6439 %s: warning: build-products-dir will be ignored; files will go to ..
6440 END
6441     $buildproductsdir = '..';
6442     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6443     my $wantsrc = massage_dbp_args \@dbp;
6444     build_prep($wantsrc);
6445     if ($wantsrc & WANTSRC_SOURCE) {
6446         build_source();
6447         midbuild_checkchanges_vanilla $wantsrc;
6448     }
6449     if ($wantsrc & WANTSRC_BUILDER) {
6450         push @dbp, changesopts_version();
6451         maybe_apply_patches_dirtily();
6452         runcmd_ordryrun_local @dbp;
6453     }
6454     maybe_unapply_patches_again();
6455     postbuild_mergechanges_vanilla $wantsrc;
6456 }
6457
6458 sub pre_gbp_build {
6459     $quilt_mode //= 'gbp';
6460 }
6461
6462 sub cmd_gbp_build {
6463     build_prep_early();
6464
6465     # gbp can make .origs out of thin air.  In my tests it does this
6466     # even for a 1.0 format package, with no origs present.  So I
6467     # guess it keys off just the version number.  We don't know
6468     # exactly what .origs ought to exist, but let's assume that we
6469     # should run gbp if: the version has an upstream part and the main
6470     # orig is absent.
6471     my $upstreamversion = upstreamversion $version;
6472     my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6473     my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6474
6475     if ($gbp_make_orig) {
6476         clean_tree();
6477         $cleanmode = 'none'; # don't do it again
6478     }
6479
6480     my @dbp = @dpkgbuildpackage;
6481
6482     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6483
6484     if (!length $gbp_build[0]) {
6485         if (length executable_on_path('git-buildpackage')) {
6486             $gbp_build[0] = qw(git-buildpackage);
6487         } else {
6488             $gbp_build[0] = 'gbp buildpackage';
6489         }
6490     }
6491     my @cmd = opts_opt_multi_cmd [], @gbp_build;
6492
6493     push @cmd, (qw(-us -uc --git-no-sign-tags),
6494                 "--git-builder=".(shellquote @dbp));
6495
6496     if ($gbp_make_orig) {
6497         my $priv = dgit_privdir();
6498         my $ok = "$priv/origs-gen-ok";
6499         unlink $ok or $!==&ENOENT or confess $!;
6500         my @origs_cmd = @cmd;
6501         push @origs_cmd, qw(--git-cleaner=true);
6502         push @origs_cmd, "--git-prebuild=".
6503             "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6504         push @origs_cmd, @ARGV;
6505         if (act_local()) {
6506             debugcmd @origs_cmd;
6507             system @origs_cmd;
6508             do { local $!; stat_exists $ok; }
6509                 or failedcmd @origs_cmd;
6510         } else {
6511             dryrun_report @origs_cmd;
6512         }
6513     }
6514
6515     build_prep($wantsrc);
6516     if ($wantsrc & WANTSRC_SOURCE) {
6517         build_source();
6518         midbuild_checkchanges_vanilla $wantsrc;
6519     } else {
6520         if (!$clean_using_builder) {
6521             push @cmd, '--git-cleaner=true';
6522         }
6523     }
6524     maybe_unapply_patches_again();
6525     if ($wantsrc & WANTSRC_BUILDER) {
6526         push @cmd, changesopts();
6527         runcmd_ordryrun_local @cmd, @ARGV;
6528     }
6529     postbuild_mergechanges_vanilla $wantsrc;
6530 }
6531 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6532
6533 sub building_source_in_playtree {
6534     # If $includedirty, we have to build the source package from the
6535     # working tree, not a playtree, so that uncommitted changes are
6536     # included (copying or hardlinking them into the playtree could
6537     # cause trouble).
6538     #
6539     # Note that if we are building a source package in split brain
6540     # mode we do not support including uncommitted changes, because
6541     # that makes quilt fixup too hard.  I.e. ($split_brain && (dgit is
6542     # building a source package)) => !$includedirty
6543     return !$includedirty;
6544 }
6545
6546 sub build_source {
6547     $sourcechanges = changespat $version,'source';
6548     if (act_local()) {
6549         unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6550             or fail f_ "remove %s: %s", $sourcechanges, $!;
6551     }
6552     my @cmd = (@dpkgsource, qw(-b --));
6553     my $leafdir;
6554     if (building_source_in_playtree()) {
6555         $leafdir = 'work';
6556         my $headref = git_rev_parse('HEAD');
6557         # If we are in split brain, there is already a playtree with
6558         # the thing we should package into a .dsc (thanks to quilt
6559         # fixup).  If not, make a playtree
6560         prep_ud() unless $split_brain;
6561         changedir $playground;
6562         unless ($split_brain) {
6563             my $upstreamversion = upstreamversion $version;
6564             unpack_playtree_linkorigs($upstreamversion, sub { });
6565             unpack_playtree_mkwork($headref);
6566             changedir '..';
6567         }
6568     } else {
6569         $leafdir = basename $maindir;
6570
6571         if ($buildproductsdir ne '..') {
6572             # Well, we are going to run dpkg-source -b which consumes
6573             # origs from .. and generates output there.  To make this
6574             # work when the bpd is not .. , we would have to (i) link
6575             # origs from bpd to .. , (ii) check for files that
6576             # dpkg-source -b would/might overwrite, and afterwards
6577             # (iii) move all the outputs back to the bpd (iv) except
6578             # for the origs which should be deleted from .. if they
6579             # weren't there beforehand.  And if there is an error and
6580             # we don't run to completion we would necessarily leave a
6581             # mess.  This is too much.  The real way to fix this
6582             # is for dpkg-source to have bpd support.
6583             confess unless $includedirty;
6584             fail __
6585  "--include-dirty not supported with --build-products-dir, sorry";
6586         }
6587
6588         changedir '..';
6589     }
6590     runcmd_ordryrun_local @cmd, $leafdir;
6591
6592     changedir $leafdir;
6593     runcmd_ordryrun_local qw(sh -ec),
6594       'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6595       @dpkggenchanges, qw(-S), changesopts();
6596     changedir '..';
6597
6598     printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6599     $dsc = parsecontrol($dscfn, "source package");
6600
6601     my $mv = sub {
6602         my ($why, $l) = @_;
6603         printdebug " renaming ($why) $l\n";
6604         rename "$l", bpd_abs()."/$l"
6605             or fail f_ "put in place new built file (%s): %s", $l, $!;
6606     };
6607     foreach my $l (split /\n/, getfield $dsc, 'Files') {
6608         $l =~ m/\S+$/ or next;
6609         $mv->('Files', $&);
6610     }
6611     $mv->('dsc', $dscfn);
6612     $mv->('changes', $sourcechanges);
6613
6614     changedir $maindir;
6615 }
6616
6617 sub cmd_build_source {
6618     badusage __ "build-source takes no additional arguments" if @ARGV;
6619     build_prep(WANTSRC_SOURCE);
6620     build_source();
6621     maybe_unapply_patches_again();
6622     printdone f_ "source built, results in %s and %s",
6623                  $dscfn, $sourcechanges;
6624 }
6625
6626 sub cmd_push_source {
6627     prep_push();
6628     fail __
6629         "dgit push-source: --include-dirty/--ignore-dirty does not make".
6630         "sense with push-source!"
6631         if $includedirty;
6632     build_maybe_quilt_fixup();
6633     if ($changesfile) {
6634         my $changes = parsecontrol("$buildproductsdir/$changesfile",
6635                                    __ "source changes file");
6636         unless (test_source_only_changes($changes)) {
6637             fail __ "user-specified changes file is not source-only";
6638         }
6639     } else {
6640         # Building a source package is very fast, so just do it
6641         build_source();
6642         confess "er, patches are applied dirtily but shouldn't be.."
6643             if $patches_applied_dirtily;
6644         $changesfile = $sourcechanges;
6645     }
6646     dopush();
6647 }
6648
6649 sub binary_builder {
6650     my ($bbuilder, $pbmc_msg, @args) = @_;
6651     build_prep(WANTSRC_SOURCE);
6652     build_source();
6653     midbuild_checkchanges();
6654     in_bpd {
6655         if (act_local()) {
6656             stat_exists $dscfn or fail f_
6657                 "%s (in build products dir): %s", $dscfn, $!;
6658             stat_exists $sourcechanges or fail f_
6659                 "%s (in build products dir): %s", $sourcechanges, $!;
6660         }
6661         runcmd_ordryrun_local @$bbuilder, @args;
6662     };
6663     maybe_unapply_patches_again();
6664     in_bpd {
6665         postbuild_mergechanges($pbmc_msg);
6666     };
6667 }
6668
6669 sub cmd_sbuild {
6670     build_prep_early();
6671     binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6672 perhaps you need to pass -A ?  (sbuild's default is to build only
6673 arch-specific binaries; dgit 1.4 used to override that.)
6674 END
6675 }
6676
6677 sub pbuilder ($) {
6678     my ($pbuilder) = @_;
6679     build_prep_early();
6680     # @ARGV is allowed to contain only things that should be passed to
6681     # pbuilder under debbuildopts; just massage those
6682     my $wantsrc = massage_dbp_args \@ARGV;
6683     fail __
6684         "you asked for a builder but your debbuildopts didn't ask for".
6685         " any binaries -- is this really what you meant?"
6686         unless $wantsrc & WANTSRC_BUILDER;
6687     fail __
6688         "we must build a .dsc to pass to the builder but your debbuiltopts".
6689         " forbids the building of a source package; cannot continue"
6690       unless $wantsrc & WANTSRC_SOURCE;
6691     # We do not want to include the verb "build" in @pbuilder because
6692     # the user can customise @pbuilder and they shouldn't be required
6693     # to include "build" in their customised value.  However, if the
6694     # user passes any additional args to pbuilder using the dgit
6695     # option --pbuilder:foo, such args need to come after the "build"
6696     # verb.  opts_opt_multi_cmd does all of that.
6697     binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6698                    qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6699                    $dscfn);
6700 }
6701
6702 sub cmd_pbuilder {
6703     pbuilder(\@pbuilder);
6704 }
6705
6706 sub cmd_cowbuilder {
6707     pbuilder(\@cowbuilder);
6708 }
6709
6710 sub cmd_quilt_fixup {
6711     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6712     build_prep_early();
6713     clean_tree();
6714     build_maybe_quilt_fixup();
6715 }
6716
6717 sub cmd_print_unapplied_treeish {
6718     badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6719         if @ARGV;
6720     my $headref = git_rev_parse('HEAD');
6721     my $clogp = commit_getclogp $headref;
6722     $package = getfield $clogp, 'Source';
6723     $version = getfield $clogp, 'Version';
6724     $isuite = getfield $clogp, 'Distribution';
6725     $csuite = $isuite; # we want this to be offline!
6726     notpushing();
6727
6728     prep_ud();
6729     changedir $playground;
6730     my $uv = upstreamversion $version;
6731     quilt_make_fake_dsc($uv);
6732     my $u = quilt_fakedsc2unapplied($headref, $uv);
6733     print $u, "\n" or confess $!;
6734 }
6735
6736 sub import_dsc_result {
6737     my ($dstref, $newhash, $what_log, $what_msg) = @_;
6738     my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6739     runcmd @cmd;
6740     check_gitattrs($newhash, __ "source tree");
6741
6742     progress f_ "dgit: import-dsc: %s", $what_msg;
6743 }
6744
6745 sub cmd_import_dsc {
6746     my $needsig = 0;
6747
6748     while (@ARGV) {
6749         last unless $ARGV[0] =~ m/^-/;
6750         $_ = shift @ARGV;
6751         last if m/^--?$/;
6752         if (m/^--require-valid-signature$/) {
6753             $needsig = 1;
6754         } else {
6755             badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6756         }
6757     }
6758
6759     badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6760         unless @ARGV==2;
6761     my ($dscfn, $dstbranch) = @ARGV;
6762
6763     badusage __ "dry run makes no sense with import-dsc"
6764         unless act_local();
6765
6766     my $force = $dstbranch =~ s/^\+//   ? +1 :
6767                 $dstbranch =~ s/^\.\.// ? -1 :
6768                                            0;
6769     my $info = $force ? " $&" : '';
6770     $info = "$dscfn$info";
6771
6772     my $specbranch = $dstbranch;
6773     $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6774     $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6775
6776     my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6777     my $chead = cmdoutput_errok @symcmd;
6778     defined $chead or $?==256 or failedcmd @symcmd;
6779
6780     fail f_ "%s is checked out - will not update it", $dstbranch
6781         if defined $chead and $chead eq $dstbranch;
6782
6783     my $oldhash = git_get_ref $dstbranch;
6784
6785     open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6786     $dscdata = do { local $/ = undef; <D>; };
6787     D->error and fail f_ "read %s: %s", $dscfn, $!;
6788     close C;
6789
6790     # we don't normally need this so import it here
6791     use Dpkg::Source::Package;
6792     my $dp = new Dpkg::Source::Package filename => $dscfn,
6793         require_valid_signature => $needsig;
6794     {
6795         local $SIG{__WARN__} = sub {
6796             print STDERR $_[0];
6797             return unless $needsig;
6798             fail __ "import-dsc signature check failed";
6799         };
6800         if (!$dp->is_signed()) {
6801             warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6802         } else {
6803             my $r = $dp->check_signature();
6804             confess "->check_signature => $r" if $needsig && $r;
6805         }
6806     }
6807
6808     parse_dscdata();
6809
6810     $package = getfield $dsc, 'Source';
6811
6812     parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6813         unless forceing [qw(import-dsc-with-dgit-field)];
6814     parse_dsc_field_def_dsc_distro();
6815
6816     $isuite = 'DGIT-IMPORT-DSC';
6817     $idistro //= $dsc_distro;
6818
6819     notpushing();
6820
6821     if (defined $dsc_hash) {
6822         progress __
6823             "dgit: import-dsc of .dsc with Dgit field, using git hash";
6824         resolve_dsc_field_commit undef, undef;
6825     }
6826     if (defined $dsc_hash) {
6827         my @cmd = (qw(sh -ec),
6828                    "echo $dsc_hash | git cat-file --batch-check");
6829         my $objgot = cmdoutput @cmd;
6830         if ($objgot =~ m#^\w+ missing\b#) {
6831             fail f_ <<END, $dsc_hash
6832 .dsc contains Dgit field referring to object %s
6833 Your git tree does not have that object.  Try `git fetch' from a
6834 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
6835 END
6836         }
6837         if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6838             if ($force > 0) {
6839                 progress __ "Not fast forward, forced update.";
6840             } else {
6841                 fail f_ "Not fast forward to %s", $dsc_hash;
6842             }
6843         }
6844         import_dsc_result $dstbranch, $dsc_hash,
6845             "dgit import-dsc (Dgit): $info",
6846             f_ "updated git ref %s", $dstbranch;
6847         return 0;
6848     }
6849
6850     fail f_ <<END, $dstbranch, $specbranch, $specbranch
6851 Branch %s already exists
6852 Specify ..%s for a pseudo-merge, binding in existing history
6853 Specify  +%s to overwrite, discarding existing history
6854 END
6855         if $oldhash && !$force;
6856
6857     my @dfi = dsc_files_info();
6858     foreach my $fi (@dfi) {
6859         my $f = $fi->{Filename};
6860         my $here = "$buildproductsdir/$f";
6861         if (lstat $here) {
6862             next if stat $here;
6863             fail f_ "lstat %s works but stat gives %s !", $here, $!;
6864         }
6865         fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
6866         my $there = $dscfn;
6867         if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6868             $there = $';
6869         } elsif ($dscfn =~ m#^/#) {
6870             $there = $dscfn;
6871         } else {
6872             fail f_
6873                 "cannot import %s which seems to be inside working tree!",
6874                 $dscfn;
6875         }
6876         $there =~ s#/+[^/]+$## or fail f_
6877             "import %s requires .../%s, but it does not exist",
6878             $dscfn, $f;
6879         $there .= "/$f";
6880         my $test = $there =~ m{^/} ? $there : "../$there";
6881         stat $test or fail f_
6882             "import %s requires %s, but: %s", $dscfn, $test, $!;
6883         symlink $there, $here or fail f_
6884             "symlink %s to %s: %s", $there, $here, $!;
6885         progress f_ "made symlink %s -> %s", $here, $there;
6886 #       print STDERR Dumper($fi);
6887     }
6888     my @mergeinputs = generate_commits_from_dsc();
6889     die unless @mergeinputs == 1;
6890
6891     my $newhash = $mergeinputs[0]{Commit};
6892
6893     if ($oldhash) {
6894         if ($force > 0) {
6895             progress __
6896                 "Import, forced update - synthetic orphan git history.";
6897         } elsif ($force < 0) {
6898             progress __ "Import, merging.";
6899             my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6900             my $version = getfield $dsc, 'Version';
6901             my $clogp = commit_getclogp $newhash;
6902             my $authline = clogp_authline $clogp;
6903             $newhash = make_commit_text <<ENDU
6904 tree $tree
6905 parent $newhash
6906 parent $oldhash
6907 author $authline
6908 committer $authline
6909
6910 ENDU
6911                 .(f_ <<END, $package, $version, $dstbranch);
6912 Merge %s (%s) import into %s
6913 END
6914         } else {
6915             die; # caught earlier
6916         }
6917     }
6918
6919     import_dsc_result $dstbranch, $newhash,
6920         "dgit import-dsc: $info",
6921         f_ "results are in git ref %s", $dstbranch;
6922 }
6923
6924 sub pre_archive_api_query () {
6925     not_necessarily_a_tree();
6926 }
6927 sub cmd_archive_api_query {
6928     badusage __ "need only 1 subpath argument" unless @ARGV==1;
6929     my ($subpath) = @ARGV;
6930     local $isuite = 'DGIT-API-QUERY-CMD';
6931     my @cmd = archive_api_query_cmd($subpath);
6932     push @cmd, qw(-f);
6933     debugcmd ">",@cmd;
6934     exec @cmd or fail f_ "exec curl: %s\n", $!;
6935 }
6936
6937 sub repos_server_url () {
6938     $package = '_dgit-repos-server';
6939     local $access_forpush = 1;
6940     local $isuite = 'DGIT-REPOS-SERVER';
6941     my $url = access_giturl();
6942 }
6943
6944 sub pre_clone_dgit_repos_server () {
6945     not_necessarily_a_tree();
6946 }
6947 sub cmd_clone_dgit_repos_server {
6948     badusage __ "need destination argument" unless @ARGV==1;
6949     my ($destdir) = @ARGV;
6950     my $url = repos_server_url();
6951     my @cmd = (@git, qw(clone), $url, $destdir);
6952     debugcmd ">",@cmd;
6953     exec @cmd or fail f_ "exec git clone: %s\n", $!;
6954 }
6955
6956 sub pre_print_dgit_repos_server_source_url () {
6957     not_necessarily_a_tree();
6958 }
6959 sub cmd_print_dgit_repos_server_source_url {
6960     badusage __
6961         "no arguments allowed to dgit print-dgit-repos-server-source-url"
6962         if @ARGV;
6963     my $url = repos_server_url();
6964     print $url, "\n" or confess $!;
6965 }
6966
6967 sub pre_print_dpkg_source_ignores {
6968     not_necessarily_a_tree();
6969 }
6970 sub cmd_print_dpkg_source_ignores {
6971     badusage __
6972         "no arguments allowed to dgit print-dpkg-source-ignores"
6973         if @ARGV;
6974     print "@dpkg_source_ignores\n" or confess $!;
6975 }
6976
6977 sub cmd_setup_mergechangelogs {
6978     badusage __ "no arguments allowed to dgit setup-mergechangelogs"
6979         if @ARGV;
6980     local $isuite = 'DGIT-SETUP-TREE';
6981     setup_mergechangelogs(1);
6982 }
6983
6984 sub cmd_setup_useremail {
6985     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
6986     local $isuite = 'DGIT-SETUP-TREE';
6987     setup_useremail(1);
6988 }
6989
6990 sub cmd_setup_gitattributes {
6991     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
6992     local $isuite = 'DGIT-SETUP-TREE';
6993     setup_gitattrs(1);
6994 }
6995
6996 sub cmd_setup_new_tree {
6997     badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
6998     local $isuite = 'DGIT-SETUP-TREE';
6999     setup_new_tree();
7000 }
7001
7002 #---------- argument parsing and main program ----------
7003
7004 sub cmd_version {
7005     print "dgit version $our_version\n" or confess $!;
7006     finish 0;
7007 }
7008
7009 our (%valopts_long, %valopts_short);
7010 our (%funcopts_long);
7011 our @rvalopts;
7012 our (@modeopt_cfgs);
7013
7014 sub defvalopt ($$$$) {
7015     my ($long,$short,$val_re,$how) = @_;
7016     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7017     $valopts_long{$long} = $oi;
7018     $valopts_short{$short} = $oi;
7019     # $how subref should:
7020     #   do whatever assignemnt or thing it likes with $_[0]
7021     #   if the option should not be passed on to remote, @rvalopts=()
7022     # or $how can be a scalar ref, meaning simply assign the value
7023 }
7024
7025 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7026 defvalopt '--distro',        '-d', '.+',      \$idistro;
7027 defvalopt '',                '-k', '.+',      \$keyid;
7028 defvalopt '--existing-package','', '.*',      \$existing_package;
7029 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
7030 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
7031 defvalopt '--package',   '-p',   $package_re, \$package;
7032 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
7033
7034 defvalopt '', '-C', '.+', sub {
7035     ($changesfile) = (@_);
7036     if ($changesfile =~ s#^(.*)/##) {
7037         $buildproductsdir = $1;
7038     }
7039 };
7040
7041 defvalopt '--initiator-tempdir','','.*', sub {
7042     ($initiator_tempdir) = (@_);
7043     $initiator_tempdir =~ m#^/# or
7044         badusage __ "--initiator-tempdir must be used specify an".
7045                     " absolute, not relative, directory."
7046 };
7047
7048 sub defoptmodes ($@) {
7049     my ($varref, $cfgkey, $default, %optmap) = @_;
7050     my %permit;
7051     while (my ($opt,$val) = each %optmap) {
7052         $funcopts_long{$opt} = sub { $$varref = $val; };
7053         $permit{$val} = $val;
7054     }
7055     push @modeopt_cfgs, {
7056         Var => $varref,
7057         Key => $cfgkey,
7058         Default => $default,
7059         Vals => \%permit
7060     };
7061 }
7062
7063 defoptmodes \$dodep14tag, qw( dep14tag          want
7064                               --dep14tag        want
7065                               --no-dep14tag     no
7066                               --always-dep14tag always );
7067
7068 sub parseopts () {
7069     my $om;
7070
7071     if (defined $ENV{'DGIT_SSH'}) {
7072         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7073     } elsif (defined $ENV{'GIT_SSH'}) {
7074         @ssh = ($ENV{'GIT_SSH'});
7075     }
7076
7077     my $oi;
7078     my $val;
7079     my $valopt = sub {
7080         my ($what) = @_;
7081         @rvalopts = ($_);
7082         if (!defined $val) {
7083             badusage f_ "%s needs a value", $what unless @ARGV;
7084             $val = shift @ARGV;
7085             push @rvalopts, $val;
7086         }
7087         badusage f_ "bad value \`%s' for %s", $val, $what unless
7088             $val =~ m/^$oi->{Re}$(?!\n)/s;
7089         my $how = $oi->{How};
7090         if (ref($how) eq 'SCALAR') {
7091             $$how = $val;
7092         } else {
7093             $how->($val);
7094         }
7095         push @ropts, @rvalopts;
7096     };
7097
7098     while (@ARGV) {
7099         last unless $ARGV[0] =~ m/^-/;
7100         $_ = shift @ARGV;
7101         last if m/^--?$/;
7102         if (m/^--/) {
7103             if (m/^--dry-run$/) {
7104                 push @ropts, $_;
7105                 $dryrun_level=2;
7106             } elsif (m/^--damp-run$/) {
7107                 push @ropts, $_;
7108                 $dryrun_level=1;
7109             } elsif (m/^--no-sign$/) {
7110                 push @ropts, $_;
7111                 $sign=0;
7112             } elsif (m/^--help$/) {
7113                 cmd_help();
7114             } elsif (m/^--version$/) {
7115                 cmd_version();
7116             } elsif (m/^--new$/) {
7117                 push @ropts, $_;
7118                 $new_package=1;
7119             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7120                      ($om = $opts_opt_map{$1}) &&
7121                      length $om->[0]) {
7122                 push @ropts, $_;
7123                 $om->[0] = $2;
7124             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7125                      !$opts_opt_cmdonly{$1} &&
7126                      ($om = $opts_opt_map{$1})) {
7127                 push @ropts, $_;
7128                 push @$om, $2;
7129             } elsif (m/^--(gbp|dpm)$/s) {
7130                 push @ropts, "--quilt=$1";
7131                 $quilt_mode = $1;
7132             } elsif (m/^--(?:ignore|include)-dirty$/s) {
7133                 push @ropts, $_;
7134                 $includedirty = 1;
7135             } elsif (m/^--no-quilt-fixup$/s) {
7136                 push @ropts, $_;
7137                 $quilt_mode = 'nocheck';
7138             } elsif (m/^--no-rm-on-error$/s) {
7139                 push @ropts, $_;
7140                 $rmonerror = 0;
7141             } elsif (m/^--no-chase-dsc-distro$/s) {
7142                 push @ropts, $_;
7143                 $chase_dsc_distro = 0;
7144             } elsif (m/^--overwrite$/s) {
7145                 push @ropts, $_;
7146                 $overwrite_version = '';
7147             } elsif (m/^--overwrite=(.+)$/s) {
7148                 push @ropts, $_;
7149                 $overwrite_version = $1;
7150             } elsif (m/^--delayed=(\d+)$/s) {
7151                 push @ropts, $_;
7152                 push @dput, $_;
7153             } elsif (my ($k,$v) =
7154                      m/^--save-(dgit-view)=(.+)$/s ||
7155                      m/^--(dgit-view)-save=(.+)$/s
7156                      ) {
7157                 push @ropts, $_;
7158                 $v =~ s#^(?!refs/)#refs/heads/#;
7159                 $internal_object_save{$k} = $v;
7160             } elsif (m/^--(no-)?rm-old-changes$/s) {
7161                 push @ropts, $_;
7162                 $rmchanges = !$1;
7163             } elsif (m/^--deliberately-($deliberately_re)$/s) {
7164                 push @ropts, $_;
7165                 push @deliberatelies, $&;
7166             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7167                 push @ropts, $&;
7168                 $forceopts{$1} = 1;
7169                 $_='';
7170             } elsif (m/^--force-/) {
7171                 print STDERR
7172                     f_ "%s: warning: ignoring unknown force option %s\n",
7173                        $us, $_;
7174                 $_='';
7175             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7176                 # undocumented, for testing
7177                 push @ropts, $_;
7178                 $tagformat_want = [ $1, 'command line', 1 ];
7179                 # 1 menas overrides distro configuration
7180             } elsif (m/^--config-lookup-explode=(.+)$/s) {
7181                 # undocumented, for testing
7182                 push @ropts, $_;
7183                 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7184                 # ^ it's supposed to be an array ref
7185             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7186                 $val = $2 ? $' : undef; #';
7187                 $valopt->($oi->{Long});
7188             } elsif ($funcopts_long{$_}) {
7189                 push @ropts, $_;
7190                 $funcopts_long{$_}();
7191             } else {
7192                 badusage f_ "unknown long option \`%s'", $_;
7193             }
7194         } else {
7195             while (m/^-./s) {
7196                 if (s/^-n/-/) {
7197                     push @ropts, $&;
7198                     $dryrun_level=2;
7199                 } elsif (s/^-L/-/) {
7200                     push @ropts, $&;
7201                     $dryrun_level=1;
7202                 } elsif (s/^-h/-/) {
7203                     cmd_help();
7204                 } elsif (s/^-D/-/) {
7205                     push @ropts, $&;
7206                     $debuglevel++;
7207                     enabledebug();
7208                 } elsif (s/^-N/-/) {
7209                     push @ropts, $&;
7210                     $new_package=1;
7211                 } elsif (m/^-m/) {
7212                     push @ropts, $&;
7213                     push @changesopts, $_;
7214                     $_ = '';
7215                 } elsif (s/^-wn$//s) {
7216                     push @ropts, $&;
7217                     $cleanmode = 'none';
7218                 } elsif (s/^-wg$//s) {
7219                     push @ropts, $&;
7220                     $cleanmode = 'git';
7221                 } elsif (s/^-wgf$//s) {
7222                     push @ropts, $&;
7223                     $cleanmode = 'git-ff';
7224                 } elsif (s/^-wd$//s) {
7225                     push @ropts, $&;
7226                     $cleanmode = 'dpkg-source';
7227                 } elsif (s/^-wdd$//s) {
7228                     push @ropts, $&;
7229                     $cleanmode = 'dpkg-source-d';
7230                 } elsif (s/^-wc$//s) {
7231                     push @ropts, $&;
7232                     $cleanmode = 'check';
7233                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7234                     push @git, '-c', $&;
7235                     $gitcfgs{cmdline}{$1} = [ $2 ];
7236                 } elsif (s/^-c([^=]+)$//s) {
7237                     push @git, '-c', $&;
7238                     $gitcfgs{cmdline}{$1} = [ 'true' ];
7239                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7240                     $val = $'; #';
7241                     $val = undef unless length $val;
7242                     $valopt->($oi->{Short});
7243                     $_ = '';
7244                 } else {
7245                     badusage f_ "unknown short option \`%s'", $_;
7246                 }
7247             }
7248         }
7249     }
7250 }
7251
7252 sub check_env_sanity () {
7253     my $blocked = new POSIX::SigSet;
7254     sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess $!;
7255
7256     eval {
7257         foreach my $name (qw(PIPE CHLD)) {
7258             my $signame = "SIG$name";
7259             my $signum = eval "POSIX::$signame" // die;
7260             die f_ "%s is set to something other than SIG_DFL\n",
7261                 $signame
7262                 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7263             $blocked->ismember($signum) and
7264                 die f_ "%s is blocked\n", $signame;
7265         }
7266     };
7267     return unless $@;
7268     chomp $@;
7269     fail f_ <<END, $@;
7270 On entry to dgit, %s
7271 This is a bug produced by something in your execution environment.
7272 Giving up.
7273 END
7274 }
7275
7276
7277 sub parseopts_late_defaults () {
7278     $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7279         if defined $idistro;
7280     $isuite //= cfg('dgit.default.default-suite');
7281
7282     foreach my $k (keys %opts_opt_map) {
7283         my $om = $opts_opt_map{$k};
7284
7285         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7286         if (defined $v) {
7287             badcfg f_ "cannot set command for %s", $k
7288                 unless length $om->[0];
7289             $om->[0] = $v;
7290         }
7291
7292         foreach my $c (access_cfg_cfgs("opts-$k")) {
7293             my @vl =
7294                 map { $_ ? @$_ : () }
7295                 map { $gitcfgs{$_}{$c} }
7296                 reverse @gitcfgsources;
7297             printdebug "CL $c ", (join " ", map { shellquote } @vl),
7298                 "\n" if $debuglevel >= 4;
7299             next unless @vl;
7300             badcfg f_ "cannot configure options for %s", $k
7301                 if $opts_opt_cmdonly{$k};
7302             my $insertpos = $opts_cfg_insertpos{$k};
7303             @$om = ( @$om[0..$insertpos-1],
7304                      @vl,
7305                      @$om[$insertpos..$#$om] );
7306         }
7307     }
7308
7309     if (!defined $rmchanges) {
7310         local $access_forpush;
7311         $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7312     }
7313
7314     if (!defined $quilt_mode) {
7315         local $access_forpush;
7316         $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7317             // access_cfg('quilt-mode', 'RETURN-UNDEF')
7318             // 'linear';
7319         $quilt_mode =~ m/^($quilt_modes_re)$/
7320             or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7321         $quilt_mode = $1;
7322     }
7323
7324     foreach my $moc (@modeopt_cfgs) {
7325         local $access_forpush;
7326         my $vr = $moc->{Var};
7327         next if defined $$vr;
7328         $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7329         my $v = $moc->{Vals}{$$vr};
7330         badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7331             unless defined $v;
7332         $$vr = $v;
7333     }
7334
7335     fail __ "dgit: --include-dirty is not supported in split view quilt mode"
7336         if $split_brain && $includedirty;
7337
7338     if (!defined $cleanmode) {
7339         local $access_forpush;
7340         $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7341         $cleanmode //= 'dpkg-source';
7342
7343         badcfg f_ "unknown clean-mode \`%s'", $cleanmode unless
7344             $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7345     }
7346
7347     $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7348     $buildproductsdir //= '..';
7349     $bpd_glob = $buildproductsdir;
7350     $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7351 }
7352
7353 setlocale(LC_MESSAGES, "");
7354 textdomain("dgit");
7355
7356 if ($ENV{$fakeeditorenv}) {
7357     git_slurp_config();
7358     quilt_fixup_editor();
7359 }
7360
7361 parseopts();
7362 check_env_sanity();
7363
7364 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7365 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7366     if $dryrun_level == 1;
7367 if (!@ARGV) {
7368     print STDERR __ $helpmsg or confess $!;
7369     finish 8;
7370 }
7371 $cmd = $subcommand = shift @ARGV;
7372 $cmd =~ y/-/_/;
7373
7374 my $pre_fn = ${*::}{"pre_$cmd"};
7375 $pre_fn->() if $pre_fn;
7376
7377 record_maindir if $invoked_in_git_tree;
7378 git_slurp_config();
7379
7380 my $fn = ${*::}{"cmd_$cmd"};
7381 $fn or badusage f_ "unknown operation %s", $cmd;
7382 $fn->();
7383
7384 finish 0;