dgit

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