dgit

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