dgit

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