dgit

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