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