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