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 && $protovsn < 4;
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         runcmd @git, qw(checkout -q -b dgit-view);
5380         $split_brain = 1;
5381     }
5382 }
5383
5384 sub quiltify_splitbrain ($$$$$$$) {
5385     my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5386         $editedignores, $cachekey) = @_;
5387     my $gitignore_special = 1;
5388     if ($quilt_mode !~ m/gbp|dpm/) {
5389         # treat .gitignore just like any other upstream file
5390         $diffbits = { %$diffbits };
5391         $_ = !!$_ foreach values %$diffbits;
5392         $gitignore_special = 0;
5393     }
5394     # We would like any commits we generate to be reproducible
5395     my @authline = clogp_authline($clogp);
5396     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
5397     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5398     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
5399     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
5400     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5401     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
5402
5403     quiltify_splitbrain_needed();
5404
5405     my $fulldiffhint = sub {
5406         my ($x,$y) = @_;
5407         my $cmd = "git diff $x $y -- :/ ':!debian'";
5408         $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5409         return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5410                   $cmd;
5411     };
5412
5413     if ($quilt_mode =~ m/gbp|unapplied/ &&
5414         ($diffbits->{O2H} & 01)) {
5415         my $msg = f_
5416  "--quilt=%s specified, implying patches-unapplied git tree\n".
5417  " but git tree differs from orig in upstream files.",
5418                      $quilt_mode;
5419         $msg .= $fulldiffhint->($unapplied, 'HEAD');
5420         if (!stat_exists "debian/patches") {
5421             $msg .= __
5422  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5423         }
5424         fail $msg;
5425     }
5426     if ($quilt_mode =~ m/dpm/ &&
5427         ($diffbits->{H2A} & 01)) {
5428         fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5429 --quilt=%s specified, implying patches-applied git tree
5430  but git tree differs from result of applying debian/patches to upstream
5431 END
5432     }
5433     if ($quilt_mode =~ m/gbp|unapplied/ &&
5434         ($diffbits->{O2A} & 01)) { # some patches
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         progress __
5452             "dgit view: creating patch to represent .gitignore changes";
5453         ensuredir "debian/patches";
5454         my $gipatch = "debian/patches/auto-gitignore";
5455         open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5456         stat GIPATCH or confess "$gipatch: $!";
5457         fail f_ "%s already exists; but want to create it".
5458                 " to record .gitignore changes",
5459                 $gipatch
5460             if (stat _)[7];
5461         print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5462 Subject: Update .gitignore from Debian packaging branch
5463
5464 The Debian packaging git branch contains these updates to the upstream
5465 .gitignore file(s).  This patch is autogenerated, to provide these
5466 updates to users of the official Debian archive view of the package.
5467 END
5468
5469 [dgit ($our_version) update-gitignore]
5470 ---
5471 ENDU
5472         close GIPATCH or die "$gipatch: $!";
5473         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5474             $unapplied, $headref, "--", sort keys %$editedignores;
5475         open SERIES, "+>>", "debian/patches/series" or confess "$!";
5476         defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5477         my $newline;
5478         defined read SERIES, $newline, 1 or confess "$!";
5479         print SERIES "\n" or confess "$!" unless $newline eq "\n";
5480         print SERIES "auto-gitignore\n" or confess "$!";
5481         close SERIES or die  $!;
5482         runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5483         commit_admin +(__ <<END).<<ENDU
5484 Commit patch to update .gitignore
5485 END
5486
5487 [dgit ($our_version) update-gitignore-quilt-fixup]
5488 ENDU
5489     }
5490
5491     my $dgitview = git_rev_parse 'HEAD';
5492
5493     changedir $maindir;
5494     reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5495
5496     changedir "$playground/work";
5497
5498     my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5499     progress f_ "dgit view: created (%s)", $saved;
5500 }
5501
5502 sub quiltify ($$$$) {
5503     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5504
5505     # Quilt patchification algorithm
5506     #
5507     # We search backwards through the history of the main tree's HEAD
5508     # (T) looking for a start commit S whose tree object is identical
5509     # to to the patch tip tree (ie the tree corresponding to the
5510     # current dpkg-committed patch series).  For these purposes
5511     # `identical' disregards anything in debian/ - this wrinkle is
5512     # necessary because dpkg-source treates debian/ specially.
5513     #
5514     # We can only traverse edges where at most one of the ancestors'
5515     # trees differs (in changes outside in debian/).  And we cannot
5516     # handle edges which change .pc/ or debian/patches.  To avoid
5517     # going down a rathole we avoid traversing edges which introduce
5518     # debian/rules or debian/control.  And we set a limit on the
5519     # number of edges we are willing to look at.
5520     #
5521     # If we succeed, we walk forwards again.  For each traversed edge
5522     # PC (with P parent, C child) (starting with P=S and ending with
5523     # C=T) to we do this:
5524     #  - git checkout C
5525     #  - dpkg-source --commit with a patch name and message derived from C
5526     # After traversing PT, we git commit the changes which
5527     # should be contained within debian/patches.
5528
5529     # The search for the path S..T is breadth-first.  We maintain a
5530     # todo list containing search nodes.  A search node identifies a
5531     # commit, and looks something like this:
5532     #  $p = {
5533     #      Commit => $git_commit_id,
5534     #      Child => $c,                          # or undef if P=T
5535     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
5536     #      Nontrivial => true iff $p..$c has relevant changes
5537     #  };
5538
5539     my @todo;
5540     my @nots;
5541     my $sref_S;
5542     my $max_work=100;
5543     my %considered; # saves being exponential on some weird graphs
5544
5545     my $t_sentinels = quiltify_tree_sentinelfiles $target;
5546
5547     my $not = sub {
5548         my ($search,$whynot) = @_;
5549         printdebug " search NOT $search->{Commit} $whynot\n";
5550         $search->{Whynot} = $whynot;
5551         push @nots, $search;
5552         no warnings qw(exiting);
5553         next;
5554     };
5555
5556     push @todo, {
5557         Commit => $target,
5558     };
5559
5560     while (@todo) {
5561         my $c = shift @todo;
5562         next if $considered{$c->{Commit}}++;
5563
5564         $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5565
5566         printdebug "quiltify investigate $c->{Commit}\n";
5567
5568         # are we done?
5569         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5570             printdebug " search finished hooray!\n";
5571             $sref_S = $c;
5572             last;
5573         }
5574
5575         quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5576         if ($quilt_mode eq 'smash') {
5577             printdebug " search quitting smash\n";
5578             last;
5579         }
5580
5581         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5582         $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5583             if $c_sentinels ne $t_sentinels;
5584
5585         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5586         $commitdata =~ m/\n\n/;
5587         $commitdata =~ $`;
5588         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5589         @parents = map { { Commit => $_, Child => $c } } @parents;
5590
5591         $not->($c, __ "root commit") if !@parents;
5592
5593         foreach my $p (@parents) {
5594             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5595         }
5596         my $ndiffers = grep { $_->{Nontrivial} } @parents;
5597         $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5598             if $ndiffers > 1;
5599
5600         foreach my $p (@parents) {
5601             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5602
5603             my @cmd= (@git, qw(diff-tree -r --name-only),
5604                       $p->{Commit},$c->{Commit},
5605                       qw(-- debian/patches .pc debian/source/format));
5606             my $patchstackchange = cmdoutput @cmd;
5607             if (length $patchstackchange) {
5608                 $patchstackchange =~ s/\n/,/g;
5609                 $not->($p, f_ "changed %s", $patchstackchange);
5610             }
5611
5612             printdebug " search queue P=$p->{Commit} ",
5613                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5614             push @todo, $p;
5615         }
5616     }
5617
5618     if (!$sref_S) {
5619         printdebug "quiltify want to smash\n";
5620
5621         my $abbrev = sub {
5622             my $x = $_[0]{Commit};
5623             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5624             return $x;
5625         };
5626         if ($quilt_mode eq 'linear') {
5627             print STDERR f_
5628                 "\n%s: error: quilt fixup cannot be linear.  Stopped at:\n",
5629                 $us;
5630             my $all_gdr = !!@nots;
5631             foreach my $notp (@nots) {
5632                 my $c = $notp->{Child};
5633                 my $cprange = $abbrev->($notp);
5634                 $cprange .= "..".$abbrev->($c) if $c;
5635                 print STDERR f_ "%s:  %s: %s\n",
5636                     $us, $cprange, $notp->{Whynot};
5637                 $all_gdr &&= $notp->{Child} &&
5638                     (git_cat_file $notp->{Child}{Commit}, 'commit')
5639                     =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5640             }
5641             print STDERR "\n";
5642             $failsuggestion =
5643                 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5644                 if $all_gdr;
5645             print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5646             fail __
5647  "quilt history linearisation failed.  Search \`quilt fixup' in dgit(7).\n";
5648         } elsif ($quilt_mode eq 'smash') {
5649         } elsif ($quilt_mode eq 'auto') {
5650             progress __ "quilt fixup cannot be linear, smashing...";
5651         } else {
5652             confess "$quilt_mode ?";
5653         }
5654
5655         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5656         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5657         my $ncommits = 3;
5658         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5659
5660         quiltify_dpkg_commit "auto-$version-$target-$time",
5661             (getfield $clogp, 'Maintainer'),
5662             (f_ "Automatically generated patch (%s)\n".
5663              "Last (up to) %s git changes, FYI:\n\n",
5664              $clogp->{Version}, $ncommits).
5665              $msg;
5666         return;
5667     }
5668
5669     progress __ "quiltify linearisation planning successful, executing...";
5670
5671     for (my $p = $sref_S;
5672          my $c = $p->{Child};
5673          $p = $p->{Child}) {
5674         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5675         next unless $p->{Nontrivial};
5676
5677         my $cc = $c->{Commit};
5678
5679         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5680         $commitdata =~ m/\n\n/ or die "$c ?";
5681         $commitdata = $`;
5682         my $msg = $'; #';
5683         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5684         my $author = $1;
5685
5686         my $commitdate = cmdoutput
5687             @git, qw(log -n1 --pretty=format:%aD), $cc;
5688
5689         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5690
5691         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5692         $strip_nls->();
5693
5694         my $title = $1;
5695         my $patchname;
5696         my $patchdir;
5697
5698         my $gbp_check_suitable = sub {
5699             $_ = shift;
5700             my ($what) = @_;
5701
5702             eval {
5703                 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5704                 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5705                 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5706                 die __ "is series file\n" if m{$series_filename_re}o;
5707                 die __ "too long\n" if length > 200;
5708             };
5709             return $_ unless $@;
5710             print STDERR f_
5711                 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5712                 $cc, $what, $@;
5713             return undef;
5714         };
5715
5716         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5717                            gbp-pq-name: \s* )
5718                        (\S+) \s* \n //ixm) {
5719             $patchname = $gbp_check_suitable->($1, 'Name');
5720         }
5721         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5722                            gbp-pq-topic: \s* )
5723                        (\S+) \s* \n //ixm) {
5724             $patchdir = $gbp_check_suitable->($1, 'Topic');
5725         }
5726
5727         $strip_nls->();
5728
5729         if (!defined $patchname) {
5730             $patchname = $title;
5731             $patchname =~ s/[.:]$//;
5732             use Text::Iconv;
5733             eval {
5734                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5735                 my $translitname = $converter->convert($patchname);
5736                 die unless defined $translitname;
5737                 $patchname = $translitname;
5738             };
5739             print STDERR
5740                 +(f_ "dgit: patch title transliteration error: %s", $@)
5741                 if $@;
5742             $patchname =~ y/ A-Z/-a-z/;
5743             $patchname =~ y/-a-z0-9_.+=~//cd;
5744             $patchname =~ s/^\W/x-$&/;
5745             $patchname = substr($patchname,0,40);
5746             $patchname .= ".patch";
5747         }
5748         if (!defined $patchdir) {
5749             $patchdir = '';
5750         }
5751         if (length $patchdir) {
5752             $patchname = "$patchdir/$patchname";
5753         }
5754         if ($patchname =~ m{^(.*)/}) {
5755             mkpath "debian/patches/$1";
5756         }
5757
5758         my $index;
5759         for ($index='';
5760              stat "debian/patches/$patchname$index";
5761              $index++) { }
5762         $!==ENOENT or confess "$patchname$index $!";
5763
5764         runcmd @git, qw(checkout -q), $cc;
5765
5766         # We use the tip's changelog so that dpkg-source doesn't
5767         # produce complaining messages from dpkg-parsechangelog.  None
5768         # of the information dpkg-source gets from the changelog is
5769         # actually relevant - it gets put into the original message
5770         # which dpkg-source provides our stunt editor, and then
5771         # overwritten.
5772         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5773
5774         quiltify_dpkg_commit "$patchname$index", $author, $msg,
5775             "Date: $commitdate\n".
5776             "X-Dgit-Generated: $clogp->{Version} $cc\n";
5777
5778         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5779     }
5780
5781     runcmd @git, qw(checkout -q master);
5782 }
5783
5784 sub build_maybe_quilt_fixup () {
5785     my ($format,$fopts) = get_source_format;
5786     return unless madformat_wantfixup $format;
5787     # sigh
5788
5789     check_for_vendor_patches();
5790
5791     if (quiltmode_splitbrain) {
5792         fail <<END unless access_cfg_tagformats_can_splitbrain;
5793 quilt mode $quilt_mode requires split view so server needs to support
5794  both "new" and "maint" tag formats, but config says it doesn't.
5795 END
5796     }
5797
5798     my $clogp = parsechangelog();
5799     my $headref = git_rev_parse('HEAD');
5800     my $symref = git_get_symref();
5801
5802     if ($quilt_mode eq 'linear'
5803         && !$fopts->{'single-debian-patch'}
5804         && branch_is_gdr($headref)) {
5805         # This is much faster.  It also makes patches that gdr
5806         # likes better for future updates without laundering.
5807         #
5808         # However, it can fail in some casses where we would
5809         # succeed: if there are existing patches, which correspond
5810         # to a prefix of the branch, but are not in gbp/gdr
5811         # format, gdr will fail (exiting status 7), but we might
5812         # be able to figure out where to start linearising.  That
5813         # will be slower so hopefully there's not much to do.
5814         my @cmd = (@git_debrebase,
5815                    qw(--noop-ok -funclean-mixed -funclean-ordering
5816                       make-patches --quiet-would-amend));
5817         # We tolerate soe snags that gdr wouldn't, by default.
5818         if (act_local()) {
5819             debugcmd "+",@cmd;
5820             $!=0; $?=-1;
5821             failedcmd @cmd
5822                 if system @cmd
5823                 and not ($? == 7*256 or
5824                          $? == -1 && $!==ENOENT);
5825         } else {
5826             dryrun_report @cmd;
5827         }
5828         $headref = git_rev_parse('HEAD');
5829     }
5830
5831     prep_ud();
5832     changedir $playground;
5833
5834     my $upstreamversion = upstreamversion $version;
5835
5836     if ($fopts->{'single-debian-patch'}) {
5837         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5838     } else {
5839         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5840     }
5841
5842     changedir $maindir;
5843     runcmd_ordryrun_local
5844         @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5845 }
5846
5847 sub unpack_playtree_mkwork ($) {
5848     my ($headref) = @_;
5849
5850     mkdir "work" or confess "$!";
5851     changedir "work";
5852     mktree_in_ud_here();
5853     runcmd @git, qw(reset -q --hard), $headref;
5854 }
5855
5856 sub unpack_playtree_linkorigs ($$) {
5857     my ($upstreamversion, $fn) = @_;
5858     # calls $fn->($leafname);
5859
5860     my $bpd_abs = bpd_abs();
5861
5862     dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5863
5864     opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5865     while ($!=0, defined(my $leaf = readdir QFD)) {
5866         my $f = bpd_abs()."/".$leaf;
5867         {
5868             local ($debuglevel) = $debuglevel-1;
5869             printdebug "QF linkorigs bpd $leaf, $f ?\n";
5870         }
5871         next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5872         printdebug "QF linkorigs $leaf, $f Y\n";
5873         link_ltarget $f, $leaf or die "$leaf $!";
5874         $fn->($leaf);
5875     }
5876     die "$buildproductsdir: $!" if $!;
5877     closedir QFD;
5878 }
5879
5880 sub quilt_fixup_delete_pc () {
5881     runcmd @git, qw(rm -rqf .pc);
5882     commit_admin +(__ <<END).<<ENDU
5883 Commit removal of .pc (quilt series tracking data)
5884 END
5885
5886 [dgit ($our_version) upgrade quilt-remove-pc]
5887 ENDU
5888 }
5889
5890 sub quilt_fixup_singlepatch ($$$) {
5891     my ($clogp, $headref, $upstreamversion) = @_;
5892
5893     progress __ "starting quiltify (single-debian-patch)";
5894
5895     # dpkg-source --commit generates new patches even if
5896     # single-debian-patch is in debian/source/options.  In order to
5897     # get it to generate debian/patches/debian-changes, it is
5898     # necessary to build the source package.
5899
5900     unpack_playtree_linkorigs($upstreamversion, sub { });
5901     unpack_playtree_mkwork($headref);
5902
5903     rmtree("debian/patches");
5904
5905     runcmd @dpkgsource, qw(-b .);
5906     changedir "..";
5907     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5908     rename srcfn("$upstreamversion", "/debian/patches"),
5909         "work/debian/patches"
5910         or $!==ENOENT
5911         or confess "install d/patches: $!";
5912
5913     changedir "work";
5914     commit_quilty_patch();
5915 }
5916
5917 sub quilt_make_fake_dsc ($) {
5918     my ($upstreamversion) = @_;
5919
5920     my $fakeversion="$upstreamversion-~~DGITFAKE";
5921
5922     my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5923     print $fakedsc <<END or confess "$!";
5924 Format: 3.0 (quilt)
5925 Source: $package
5926 Version: $fakeversion
5927 Files:
5928 END
5929
5930     my $dscaddfile=sub {
5931         my ($leaf) = @_;
5932
5933         my $md = new Digest::MD5;
5934
5935         my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5936         stat $fh or confess "$!";
5937         my $size = -s _;
5938
5939         $md->addfile($fh);
5940         print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5941     };
5942
5943     unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5944
5945     my @files=qw(debian/source/format debian/rules
5946                  debian/control debian/changelog);
5947     foreach my $maybe (qw(debian/patches debian/source/options
5948                           debian/tests/control)) {
5949         next unless stat_exists "$maindir/$maybe";
5950         push @files, $maybe;
5951     }
5952
5953     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5954     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5955
5956     $dscaddfile->($debtar);
5957     close $fakedsc or confess "$!";
5958 }
5959
5960 sub quilt_fakedsc2unapplied ($$) {
5961     my ($headref, $upstreamversion) = @_;
5962     # must be run in the playground
5963     # quilt_make_fake_dsc must have been called
5964
5965     runcmd qw(sh -ec),
5966         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5967
5968     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5969     rename $fakexdir, "fake" or die "$fakexdir $!";
5970
5971     changedir 'fake';
5972
5973     remove_stray_gits(__ "source package");
5974     mktree_in_ud_here();
5975
5976     rmtree '.pc';
5977
5978     rmtree 'debian'; # git checkout commitish paths does not delete!
5979     runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5980     my $unapplied=git_add_write_tree();
5981     printdebug "fake orig tree object $unapplied\n";
5982     return $unapplied;
5983 }
5984
5985 sub quilt_check_splitbrain_cache ($$) {
5986     my ($headref, $upstreamversion) = @_;
5987     # Called only if we are in (potentially) split brain mode.
5988     # Called in playground.
5989     # Computes the cache key and looks in the cache.
5990     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5991
5992     my $splitbrain_cachekey;
5993
5994     progress f_
5995  "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5996                 $quilt_mode;
5997     # we look in the reflog of dgit-intern/quilt-cache
5998     # we look for an entry whose message is the key for the cache lookup
5999     my @cachekey = (qw(dgit), $our_version);
6000     push @cachekey, $upstreamversion;
6001     push @cachekey, $quilt_mode;
6002     push @cachekey, $headref;
6003
6004     push @cachekey, hashfile('fake.dsc');
6005
6006     my $srcshash = Digest::SHA->new(256);
6007     my %sfs = ( %INC, '$0(dgit)' => $0 );
6008     foreach my $sfk (sort keys %sfs) {
6009         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6010         $srcshash->add($sfk,"  ");
6011         $srcshash->add(hashfile($sfs{$sfk}));
6012         $srcshash->add("\n");
6013     }
6014     push @cachekey, $srcshash->hexdigest();
6015     $splitbrain_cachekey = "@cachekey";
6016
6017     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6018
6019     my $cachehit = reflog_cache_lookup
6020         "refs/$splitbraincache", $splitbrain_cachekey;
6021
6022     if ($cachehit) {
6023         unpack_playtree_mkwork($headref);
6024         my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6025         if ($cachehit ne $headref) {
6026             progress f_ "dgit view: found cached (%s)", $saved;
6027             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6028             $split_brain = 1;
6029             return ($cachehit, $splitbrain_cachekey);
6030         }
6031         progress __ "dgit view: found cached, no changes required";
6032         return ($headref, $splitbrain_cachekey);
6033     }
6034
6035     printdebug "splitbrain cache miss\n";
6036     return (undef, $splitbrain_cachekey);
6037 }
6038
6039 sub quilt_fixup_multipatch ($$$) {
6040     my ($clogp, $headref, $upstreamversion) = @_;
6041
6042     progress f_ "examining quilt state (multiple patches, %s mode)",
6043                 $quilt_mode;
6044
6045     # Our objective is:
6046     #  - honour any existing .pc in case it has any strangeness
6047     #  - determine the git commit corresponding to the tip of
6048     #    the patch stack (if there is one)
6049     #  - if there is such a git commit, convert each subsequent
6050     #    git commit into a quilt patch with dpkg-source --commit
6051     #  - otherwise convert all the differences in the tree into
6052     #    a single git commit
6053     #
6054     # To do this we:
6055
6056     # Our git tree doesn't necessarily contain .pc.  (Some versions of
6057     # dgit would include the .pc in the git tree.)  If there isn't
6058     # one, we need to generate one by unpacking the patches that we
6059     # have.
6060     #
6061     # We first look for a .pc in the git tree.  If there is one, we
6062     # will use it.  (This is not the normal case.)
6063     #
6064     # Otherwise need to regenerate .pc so that dpkg-source --commit
6065     # can work.  We do this as follows:
6066     #     1. Collect all relevant .orig from parent directory
6067     #     2. Generate a debian.tar.gz out of
6068     #         debian/{patches,rules,source/format,source/options}
6069     #     3. Generate a fake .dsc containing just these fields:
6070     #          Format Source Version Files
6071     #     4. Extract the fake .dsc
6072     #        Now the fake .dsc has a .pc directory.
6073     # (In fact we do this in every case, because in future we will
6074     # want to search for a good base commit for generating patches.)
6075     #
6076     # Then we can actually do the dpkg-source --commit
6077     #     1. Make a new working tree with the same object
6078     #        store as our main tree and check out the main
6079     #        tree's HEAD.
6080     #     2. Copy .pc from the fake's extraction, if necessary
6081     #     3. Run dpkg-source --commit
6082     #     4. If the result has changes to debian/, then
6083     #          - git add them them
6084     #          - git add .pc if we had a .pc in-tree
6085     #          - git commit
6086     #     5. If we had a .pc in-tree, delete it, and git commit
6087     #     6. Back in the main tree, fast forward to the new HEAD
6088
6089     # Another situation we may have to cope with is gbp-style
6090     # patches-unapplied trees.
6091     #
6092     # We would want to detect these, so we know to escape into
6093     # quilt_fixup_gbp.  However, this is in general not possible.
6094     # Consider a package with a one patch which the dgit user reverts
6095     # (with git revert or the moral equivalent).
6096     #
6097     # That is indistinguishable in contents from a patches-unapplied
6098     # tree.  And looking at the history to distinguish them is not
6099     # useful because the user might have made a confusing-looking git
6100     # history structure (which ought to produce an error if dgit can't
6101     # cope, not a silent reintroduction of an unwanted patch).
6102     #
6103     # So gbp users will have to pass an option.  But we can usually
6104     # detect their failure to do so: if the tree is not a clean
6105     # patches-applied tree, quilt linearisation fails, but the tree
6106     # _is_ a clean patches-unapplied tree, we can suggest that maybe
6107     # they want --quilt=unapplied.
6108     #
6109     # To help detect this, when we are extracting the fake dsc, we
6110     # first extract it with --skip-patches, and then apply the patches
6111     # afterwards with dpkg-source --before-build.  That lets us save a
6112     # tree object corresponding to .origs.
6113
6114     my $splitbrain_cachekey;
6115
6116     quilt_make_fake_dsc($upstreamversion);
6117
6118     if (quiltmode_splitbrain()) {
6119         my $cachehit;
6120         ($cachehit, $splitbrain_cachekey) =
6121             quilt_check_splitbrain_cache($headref, $upstreamversion);
6122         return if $cachehit;
6123     }
6124     my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6125
6126     ensuredir '.pc';
6127
6128     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6129     $!=0; $?=-1;
6130     if (system @bbcmd) {
6131         failedcmd @bbcmd if $? < 0;
6132         fail __ <<END;
6133 failed to apply your git tree's patch stack (from debian/patches/) to
6134  the corresponding upstream tarball(s).  Your source tree and .orig
6135  are probably too inconsistent.  dgit can only fix up certain kinds of
6136  anomaly (depending on the quilt mode).  Please see --quilt= in dgit(1).
6137 END
6138     }
6139
6140     changedir '..';
6141
6142     unpack_playtree_mkwork($headref);
6143
6144     my $mustdeletepc=0;
6145     if (stat_exists ".pc") {
6146         -d _ or die;
6147         progress __ "Tree already contains .pc - will use it then delete it.";
6148         $mustdeletepc=1;
6149     } else {
6150         rename '../fake/.pc','.pc' or confess "$!";
6151     }
6152
6153     changedir '../fake';
6154     rmtree '.pc';
6155     my $oldtiptree=git_add_write_tree();
6156     printdebug "fake o+d/p tree object $unapplied\n";
6157     changedir '../work';
6158
6159
6160     # We calculate some guesswork now about what kind of tree this might
6161     # be.  This is mostly for error reporting.
6162
6163     my %editedignores;
6164     my @unrepres;
6165     my $diffbits = {
6166         # H = user's HEAD
6167         # O = orig, without patches applied
6168         # A = "applied", ie orig with H's debian/patches applied
6169         O2H => quiltify_trees_differ($unapplied,$headref,   1,
6170                                      \%editedignores, \@unrepres),
6171         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
6172         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6173     };
6174
6175     my @dl;
6176     foreach my $bits (qw(01 02)) {
6177         foreach my $v (qw(O2H O2A H2A)) {
6178             push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6179         }
6180     }
6181     printdebug "differences \@dl @dl.\n";
6182
6183     progress f_
6184 "%s: base trees orig=%.20s o+d/p=%.20s",
6185               $us, $unapplied, $oldtiptree;
6186     progress f_
6187 "%s: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
6188 "%s: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
6189   $us,                      $dl[0], $dl[1],              $dl[3], $dl[4],
6190   $us,                          $dl[2],                     $dl[5];
6191
6192     if (@unrepres) {
6193         print STDERR f_ "dgit:  cannot represent change: %s: %s\n",
6194                         $_->[1], $_->[0]
6195             foreach @unrepres;
6196         forceable_fail [qw(unrepresentable)], __ <<END;
6197 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6198 END
6199     }
6200
6201     my @failsuggestion;
6202     if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6203         push @failsuggestion, [ 'unapplied', __
6204  "This might be a patches-unapplied branch." ];
6205     } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6206         push @failsuggestion, [ 'applied', __
6207  "This might be a patches-applied branch." ];
6208     }
6209     push @failsuggestion, [ 'quilt-mode', __
6210  "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6211
6212     push @failsuggestion, [ 'gitattrs', __
6213  "Warning: Tree has .gitattributes.  See GITATTRIBUTES in dgit(7)." ]
6214         if stat_exists '.gitattributes';
6215
6216     push @failsuggestion, [ 'origs', __
6217  "Maybe orig tarball(s) are not identical to git representation?" ];
6218
6219     if (quiltmode_splitbrain()) {
6220         quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6221                             $diffbits, \%editedignores,
6222                             $splitbrain_cachekey);
6223         return;
6224     }
6225
6226     progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6227     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6228
6229     if (!open P, '>>', ".pc/applied-patches") {
6230         $!==&ENOENT or confess "$!";
6231     } else {
6232         close P;
6233     }
6234
6235     commit_quilty_patch();
6236
6237     if ($mustdeletepc) {
6238         quilt_fixup_delete_pc();
6239     }
6240 }
6241
6242 sub quilt_fixup_editor () {
6243     my $descfn = $ENV{$fakeeditorenv};
6244     my $editing = $ARGV[$#ARGV];
6245     open I1, '<', $descfn or confess "$descfn: $!";
6246     open I2, '<', $editing or confess "$editing: $!";
6247     unlink $editing or confess "$editing: $!";
6248     open O, '>', $editing or confess "$editing: $!";
6249     while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6250     my $copying = 0;
6251     while (<I2>) {
6252         $copying ||= m/^\-\-\- /;
6253         next unless $copying;
6254         print O or confess "$!";
6255     }
6256     I2->error and confess "$!";
6257     close O or die $1;
6258     finish 0;
6259 }
6260
6261 sub maybe_apply_patches_dirtily () {
6262     return unless $quilt_mode =~ m/gbp|unapplied/;
6263     print STDERR __ <<END or confess "$!";
6264
6265 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6266 dgit: Have to apply the patches - making the tree dirty.
6267 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6268
6269 END
6270     $patches_applied_dirtily = 01;
6271     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6272     runcmd qw(dpkg-source --before-build .);
6273 }
6274
6275 sub maybe_unapply_patches_again () {
6276     progress __ "dgit: Unapplying patches again to tidy up the tree."
6277         if $patches_applied_dirtily;
6278     runcmd qw(dpkg-source --after-build .)
6279         if $patches_applied_dirtily & 01;
6280     rmtree '.pc'
6281         if $patches_applied_dirtily & 02;
6282     $patches_applied_dirtily = 0;
6283 }
6284
6285 #----- other building -----
6286
6287 sub clean_tree_check_git ($$$) {
6288     my ($honour_ignores, $message, $ignmessage) = @_;
6289     my @cmd = (@git, qw(clean -dn));
6290     push @cmd, qw(-x) unless $honour_ignores;
6291     my $leftovers = cmdoutput @cmd;
6292     if (length $leftovers) {
6293         print STDERR $leftovers, "\n" or confess "$!";
6294         $message .= $ignmessage if $honour_ignores;
6295         fail $message;
6296     }
6297 }
6298
6299 sub clean_tree_check_git_wd ($) {
6300     my ($message) = @_;
6301     return if $cleanmode =~ m{no-check};
6302     return if $patches_applied_dirtily; # yuk
6303     clean_tree_check_git +($cleanmode !~ m{all-check}),
6304         $message, "\n".__ <<END;
6305 If this is just missing .gitignore entries, use a different clean
6306 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6307 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6308 END
6309 }
6310
6311 sub clean_tree_check () {
6312     # This function needs to not care about modified but tracked files.
6313     # That was done by check_not_dirty, and by now we may have run
6314     # the rules clean target which might modify tracked files (!)
6315     if ($cleanmode =~ m{^check}) {
6316         clean_tree_check_git +($cleanmode =~ m{ignores}), __
6317  "tree contains uncommitted files and --clean=check specified", '';
6318     } elsif ($cleanmode =~ m{^dpkg-source}) {
6319         clean_tree_check_git_wd __
6320  "tree contains uncommitted files (NB dgit didn't run rules clean)";
6321     } elsif ($cleanmode =~ m{^git}) {
6322         clean_tree_check_git 1, __
6323  "tree contains uncommited, untracked, unignored files\n".
6324  "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6325     } elsif ($cleanmode eq 'none') {
6326     } else {
6327         confess "$cleanmode ?";
6328     }
6329 }
6330
6331 sub clean_tree () {
6332     # We always clean the tree ourselves, rather than leave it to the
6333     # builder (dpkg-source, or soemthing which calls dpkg-source).
6334     if ($cleanmode =~ m{^dpkg-source}) {
6335         my @cmd = @dpkgbuildpackage;
6336         push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6337         push @cmd, qw(-T clean);
6338         maybe_apply_patches_dirtily();
6339         runcmd_ordryrun_local @cmd;
6340         clean_tree_check_git_wd __
6341  "tree contains uncommitted files (after running rules clean)";
6342     } elsif ($cleanmode =~ m{^git(?!-)}) {
6343         runcmd_ordryrun_local @git, qw(clean -xdf);
6344     } elsif ($cleanmode =~ m{^git-ff}) {
6345         runcmd_ordryrun_local @git, qw(clean -xdff);
6346     } elsif ($cleanmode =~ m{^check}) {
6347         clean_tree_check();
6348     } elsif ($cleanmode eq 'none') {
6349     } else {
6350         confess "$cleanmode ?";
6351     }
6352 }
6353
6354 sub cmd_clean () {
6355     badusage __ "clean takes no additional arguments" if @ARGV;
6356     notpushing();
6357     clean_tree();
6358     maybe_unapply_patches_again();
6359 }
6360
6361 # return values from massage_dbp_args are one or both of these flags
6362 sub WANTSRC_SOURCE  () { 01; } # caller should build source (separately)
6363 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6364
6365 sub build_or_push_prep_early () {
6366     our $build_or_push_prep_early_done //= 0;
6367     return if $build_or_push_prep_early_done++;
6368     badusage f_ "-p is not allowed with dgit %s", $subcommand
6369         if defined $package;
6370     my $clogp = parsechangelog();
6371     $isuite = getfield $clogp, 'Distribution';
6372     $package = getfield $clogp, 'Source';
6373     $version = getfield $clogp, 'Version';
6374     $dscfn = dscfn($version);
6375 }
6376
6377 sub build_prep_early () {
6378     build_or_push_prep_early();
6379     notpushing();
6380     check_not_dirty();
6381 }
6382
6383 sub build_prep ($) {
6384     my ($wantsrc) = @_;
6385     build_prep_early();
6386     check_bpd_exists();
6387     if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6388         # Clean the tree because we're going to use the contents of
6389         # $maindir.  (We trying to include dirty changes in the source
6390         # package, or we are running the builder in $maindir.)
6391         || $cleanmode =~ m{always}) {
6392         # Or because the user asked us to.
6393         clean_tree();
6394     } else {
6395         # We don't actually need to do anything in $maindir, but we
6396         # should do some kind of cleanliness check because (i) the
6397         # user may have forgotten a `git add', and (ii) if the user
6398         # said -wc we should still do the check.
6399         clean_tree_check();
6400     }
6401     build_maybe_quilt_fixup();
6402     if ($rmchanges) {
6403         my $pat = changespat $version;
6404         foreach my $f (glob "$buildproductsdir/$pat") {
6405             if (act_local()) {
6406                 unlink $f or
6407                     fail f_ "remove old changes file %s: %s", $f, $!;
6408             } else {
6409                 progress f_ "would remove %s", $f;
6410             }
6411         }
6412     }
6413 }
6414
6415 sub changesopts_initial () {
6416     my @opts =@changesopts[1..$#changesopts];
6417 }
6418
6419 sub changesopts_version () {
6420     if (!defined $changes_since_version) {
6421         my @vsns;
6422         unless (eval {
6423             @vsns = archive_query('archive_query');
6424             my @quirk = access_quirk();
6425             if ($quirk[0] eq 'backports') {
6426                 local $isuite = $quirk[2];
6427                 local $csuite;
6428                 canonicalise_suite();
6429                 push @vsns, archive_query('archive_query');
6430             }
6431             1;
6432         }) {
6433             print STDERR $@;
6434             fail __
6435  "archive query failed (queried because --since-version not specified)";
6436         }
6437         if (@vsns) {
6438             @vsns = map { $_->[0] } @vsns;
6439             @vsns = sort { -version_compare($a, $b) } @vsns;
6440             $changes_since_version = $vsns[0];
6441             progress f_ "changelog will contain changes since %s", $vsns[0];
6442         } else {
6443             $changes_since_version = '_';
6444             progress __ "package seems new, not specifying -v<version>";
6445         }
6446     }
6447     if ($changes_since_version ne '_') {
6448         return ("-v$changes_since_version");
6449     } else {
6450         return ();
6451     }
6452 }
6453
6454 sub changesopts () {
6455     return (changesopts_initial(), changesopts_version());
6456 }
6457
6458 sub massage_dbp_args ($;$) {
6459     my ($cmd,$xargs) = @_;
6460     # Since we split the source build out so we can do strange things
6461     # to it, massage the arguments to dpkg-buildpackage so that the
6462     # main build doessn't build source (or add an argument to stop it
6463     # building source by default).
6464     debugcmd '#massaging#', @$cmd if $debuglevel>1;
6465     # -nc has the side effect of specifying -b if nothing else specified
6466     # and some combinations of -S, -b, et al, are errors, rather than
6467     # later simply overriding earlie.  So we need to:
6468     #  - search the command line for these options
6469     #  - pick the last one
6470     #  - perhaps add our own as a default
6471     #  - perhaps adjust it to the corresponding non-source-building version
6472     my $dmode = '-F';
6473     foreach my $l ($cmd, $xargs) {
6474         next unless $l;
6475         @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6476     }
6477     push @$cmd, '-nc';
6478 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6479     my $r = WANTSRC_BUILDER;
6480     printdebug "massage split $dmode.\n";
6481     if ($dmode =~ s/^--build=//) {
6482         $r = 0;
6483         my @d = split /,/, $dmode;
6484         $r |= WANTSRC_SOURCE  if grep { s/^full$/binary/ } @d;
6485         $r |= WANTSRC_SOURCE  if grep { s/^source$// } @d;
6486         $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6487         fail __ "Wanted to build nothing!" unless $r;
6488         $dmode = '--build='. join ',', grep m/./, @d;
6489     } else {
6490         $r =
6491           $dmode =~ m/[S]/     ?  WANTSRC_SOURCE :
6492           $dmode =~ y/gGF/ABb/ ?  WANTSRC_SOURCE | WANTSRC_BUILDER :
6493           $dmode =~ m/[ABb]/   ?                   WANTSRC_BUILDER :
6494           confess "$dmode ?";
6495     }
6496     printdebug "massage done $r $dmode.\n";
6497     push @$cmd, $dmode;
6498 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6499     return $r;
6500 }
6501
6502 sub in_bpd (&) {
6503     my ($fn) = @_;
6504     my $wasdir = must_getcwd();
6505     changedir $buildproductsdir;
6506     $fn->();
6507     changedir $wasdir;
6508 }
6509
6510 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6511 sub postbuild_mergechanges ($) {
6512     my ($msg_if_onlyone) = @_;
6513     # If there is only one .changes file, fail with $msg_if_onlyone,
6514     # or if that is undef, be a no-op.
6515     # Returns the changes file to report to the user.
6516     my $pat = changespat $version;
6517     my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6518     @changesfiles = sort {
6519         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6520             or $a cmp $b
6521     } @changesfiles;
6522     my $result;
6523     if (@changesfiles==1) {
6524         fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6525 only one changes file from build (%s)
6526 END
6527             if defined $msg_if_onlyone;
6528         $result = $changesfiles[0];
6529     } elsif (@changesfiles==2) {
6530         my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6531         foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6532             fail f_ "%s found in binaries changes file %s", $l, $binchanges
6533                 if $l =~ m/\.dsc$/;
6534         }
6535         runcmd_ordryrun_local @mergechanges, @changesfiles;
6536         my $multichanges = changespat $version,'multi';
6537         if (act_local()) {
6538             stat_exists $multichanges or fail f_
6539                 "%s unexpectedly not created by build", $multichanges;
6540             foreach my $cf (glob $pat) {
6541                 next if $cf eq $multichanges;
6542                 rename "$cf", "$cf.inmulti" or fail f_
6543                     "install new changes %s\{,.inmulti}: %s", $cf, $!;
6544             }
6545         }
6546         $result = $multichanges;
6547     } else {
6548         fail f_ "wrong number of different changes files (%s)",
6549                 "@changesfiles";
6550     }
6551     printdone f_ "build successful, results in %s\n", $result
6552         or confess "$!";
6553 }
6554
6555 sub midbuild_checkchanges () {
6556     my $pat = changespat $version;
6557     return if $rmchanges;
6558     my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6559     @unwanted = grep {
6560         $_ ne changespat $version,'source' and
6561         $_ ne changespat $version,'multi'
6562     } @unwanted;
6563     fail +(f_ <<END, $pat, "@unwanted")
6564 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6565 Suggest you delete %s.
6566 END
6567         if @unwanted;
6568 }
6569
6570 sub midbuild_checkchanges_vanilla ($) {
6571     my ($wantsrc) = @_;
6572     midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6573 }
6574
6575 sub postbuild_mergechanges_vanilla ($) {
6576     my ($wantsrc) = @_;
6577     if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6578         in_bpd {
6579             postbuild_mergechanges(undef);
6580         };
6581     } else {
6582         printdone __ "build successful\n";
6583     }
6584 }
6585
6586 sub cmd_build {
6587     build_prep_early();
6588     $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6589 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6590 %s: warning: build-products-dir will be ignored; files will go to ..
6591 END
6592     $buildproductsdir = '..';
6593     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6594     my $wantsrc = massage_dbp_args \@dbp;
6595     build_prep($wantsrc);
6596     if ($wantsrc & WANTSRC_SOURCE) {
6597         build_source();
6598         midbuild_checkchanges_vanilla $wantsrc;
6599     }
6600     if ($wantsrc & WANTSRC_BUILDER) {
6601         push @dbp, changesopts_version();
6602         maybe_apply_patches_dirtily();
6603         runcmd_ordryrun_local @dbp;
6604     }
6605     maybe_unapply_patches_again();
6606     postbuild_mergechanges_vanilla $wantsrc;
6607 }
6608
6609 sub pre_gbp_build {
6610     $quilt_mode //= 'gbp';
6611 }
6612
6613 sub cmd_gbp_build {
6614     build_prep_early();
6615
6616     # gbp can make .origs out of thin air.  In my tests it does this
6617     # even for a 1.0 format package, with no origs present.  So I
6618     # guess it keys off just the version number.  We don't know
6619     # exactly what .origs ought to exist, but let's assume that we
6620     # should run gbp if: the version has an upstream part and the main
6621     # orig is absent.
6622     my $upstreamversion = upstreamversion $version;
6623     my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6624     my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6625
6626     if ($gbp_make_orig) {
6627         clean_tree();
6628         $cleanmode = 'none'; # don't do it again
6629     }
6630
6631     my @dbp = @dpkgbuildpackage;
6632
6633     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6634
6635     if (!length $gbp_build[0]) {
6636         if (length executable_on_path('git-buildpackage')) {
6637             $gbp_build[0] = qw(git-buildpackage);
6638         } else {
6639             $gbp_build[0] = 'gbp buildpackage';
6640         }
6641     }
6642     my @cmd = opts_opt_multi_cmd [], @gbp_build;
6643
6644     push @cmd, (qw(-us -uc --git-no-sign-tags),
6645                 "--git-builder=".(shellquote @dbp));
6646
6647     if ($gbp_make_orig) {
6648         my $priv = dgit_privdir();
6649         my $ok = "$priv/origs-gen-ok";
6650         unlink $ok or $!==&ENOENT or confess "$!";
6651         my @origs_cmd = @cmd;
6652         push @origs_cmd, qw(--git-cleaner=true);
6653         push @origs_cmd, "--git-prebuild=".
6654             "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6655         push @origs_cmd, @ARGV;
6656         if (act_local()) {
6657             debugcmd @origs_cmd;
6658             system @origs_cmd;
6659             do { local $!; stat_exists $ok; }
6660                 or failedcmd @origs_cmd;
6661         } else {
6662             dryrun_report @origs_cmd;
6663         }
6664     }
6665
6666     build_prep($wantsrc);
6667     if ($wantsrc & WANTSRC_SOURCE) {
6668         build_source();
6669         midbuild_checkchanges_vanilla $wantsrc;
6670     } else {
6671         push @cmd, '--git-cleaner=true';
6672     }
6673     maybe_unapply_patches_again();
6674     if ($wantsrc & WANTSRC_BUILDER) {
6675         push @cmd, changesopts();
6676         runcmd_ordryrun_local @cmd, @ARGV;
6677     }
6678     postbuild_mergechanges_vanilla $wantsrc;
6679 }
6680 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6681
6682 sub building_source_in_playtree {
6683     # If $includedirty, we have to build the source package from the
6684     # working tree, not a playtree, so that uncommitted changes are
6685     # included (copying or hardlinking them into the playtree could
6686     # cause trouble).
6687     #
6688     # Note that if we are building a source package in split brain
6689     # mode we do not support including uncommitted changes, because
6690     # that makes quilt fixup too hard.  I.e. ($split_brain && (dgit is
6691     # building a source package)) => !$includedirty
6692     return !$includedirty;
6693 }
6694
6695 sub build_source {
6696     $sourcechanges = changespat $version,'source';
6697     if (act_local()) {
6698         unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6699             or fail f_ "remove %s: %s", $sourcechanges, $!;
6700     }
6701     my @cmd = (@dpkgsource, qw(-b --));
6702     my $leafdir;
6703     if (building_source_in_playtree()) {
6704         $leafdir = 'work';
6705         my $headref = git_rev_parse('HEAD');
6706         # If we are in split brain, there is already a playtree with
6707         # the thing we should package into a .dsc (thanks to quilt
6708         # fixup).  If not, make a playtree
6709         prep_ud() unless $split_brain;
6710         changedir $playground;
6711         unless ($split_brain) {
6712             my $upstreamversion = upstreamversion $version;
6713             unpack_playtree_linkorigs($upstreamversion, sub { });
6714             unpack_playtree_mkwork($headref);
6715             changedir '..';
6716         }
6717     } else {
6718         $leafdir = basename $maindir;
6719
6720         if ($buildproductsdir ne '..') {
6721             # Well, we are going to run dpkg-source -b which consumes
6722             # origs from .. and generates output there.  To make this
6723             # work when the bpd is not .. , we would have to (i) link
6724             # origs from bpd to .. , (ii) check for files that
6725             # dpkg-source -b would/might overwrite, and afterwards
6726             # (iii) move all the outputs back to the bpd (iv) except
6727             # for the origs which should be deleted from .. if they
6728             # weren't there beforehand.  And if there is an error and
6729             # we don't run to completion we would necessarily leave a
6730             # mess.  This is too much.  The real way to fix this
6731             # is for dpkg-source to have bpd support.
6732             confess unless $includedirty;
6733             fail __
6734  "--include-dirty not supported with --build-products-dir, sorry";
6735         }
6736
6737         changedir '..';
6738     }
6739     runcmd_ordryrun_local @cmd, $leafdir;
6740
6741     changedir $leafdir;
6742     runcmd_ordryrun_local qw(sh -ec),
6743       'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6744       @dpkggenchanges, qw(-S), changesopts();
6745     changedir '..';
6746
6747     printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6748     $dsc = parsecontrol($dscfn, "source package");
6749
6750     my $mv = sub {
6751         my ($why, $l) = @_;
6752         printdebug " renaming ($why) $l\n";
6753         rename_link_xf 0, "$l", bpd_abs()."/$l"
6754             or fail f_ "put in place new built file (%s): %s", $l, $@;
6755     };
6756     foreach my $l (split /\n/, getfield $dsc, 'Files') {
6757         $l =~ m/\S+$/ or next;
6758         $mv->('Files', $&);
6759     }
6760     $mv->('dsc', $dscfn);
6761     $mv->('changes', $sourcechanges);
6762
6763     changedir $maindir;
6764 }
6765
6766 sub cmd_build_source {
6767     badusage __ "build-source takes no additional arguments" if @ARGV;
6768     build_prep(WANTSRC_SOURCE);
6769     build_source();
6770     maybe_unapply_patches_again();
6771     printdone f_ "source built, results in %s and %s",
6772                  $dscfn, $sourcechanges;
6773 }
6774
6775 sub cmd_push_source {
6776     prep_push();
6777     fail __
6778         "dgit push-source: --include-dirty/--ignore-dirty does not make".
6779         "sense with push-source!"
6780         if $includedirty;
6781     build_maybe_quilt_fixup();
6782     if ($changesfile) {
6783         my $changes = parsecontrol("$buildproductsdir/$changesfile",
6784                                    __ "source changes file");
6785         unless (test_source_only_changes($changes)) {
6786             fail __ "user-specified changes file is not source-only";
6787         }
6788     } else {
6789         # Building a source package is very fast, so just do it
6790         build_source();
6791         confess "er, patches are applied dirtily but shouldn't be.."
6792             if $patches_applied_dirtily;
6793         $changesfile = $sourcechanges;
6794     }
6795     dopush();
6796 }
6797
6798 sub binary_builder {
6799     my ($bbuilder, $pbmc_msg, @args) = @_;
6800     build_prep(WANTSRC_SOURCE);
6801     build_source();
6802     midbuild_checkchanges();
6803     in_bpd {
6804         if (act_local()) {
6805             stat_exists $dscfn or fail f_
6806                 "%s (in build products dir): %s", $dscfn, $!;
6807             stat_exists $sourcechanges or fail f_
6808                 "%s (in build products dir): %s", $sourcechanges, $!;
6809         }
6810         runcmd_ordryrun_local @$bbuilder, @args;
6811     };
6812     maybe_unapply_patches_again();
6813     in_bpd {
6814         postbuild_mergechanges($pbmc_msg);
6815     };
6816 }
6817
6818 sub cmd_sbuild {
6819     build_prep_early();
6820     binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6821 perhaps you need to pass -A ?  (sbuild's default is to build only
6822 arch-specific binaries; dgit 1.4 used to override that.)
6823 END
6824 }
6825
6826 sub pbuilder ($) {
6827     my ($pbuilder) = @_;
6828     build_prep_early();
6829     # @ARGV is allowed to contain only things that should be passed to
6830     # pbuilder under debbuildopts; just massage those
6831     my $wantsrc = massage_dbp_args \@ARGV;
6832     fail __
6833         "you asked for a builder but your debbuildopts didn't ask for".
6834         " any binaries -- is this really what you meant?"
6835         unless $wantsrc & WANTSRC_BUILDER;
6836     fail __
6837         "we must build a .dsc to pass to the builder but your debbuiltopts".
6838         " forbids the building of a source package; cannot continue"
6839       unless $wantsrc & WANTSRC_SOURCE;
6840     # We do not want to include the verb "build" in @pbuilder because
6841     # the user can customise @pbuilder and they shouldn't be required
6842     # to include "build" in their customised value.  However, if the
6843     # user passes any additional args to pbuilder using the dgit
6844     # option --pbuilder:foo, such args need to come after the "build"
6845     # verb.  opts_opt_multi_cmd does all of that.
6846     binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6847                    qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6848                    $dscfn);
6849 }
6850
6851 sub cmd_pbuilder {
6852     pbuilder(\@pbuilder);
6853 }
6854
6855 sub cmd_cowbuilder {
6856     pbuilder(\@cowbuilder);
6857 }
6858
6859 sub cmd_quilt_fixup {
6860     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6861     build_prep_early();
6862     clean_tree();
6863     build_maybe_quilt_fixup();
6864 }
6865
6866 sub cmd_print_unapplied_treeish {
6867     badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6868         if @ARGV;
6869     my $headref = git_rev_parse('HEAD');
6870     my $clogp = commit_getclogp $headref;
6871     $package = getfield $clogp, 'Source';
6872     $version = getfield $clogp, 'Version';
6873     $isuite = getfield $clogp, 'Distribution';
6874     $csuite = $isuite; # we want this to be offline!
6875     notpushing();
6876
6877     prep_ud();
6878     changedir $playground;
6879     my $uv = upstreamversion $version;
6880     quilt_make_fake_dsc($uv);
6881     my $u = quilt_fakedsc2unapplied($headref, $uv);
6882     print $u, "\n" or confess "$!";
6883 }
6884
6885 sub import_dsc_result {
6886     my ($dstref, $newhash, $what_log, $what_msg) = @_;
6887     my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6888     runcmd @cmd;
6889     check_gitattrs($newhash, __ "source tree");
6890
6891     progress f_ "dgit: import-dsc: %s", $what_msg;
6892 }
6893
6894 sub cmd_import_dsc {
6895     my $needsig = 0;
6896
6897     while (@ARGV) {
6898         last unless $ARGV[0] =~ m/^-/;
6899         $_ = shift @ARGV;
6900         last if m/^--?$/;
6901         if (m/^--require-valid-signature$/) {
6902             $needsig = 1;
6903         } else {
6904             badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6905         }
6906     }
6907
6908     badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6909         unless @ARGV==2;
6910     my ($dscfn, $dstbranch) = @ARGV;
6911
6912     badusage __ "dry run makes no sense with import-dsc"
6913         unless act_local();
6914
6915     my $force = $dstbranch =~ s/^\+//   ? +1 :
6916                 $dstbranch =~ s/^\.\.// ? -1 :
6917                                            0;
6918     my $info = $force ? " $&" : '';
6919     $info = "$dscfn$info";
6920
6921     my $specbranch = $dstbranch;
6922     $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6923     $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6924
6925     my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6926     my $chead = cmdoutput_errok @symcmd;
6927     defined $chead or $?==256 or failedcmd @symcmd;
6928
6929     fail f_ "%s is checked out - will not update it", $dstbranch
6930         if defined $chead and $chead eq $dstbranch;
6931
6932     my $oldhash = git_get_ref $dstbranch;
6933
6934     open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6935     $dscdata = do { local $/ = undef; <D>; };
6936     D->error and fail f_ "read %s: %s", $dscfn, $!;
6937     close C;
6938
6939     # we don't normally need this so import it here
6940     use Dpkg::Source::Package;
6941     my $dp = new Dpkg::Source::Package filename => $dscfn,
6942         require_valid_signature => $needsig;
6943     {
6944         local $SIG{__WARN__} = sub {
6945             print STDERR $_[0];
6946             return unless $needsig;
6947             fail __ "import-dsc signature check failed";
6948         };
6949         if (!$dp->is_signed()) {
6950             warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6951         } else {
6952             my $r = $dp->check_signature();
6953             confess "->check_signature => $r" if $needsig && $r;
6954         }
6955     }
6956
6957     parse_dscdata();
6958
6959     $package = getfield $dsc, 'Source';
6960
6961     parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6962         unless forceing [qw(import-dsc-with-dgit-field)];
6963     parse_dsc_field_def_dsc_distro();
6964
6965     $isuite = 'DGIT-IMPORT-DSC';
6966     $idistro //= $dsc_distro;
6967
6968     notpushing();
6969
6970     if (defined $dsc_hash) {
6971         progress __
6972             "dgit: import-dsc of .dsc with Dgit field, using git hash";
6973         resolve_dsc_field_commit undef, undef;
6974     }
6975     if (defined $dsc_hash) {
6976         my @cmd = (qw(sh -ec),
6977                    "echo $dsc_hash | git cat-file --batch-check");
6978         my $objgot = cmdoutput @cmd;
6979         if ($objgot =~ m#^\w+ missing\b#) {
6980             fail f_ <<END, $dsc_hash
6981 .dsc contains Dgit field referring to object %s
6982 Your git tree does not have that object.  Try `git fetch' from a
6983 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
6984 END
6985         }
6986         if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6987             if ($force > 0) {
6988                 progress __ "Not fast forward, forced update.";
6989             } else {
6990                 fail f_ "Not fast forward to %s", $dsc_hash;
6991             }
6992         }
6993         import_dsc_result $dstbranch, $dsc_hash,
6994             "dgit import-dsc (Dgit): $info",
6995             f_ "updated git ref %s", $dstbranch;
6996         return 0;
6997     }
6998
6999     fail f_ <<END, $dstbranch, $specbranch, $specbranch
7000 Branch %s already exists
7001 Specify ..%s for a pseudo-merge, binding in existing history
7002 Specify  +%s to overwrite, discarding existing history
7003 END
7004         if $oldhash && !$force;
7005
7006     my @dfi = dsc_files_info();
7007     foreach my $fi (@dfi) {
7008         my $f = $fi->{Filename};
7009         # We transfer all the pieces of the dsc to the bpd, not just
7010         # origs.  This is by analogy with dgit fetch, which wants to
7011         # keep them somewhere to avoid downloading them again.
7012         # We make symlinks, though.  If the user wants copies, then
7013         # they can copy the parts of the dsc to the bpd using dcmd,
7014         # or something.
7015         my $here = "$buildproductsdir/$f";
7016         if (lstat $here) {
7017             if (stat $here) {
7018                 next;
7019             }
7020             fail f_ "lstat %s works but stat gives %s !", $here, $!;
7021         }
7022         fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7023         printdebug "not in bpd, $f ...\n";
7024         # $f does not exist in bpd, we need to transfer it
7025         my $there = $dscfn;
7026         $there =~ s{[^/]+$}{$f} or confess "$there ?";
7027         # $there is file we want, relative to user's cwd, or abs
7028         printdebug "not in bpd, $f, test $there ...\n";
7029         stat $there or fail f_
7030             "import %s requires %s, but: %s", $dscfn, $there, $!;
7031         if ($there =~ m#^(?:\./+)?\.\./+#) {
7032             # $there is relative to user's cwd
7033             my $there_from_parent = $';
7034             if ($buildproductsdir !~ m{^/}) {
7035                 # abs2rel, despite its name, can take two relative paths
7036                 $there = File::Spec->abs2rel($there,$buildproductsdir);
7037                 # now $there is relative to bpd, great
7038                 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7039             } else {
7040                 $there = (dirname $maindir)."/$there_from_parent";
7041                 # now $there is absoute
7042                 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7043             }
7044         } elsif ($there =~ m#^/#) {
7045             # $there is absolute already
7046             printdebug "not in bpd, $f, abs, $there ...\n";
7047         } else {
7048             fail f_
7049                 "cannot import %s which seems to be inside working tree!",
7050                 $dscfn;
7051         }
7052         symlink $there, $here or fail f_
7053             "symlink %s to %s: %s", $there, $here, $!;
7054         progress f_ "made symlink %s -> %s", $here, $there;
7055 #       print STDERR Dumper($fi);
7056     }
7057     my @mergeinputs = generate_commits_from_dsc();
7058     die unless @mergeinputs == 1;
7059
7060     my $newhash = $mergeinputs[0]{Commit};
7061
7062     if ($oldhash) {
7063         if ($force > 0) {
7064             progress __
7065                 "Import, forced update - synthetic orphan git history.";
7066         } elsif ($force < 0) {
7067             progress __ "Import, merging.";
7068             my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7069             my $version = getfield $dsc, 'Version';
7070             my $clogp = commit_getclogp $newhash;
7071             my $authline = clogp_authline $clogp;
7072             $newhash = make_commit_text <<ENDU
7073 tree $tree
7074 parent $newhash
7075 parent $oldhash
7076 author $authline
7077 committer $authline
7078
7079 ENDU
7080                 .(f_ <<END, $package, $version, $dstbranch);
7081 Merge %s (%s) import into %s
7082 END
7083         } else {
7084             die; # caught earlier
7085         }
7086     }
7087
7088     import_dsc_result $dstbranch, $newhash,
7089         "dgit import-dsc: $info",
7090         f_ "results are in git ref %s", $dstbranch;
7091 }
7092
7093 sub pre_archive_api_query () {
7094     not_necessarily_a_tree();
7095 }
7096 sub cmd_archive_api_query {
7097     badusage __ "need only 1 subpath argument" unless @ARGV==1;
7098     my ($subpath) = @ARGV;
7099     local $isuite = 'DGIT-API-QUERY-CMD';
7100     my @cmd = archive_api_query_cmd($subpath);
7101     push @cmd, qw(-f);
7102     debugcmd ">",@cmd;
7103     exec @cmd or fail f_ "exec curl: %s\n", $!;
7104 }
7105
7106 sub repos_server_url () {
7107     $package = '_dgit-repos-server';
7108     local $access_forpush = 1;
7109     local $isuite = 'DGIT-REPOS-SERVER';
7110     my $url = access_giturl();
7111 }
7112
7113 sub pre_clone_dgit_repos_server () {
7114     not_necessarily_a_tree();
7115 }
7116 sub cmd_clone_dgit_repos_server {
7117     badusage __ "need destination argument" unless @ARGV==1;
7118     my ($destdir) = @ARGV;
7119     my $url = repos_server_url();
7120     my @cmd = (@git, qw(clone), $url, $destdir);
7121     debugcmd ">",@cmd;
7122     exec @cmd or fail f_ "exec git clone: %s\n", $!;
7123 }
7124
7125 sub pre_print_dgit_repos_server_source_url () {
7126     not_necessarily_a_tree();
7127 }
7128 sub cmd_print_dgit_repos_server_source_url {
7129     badusage __
7130         "no arguments allowed to dgit print-dgit-repos-server-source-url"
7131         if @ARGV;
7132     my $url = repos_server_url();
7133     print $url, "\n" or confess "$!";
7134 }
7135
7136 sub pre_print_dpkg_source_ignores {
7137     not_necessarily_a_tree();
7138 }
7139 sub cmd_print_dpkg_source_ignores {
7140     badusage __
7141         "no arguments allowed to dgit print-dpkg-source-ignores"
7142         if @ARGV;
7143     print "@dpkg_source_ignores\n" or confess "$!";
7144 }
7145
7146 sub cmd_setup_mergechangelogs {
7147     badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7148         if @ARGV;
7149     local $isuite = 'DGIT-SETUP-TREE';
7150     setup_mergechangelogs(1);
7151 }
7152
7153 sub cmd_setup_useremail {
7154     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7155     local $isuite = 'DGIT-SETUP-TREE';
7156     setup_useremail(1);
7157 }
7158
7159 sub cmd_setup_gitattributes {
7160     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7161     local $isuite = 'DGIT-SETUP-TREE';
7162     setup_gitattrs(1);
7163 }
7164
7165 sub cmd_setup_new_tree {
7166     badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7167     local $isuite = 'DGIT-SETUP-TREE';
7168     setup_new_tree();
7169 }
7170
7171 #---------- argument parsing and main program ----------
7172
7173 sub cmd_version {
7174     print "dgit version $our_version\n" or confess "$!";
7175     finish 0;
7176 }
7177
7178 our (%valopts_long, %valopts_short);
7179 our (%funcopts_long);
7180 our @rvalopts;
7181 our (@modeopt_cfgs);
7182
7183 sub defvalopt ($$$$) {
7184     my ($long,$short,$val_re,$how) = @_;
7185     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7186     $valopts_long{$long} = $oi;
7187     $valopts_short{$short} = $oi;
7188     # $how subref should:
7189     #   do whatever assignemnt or thing it likes with $_[0]
7190     #   if the option should not be passed on to remote, @rvalopts=()
7191     # or $how can be a scalar ref, meaning simply assign the value
7192 }
7193
7194 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7195 defvalopt '--distro',        '-d', '.+',      \$idistro;
7196 defvalopt '',                '-k', '.+',      \$keyid;
7197 defvalopt '--existing-package','', '.*',      \$existing_package;
7198 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
7199 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
7200 defvalopt '--package',   '-p',   $package_re, \$package;
7201 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
7202
7203 defvalopt '', '-C', '.+', sub {
7204     ($changesfile) = (@_);
7205     if ($changesfile =~ s#^(.*)/##) {
7206         $buildproductsdir = $1;
7207     }
7208 };
7209
7210 defvalopt '--initiator-tempdir','','.*', sub {
7211     ($initiator_tempdir) = (@_);
7212     $initiator_tempdir =~ m#^/# or
7213         badusage __ "--initiator-tempdir must be used specify an".
7214                     " absolute, not relative, directory."
7215 };
7216
7217 sub defoptmodes ($@) {
7218     my ($varref, $cfgkey, $default, %optmap) = @_;
7219     my %permit;
7220     while (my ($opt,$val) = each %optmap) {
7221         $funcopts_long{$opt} = sub { $$varref = $val; };
7222         $permit{$val} = $val;
7223     }
7224     push @modeopt_cfgs, {
7225         Var => $varref,
7226         Key => $cfgkey,
7227         Default => $default,
7228         Vals => \%permit
7229     };
7230 }
7231
7232 defoptmodes \$dodep14tag, qw( dep14tag          want
7233                               --dep14tag        want
7234                               --no-dep14tag     no
7235                               --always-dep14tag always );
7236
7237 sub parseopts () {
7238     my $om;
7239
7240     if (defined $ENV{'DGIT_SSH'}) {
7241         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7242     } elsif (defined $ENV{'GIT_SSH'}) {
7243         @ssh = ($ENV{'GIT_SSH'});
7244     }
7245
7246     my $oi;
7247     my $val;
7248     my $valopt = sub {
7249         my ($what) = @_;
7250         @rvalopts = ($_);
7251         if (!defined $val) {
7252             badusage f_ "%s needs a value", $what unless @ARGV;
7253             $val = shift @ARGV;
7254             push @rvalopts, $val;
7255         }
7256         badusage f_ "bad value \`%s' for %s", $val, $what unless
7257             $val =~ m/^$oi->{Re}$(?!\n)/s;
7258         my $how = $oi->{How};
7259         if (ref($how) eq 'SCALAR') {
7260             $$how = $val;
7261         } else {
7262             $how->($val);
7263         }
7264         push @ropts, @rvalopts;
7265     };
7266
7267     while (@ARGV) {
7268         last unless $ARGV[0] =~ m/^-/;
7269         $_ = shift @ARGV;
7270         last if m/^--?$/;
7271         if (m/^--/) {
7272             if (m/^--dry-run$/) {
7273                 push @ropts, $_;
7274                 $dryrun_level=2;
7275             } elsif (m/^--damp-run$/) {
7276                 push @ropts, $_;
7277                 $dryrun_level=1;
7278             } elsif (m/^--no-sign$/) {
7279                 push @ropts, $_;
7280                 $sign=0;
7281             } elsif (m/^--help$/) {
7282                 cmd_help();
7283             } elsif (m/^--version$/) {
7284                 cmd_version();
7285             } elsif (m/^--new$/) {
7286                 push @ropts, $_;
7287                 $new_package=1;
7288             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7289                      ($om = $opts_opt_map{$1}) &&
7290                      length $om->[0]) {
7291                 push @ropts, $_;
7292                 $om->[0] = $2;
7293             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7294                      !$opts_opt_cmdonly{$1} &&
7295                      ($om = $opts_opt_map{$1})) {
7296                 push @ropts, $_;
7297                 push @$om, $2;
7298             } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7299                      !$opts_opt_cmdonly{$1} &&
7300                      ($om = $opts_opt_map{$1})) {
7301                 push @ropts, $_;
7302                 my $cmd = shift @$om;
7303                 @$om = ($cmd, grep { $_ ne $2 } @$om);
7304             } elsif (m/^--(gbp|dpm)$/s) {
7305                 push @ropts, "--quilt=$1";
7306                 $quilt_mode = $1;
7307             } elsif (m/^--(?:ignore|include)-dirty$/s) {
7308                 push @ropts, $_;
7309                 $includedirty = 1;
7310             } elsif (m/^--no-quilt-fixup$/s) {
7311                 push @ropts, $_;
7312                 $quilt_mode = 'nocheck';
7313             } elsif (m/^--no-rm-on-error$/s) {
7314                 push @ropts, $_;
7315                 $rmonerror = 0;
7316             } elsif (m/^--no-chase-dsc-distro$/s) {
7317                 push @ropts, $_;
7318                 $chase_dsc_distro = 0;
7319             } elsif (m/^--overwrite$/s) {
7320                 push @ropts, $_;
7321                 $overwrite_version = '';
7322             } elsif (m/^--overwrite=(.+)$/s) {
7323                 push @ropts, $_;
7324                 $overwrite_version = $1;
7325             } elsif (m/^--delayed=(\d+)$/s) {
7326                 push @ropts, $_;
7327                 push @dput, $_;
7328             } elsif (my ($k,$v) =
7329                      m/^--save-(dgit-view)=(.+)$/s ||
7330                      m/^--(dgit-view)-save=(.+)$/s
7331                      ) {
7332                 push @ropts, $_;
7333                 $v =~ s#^(?!refs/)#refs/heads/#;
7334                 $internal_object_save{$k} = $v;
7335             } elsif (m/^--(no-)?rm-old-changes$/s) {
7336                 push @ropts, $_;
7337                 $rmchanges = !$1;
7338             } elsif (m/^--deliberately-($deliberately_re)$/s) {
7339                 push @ropts, $_;
7340                 push @deliberatelies, $&;
7341             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7342                 push @ropts, $&;
7343                 $forceopts{$1} = 1;
7344                 $_='';
7345             } elsif (m/^--force-/) {
7346                 print STDERR
7347                     f_ "%s: warning: ignoring unknown force option %s\n",
7348                        $us, $_;
7349                 $_='';
7350             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7351                 # undocumented, for testing
7352                 push @ropts, $_;
7353                 $tagformat_want = [ $1, 'command line', 1 ];
7354                 # 1 menas overrides distro configuration
7355             } elsif (m/^--config-lookup-explode=(.+)$/s) {
7356                 # undocumented, for testing
7357                 push @ropts, $_;
7358                 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7359                 # ^ it's supposed to be an array ref
7360             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7361                 $val = $2 ? $' : undef; #';
7362                 $valopt->($oi->{Long});
7363             } elsif ($funcopts_long{$_}) {
7364                 push @ropts, $_;
7365                 $funcopts_long{$_}();
7366             } else {
7367                 badusage f_ "unknown long option \`%s'", $_;
7368             }
7369         } else {
7370             while (m/^-./s) {
7371                 if (s/^-n/-/) {
7372                     push @ropts, $&;
7373                     $dryrun_level=2;
7374                 } elsif (s/^-L/-/) {
7375                     push @ropts, $&;
7376                     $dryrun_level=1;
7377                 } elsif (s/^-h/-/) {
7378                     cmd_help();
7379                 } elsif (s/^-D/-/) {
7380                     push @ropts, $&;
7381                     $debuglevel++;
7382                     enabledebug();
7383                 } elsif (s/^-N/-/) {
7384                     push @ropts, $&;
7385                     $new_package=1;
7386                 } elsif (m/^-m/) {
7387                     push @ropts, $&;
7388                     push @changesopts, $_;
7389                     $_ = '';
7390                 } elsif (s/^-wn$//s) {
7391                     push @ropts, $&;
7392                     $cleanmode = 'none';
7393                 } elsif (s/^-wg(f?)(a?)$//s) {
7394                     push @ropts, $&;
7395                     $cleanmode = 'git';
7396                     $cleanmode .= '-ff' if $1;
7397                     $cleanmode .= ',always' if $2;
7398                 } elsif (s/^-wd(d?)([na]?)$//s) {
7399                     push @ropts, $&;
7400                     $cleanmode = 'dpkg-source';
7401                     $cleanmode .= '-d' if $1;
7402                     $cleanmode .= ',no-check' if $2 eq 'n';
7403                     $cleanmode .= ',all-check' if $2 eq 'a';
7404                 } elsif (s/^-wc$//s) {
7405                     push @ropts, $&;
7406                     $cleanmode = 'check';
7407                 } elsif (s/^-wci$//s) {
7408                     push @ropts, $&;
7409                     $cleanmode = 'check,ignores';
7410                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7411                     push @git, '-c', $&;
7412                     $gitcfgs{cmdline}{$1} = [ $2 ];
7413                 } elsif (s/^-c([^=]+)$//s) {
7414                     push @git, '-c', $&;
7415                     $gitcfgs{cmdline}{$1} = [ 'true' ];
7416                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7417                     $val = $'; #';
7418                     $val = undef unless length $val;
7419                     $valopt->($oi->{Short});
7420                     $_ = '';
7421                 } else {
7422                     badusage f_ "unknown short option \`%s'", $_;
7423                 }
7424             }
7425         }
7426     }
7427 }
7428
7429 sub check_env_sanity () {
7430     my $blocked = new POSIX::SigSet;
7431     sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7432
7433     eval {
7434         foreach my $name (qw(PIPE CHLD)) {
7435             my $signame = "SIG$name";
7436             my $signum = eval "POSIX::$signame" // die;
7437             die f_ "%s is set to something other than SIG_DFL\n",
7438                 $signame
7439                 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7440             $blocked->ismember($signum) and
7441                 die f_ "%s is blocked\n", $signame;
7442         }
7443     };
7444     return unless $@;
7445     chomp $@;
7446     fail f_ <<END, $@;
7447 On entry to dgit, %s
7448 This is a bug produced by something in your execution environment.
7449 Giving up.
7450 END
7451 }
7452
7453
7454 sub parseopts_late_defaults () {
7455     $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7456         if defined $idistro;
7457     $isuite //= cfg('dgit.default.default-suite');
7458
7459     foreach my $k (keys %opts_opt_map) {
7460         my $om = $opts_opt_map{$k};
7461
7462         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7463         if (defined $v) {
7464             badcfg f_ "cannot set command for %s", $k
7465                 unless length $om->[0];
7466             $om->[0] = $v;
7467         }
7468
7469         foreach my $c (access_cfg_cfgs("opts-$k")) {
7470             my @vl =
7471                 map { $_ ? @$_ : () }
7472                 map { $gitcfgs{$_}{$c} }
7473                 reverse @gitcfgsources;
7474             printdebug "CL $c ", (join " ", map { shellquote } @vl),
7475                 "\n" if $debuglevel >= 4;
7476             next unless @vl;
7477             badcfg f_ "cannot configure options for %s", $k
7478                 if $opts_opt_cmdonly{$k};
7479             my $insertpos = $opts_cfg_insertpos{$k};
7480             @$om = ( @$om[0..$insertpos-1],
7481                      @vl,
7482                      @$om[$insertpos..$#$om] );
7483         }
7484     }
7485
7486     if (!defined $rmchanges) {
7487         local $access_forpush;
7488         $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7489     }
7490
7491     if (!defined $quilt_mode) {
7492         local $access_forpush;
7493         $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7494             // access_cfg('quilt-mode', 'RETURN-UNDEF')
7495             // 'linear';
7496         $quilt_mode =~ m/^($quilt_modes_re)$/
7497             or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7498         $quilt_mode = $1;
7499     }
7500
7501     foreach my $moc (@modeopt_cfgs) {
7502         local $access_forpush;
7503         my $vr = $moc->{Var};
7504         next if defined $$vr;
7505         $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7506         my $v = $moc->{Vals}{$$vr};
7507         badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7508             unless defined $v;
7509         $$vr = $v;
7510     }
7511
7512     fail __ "dgit: --include-dirty is not supported in split view quilt mode"
7513         if $split_brain && $includedirty;
7514
7515     if (!defined $cleanmode) {
7516         local $access_forpush;
7517         $cleanmode = access_cfg('clean-mode-newer', 'RETURN-UNDEF');
7518         $cleanmode = undef if $cleanmode && $cleanmode !~ m/^$cleanmode_re$/;
7519
7520         $cleanmode //= access_cfg('clean-mode', 'RETURN-UNDEF');
7521         $cleanmode //= 'dpkg-source';
7522
7523         badcfg f_ "unknown clean-mode \`%s'", $cleanmode unless
7524             $cleanmode =~ m/$cleanmode_re/;
7525     }
7526
7527     $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7528     $buildproductsdir //= '..';
7529     $bpd_glob = $buildproductsdir;
7530     $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7531 }
7532
7533 setlocale(LC_MESSAGES, "");
7534 textdomain("dgit");
7535
7536 if ($ENV{$fakeeditorenv}) {
7537     git_slurp_config();
7538     quilt_fixup_editor();
7539 }
7540
7541 parseopts();
7542 check_env_sanity();
7543
7544 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7545 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7546     if $dryrun_level == 1;
7547 if (!@ARGV) {
7548     print STDERR __ $helpmsg or confess "$!";
7549     finish 8;
7550 }
7551 $cmd = $subcommand = shift @ARGV;
7552 $cmd =~ y/-/_/;
7553
7554 my $pre_fn = ${*::}{"pre_$cmd"};
7555 $pre_fn->() if $pre_fn;
7556
7557 if ($invoked_in_git_tree) {
7558     changedir_git_toplevel();
7559     record_maindir();
7560 }
7561 git_slurp_config();
7562
7563 my $fn = ${*::}{"cmd_$cmd"};
7564 $fn or badusage f_ "unknown operation %s", $cmd;
7565 $fn->();
7566
7567 finish 0;