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 supplementary_message ($) {
 971     my ($msg) = @_;
 972     if (!$we_are_responder) {
 973         $supplementary_message = $msg;
 974         return;
 975     } else {
 976         responder_send_command "supplementary-message ".length($msg)
 977             or confess "$!";
 978         print PO $msg or confess "$!";
 979     }
 980 }
 981
 982 sub access_distros () {
 983     # Returns list of distros to try, in order
 984     #
 985     # We want to try:
 986     #    0. `instead of' distro name(s) we have been pointed to
 987     #    1. the access_quirk distro, if any
 988     #    2a. the user's specified distro, or failing that  } basedistro
 989     #    2b. the distro calculated from the suite          }
 990     my @l = access_basedistro();
 991
 992     my (undef,$quirkdistro) = access_quirk();
 993     unshift @l, $quirkdistro;
 994     unshift @l, $instead_distro;
 995     @l = grep { defined } @l;
 996
 997     push @l, access_nomdistro();
 998
 999     if (access_forpush()) {
1000         @l = map { ("$_/push", $_) } @l;
1001     }
1002     @l;
1003 }
1004
1005 sub access_cfg_cfgs (@) {
1006     my (@keys) = @_;
1007     my @cfgs;
1008     # The nesting of these loops determines the search order.  We put
1009     # the key loop on the outside so that we search all the distros
1010     # for each key, before going on to the next key.  That means that
1011     # if access_cfg is called with a more specific, and then a less
1012     # specific, key, an earlier distro can override the less specific
1013     # without necessarily overriding any more specific keys.  (If the
1014     # distro wants to override the more specific keys it can simply do
1015     # so; whereas if we did the loop the other way around, it would be
1016     # impossible to for an earlier distro to override a less specific
1017     # key but not the more specific ones without restating the unknown
1018     # values of the more specific keys.
1019     my @realkeys;
1020     my @rundef;
1021     # We have to deal with RETURN-UNDEF specially, so that we don't
1022     # terminate the search prematurely.
1023     foreach (@keys) {
1024         if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
1025         push @realkeys, $_
1026     }
1027     foreach my $d (access_distros()) {
1028         push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
1029     }
1030     push @cfgs, map { "dgit.default.$_" } @realkeys;
1031     push @cfgs, @rundef;
1032     return @cfgs;
1033 }
1034
1035 sub access_cfg (@) {
1036     my (@keys) = @_;
1037     my (@cfgs) = access_cfg_cfgs(@keys);
1038     my $value = cfg(@cfgs);
1039     return $value;
1040 }
1041
1042 sub access_cfg_bool ($$) {
1043     my ($def, @keys) = @_;
1044     parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1045 }
1046
1047 sub string_to_ssh ($) {
1048     my ($spec) = @_;
1049     if ($spec =~ m/\s/) {
1050         return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1051     } else {
1052         return ($spec);
1053     }
1054 }
1055
1056 sub access_cfg_ssh () {
1057     my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1058     if (!defined $gitssh) {
1059         return @ssh;
1060     } else {
1061         return string_to_ssh $gitssh;
1062     }
1063 }
1064
1065 sub access_runeinfo ($) {
1066     my ($info) = @_;
1067     return ": dgit ".access_basedistro()." $info ;";
1068 }
1069
1070 sub access_someuserhost ($) {
1071     my ($some) = @_;
1072     my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1073     defined($user) && length($user) or
1074         $user = access_cfg("$some-user",'username');
1075     my $host = access_cfg("$some-host");
1076     return length($user) ? "$user\@$host" : $host;
1077 }
1078
1079 sub access_gituserhost () {
1080     return access_someuserhost('git');
1081 }
1082
1083 sub access_giturl (;$) {
1084     my ($optional) = @_;
1085     my $url = access_cfg('git-url','RETURN-UNDEF');
1086     my $suffix;
1087     if (!length $url) {
1088         my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1089         return undef unless defined $proto;
1090         $url =
1091             $proto.
1092             access_gituserhost().
1093             access_cfg('git-path');
1094     } else {
1095         $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1096     }
1097     $suffix //= '.git';
1098     return "$url/$package$suffix";
1099 }
1100
1101 sub commit_getclogp ($) {
1102     # Returns the parsed changelog hashref for a particular commit
1103     my ($objid) = @_;
1104     our %commit_getclogp_memo;
1105     my $memo = $commit_getclogp_memo{$objid};
1106     return $memo if $memo;
1107
1108     my $mclog = dgit_privdir()."clog";
1109     runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1110         "$objid:debian/changelog";
1111     $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1112 }
1113
1114 sub parse_dscdata () {
1115     my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
1116     printdebug Dumper($dscdata) if $debuglevel>1;
1117     $dsc = parsecontrolfh($dscfh,$dscurl,1);
1118     printdebug Dumper($dsc) if $debuglevel>1;
1119 }
1120
1121 our %rmad;
1122
1123 sub archive_query ($;@) {
1124     my ($method) = shift @_;
1125     fail __ "this operation does not support multiple comma-separated suites"
1126         if $isuite =~ m/,/;
1127     my $query = access_cfg('archive-query','RETURN-UNDEF');
1128     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1129     my $proto = $1;
1130     my $data = $'; #';
1131     { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1132 }
1133
1134 sub archive_query_prepend_mirror {
1135     my $m = access_cfg('mirror');
1136     return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1137 }
1138
1139 sub pool_dsc_subpath ($$) {
1140     my ($vsn,$component) = @_; # $package is implict arg
1141     my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1142     return "/pool/$component/$prefix/$package/".dscfn($vsn);
1143 }
1144
1145 sub cfg_apply_map ($$$) {
1146     my ($varref, $what, $mapspec) = @_;
1147     return unless $mapspec;
1148
1149     printdebug "config $what EVAL{ $mapspec; }\n";
1150     $_ = $$varref;
1151     eval "package Dgit::Config; $mapspec;";
1152     die $@ if $@;
1153     $$varref = $_;
1154 }
1155
1156 #---------- `ftpmasterapi' archive query method (nascent) ----------
1157
1158 sub archive_api_query_cmd ($) {
1159     my ($subpath) = @_;
1160     my @cmd = (@curl, qw(-sS));
1161     my $url = access_cfg('archive-query-url');
1162     if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1163         my $host = $1;
1164         my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1165         foreach my $key (split /\:/, $keys) {
1166             $key =~ s/\%HOST\%/$host/g;
1167             if (!stat $key) {
1168                 fail "for $url: stat $key: $!" unless $!==ENOENT;
1169                 next;
1170             }
1171             fail f_ "config requested specific TLS key but do not know".
1172                     " how to get curl to use exactly that EE key (%s)",
1173                     $key;
1174 #           push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1175 #           # Sadly the above line does not work because of changes
1176 #           # to gnutls.   The real fix for #790093 may involve
1177 #           # new curl options.
1178             last;
1179         }
1180         # Fixing #790093 properly will involve providing a value
1181         # for this on clients.
1182         my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1183         push @cmd, split / /, $kargs if defined $kargs;
1184     }
1185     push @cmd, $url.$subpath;
1186     return @cmd;
1187 }
1188
1189 sub api_query ($$;$) {
1190     use JSON;
1191     my ($data, $subpath, $ok404) = @_;
1192     badcfg __ "ftpmasterapi archive query method takes no data part"
1193         if length $data;
1194     my @cmd = archive_api_query_cmd($subpath);
1195     my $url = $cmd[$#cmd];
1196     push @cmd, qw(-w %{http_code});
1197     my $json = cmdoutput @cmd;
1198     unless ($json =~ s/\d+\d+\d$//) {
1199         failedcmd_report_cmd undef, @cmd;
1200         fail __ "curl failed to print 3-digit HTTP code";
1201     }
1202     my $code = $&;
1203     return undef if $code eq '404' && $ok404;
1204     fail f_ "fetch of %s gave HTTP code %s", $url, $code
1205         unless $url =~ m#^file://# or $code =~ m/^2/;
1206     return decode_json($json);
1207 }
1208
1209 sub canonicalise_suite_ftpmasterapi {
1210     my ($proto,$data) = @_;
1211     my $suites = api_query($data, 'suites');
1212     my @matched;
1213     foreach my $entry (@$suites) {
1214         next unless grep {
1215             my $v = $entry->{$_};
1216             defined $v && $v eq $isuite;
1217         } qw(codename name);
1218         push @matched, $entry;
1219     }
1220     fail f_ "unknown suite %s, maybe -d would help", $isuite
1221         unless @matched;
1222     my $cn;
1223     eval {
1224         @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1225         $cn = "$matched[0]{codename}";
1226         defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1227         $cn =~ m/^$suite_re$/
1228             or die f_ "suite %s maps to bad codename\n", $isuite;
1229     };
1230     die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1231         if length $@;
1232     return $cn;
1233 }
1234
1235 sub archive_query_ftpmasterapi {
1236     my ($proto,$data) = @_;
1237     my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1238     my @rows;
1239     my $digester = Digest::SHA->new(256);
1240     foreach my $entry (@$info) {
1241         eval {
1242             my $vsn = "$entry->{version}";
1243             my ($ok,$msg) = version_check $vsn;
1244             die f_ "bad version: %s\n", $msg unless $ok;
1245             my $component = "$entry->{component}";
1246             $component =~ m/^$component_re$/ or die __ "bad component";
1247             my $filename = "$entry->{filename}";
1248             $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1249                 or die __ "bad filename";
1250             my $sha256sum = "$entry->{sha256sum}";
1251             $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1252             push @rows, [ $vsn, "/pool/$component/$filename",
1253                           $digester, $sha256sum ];
1254         };
1255         die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1256             if length $@;
1257     }
1258     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1259     return archive_query_prepend_mirror @rows;
1260 }
1261
1262 sub file_in_archive_ftpmasterapi {
1263     my ($proto,$data,$filename) = @_;
1264     my $pat = $filename;
1265     $pat =~ s/_/\\_/g;
1266     $pat = "%/$pat";
1267     $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1268     my $info = api_query($data, "file_in_archive/$pat", 1);
1269 }
1270
1271 sub package_not_wholly_new_ftpmasterapi {
1272     my ($proto,$data,$pkg) = @_;
1273     my $info = api_query($data,"madison?package=${pkg}&f=json");
1274     return !!@$info;
1275 }
1276
1277 #---------- `aptget' archive query method ----------
1278
1279 our $aptget_base;
1280 our $aptget_releasefile;
1281 our $aptget_configpath;
1282
1283 sub aptget_aptget   () { return @aptget,   qw(-c), $aptget_configpath; }
1284 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1285
1286 sub aptget_cache_clean {
1287     runcmd_ordryrun_local qw(sh -ec),
1288         'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1289         'x', $aptget_base;
1290 }
1291
1292 sub aptget_lock_acquire () {
1293     my $lockfile = "$aptget_base/lock";
1294     open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1295     flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1296 }
1297
1298 sub aptget_prep ($) {
1299     my ($data) = @_;
1300     return if defined $aptget_base;
1301
1302     badcfg __ "aptget archive query method takes no data part"
1303         if length $data;
1304
1305     my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1306
1307     ensuredir $cache;
1308     ensuredir "$cache/dgit";
1309     my $cachekey =
1310         access_cfg('aptget-cachekey','RETURN-UNDEF')
1311         // access_nomdistro();
1312
1313     $aptget_base = "$cache/dgit/aptget";
1314     ensuredir $aptget_base;
1315
1316     my $quoted_base = $aptget_base;
1317     confess "$quoted_base contains bad chars, cannot continue"
1318         if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1319
1320     ensuredir $aptget_base;
1321
1322     aptget_lock_acquire();
1323
1324     aptget_cache_clean();
1325
1326     $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1327     my $sourceslist = "source.list#$cachekey";
1328
1329     my $aptsuites = $isuite;
1330     cfg_apply_map(\$aptsuites, 'suite map',
1331                   access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1332
1333     open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
1334     printf SRCS "deb-src %s %s %s\n",
1335         access_cfg('mirror'),
1336         $aptsuites,
1337         access_cfg('aptget-components')
1338         or confess "$!";
1339
1340     ensuredir "$aptget_base/cache";
1341     ensuredir "$aptget_base/lists";
1342
1343     open CONF, ">", $aptget_configpath or confess "$!";
1344     print CONF <<END;
1345 Debug::NoLocking "true";
1346 APT::Get::List-Cleanup "false";
1347 #clear APT::Update::Post-Invoke-Success;
1348 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1349 Dir::State::Lists "$quoted_base/lists";
1350 Dir::Etc::preferences "$quoted_base/preferences";
1351 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1352 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1353 END
1354
1355     foreach my $key (qw(
1356                         Dir::Cache
1357                         Dir::State
1358                         Dir::Cache::Archives
1359                         Dir::Etc::SourceParts
1360                         Dir::Etc::preferencesparts
1361                       )) {
1362         ensuredir "$aptget_base/$key";
1363         print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
1364     };
1365
1366     my $oldatime = (time // confess "$!") - 1;
1367     foreach my $oldlist (<$aptget_base/lists/*Release>) {
1368         next unless stat_exists $oldlist;
1369         my ($mtime) = (stat _)[9];
1370         utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1371     }
1372
1373     runcmd_ordryrun_local aptget_aptget(), qw(update);
1374
1375     my @releasefiles;
1376     foreach my $oldlist (<$aptget_base/lists/*Release>) {
1377         next unless stat_exists $oldlist;
1378         my ($atime) = (stat _)[8];
1379         next if $atime == $oldatime;
1380         push @releasefiles, $oldlist;
1381     }
1382     my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1383     @releasefiles = @inreleasefiles if @inreleasefiles;
1384     if (!@releasefiles) {
1385         fail f_ <<END, $isuite, $cache;
1386 apt seemed to not to update dgit's cached Release files for %s.
1387 (Perhaps %s
1388  is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1389 END
1390     }
1391     confess "apt updated too many Release files (@releasefiles), erk"
1392         unless @releasefiles == 1;
1393
1394     ($aptget_releasefile) = @releasefiles;
1395 }
1396
1397 sub canonicalise_suite_aptget {
1398     my ($proto,$data) = @_;
1399     aptget_prep($data);
1400
1401     my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1402
1403     foreach my $name (qw(Codename Suite)) {
1404         my $val = $release->{$name};
1405         if (defined $val) {
1406             printdebug "release file $name: $val\n";
1407             $val =~ m/^$suite_re$/o or fail f_
1408                 "Release file (%s) specifies intolerable %s",
1409                 $aptget_releasefile, $name;
1410             cfg_apply_map(\$val, 'suite rmap',
1411                           access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1412             return $val
1413         }
1414     }
1415     return $isuite;
1416 }
1417
1418 sub archive_query_aptget {
1419     my ($proto,$data) = @_;
1420     aptget_prep($data);
1421
1422     ensuredir "$aptget_base/source";
1423     foreach my $old (<$aptget_base/source/*.dsc>) {
1424         unlink $old or die "$old: $!";
1425     }
1426
1427     my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1428     return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1429     # avoids apt-get source failing with ambiguous error code
1430
1431     runcmd_ordryrun_local
1432         shell_cmd 'cd "$1"/source; shift', $aptget_base,
1433         aptget_aptget(), qw(--download-only --only-source source), $package;
1434
1435     my @dscs = <$aptget_base/source/*.dsc>;
1436     fail __ "apt-get source did not produce a .dsc" unless @dscs;
1437     fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1438         unless @dscs==1;
1439
1440     my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1441
1442     use URI::Escape;
1443     my $uri = "file://". uri_escape $dscs[0];
1444     $uri =~ s{\%2f}{/}gi;
1445     return [ (getfield $pre_dsc, 'Version'), $uri ];
1446 }
1447
1448 sub file_in_archive_aptget () { return undef; }
1449 sub package_not_wholly_new_aptget () { return undef; }
1450
1451 #---------- `dummyapicat' archive query method ----------
1452 # (untranslated, because this is for testing purposes etc.)
1453
1454 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1455 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1456
1457 sub dummycatapi_run_in_mirror ($@) {
1458     # runs $fn with FIA open onto rune
1459     my ($rune, $argl, $fn) = @_;
1460
1461     my $mirror = access_cfg('mirror');
1462     $mirror =~ s#^file://#/# or die "$mirror ?";
1463     my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1464                qw(x), $mirror, @$argl);
1465     debugcmd "-|", @cmd;
1466     open FIA, "-|", @cmd or confess "$!";
1467     my $r = $fn->();
1468     close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1469     return $r;
1470 }
1471
1472 sub file_in_archive_dummycatapi ($$$) {
1473     my ($proto,$data,$filename) = @_;
1474     my @out;
1475     dummycatapi_run_in_mirror '
1476             find -name "$1" -print0 |
1477             xargs -0r sha256sum
1478     ', [$filename], sub {
1479         while (<FIA>) {
1480             chomp or die;
1481             printdebug "| $_\n";
1482             m/^(\w+)  (\S+)$/ or die "$_ ?";
1483             push @out, { sha256sum => $1, filename => $2 };
1484         }
1485     };
1486     return \@out;
1487 }
1488
1489 sub package_not_wholly_new_dummycatapi {
1490     my ($proto,$data,$pkg) = @_;
1491     dummycatapi_run_in_mirror "
1492             find -name ${pkg}_*.dsc
1493     ", [], sub {
1494         local $/ = undef;
1495         !!<FIA>;
1496     };
1497 }
1498
1499 #---------- `madison' archive query method ----------
1500
1501 sub archive_query_madison {
1502     return archive_query_prepend_mirror
1503         map { [ @$_[0..1] ] } madison_get_parse(@_);
1504 }
1505
1506 sub madison_get_parse {
1507     my ($proto,$data) = @_;
1508     die unless $proto eq 'madison';
1509     if (!length $data) {
1510         $data= access_cfg('madison-distro','RETURN-UNDEF');
1511         $data //= access_basedistro();
1512     }
1513     $rmad{$proto,$data,$package} ||= cmdoutput
1514         qw(rmadison -asource),"-s$isuite","-u$data",$package;
1515     my $rmad = $rmad{$proto,$data,$package};
1516
1517     my @out;
1518     foreach my $l (split /\n/, $rmad) {
1519         $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1520                   \s*( [^ \t|]+ )\s* \|
1521                   \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1522                   \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1523         $1 eq $package or die "$rmad $package ?";
1524         my $vsn = $2;
1525         my $newsuite = $3;
1526         my $component;
1527         if (defined $4) {
1528             $component = $4;
1529         } else {
1530             $component = access_cfg('archive-query-default-component');
1531         }
1532         $5 eq 'source' or die "$rmad ?";
1533         push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1534     }
1535     return sort { -version_compare($a->[0],$b->[0]); } @out;
1536 }
1537
1538 sub canonicalise_suite_madison {
1539     # madison canonicalises for us
1540     my @r = madison_get_parse(@_);
1541     @r or fail f_
1542         "unable to canonicalise suite using package %s".
1543         " which does not appear to exist in suite %s;".
1544         " --existing-package may help",
1545         $package, $isuite;
1546     return $r[0][2];
1547 }
1548
1549 sub file_in_archive_madison { return undef; }
1550 sub package_not_wholly_new_madison { return undef; }
1551
1552 #---------- `sshpsql' archive query method ----------
1553 # (untranslated, because this is obsolete)
1554
1555 sub sshpsql ($$$) {
1556     my ($data,$runeinfo,$sql) = @_;
1557     if (!length $data) {
1558         $data= access_someuserhost('sshpsql').':'.
1559             access_cfg('sshpsql-dbname');
1560     }
1561     $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1562     my ($userhost,$dbname) = ($`,$'); #';
1563     my @rows;
1564     my @cmd = (access_cfg_ssh, $userhost,
1565                access_runeinfo("ssh-psql $runeinfo").
1566                " export LC_MESSAGES=C; export LC_CTYPE=C;".
1567                " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1568     debugcmd "|",@cmd;
1569     open P, "-|", @cmd or confess "$!";
1570     while (<P>) {
1571         chomp or die;
1572         printdebug(">|$_|\n");
1573         push @rows, $_;
1574     }
1575     $!=0; $?=0; close P or failedcmd @cmd;
1576     @rows or die;
1577     my $nrows = pop @rows;
1578     $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1579     @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1580     @rows = map { [ split /\|/, $_ ] } @rows;
1581     my $ncols = scalar @{ shift @rows };
1582     die if grep { scalar @$_ != $ncols } @rows;
1583     return @rows;
1584 }
1585
1586 sub sql_injection_check {
1587     foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1588 }
1589
1590 sub archive_query_sshpsql ($$) {
1591     my ($proto,$data) = @_;
1592     sql_injection_check $isuite, $package;
1593     my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1594         SELECT source.version, component.name, files.filename, files.sha256sum
1595           FROM source
1596           JOIN src_associations ON source.id = src_associations.source
1597           JOIN suite ON suite.id = src_associations.suite
1598           JOIN dsc_files ON dsc_files.source = source.id
1599           JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1600           JOIN component ON component.id = files_archive_map.component_id
1601           JOIN files ON files.id = dsc_files.file
1602          WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1603            AND source.source='$package'
1604            AND files.filename LIKE '%.dsc';
1605 END
1606     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1607     my $digester = Digest::SHA->new(256);
1608     @rows = map {
1609         my ($vsn,$component,$filename,$sha256sum) = @$_;
1610         [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1611     } @rows;
1612     return archive_query_prepend_mirror @rows;
1613 }
1614
1615 sub canonicalise_suite_sshpsql ($$) {
1616     my ($proto,$data) = @_;
1617     sql_injection_check $isuite;
1618     my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1619         SELECT suite.codename
1620           FROM suite where suite_name='$isuite' or codename='$isuite';
1621 END
1622     @rows = map { $_->[0] } @rows;
1623     fail "unknown suite $isuite" unless @rows;
1624     die "ambiguous $isuite: @rows ?" if @rows>1;
1625     return $rows[0];
1626 }
1627
1628 sub file_in_archive_sshpsql ($$$) { return undef; }
1629 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1630
1631 #---------- `dummycat' archive query method ----------
1632 # (untranslated, because this is for testing purposes etc.)
1633
1634 sub canonicalise_suite_dummycat ($$) {
1635     my ($proto,$data) = @_;
1636     my $dpath = "$data/suite.$isuite";
1637     if (!open C, "<", $dpath) {
1638         $!==ENOENT or die "$dpath: $!";
1639         printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1640         return $isuite;
1641     }
1642     $!=0; $_ = <C>;
1643     chomp or die "$dpath: $!";
1644     close C;
1645     printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1646     return $_;
1647 }
1648
1649 sub archive_query_dummycat ($$) {
1650     my ($proto,$data) = @_;
1651     canonicalise_suite();
1652     my $dpath = "$data/package.$csuite.$package";
1653     if (!open C, "<", $dpath) {
1654         $!==ENOENT or die "$dpath: $!";
1655         printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1656         return ();
1657     }
1658     my @rows;
1659     while (<C>) {
1660         next if m/^\#/;
1661         next unless m/\S/;
1662         die unless chomp;
1663         printdebug "dummycat query $csuite $package $dpath | $_\n";
1664         my @row = split /\s+/, $_;
1665         @row==2 or die "$dpath: $_ ?";
1666         push @rows, \@row;
1667     }
1668     C->error and die "$dpath: $!";
1669     close C;
1670     return archive_query_prepend_mirror
1671         sort { -version_compare($a->[0],$b->[0]); } @rows;
1672 }
1673
1674 sub file_in_archive_dummycat () { return undef; }
1675 sub package_not_wholly_new_dummycat () { return undef; }
1676
1677 #---------- archive query entrypoints and rest of program ----------
1678
1679 sub canonicalise_suite () {
1680     return if defined $csuite;
1681     fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1682     $csuite = archive_query('canonicalise_suite');
1683     if ($isuite ne $csuite) {
1684         progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1685     } else {
1686         progress f_ "canonical suite name is %s", $csuite;
1687     }
1688 }
1689
1690 sub get_archive_dsc () {
1691     canonicalise_suite();
1692     my @vsns = archive_query('archive_query');
1693     foreach my $vinfo (@vsns) {
1694         my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1695         $dscurl = $vsn_dscurl;
1696         $dscdata = url_get($dscurl);
1697         if (!$dscdata) {
1698             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1699             next;
1700         }
1701         if ($digester) {
1702             $digester->reset();
1703             $digester->add($dscdata);
1704             my $got = $digester->hexdigest();
1705             $got eq $digest or
1706                 fail f_ "%s has hash %s but archive told us to expect %s",
1707                         $dscurl, $got, $digest;
1708         }
1709         parse_dscdata();
1710         my $fmt = getfield $dsc, 'Format';
1711         $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1712             f_ "unsupported source format %s, sorry", $fmt;
1713
1714         $dsc_checked = !!$digester;
1715         printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1716         return;
1717     }
1718     $dsc = undef;
1719     printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1720 }
1721
1722 sub check_for_git ();
1723 sub check_for_git () {
1724     # returns 0 or 1
1725     my $how = access_cfg('git-check');
1726     if ($how eq 'ssh-cmd') {
1727         my @cmd =
1728             (access_cfg_ssh, access_gituserhost(),
1729              access_runeinfo("git-check $package").
1730              " set -e; cd ".access_cfg('git-path').";".
1731              " if test -d $package.git; then echo 1; else echo 0; fi");
1732         my $r= cmdoutput @cmd;
1733         if (defined $r and $r =~ m/^divert (\w+)$/) {
1734             my $divert=$1;
1735             my ($usedistro,) = access_distros();
1736             # NB that if we are pushing, $usedistro will be $distro/push
1737             $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1738             $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1739             progress f_ "diverting to %s (using config for %s)",
1740                         $divert, $instead_distro;
1741             return check_for_git();
1742         }
1743         failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1744         return $r+0;
1745     } elsif ($how eq 'url') {
1746         my $prefix = access_cfg('git-check-url','git-url');
1747         my $suffix = access_cfg('git-check-suffix','git-suffix',
1748                                 'RETURN-UNDEF') // '.git';
1749         my $url = "$prefix/$package$suffix";
1750         my @cmd = (@curl, qw(-sS -I), $url);
1751         my $result = cmdoutput @cmd;
1752         $result =~ s/^\S+ 200 .*\n\r?\n//;
1753         # curl -sS -I with https_proxy prints
1754         # HTTP/1.0 200 Connection established
1755         $result =~ m/^\S+ (404|200) /s or
1756             fail +(__ "unexpected results from git check query - ").
1757                 Dumper($prefix, $result);
1758         my $code = $1;
1759         if ($code eq '404') {
1760             return 0;
1761         } elsif ($code eq '200') {
1762             return 1;
1763         } else {
1764             die;
1765         }
1766     } elsif ($how eq 'true') {
1767         return 1;
1768     } elsif ($how eq 'false') {
1769         return 0;
1770     } else {
1771         badcfg f_ "unknown git-check \`%s'", $how;
1772     }
1773 }
1774
1775 sub create_remote_git_repo () {
1776     my $how = access_cfg('git-create');
1777     if ($how eq 'ssh-cmd') {
1778         runcmd_ordryrun
1779             (access_cfg_ssh, access_gituserhost(),
1780              access_runeinfo("git-create $package").
1781              "set -e; cd ".access_cfg('git-path').";".
1782              " cp -a _template $package.git");
1783     } elsif ($how eq 'true') {
1784         # nothing to do
1785     } else {
1786         badcfg f_ "unknown git-create \`%s'", $how;
1787     }
1788 }
1789
1790 our ($dsc_hash,$lastpush_mergeinput);
1791 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1792
1793
1794 sub prep_ud () {
1795     dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1796     $playground = fresh_playground 'dgit/unpack';
1797 }
1798
1799 sub mktree_in_ud_here () {
1800     playtree_setup $gitcfgs{local};
1801 }
1802
1803 sub git_write_tree () {
1804     my $tree = cmdoutput @git, qw(write-tree);
1805     $tree =~ m/^\w+$/ or die "$tree ?";
1806     return $tree;
1807 }
1808
1809 sub git_add_write_tree () {
1810     runcmd @git, qw(add -Af .);
1811     return git_write_tree();
1812 }
1813
1814 sub remove_stray_gits ($) {
1815     my ($what) = @_;
1816     my @gitscmd = qw(find -name .git -prune -print0);
1817     debugcmd "|",@gitscmd;
1818     open GITS, "-|", @gitscmd or confess "$!";
1819     {
1820         local $/="\0";
1821         while (<GITS>) {
1822             chomp or die;
1823             print STDERR f_ "%s: warning: removing from %s: %s\n",
1824                 $us, $what, (messagequote $_);
1825             rmtree $_;
1826         }
1827     }
1828     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1829 }
1830
1831 sub mktree_in_ud_from_only_subdir ($;$) {
1832     my ($what,$raw) = @_;
1833     # changes into the subdir
1834
1835     my (@dirs) = <*/.>;
1836     confess "expected one subdir but found @dirs ?" unless @dirs==1;
1837     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1838     my $dir = $1;
1839     changedir $dir;
1840
1841     remove_stray_gits($what);
1842     mktree_in_ud_here();
1843     if (!$raw) {
1844         my ($format, $fopts) = get_source_format();
1845         if (madformat($format)) {
1846             rmtree '.pc';
1847         }
1848     }
1849
1850     my $tree=git_add_write_tree();
1851     return ($tree,$dir);
1852 }
1853
1854 our @files_csum_info_fields =
1855     (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1856      ['Checksums-Sha1',  'Digest::SHA', 'new(1)',   'sha1sum'],
1857      ['Files',           'Digest::MD5', 'new()',    'md5sum']);
1858
1859 sub dsc_files_info () {
1860     foreach my $csumi (@files_csum_info_fields) {
1861         my ($fname, $module, $method) = @$csumi;
1862         my $field = $dsc->{$fname};
1863         next unless defined $field;
1864         eval "use $module; 1;" or die $@;
1865         my @out;
1866         foreach (split /\n/, $field) {
1867             next unless m/\S/;
1868             m/^(\w+) (\d+) (\S+)$/ or
1869                 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1870             my $digester = eval "$module"."->$method;" or die $@;
1871             push @out, {
1872                 Hash => $1,
1873                 Bytes => $2,
1874                 Filename => $3,
1875                 Digester => $digester,
1876             };
1877         }
1878         return @out;
1879     }
1880     fail f_ "missing any supported Checksums-* or Files field in %s",
1881             $dsc->get_option('name');
1882 }
1883
1884 sub dsc_files () {
1885     map { $_->{Filename} } dsc_files_info();
1886 }
1887
1888 sub files_compare_inputs (@) {
1889     my $inputs = \@_;
1890     my %record;
1891     my %fchecked;
1892
1893     my $showinputs = sub {
1894         return join "; ", map { $_->get_option('name') } @$inputs;
1895     };
1896
1897     foreach my $in (@$inputs) {
1898         my $expected_files;
1899         my $in_name = $in->get_option('name');
1900
1901         printdebug "files_compare_inputs $in_name\n";
1902
1903         foreach my $csumi (@files_csum_info_fields) {
1904             my ($fname) = @$csumi;
1905             printdebug "files_compare_inputs $in_name $fname\n";
1906
1907             my $field = $in->{$fname};
1908             next unless defined $field;
1909
1910             my @files;
1911             foreach (split /\n/, $field) {
1912                 next unless m/\S/;
1913
1914                 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1915                     fail "could not parse $in_name $fname line \`$_'";
1916
1917                 printdebug "files_compare_inputs $in_name $fname $f\n";
1918
1919                 push @files, $f;
1920
1921                 my $re = \ $record{$f}{$fname};
1922                 if (defined $$re) {
1923                     $fchecked{$f}{$in_name} = 1;
1924                     $$re eq $info or
1925                         fail f_
1926               "hash or size of %s varies in %s fields (between: %s)",
1927                                  $f, $fname, $showinputs->();
1928                 } else {
1929                     $$re = $info;
1930                 }
1931             }
1932             @files = sort @files;
1933             $expected_files //= \@files;
1934             "@$expected_files" eq "@files" or
1935                 fail f_ "file list in %s varies between hash fields!",
1936                         $in_name;
1937         }
1938         $expected_files or
1939             fail f_ "%s has no files list field(s)", $in_name;
1940     }
1941     printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1942         if $debuglevel>=2;
1943
1944     grep { keys %$_ == @$inputs-1 } values %fchecked
1945         or fail f_ "no file appears in all file lists (looked in: %s)",
1946                    $showinputs->();
1947 }
1948
1949 sub is_orig_file_in_dsc ($$) {
1950     my ($f, $dsc_files_info) = @_;
1951     return 0 if @$dsc_files_info <= 1;
1952     # One file means no origs, and the filename doesn't have a "what
1953     # part of dsc" component.  (Consider versions ending `.orig'.)
1954     return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1955     return 1;
1956 }
1957
1958 # This function determines whether a .changes file is source-only from
1959 # the point of view of dak.  Thus, it permits *_source.buildinfo
1960 # files.
1961 #
1962 # It does not, however, permit any other buildinfo files.  After a
1963 # source-only upload, the buildds will try to upload files like
1964 # foo_1.2.3_amd64.buildinfo.  If the package maintainer included files
1965 # named like this in their (otherwise) source-only upload, the uploads
1966 # of the buildd can be rejected by dak.  Fixing the resultant
1967 # situation can require manual intervention.  So we block such
1968 # .buildinfo files when the user tells us to perform a source-only
1969 # upload (such as when using the push-source subcommand with the -C
1970 # option, which calls this function).
1971 #
1972 # Note, though, that when dgit is told to prepare a source-only
1973 # upload, such as when subcommands like build-source and push-source
1974 # without -C are used, dgit has a more restrictive notion of
1975 # source-only .changes than dak: such uploads will never include
1976 # *_source.buildinfo files.  This is because there is no use for such
1977 # files when using a tool like dgit to produce the source package, as
1978 # dgit ensures the source is identical to git HEAD.
1979 sub test_source_only_changes ($) {
1980     my ($changes) = @_;
1981     foreach my $l (split /\n/, getfield $changes, 'Files') {
1982         $l =~ m/\S+$/ or next;
1983         # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1984         unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1985             print f_ "purportedly source-only changes polluted by %s\n", $&;
1986             return 0;
1987         }
1988     }
1989     return 1;
1990 }
1991
1992 sub changes_update_origs_from_dsc ($$$$) {
1993     my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1994     my %changes_f;
1995     printdebug "checking origs needed ($upstreamvsn)...\n";
1996     $_ = getfield $changes, 'Files';
1997     m/^\w+ \d+ (\S+ \S+) \S+$/m or
1998         fail __ "cannot find section/priority from .changes Files field";
1999     my $placementinfo = $1;
2000     my %changed;
2001     printdebug "checking origs needed placement '$placementinfo'...\n";
2002     foreach my $l (split /\n/, getfield $dsc, 'Files') {
2003         $l =~ m/\S+$/ or next;
2004         my $file = $&;
2005         printdebug "origs $file | $l\n";
2006         next unless is_orig_file_of_vsn $file, $upstreamvsn;
2007         printdebug "origs $file is_orig\n";
2008         my $have = archive_query('file_in_archive', $file);
2009         if (!defined $have) {
2010             print STDERR __ <<END;
2011 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2012 END
2013             return;
2014         }
2015         my $found_same = 0;
2016         my @found_differ;
2017         printdebug "origs $file \$#\$have=$#$have\n";
2018         foreach my $h (@$have) {
2019             my $same = 0;
2020             my @differ;
2021             foreach my $csumi (@files_csum_info_fields) {
2022                 my ($fname, $module, $method, $archivefield) = @$csumi;
2023                 next unless defined $h->{$archivefield};
2024                 $_ = $dsc->{$fname};
2025                 next unless defined;
2026                 m/^(\w+) .* \Q$file\E$/m or
2027                     fail f_ ".dsc %s missing entry for %s", $fname, $file;
2028                 if ($h->{$archivefield} eq $1) {
2029                     $same++;
2030                 } else {
2031                     push @differ, f_
2032                         "%s: %s (archive) != %s (local .dsc)",
2033                         $archivefield, $h->{$archivefield}, $1;
2034                 }
2035             }
2036             confess "$file ".Dumper($h)." ?!" if $same && @differ;
2037             $found_same++
2038                 if $same;
2039             push @found_differ,
2040                 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2041                 if @differ;
2042         }
2043         printdebug "origs $file f.same=$found_same".
2044             " #f._differ=$#found_differ\n";
2045         if (@found_differ && !$found_same) {
2046             fail join "\n",
2047                 (f_ "archive contains %s with different checksum", $file),
2048                 @found_differ;
2049         }
2050         # Now we edit the changes file to add or remove it
2051         foreach my $csumi (@files_csum_info_fields) {
2052             my ($fname, $module, $method, $archivefield) = @$csumi;
2053             next unless defined $changes->{$fname};
2054             if ($found_same) {
2055                 # in archive, delete from .changes if it's there
2056                 $changed{$file} = "removed" if
2057                     $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2058             } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2059                 # not in archive, but it's here in the .changes
2060             } else {
2061                 my $dsc_data = getfield $dsc, $fname;
2062                 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2063                 my $extra = $1;
2064                 $extra =~ s/ \d+ /$&$placementinfo /
2065                     or confess "$fname $extra >$dsc_data< ?"
2066                     if $fname eq 'Files';
2067                 $changes->{$fname} .= "\n". $extra;
2068                 $changed{$file} = "added";
2069             }
2070         }
2071     }
2072     if (%changed) {
2073         foreach my $file (keys %changed) {
2074             progress f_
2075                 "edited .changes for archive .orig contents: %s %s",
2076                 $changed{$file}, $file;
2077         }
2078         my $chtmp = "$changesfile.tmp";
2079         $changes->save($chtmp);
2080         if (act_local()) {
2081             rename $chtmp,$changesfile or die "$changesfile $!";
2082         } else {
2083             progress f_ "[new .changes left in %s]", $changesfile;
2084         }
2085     } else {
2086         progress f_ "%s already has appropriate .orig(s) (if any)",
2087                     $changesfile;
2088     }
2089 }
2090
2091 sub make_commit ($) {
2092     my ($file) = @_;
2093     return cmdoutput @git, qw(hash-object -w -t commit), $file;
2094 }
2095
2096 sub clogp_authline ($) {
2097     my ($clogp) = @_;
2098     my $author = getfield $clogp, 'Maintainer';
2099     if ($author =~ m/^[^"\@]+\,/) {
2100         # single entry Maintainer field with unquoted comma
2101         $author = ($& =~ y/,//rd).$'; # strip the comma
2102     }
2103     # git wants a single author; any remaining commas in $author
2104     # are by now preceded by @ (or ").  It seems safer to punt on
2105     # "..." for now rather than attempting to dequote or something.
2106     $author =~ s#,.*##ms unless $author =~ m/"/;
2107     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2108     my $authline = "$author $date";
2109     $authline =~ m/$git_authline_re/o or
2110         fail f_ "unexpected commit author line format \`%s'".
2111                 " (was generated from changelog Maintainer field)",
2112                 $authline;
2113     return ($1,$2,$3) if wantarray;
2114     return $authline;
2115 }
2116
2117 sub vendor_patches_distro ($$) {
2118     my ($checkdistro, $what) = @_;
2119     return unless defined $checkdistro;
2120
2121     my $series = "debian/patches/\L$checkdistro\E.series";
2122     printdebug "checking for vendor-specific $series ($what)\n";
2123
2124     if (!open SERIES, "<", $series) {
2125         confess "$series $!" unless $!==ENOENT;
2126         return;
2127     }
2128     while (<SERIES>) {
2129         next unless m/\S/;
2130         next if m/^\s+\#/;
2131
2132         print STDERR __ <<END;
2133
2134 Unfortunately, this source package uses a feature of dpkg-source where
2135 the same source package unpacks to different source code on different
2136 distros.  dgit cannot safely operate on such packages on affected
2137 distros, because the meaning of source packages is not stable.
2138
2139 Please ask the distro/maintainer to remove the distro-specific series
2140 files and use a different technique (if necessary, uploading actually
2141 different packages, if different distros are supposed to have
2142 different code).
2143
2144 END
2145         fail f_ "Found active distro-specific series file for".
2146                 " %s (%s): %s, cannot continue",
2147                 $checkdistro, $what, $series;
2148     }
2149     die "$series $!" if SERIES->error;
2150     close SERIES;
2151 }
2152
2153 sub check_for_vendor_patches () {
2154     # This dpkg-source feature doesn't seem to be documented anywhere!
2155     # But it can be found in the changelog (reformatted):
2156
2157     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
2158     #   Author: Raphael Hertzog <hertzog@debian.org>
2159     #   Date: Sun  Oct  3  09:36:48  2010 +0200
2160
2161     #   dpkg-source: correctly create .pc/.quilt_series with alternate
2162     #   series files
2163     #
2164     #   If you have debian/patches/ubuntu.series and you were
2165     #   unpacking the source package on ubuntu, quilt was still
2166     #   directed to debian/patches/series instead of
2167     #   debian/patches/ubuntu.series.
2168     #
2169     #   debian/changelog                        |    3 +++
2170     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
2171     #   2 files changed, 6 insertions(+), 1 deletion(-)
2172
2173     use Dpkg::Vendor;
2174     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2175     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2176                           __ "Dpkg::Vendor \`current vendor'");
2177     vendor_patches_distro(access_basedistro(),
2178                           __ "(base) distro being accessed");
2179     vendor_patches_distro(access_nomdistro(),
2180                           __ "(nominal) distro being accessed");
2181 }
2182
2183 sub check_bpd_exists () {
2184     stat $buildproductsdir
2185         or fail f_ "build-products-dir %s is not accessible: %s\n",
2186         $buildproductsdir, $!;
2187 }
2188
2189 sub dotdot_bpd_transfer_origs ($$$) {
2190     my ($bpd_abs, $upstreamversion, $wanted) = @_;
2191     # checks is_orig_file_of_vsn and if
2192     # calls $wanted->{$leaf} and expects boolish
2193
2194     return if $buildproductsdir eq '..';
2195
2196     my $warned;
2197     my $dotdot = $maindir;
2198     $dotdot =~ s{/[^/]+$}{};
2199     opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2200     while ($!=0, defined(my $leaf = readdir DD)) {
2201         {
2202             local ($debuglevel) = $debuglevel-1;
2203             printdebug "DD_BPD $leaf ?\n";
2204         }
2205         next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2206         next unless $wanted->($leaf);
2207         next if lstat "$bpd_abs/$leaf";
2208
2209         print STDERR f_
2210  "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2211             $us
2212             unless $warned++;
2213         $! == &ENOENT or fail f_
2214             "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2215         lstat "$dotdot/$leaf" or fail f_
2216             "check orig file %s in ..: %s", $leaf, $!;
2217         if (-l _) {
2218             stat "$dotdot/$leaf" or fail f_
2219                 "check target of orig symlink %s in ..: %s", $leaf, $!;
2220             my $ltarget = readlink "$dotdot/$leaf" or
2221                 die "readlink $dotdot/$leaf: $!";
2222             if ($ltarget !~ m{^/}) {
2223                 $ltarget = "$dotdot/$ltarget";
2224             }
2225             symlink $ltarget, "$bpd_abs/$leaf"
2226                 or die "$ltarget $bpd_abs $leaf: $!";
2227             print STDERR f_
2228  "%s: cloned orig symlink from ..: %s\n",
2229                 $us, $leaf;
2230         } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2231             print STDERR f_
2232  "%s: hardlinked orig from ..: %s\n",
2233                 $us, $leaf;
2234         } elsif ($! != EXDEV) {
2235             fail f_ "failed to make %s a hardlink to %s: %s",
2236                 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2237         } else {
2238             symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2239                 or die "$bpd_abs $dotdot $leaf $!";
2240             print STDERR f_
2241  "%s: symmlinked orig from .. on other filesystem: %s\n",
2242                 $us, $leaf;
2243         }
2244     }
2245     die "$dotdot; $!" if $!;
2246     closedir DD;
2247 }
2248
2249 sub generate_commits_from_dsc () {
2250     # See big comment in fetch_from_archive, below.
2251     # See also README.dsc-import.
2252     prep_ud();
2253     changedir $playground;
2254
2255     my $bpd_abs = bpd_abs();
2256     my $upstreamv = upstreamversion $dsc->{version};
2257     my @dfi = dsc_files_info();
2258
2259     dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2260         sub { grep { $_->{Filename} eq $_[0] } @dfi };
2261
2262     foreach my $fi (@dfi) {
2263         my $f = $fi->{Filename};
2264         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2265         my $upper_f = "$bpd_abs/$f";
2266
2267         printdebug "considering reusing $f: ";
2268
2269         if (link_ltarget "$upper_f,fetch", $f) {
2270             printdebug "linked (using ...,fetch).\n";
2271         } elsif ((printdebug "($!) "),
2272                  $! != ENOENT) {
2273             fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2274         } elsif (link_ltarget $upper_f, $f) {
2275             printdebug "linked.\n";
2276         } elsif ((printdebug "($!) "),
2277                  $! != ENOENT) {
2278             fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2279         } else {
2280             printdebug "absent.\n";
2281         }
2282
2283         my $refetched;
2284         complete_file_from_dsc('.', $fi, \$refetched)
2285             or next;
2286
2287         printdebug "considering saving $f: ";
2288
2289         if (rename_link_xf 1, $f, $upper_f) {
2290             printdebug "linked.\n";
2291         } elsif ((printdebug "($@) "),
2292                  $! != EEXIST) {
2293             fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2294         } elsif (!$refetched) {
2295             printdebug "no need.\n";
2296         } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2297             printdebug "linked (using ...,fetch).\n";
2298         } elsif ((printdebug "($@) "),
2299                  $! != EEXIST) {
2300             fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2301         } else {
2302             printdebug "cannot.\n";
2303         }
2304     }
2305
2306     # We unpack and record the orig tarballs first, so that we only
2307     # need disk space for one private copy of the unpacked source.
2308     # But we can't make them into commits until we have the metadata
2309     # from the debian/changelog, so we record the tree objects now and
2310     # make them into commits later.
2311     my @tartrees;
2312     my $orig_f_base = srcfn $upstreamv, '';
2313
2314     foreach my $fi (@dfi) {
2315         # We actually import, and record as a commit, every tarball
2316         # (unless there is only one file, in which case there seems
2317         # little point.
2318
2319         my $f = $fi->{Filename};
2320         printdebug "import considering $f ";
2321         (printdebug "only one dfi\n"), next if @dfi == 1;
2322         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2323         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2324         my $compr_ext = $1;
2325
2326         my ($orig_f_part) =
2327             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2328
2329         printdebug "Y ", (join ' ', map { $_//"(none)" }
2330                           $compr_ext, $orig_f_part
2331                          ), "\n";
2332
2333         my $input = new IO::File $f, '<' or die "$f $!";
2334         my $compr_pid;
2335         my @compr_cmd;
2336
2337         if (defined $compr_ext) {
2338             my $cname =
2339                 Dpkg::Compression::compression_guess_from_filename $f;
2340             fail "Dpkg::Compression cannot handle file $f in source package"
2341                 if defined $compr_ext && !defined $cname;
2342             my $compr_proc =
2343                 new Dpkg::Compression::Process compression => $cname;
2344             @compr_cmd = $compr_proc->get_uncompress_cmdline();
2345             my $compr_fh = new IO::Handle;
2346             my $compr_pid = open $compr_fh, "-|" // confess "$!";
2347             if (!$compr_pid) {
2348                 open STDIN, "<&", $input or confess "$!";
2349                 exec @compr_cmd;
2350                 die "dgit (child): exec $compr_cmd[0]: $!\n";
2351             }
2352             $input = $compr_fh;
2353         }
2354
2355         rmtree "_unpack-tar";
2356         mkdir "_unpack-tar" or confess "$!";
2357         my @tarcmd = qw(tar -x -f -
2358                         --no-same-owner --no-same-permissions
2359                         --no-acls --no-xattrs --no-selinux);
2360         my $tar_pid = fork // confess "$!";
2361         if (!$tar_pid) {
2362             chdir "_unpack-tar" or confess "$!";
2363             open STDIN, "<&", $input or confess "$!";
2364             exec @tarcmd;
2365             die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2366         }
2367         $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2368         !$? or failedcmd @tarcmd;
2369
2370         close $input or
2371             (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2372              : confess "$!");
2373         # finally, we have the results in "tarball", but maybe
2374         # with the wrong permissions
2375
2376         runcmd qw(chmod -R +rwX _unpack-tar);
2377         changedir "_unpack-tar";
2378         remove_stray_gits($f);
2379         mktree_in_ud_here();
2380
2381         my ($tree) = git_add_write_tree();
2382         my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2383         if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2384             $tree = $1;
2385             printdebug "one subtree $1\n";
2386         } else {
2387             printdebug "multiple subtrees\n";
2388         }
2389         changedir "..";
2390         rmtree "_unpack-tar";
2391
2392         my $ent = [ $f, $tree ];
2393         push @tartrees, {
2394             Orig => !!$orig_f_part,
2395             Sort => (!$orig_f_part         ? 2 :
2396                      $orig_f_part =~ m/-/g ? 1 :
2397                                              0),
2398             F => $f,
2399             Tree => $tree,
2400         };
2401     }
2402
2403     @tartrees = sort {
2404         # put any without "_" first (spec is not clear whether files
2405         # are always in the usual order).  Tarballs without "_" are
2406         # the main orig or the debian tarball.
2407         $a->{Sort} <=> $b->{Sort} or
2408         $a->{F}    cmp $b->{F}
2409     } @tartrees;
2410
2411     my $any_orig = grep { $_->{Orig} } @tartrees;
2412
2413     my $dscfn = "$package.dsc";
2414
2415     my $treeimporthow = 'package';
2416
2417     open D, ">", $dscfn or die "$dscfn: $!";
2418     print D $dscdata or die "$dscfn: $!";
2419     close D or die "$dscfn: $!";
2420     my @cmd = qw(dpkg-source);
2421     push @cmd, '--no-check' if $dsc_checked;
2422     if (madformat $dsc->{format}) {
2423         push @cmd, '--skip-patches';
2424         $treeimporthow = 'unpatched';
2425     }
2426     push @cmd, qw(-x --), $dscfn;
2427     runcmd @cmd;
2428
2429     my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2430     if (madformat $dsc->{format}) {
2431         check_for_vendor_patches();
2432     }
2433
2434     my $dappliedtree;
2435     if (madformat $dsc->{format}) {
2436         my @pcmd = qw(dpkg-source --before-build .);
2437         runcmd shell_cmd 'exec >/dev/null', @pcmd;
2438         rmtree '.pc';
2439         $dappliedtree = git_add_write_tree();
2440     }
2441
2442     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2443     my $clogp;
2444     my $r1clogp;
2445
2446     printdebug "import clog search...\n";
2447     parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2448         my ($thisstanza, $desc) = @_;
2449         no warnings qw(exiting);
2450
2451         $clogp //= $thisstanza;
2452
2453         printdebug "import clog $thisstanza->{version} $desc...\n";
2454
2455         last if !$any_orig; # we don't need $r1clogp
2456
2457         # We look for the first (most recent) changelog entry whose
2458         # version number is lower than the upstream version of this
2459         # package.  Then the last (least recent) previous changelog
2460         # entry is treated as the one which introduced this upstream
2461         # version and used for the synthetic commits for the upstream
2462         # tarballs.
2463
2464         # One might think that a more sophisticated algorithm would be
2465         # necessary.  But: we do not want to scan the whole changelog
2466         # file.  Stopping when we see an earlier version, which
2467         # necessarily then is an earlier upstream version, is the only
2468         # realistic way to do that.  Then, either the earliest
2469         # changelog entry we have seen so far is indeed the earliest
2470         # upload of this upstream version; or there are only changelog
2471         # entries relating to later upstream versions (which is not
2472         # possible unless the changelog and .dsc disagree about the
2473         # version).  Then it remains to choose between the physically
2474         # last entry in the file, and the one with the lowest version
2475         # number.  If these are not the same, we guess that the
2476         # versions were created in a non-monotonic order rather than
2477         # that the changelog entries have been misordered.
2478
2479         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2480
2481         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2482         $r1clogp = $thisstanza;
2483
2484         printdebug "import clog $r1clogp->{version} becomes r1\n";
2485     };
2486
2487     $clogp or fail __ "package changelog has no entries!";
2488
2489     my $authline = clogp_authline $clogp;
2490     my $changes = getfield $clogp, 'Changes';
2491     $changes =~ s/^\n//; # Changes: \n
2492     my $cversion = getfield $clogp, 'Version';
2493
2494     if (@tartrees) {
2495         $r1clogp //= $clogp; # maybe there's only one entry;
2496         my $r1authline = clogp_authline $r1clogp;
2497         # Strictly, r1authline might now be wrong if it's going to be
2498         # unused because !$any_orig.  Whatever.
2499
2500         printdebug "import tartrees authline   $authline\n";
2501         printdebug "import tartrees r1authline $r1authline\n";
2502
2503         foreach my $tt (@tartrees) {
2504             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2505
2506             my $mbody = f_ "Import %s", $tt->{F};
2507             $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2508 tree $tt->{Tree}
2509 author $r1authline
2510 committer $r1authline
2511
2512 $mbody
2513
2514 [dgit import orig $tt->{F}]
2515 END_O
2516 tree $tt->{Tree}
2517 author $authline
2518 committer $authline
2519
2520 $mbody
2521
2522 [dgit import tarball $package $cversion $tt->{F}]
2523 END_T
2524         }
2525     }
2526
2527     printdebug "import main commit\n";
2528
2529     open C, ">../commit.tmp" or confess "$!";
2530     print C <<END or confess "$!";
2531 tree $tree
2532 END
2533     print C <<END or confess "$!" foreach @tartrees;
2534 parent $_->{Commit}
2535 END
2536     print C <<END or confess "$!";
2537 author $authline
2538 committer $authline
2539
2540 $changes
2541
2542 [dgit import $treeimporthow $package $cversion]
2543 END
2544
2545     close C or confess "$!";
2546     my $rawimport_hash = make_commit qw(../commit.tmp);
2547
2548     if (madformat $dsc->{format}) {
2549         printdebug "import apply patches...\n";
2550
2551         # regularise the state of the working tree so that
2552         # the checkout of $rawimport_hash works nicely.
2553         my $dappliedcommit = make_commit_text(<<END);
2554 tree $dappliedtree
2555 author $authline
2556 committer $authline
2557
2558 [dgit dummy commit]
2559 END
2560         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2561
2562         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2563
2564         # We need the answers to be reproducible
2565         my @authline = clogp_authline($clogp);
2566         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2567         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2568         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2569         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
2570         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2571         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
2572
2573         my $path = $ENV{PATH} or die;
2574
2575         # we use ../../gbp-pq-output, which (given that we are in
2576         # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2577         # is .git/dgit.
2578
2579         foreach my $use_absurd (qw(0 1)) {
2580             runcmd @git, qw(checkout -q unpa);
2581             runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2582             local $ENV{PATH} = $path;
2583             if ($use_absurd) {
2584                 chomp $@;
2585                 progress "warning: $@";
2586                 $path = "$absurdity:$path";
2587                 progress f_ "%s: trying slow absurd-git-apply...", $us;
2588                 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2589                     or $!==ENOENT
2590                     or confess "$!";
2591             }
2592             eval {
2593                 die "forbid absurd git-apply\n" if $use_absurd
2594                     && forceing [qw(import-gitapply-no-absurd)];
2595                 die "only absurd git-apply!\n" if !$use_absurd
2596                     && forceing [qw(import-gitapply-absurd)];
2597
2598                 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2599                 local $ENV{PATH} = $path                    if $use_absurd;
2600
2601                 my @showcmd = (gbp_pq, qw(import));
2602                 my @realcmd = shell_cmd
2603                     'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2604                 debugcmd "+",@realcmd;
2605                 if (system @realcmd) {
2606                     die f_ "%s failed: %s\n",
2607                         +(shellquote @showcmd),
2608                         failedcmd_waitstatus();
2609                 }
2610
2611                 my $gapplied = git_rev_parse('HEAD');
2612                 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2613                 $gappliedtree eq $dappliedtree or
2614                     fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2615 gbp-pq import and dpkg-source disagree!
2616  gbp-pq import gave commit %s
2617  gbp-pq import gave tree %s
2618  dpkg-source --before-build gave tree %s
2619 END
2620                 $rawimport_hash = $gapplied;
2621             };
2622             last unless $@;
2623         }
2624         if ($@) {
2625             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2626             die $@;
2627         }
2628     }
2629
2630     progress f_ "synthesised git commit from .dsc %s", $cversion;
2631
2632     my $rawimport_mergeinput = {
2633         Commit => $rawimport_hash,
2634         Info => __ "Import of source package",
2635     };
2636     my @output = ($rawimport_mergeinput);
2637
2638     if ($lastpush_mergeinput) {
2639         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2640         my $oversion = getfield $oldclogp, 'Version';
2641         my $vcmp =
2642             version_compare($oversion, $cversion);
2643         if ($vcmp < 0) {
2644             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2645                 { ReverseParents => 1,
2646                   Message => (f_ <<END, $package, $cversion, $csuite) });
2647 Record %s (%s) in archive suite %s
2648 END
2649         } elsif ($vcmp > 0) {
2650             print STDERR f_ <<END, $cversion, $oversion,
2651
2652 Version actually in archive:   %s (older)
2653 Last version pushed with dgit: %s (newer or same)
2654 %s
2655 END
2656                 __ $later_warning_msg or confess "$!";
2657             @output = $lastpush_mergeinput;
2658         } else {
2659             # Same version.  Use what's in the server git branch,
2660             # discarding our own import.  (This could happen if the
2661             # server automatically imports all packages into git.)
2662             @output = $lastpush_mergeinput;
2663         }
2664     }
2665     changedir $maindir;
2666     rmtree $playground;
2667     return @output;
2668 }
2669
2670 sub complete_file_from_dsc ($$;$) {
2671     our ($dstdir, $fi, $refetched) = @_;
2672     # Ensures that we have, in $dstdir, the file $fi, with the correct
2673     # contents.  (Downloading it from alongside $dscurl if necessary.)
2674     # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2675     # and will set $$refetched=1 if it did so (or tried to).
2676
2677     my $f = $fi->{Filename};
2678     my $tf = "$dstdir/$f";
2679     my $downloaded = 0;
2680
2681     my $got;
2682     my $checkhash = sub {
2683         open F, "<", "$tf" or die "$tf: $!";
2684         $fi->{Digester}->reset();
2685         $fi->{Digester}->addfile(*F);
2686         F->error and confess "$!";
2687         $got = $fi->{Digester}->hexdigest();
2688         return $got eq $fi->{Hash};
2689     };
2690
2691     if (stat_exists $tf) {
2692         if ($checkhash->()) {
2693             progress f_ "using existing %s", $f;
2694             return 1;
2695         }
2696         if (!$refetched) {
2697             fail f_ "file %s has hash %s but .dsc demands hash %s".
2698                     " (perhaps you should delete this file?)",
2699                     $f, $got, $fi->{Hash};
2700         }
2701         progress f_ "need to fetch correct version of %s", $f;
2702         unlink $tf or die "$tf $!";
2703         $$refetched = 1;
2704     } else {
2705         printdebug "$tf does not exist, need to fetch\n";
2706     }
2707
2708     my $furl = $dscurl;
2709     $furl =~ s{/[^/]+$}{};
2710     $furl .= "/$f";
2711     die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2712     die "$f ?" if $f =~ m#/#;
2713     runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2714     return 0 if !act_local();
2715
2716     $checkhash->() or
2717         fail f_ "file %s has hash %s but .dsc demands hash %s".
2718                 " (got wrong file from archive!)",
2719                 $f, $got, $fi->{Hash};
2720
2721     return 1;
2722 }
2723
2724 sub ensure_we_have_orig () {
2725     my @dfi = dsc_files_info();
2726     foreach my $fi (@dfi) {
2727         my $f = $fi->{Filename};
2728         next unless is_orig_file_in_dsc($f, \@dfi);
2729         complete_file_from_dsc($buildproductsdir, $fi)
2730             or next;
2731     }
2732 }
2733
2734 #---------- git fetch ----------
2735
2736 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2737 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2738
2739 # We fetch some parts of lrfetchrefs/*.  Ideally we delete these
2740 # locally fetched refs because they have unhelpful names and clutter
2741 # up gitk etc.  So we track whether we have "used up" head ref (ie,
2742 # whether we have made another local ref which refers to this object).
2743 #
2744 # (If we deleted them unconditionally, then we might end up
2745 # re-fetching the same git objects each time dgit fetch was run.)
2746 #
2747 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2748 # in git_fetch_us to fetch the refs in question, and possibly a call
2749 # to lrfetchref_used.
2750
2751 our (%lrfetchrefs_f, %lrfetchrefs_d);
2752 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2753
2754 sub lrfetchref_used ($) {
2755     my ($fullrefname) = @_;
2756     my $objid = $lrfetchrefs_f{$fullrefname};
2757     $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2758 }
2759
2760 sub git_lrfetch_sane {
2761     my ($url, $supplementary, @specs) = @_;
2762     # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2763     # at least as regards @specs.  Also leave the results in
2764     # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2765     # able to clean these up.
2766     #
2767     # With $supplementary==1, @specs must not contain wildcards
2768     # and we add to our previous fetches (non-atomically).
2769
2770     # This is rather miserable:
2771     # When git fetch --prune is passed a fetchspec ending with a *,
2772     # it does a plausible thing.  If there is no * then:
2773     # - it matches subpaths too, even if the supplied refspec
2774     #   starts refs, and behaves completely madly if the source
2775     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2776     # - if there is no matching remote ref, it bombs out the whole
2777     #   fetch.
2778     # We want to fetch a fixed ref, and we don't know in advance
2779     # if it exists, so this is not suitable.
2780     #
2781     # Our workaround is to use git ls-remote.  git ls-remote has its
2782     # own qairks.  Notably, it has the absurd multi-tail-matching
2783     # behaviour: git ls-remote R refs/foo can report refs/foo AND
2784     # refs/refs/foo etc.
2785     #
2786     # Also, we want an idempotent snapshot, but we have to make two
2787     # calls to the remote: one to git ls-remote and to git fetch.  The
2788     # solution is use git ls-remote to obtain a target state, and
2789     # git fetch to try to generate it.  If we don't manage to generate
2790     # the target state, we try again.
2791
2792     printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2793
2794     my $specre = join '|', map {
2795         my $x = $_;
2796         $x =~ s/\W/\\$&/g;
2797         my $wildcard = $x =~ s/\\\*$/.*/;
2798         die if $wildcard && $supplementary;
2799         "(?:refs/$x)";
2800     } @specs;
2801     printdebug "git_lrfetch_sane specre=$specre\n";
2802     my $wanted_rref = sub {
2803         local ($_) = @_;
2804         return m/^(?:$specre)$/;
2805     };
2806
2807     my $fetch_iteration = 0;
2808     FETCH_ITERATION:
2809     for (;;) {
2810         printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2811         if (++$fetch_iteration > 10) {
2812             fail __ "too many iterations trying to get sane fetch!";
2813         }
2814
2815         my @look = map { "refs/$_" } @specs;
2816         my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2817         debugcmd "|",@lcmd;
2818
2819         my %wantr;
2820         open GITLS, "-|", @lcmd or confess "$!";
2821         while (<GITLS>) {
2822             printdebug "=> ", $_;
2823             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2824             my ($objid,$rrefname) = ($1,$2);
2825             if (!$wanted_rref->($rrefname)) {
2826                 print STDERR f_ <<END, "@look", $rrefname;
2827 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2828 END
2829                 next;
2830             }
2831             $wantr{$rrefname} = $objid;
2832         }
2833         $!=0; $?=0;
2834         close GITLS or failedcmd @lcmd;
2835
2836         # OK, now %want is exactly what we want for refs in @specs
2837         my @fspecs = map {
2838             !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2839             "+refs/$_:".lrfetchrefs."/$_";
2840         } @specs;
2841
2842         printdebug "git_lrfetch_sane fspecs @fspecs\n";
2843
2844         my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2845         runcmd_ordryrun_local @fcmd if @fspecs;
2846
2847         if (!$supplementary) {
2848             %lrfetchrefs_f = ();
2849         }
2850         my %objgot;
2851
2852         git_for_each_ref(lrfetchrefs, sub {
2853             my ($objid,$objtype,$lrefname,$reftail) = @_;
2854             $lrfetchrefs_f{$lrefname} = $objid;
2855             $objgot{$objid} = 1;
2856         });
2857
2858         if ($supplementary) {
2859             last;
2860         }
2861
2862         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2863             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2864             if (!exists $wantr{$rrefname}) {
2865                 if ($wanted_rref->($rrefname)) {
2866                     printdebug <<END;
2867 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2868 END
2869                 } else {
2870                     print STDERR f_ <<END, "@fspecs", $lrefname
2871 warning: git fetch %s created %s; this is silly, deleting it.
2872 END
2873                 }
2874                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2875                 delete $lrfetchrefs_f{$lrefname};
2876                 next;
2877             }
2878         }
2879         foreach my $rrefname (sort keys %wantr) {
2880             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2881             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2882             my $want = $wantr{$rrefname};
2883             next if $got eq $want;
2884             if (!defined $objgot{$want}) {
2885                 fail __ <<END unless act_local();
2886 --dry-run specified but we actually wanted the results of git fetch,
2887 so this is not going to work.  Try running dgit fetch first,
2888 or using --damp-run instead of --dry-run.
2889 END
2890                 print STDERR f_ <<END, $lrefname, $want;
2891 warning: git ls-remote suggests we want %s
2892 warning:  and it should refer to %s
2893 warning:  but git fetch didn't fetch that object to any relevant ref.
2894 warning:  This may be due to a race with someone updating the server.
2895 warning:  Will try again...
2896 END
2897                 next FETCH_ITERATION;
2898             }
2899             printdebug <<END;
2900 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2901 END
2902             runcmd_ordryrun_local @git, qw(update-ref -m),
2903                 "dgit fetch git fetch fixup", $lrefname, $want;
2904             $lrfetchrefs_f{$lrefname} = $want;
2905         }
2906         last;
2907     }
2908
2909     if (defined $csuite) {
2910         printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2911         git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2912             my ($objid,$objtype,$lrefname,$reftail) = @_;
2913             next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2914             runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2915         });
2916     }
2917
2918     printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2919         Dumper(\%lrfetchrefs_f);
2920 }
2921
2922 sub git_fetch_us () {
2923     # Want to fetch only what we are going to use, unless
2924     # deliberately-not-ff, in which case we must fetch everything.
2925
2926     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2927         map { "tags/$_" } debiantags('*',access_nomdistro);
2928     push @specs, server_branch($csuite);
2929     push @specs, $rewritemap;
2930     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2931
2932     my $url = access_giturl();
2933     git_lrfetch_sane $url, 0, @specs;
2934
2935     my %here;
2936     my @tagpats = debiantags('*',access_nomdistro);
2937
2938     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2939         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2940         printdebug "currently $fullrefname=$objid\n";
2941         $here{$fullrefname} = $objid;
2942     });
2943     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2944         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2945         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2946         printdebug "offered $lref=$objid\n";
2947         if (!defined $here{$lref}) {
2948             my @upd = (@git, qw(update-ref), $lref, $objid, '');
2949             runcmd_ordryrun_local @upd;
2950             lrfetchref_used $fullrefname;
2951         } elsif ($here{$lref} eq $objid) {
2952             lrfetchref_used $fullrefname;
2953         } else {
2954             print STDERR f_ "Not updating %s from %s to %s.\n",
2955                             $lref, $here{$lref}, $objid;
2956         }
2957     });
2958 }
2959
2960 #---------- dsc and archive handling ----------
2961
2962 sub mergeinfo_getclogp ($) {
2963     # Ensures thit $mi->{Clogp} exists and returns it
2964     my ($mi) = @_;
2965     $mi->{Clogp} = commit_getclogp($mi->{Commit});
2966 }
2967
2968 sub mergeinfo_version ($) {
2969     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2970 }
2971
2972 sub fetch_from_archive_record_1 ($) {
2973     my ($hash) = @_;
2974     runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2975     cmdoutput @git, qw(log -n2), $hash;
2976     # ... gives git a chance to complain if our commit is malformed
2977 }
2978
2979 sub fetch_from_archive_record_2 ($) {
2980     my ($hash) = @_;
2981     my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2982     if (act_local()) {
2983         cmdoutput @upd_cmd;
2984     } else {
2985         dryrun_report @upd_cmd;
2986     }
2987 }
2988
2989 sub parse_dsc_field_def_dsc_distro () {
2990     $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2991                            dgit.default.distro);
2992 }
2993
2994 sub parse_dsc_field ($$) {
2995     my ($dsc, $what) = @_;
2996     my $f;
2997     foreach my $field (@ourdscfield) {
2998         $f = $dsc->{$field};
2999         last if defined $f;
3000     }
3001
3002     if (!defined $f) {
3003         progress f_ "%s: NO git hash", $what;
3004         parse_dsc_field_def_dsc_distro();
3005     } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3006              = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3007         progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3008         $dsc_hint_tag = [ $dsc_hint_tag ];
3009     } elsif ($f =~ m/^\w+\s*$/) {
3010         $dsc_hash = $&;
3011         parse_dsc_field_def_dsc_distro();
3012         $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3013                           $dsc_distro ];
3014         progress f_ "%s: specified git hash", $what;
3015     } else {
3016         fail f_ "%s: invalid Dgit info", $what;
3017     }
3018 }
3019
3020 sub resolve_dsc_field_commit ($$) {
3021     my ($already_distro, $already_mapref) = @_;
3022
3023     return unless defined $dsc_hash;
3024
3025     my $mapref =
3026         defined $already_mapref &&
3027         ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3028         ? $already_mapref : undef;
3029
3030     my $do_fetch;
3031     $do_fetch = sub {
3032         my ($what, @fetch) = @_;
3033
3034         local $idistro = $dsc_distro;
3035         my $lrf = lrfetchrefs;
3036
3037         if (!$chase_dsc_distro) {
3038             progress f_ "not chasing .dsc distro %s: not fetching %s",
3039                         $dsc_distro, $what;
3040             return 0;
3041         }
3042
3043         progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3044
3045         my $url = access_giturl();
3046         if (!defined $url) {
3047             defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3048 .dsc Dgit metadata is in context of distro %s
3049 for which we have no configured url and .dsc provides no hint
3050 END
3051             my $proto =
3052                 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3053                 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3054             parse_cfg_bool "dsc-url-proto-ok", 'false',
3055                 cfg("dgit.dsc-url-proto-ok.$proto",
3056                     "dgit.default.dsc-url-proto-ok")
3057                 or fail f_ <<END, $dsc_distro, $proto;
3058 .dsc Dgit metadata is in context of distro %s
3059 for which we have no configured url;
3060 .dsc provides hinted url with protocol %s which is unsafe.
3061 (can be overridden by config - consult documentation)
3062 END
3063             $url = $dsc_hint_url;
3064         }
3065
3066         git_lrfetch_sane $url, 1, @fetch;
3067
3068         return $lrf;
3069     };
3070
3071     my $rewrite_enable = do {
3072         local $idistro = $dsc_distro;
3073         access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3074     };
3075
3076     if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3077         if (!defined $mapref) {
3078             my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3079             $mapref = $lrf.'/'.$rewritemap;
3080         }
3081         my $rewritemapdata = git_cat_file $mapref.':map';
3082         if (defined $rewritemapdata
3083             && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3084             progress __
3085                 "server's git history rewrite map contains a relevant entry!";
3086
3087             $dsc_hash = $1;
3088             if (defined $dsc_hash) {
3089                 progress __ "using rewritten git hash in place of .dsc value";
3090             } else {
3091                 progress __ "server data says .dsc hash is to be disregarded";
3092             }
3093         }
3094     }
3095
3096     if (!defined git_cat_file $dsc_hash) {
3097         my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3098         my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3099             defined git_cat_file $dsc_hash
3100             or fail f_ <<END, $dsc_hash;
3101 .dsc Dgit metadata requires commit %s
3102 but we could not obtain that object anywhere.
3103 END
3104         foreach my $t (@tags) {
3105             my $fullrefname = $lrf.'/'.$t;
3106 #           print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3107             next unless $lrfetchrefs_f{$fullrefname};
3108             next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3109             lrfetchref_used $fullrefname;
3110         }
3111     }
3112 }
3113
3114 sub fetch_from_archive () {
3115     check_bpd_exists();
3116     ensure_setup_existing_tree();
3117
3118     # Ensures that lrref() is what is actually in the archive, one way
3119     # or another, according to us - ie this client's
3120     # appropritaely-updated archive view.  Also returns the commit id.
3121     # If there is nothing in the archive, leaves lrref alone and
3122     # returns undef.  git_fetch_us must have already been called.
3123     get_archive_dsc();
3124
3125     if ($dsc) {
3126         parse_dsc_field($dsc, __ 'last upload to archive');
3127         resolve_dsc_field_commit access_basedistro,
3128             lrfetchrefs."/".$rewritemap
3129     } else {
3130         progress __ "no version available from the archive";
3131     }
3132
3133     # If the archive's .dsc has a Dgit field, there are three
3134     # relevant git commitids we need to choose between and/or merge
3135     # together:
3136     #   1. $dsc_hash: the Dgit field from the archive
3137     #   2. $lastpush_hash: the suite branch on the dgit git server
3138     #   3. $lastfetch_hash: our local tracking brach for the suite
3139     #
3140     # These may all be distinct and need not be in any fast forward
3141     # relationship:
3142     #
3143     # If the dsc was pushed to this suite, then the server suite
3144     # branch will have been updated; but it might have been pushed to
3145     # a different suite and copied by the archive.  Conversely a more
3146     # recent version may have been pushed with dgit but not appeared
3147     # in the archive (yet).
3148     #
3149     # $lastfetch_hash may be awkward because archive imports
3150     # (particularly, imports of Dgit-less .dscs) are performed only as
3151     # needed on individual clients, so different clients may perform a
3152     # different subset of them - and these imports are only made
3153     # public during push.  So $lastfetch_hash may represent a set of
3154     # imports different to a subsequent upload by a different dgit
3155     # client.
3156     #
3157     # Our approach is as follows:
3158     #
3159     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3160     # descendant of $dsc_hash, then it was pushed by a dgit user who
3161     # had based their work on $dsc_hash, so we should prefer it.
3162     # Otherwise, $dsc_hash was installed into this suite in the
3163     # archive other than by a dgit push, and (necessarily) after the
3164     # last dgit push into that suite (since a dgit push would have
3165     # been descended from the dgit server git branch); thus, in that
3166     # case, we prefer the archive's version (and produce a
3167     # pseudo-merge to overwrite the dgit server git branch).
3168     #
3169     # (If there is no Dgit field in the archive's .dsc then
3170     # generate_commit_from_dsc uses the version numbers to decide
3171     # whether the suite branch or the archive is newer.  If the suite
3172     # branch is newer it ignores the archive's .dsc; otherwise it
3173     # generates an import of the .dsc, and produces a pseudo-merge to
3174     # overwrite the suite branch with the archive contents.)
3175     #
3176     # The outcome of that part of the algorithm is the `public view',
3177     # and is same for all dgit clients: it does not depend on any
3178     # unpublished history in the local tracking branch.
3179     #
3180     # As between the public view and the local tracking branch: The
3181     # local tracking branch is only updated by dgit fetch, and
3182     # whenever dgit fetch runs it includes the public view in the
3183     # local tracking branch.  Therefore if the public view is not
3184     # descended from the local tracking branch, the local tracking
3185     # branch must contain history which was imported from the archive
3186     # but never pushed; and, its tip is now out of date.  So, we make
3187     # a pseudo-merge to overwrite the old imports and stitch the old
3188     # history in.
3189     #
3190     # Finally: we do not necessarily reify the public view (as
3191     # described above).  This is so that we do not end up stacking two
3192     # pseudo-merges.  So what we actually do is figure out the inputs
3193     # to any public view pseudo-merge and put them in @mergeinputs.
3194
3195     my @mergeinputs;
3196     # $mergeinputs[]{Commit}
3197     # $mergeinputs[]{Info}
3198     # $mergeinputs[0] is the one whose tree we use
3199     # @mergeinputs is in the order we use in the actual commit)
3200     #
3201     # Also:
3202     # $mergeinputs[]{Message} is a commit message to use
3203     # $mergeinputs[]{ReverseParents} if def specifies that parent
3204     #                                list should be in opposite order
3205     # Such an entry has no Commit or Info.  It applies only when found
3206     # in the last entry.  (This ugliness is to support making
3207     # identical imports to previous dgit versions.)
3208
3209     my $lastpush_hash = git_get_ref(lrfetchref());
3210     printdebug "previous reference hash=$lastpush_hash\n";
3211     $lastpush_mergeinput = $lastpush_hash && {
3212         Commit => $lastpush_hash,
3213         Info => (__ "dgit suite branch on dgit git server"),
3214     };
3215
3216     my $lastfetch_hash = git_get_ref(lrref());
3217     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3218     my $lastfetch_mergeinput = $lastfetch_hash && {
3219         Commit => $lastfetch_hash,
3220         Info => (__ "dgit client's archive history view"),
3221     };
3222
3223     my $dsc_mergeinput = $dsc_hash && {
3224         Commit => $dsc_hash,
3225         Info => (__ "Dgit field in .dsc from archive"),
3226     };
3227
3228     my $cwd = getcwd();
3229     my $del_lrfetchrefs = sub {
3230         changedir $cwd;
3231         my $gur;
3232         printdebug "del_lrfetchrefs...\n";
3233         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3234             my $objid = $lrfetchrefs_d{$fullrefname};
3235             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3236             if (!$gur) {
3237                 $gur ||= new IO::Handle;
3238                 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3239             }
3240             printf $gur "delete %s %s\n", $fullrefname, $objid;
3241         }
3242         if ($gur) {
3243             close $gur or failedcmd "git update-ref delete lrfetchrefs";
3244         }
3245     };
3246
3247     if (defined $dsc_hash) {
3248         ensure_we_have_orig();
3249         if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3250             @mergeinputs = $dsc_mergeinput
3251         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3252             print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3253
3254 Git commit in archive is behind the last version allegedly pushed/uploaded.
3255 Commit referred to by archive: %s
3256 Last version pushed with dgit: %s
3257 %s
3258 END
3259                 __ $later_warning_msg or confess "$!";
3260             @mergeinputs = ($lastpush_mergeinput);
3261         } else {
3262             # Archive has .dsc which is not a descendant of the last dgit
3263             # push.  This can happen if the archive moves .dscs about.
3264             # Just follow its lead.
3265             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3266                 progress __ "archive .dsc names newer git commit";
3267                 @mergeinputs = ($dsc_mergeinput);
3268             } else {
3269                 progress __ "archive .dsc names other git commit, fixing up";
3270                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3271             }
3272         }
3273     } elsif ($dsc) {
3274         @mergeinputs = generate_commits_from_dsc();
3275         # We have just done an import.  Now, our import algorithm might
3276         # have been improved.  But even so we do not want to generate
3277         # a new different import of the same package.  So if the
3278         # version numbers are the same, just use our existing version.
3279         # If the version numbers are different, the archive has changed
3280         # (perhaps, rewound).
3281         if ($lastfetch_mergeinput &&
3282             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3283                               (mergeinfo_version $mergeinputs[0]) )) {
3284             @mergeinputs = ($lastfetch_mergeinput);
3285         }
3286     } elsif ($lastpush_hash) {
3287         # only in git, not in the archive yet
3288         @mergeinputs = ($lastpush_mergeinput);
3289         print STDERR f_ <<END,
3290
3291 Package not found in the archive, but has allegedly been pushed using dgit.
3292 %s
3293 END
3294             __ $later_warning_msg or confess "$!";
3295     } else {
3296         printdebug "nothing found!\n";
3297         if (defined $skew_warning_vsn) {
3298             print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3299
3300 Warning: relevant archive skew detected.
3301 Archive allegedly contains %s
3302 But we were not able to obtain any version from the archive or git.
3303
3304 END
3305         }
3306         unshift @end, $del_lrfetchrefs;
3307         return undef;
3308     }
3309
3310     if ($lastfetch_hash &&
3311         !grep {
3312             my $h = $_->{Commit};
3313             $h and is_fast_fwd($lastfetch_hash, $h);
3314             # If true, one of the existing parents of this commit
3315             # is a descendant of the $lastfetch_hash, so we'll
3316             # be ff from that automatically.
3317         } @mergeinputs
3318         ) {
3319         # Otherwise:
3320         push @mergeinputs, $lastfetch_mergeinput;
3321     }
3322
3323     printdebug "fetch mergeinfos:\n";
3324     foreach my $mi (@mergeinputs) {
3325         if ($mi->{Info}) {
3326             printdebug " commit $mi->{Commit} $mi->{Info}\n";
3327         } else {
3328             printdebug sprintf " ReverseParents=%d Message=%s",
3329                 $mi->{ReverseParents}, $mi->{Message};
3330         }
3331     }
3332
3333     my $compat_info= pop @mergeinputs
3334         if $mergeinputs[$#mergeinputs]{Message};
3335
3336     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3337
3338     my $hash;
3339     if (@mergeinputs > 1) {
3340         # here we go, then:
3341         my $tree_commit = $mergeinputs[0]{Commit};
3342
3343         my $tree = get_tree_of_commit $tree_commit;;
3344
3345         # We use the changelog author of the package in question the
3346         # author of this pseudo-merge.  This is (roughly) correct if
3347         # this commit is simply representing aa non-dgit upload.
3348         # (Roughly because it does not record sponsorship - but we
3349         # don't have sponsorship info because that's in the .changes,
3350         # which isn't in the archivw.)
3351         #
3352         # But, it might be that we are representing archive history
3353         # updates (including in-archive copies).  These are not really
3354         # the responsibility of the person who created the .dsc, but
3355         # there is no-one whose name we should better use.  (The
3356         # author of the .dsc-named commit is clearly worse.)
3357
3358         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3359         my $author = clogp_authline $useclogp;
3360         my $cversion = getfield $useclogp, 'Version';
3361
3362         my $mcf = dgit_privdir()."/mergecommit";
3363         open MC, ">", $mcf or die "$mcf $!";
3364         print MC <<END or confess "$!";
3365 tree $tree
3366 END
3367
3368         my @parents = grep { $_->{Commit} } @mergeinputs;
3369         @parents = reverse @parents if $compat_info->{ReverseParents};
3370         print MC <<END or confess "$!" foreach @parents;
3371 parent $_->{Commit}
3372 END
3373
3374         print MC <<END or confess "$!";
3375 author $author
3376 committer $author
3377
3378 END
3379
3380         if (defined $compat_info->{Message}) {
3381             print MC $compat_info->{Message} or confess "$!";
3382         } else {
3383             print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3384 Record %s (%s) in archive suite %s
3385
3386 Record that
3387 END
3388             my $message_add_info = sub {
3389                 my ($mi) = (@_);
3390                 my $mversion = mergeinfo_version $mi;
3391                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
3392                     or confess "$!";
3393             };
3394
3395             $message_add_info->($mergeinputs[0]);
3396             print MC __ <<END or confess "$!";
3397 should be treated as descended from
3398 END
3399             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3400         }
3401
3402         close MC or confess "$!";
3403         $hash = make_commit $mcf;
3404     } else {
3405         $hash = $mergeinputs[0]{Commit};
3406     }
3407     printdebug "fetch hash=$hash\n";
3408
3409     my $chkff = sub {
3410         my ($lasth, $what) = @_;
3411         return unless $lasth;
3412         confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3413     };
3414
3415     $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3416         if $lastpush_hash;
3417     $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3418
3419     fetch_from_archive_record_1($hash);
3420
3421     if (defined $skew_warning_vsn) {
3422         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3423         my $gotclogp = commit_getclogp($hash);
3424         my $got_vsn = getfield $gotclogp, 'Version';
3425         printdebug "SKEW CHECK GOT $got_vsn\n";
3426         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3427             print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3428
3429 Warning: archive skew detected.  Using the available version:
3430 Archive allegedly contains    %s
3431 We were able to obtain only   %s
3432
3433 END
3434         }
3435     }
3436
3437     if ($lastfetch_hash ne $hash) {
3438         fetch_from_archive_record_2($hash);
3439     }
3440
3441     lrfetchref_used lrfetchref();
3442
3443     check_gitattrs($hash, __ "fetched source tree");
3444
3445     unshift @end, $del_lrfetchrefs;
3446     return $hash;
3447 }
3448
3449 sub set_local_git_config ($$) {
3450     my ($k, $v) = @_;
3451     runcmd @git, qw(config), $k, $v;
3452 }
3453
3454 sub setup_mergechangelogs (;$) {
3455     my ($always) = @_;
3456     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3457
3458     my $driver = 'dpkg-mergechangelogs';
3459     my $cb = "merge.$driver";
3460     confess unless defined $maindir;
3461     my $attrs = "$maindir_gitcommon/info/attributes";
3462     ensuredir "$maindir_gitcommon/info";
3463
3464     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3465     if (!open ATTRS, "<", $attrs) {
3466         $!==ENOENT or die "$attrs: $!";
3467     } else {
3468         while (<ATTRS>) {
3469             chomp;
3470             next if m{^debian/changelog\s};
3471             print NATTRS $_, "\n" or confess "$!";
3472         }
3473         ATTRS->error and confess "$!";
3474         close ATTRS;
3475     }
3476     print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3477     close NATTRS;
3478
3479     set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3480     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3481
3482     rename "$attrs.new", "$attrs" or die "$attrs: $!";
3483 }
3484
3485 sub setup_useremail (;$) {
3486     my ($always) = @_;
3487     return unless $always || access_cfg_bool(1, 'setup-useremail');
3488
3489     my $setup = sub {
3490         my ($k, $envvar) = @_;
3491         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3492         return unless defined $v;
3493         set_local_git_config "user.$k", $v;
3494     };
3495
3496     $setup->('email', 'DEBEMAIL');
3497     $setup->('name', 'DEBFULLNAME');
3498 }
3499
3500 sub ensure_setup_existing_tree () {
3501     my $k = "remote.$remotename.skipdefaultupdate";
3502     my $c = git_get_config $k;
3503     return if defined $c;
3504     set_local_git_config $k, 'true';
3505 }
3506
3507 sub open_main_gitattrs () {
3508     confess 'internal error no maindir' unless defined $maindir;
3509     my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3510         or $!==ENOENT
3511         or die "open $maindir_gitcommon/info/attributes: $!";
3512     return $gai;
3513 }
3514
3515 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3516
3517 sub is_gitattrs_setup () {
3518     # return values:
3519     #  trueish
3520     #     1: gitattributes set up and should be left alone
3521     #  falseish
3522     #     0: there is a dgit-defuse-attrs but it needs fixing
3523     #     undef: there is none
3524     my $gai = open_main_gitattrs();
3525     return 0 unless $gai;
3526     while (<$gai>) {
3527         next unless m{$gitattrs_ourmacro_re};
3528         return 1 if m{\s-working-tree-encoding\s};
3529         printdebug "is_gitattrs_setup: found old macro\n";
3530         return 0;
3531     }
3532     $gai->error and confess "$!";
3533     printdebug "is_gitattrs_setup: found nothing\n";
3534     return undef;
3535 }
3536
3537 sub setup_gitattrs (;$) {
3538     my ($always) = @_;
3539     return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3540
3541     my $already = is_gitattrs_setup();
3542     if ($already) {
3543         progress __ <<END;
3544 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3545  not doing further gitattributes setup
3546 END
3547         return;
3548     }
3549     my $new = "[attr]dgit-defuse-attrs  $negate_harmful_gitattrs";
3550     my $af = "$maindir_gitcommon/info/attributes";
3551     ensuredir "$maindir_gitcommon/info";
3552
3553     open GAO, "> $af.new" or confess "$!";
3554     print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3555 *       dgit-defuse-attrs
3556 $new
3557 END
3558 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3559 ENDT
3560     my $gai = open_main_gitattrs();
3561     if ($gai) {
3562         while (<$gai>) {
3563             if (m{$gitattrs_ourmacro_re}) {
3564                 die unless defined $already;
3565                 $_ = $new;
3566             }
3567             chomp;
3568             print GAO $_, "\n" or confess "$!";
3569         }
3570         $gai->error and confess "$!";
3571     }
3572     close GAO or confess "$!";
3573     rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3574 }
3575
3576 sub setup_new_tree () {
3577     setup_mergechangelogs();
3578     setup_useremail();
3579     setup_gitattrs();
3580 }
3581
3582 sub check_gitattrs ($$) {
3583     my ($treeish, $what) = @_;
3584
3585     return if is_gitattrs_setup;
3586
3587     local $/="\0";
3588     my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3589     debugcmd "|",@cmd;
3590     my $gafl = new IO::File;
3591     open $gafl, "-|", @cmd or confess "$!";
3592     while (<$gafl>) {
3593         chomp or die;
3594         s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3595         next if $1 == 0;
3596         next unless m{(?:^|/)\.gitattributes$};
3597
3598         # oh dear, found one
3599         print STDERR f_ <<END, $what;
3600 dgit: warning: %s contains .gitattributes
3601 dgit: .gitattributes not (fully) defused.  Recommended: dgit setup-new-tree.
3602 END
3603         close $gafl;
3604         return;
3605     }
3606     # tree contains no .gitattributes files
3607     $?=0; $!=0; close $gafl or failedcmd @cmd;
3608 }
3609
3610
3611 sub multisuite_suite_child ($$$) {
3612     my ($tsuite, $mergeinputs, $fn) = @_;
3613     # in child, sets things up, calls $fn->(), and returns undef
3614     # in parent, returns canonical suite name for $tsuite
3615     my $canonsuitefh = IO::File::new_tmpfile;
3616     my $pid = fork // confess "$!";
3617     if (!$pid) {
3618         forkcheck_setup();
3619         $isuite = $tsuite;
3620         $us .= " [$isuite]";
3621         $debugprefix .= " ";
3622         progress f_ "fetching %s...", $tsuite;
3623         canonicalise_suite();
3624         print $canonsuitefh $csuite, "\n" or confess "$!";
3625         close $canonsuitefh or confess "$!";
3626         $fn->();
3627         return undef;
3628     }
3629     waitpid $pid,0 == $pid or confess "$!";
3630     fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3631         if $? && $?!=256*4;
3632     seek $canonsuitefh,0,0 or confess "$!";
3633     local $csuite = <$canonsuitefh>;
3634     confess "$!" unless defined $csuite && chomp $csuite;
3635     if ($? == 256*4) {
3636         printdebug "multisuite $tsuite missing\n";
3637         return $csuite;
3638     }
3639     printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3640     push @$mergeinputs, {
3641         Ref => lrref,
3642         Info => $csuite,
3643     };
3644     return $csuite;
3645 }
3646
3647 sub fork_for_multisuite ($) {
3648     my ($before_fetch_merge) = @_;
3649     # if nothing unusual, just returns ''
3650     #
3651     # if multisuite:
3652     # returns 0 to caller in child, to do first of the specified suites
3653     # in child, $csuite is not yet set
3654     #
3655     # returns 1 to caller in parent, to finish up anything needed after
3656     # in parent, $csuite is set to canonicalised portmanteau
3657
3658     my $org_isuite = $isuite;
3659     my @suites = split /\,/, $isuite;
3660     return '' unless @suites > 1;
3661     printdebug "fork_for_multisuite: @suites\n";
3662
3663     my @mergeinputs;
3664
3665     my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3666                                             sub { });
3667     return 0 unless defined $cbasesuite;
3668
3669     fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3670         unless @mergeinputs;
3671
3672     my @csuites = ($cbasesuite);
3673
3674     $before_fetch_merge->();
3675
3676     foreach my $tsuite (@suites[1..$#suites]) {
3677         $tsuite =~ s/^-/$cbasesuite-/;
3678         my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3679                                                sub {
3680             @end = ();
3681             fetch_one();
3682             finish 0;
3683         });
3684
3685         $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3686         push @csuites, $csubsuite;
3687     }
3688
3689     foreach my $mi (@mergeinputs) {
3690         my $ref = git_get_ref $mi->{Ref};
3691         die "$mi->{Ref} ?" unless length $ref;
3692         $mi->{Commit} = $ref;
3693     }
3694
3695     $csuite = join ",", @csuites;
3696
3697     my $previous = git_get_ref lrref;
3698     if ($previous) {
3699         unshift @mergeinputs, {
3700             Commit => $previous,
3701             Info => (__ "local combined tracking branch"),
3702             Warning => (__
3703  "archive seems to have rewound: local tracking branch is ahead!"),
3704         };
3705     }
3706
3707     foreach my $ix (0..$#mergeinputs) {
3708         $mergeinputs[$ix]{Index} = $ix;
3709     }
3710
3711     @mergeinputs = sort {
3712         -version_compare(mergeinfo_version $a,
3713                          mergeinfo_version $b) # highest version first
3714             or
3715         $a->{Index} <=> $b->{Index}; # earliest in spec first
3716     } @mergeinputs;
3717
3718     my @needed;
3719
3720   NEEDED:
3721     foreach my $mi (@mergeinputs) {
3722         printdebug "multisuite merge check $mi->{Info}\n";
3723         foreach my $previous (@needed) {
3724             next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3725             printdebug "multisuite merge un-needed $previous->{Info}\n";
3726             next NEEDED;
3727         }
3728         push @needed, $mi;
3729         printdebug "multisuite merge this-needed\n";
3730         $mi->{Character} = '+';
3731     }
3732
3733     $needed[0]{Character} = '*';
3734
3735     my $output = $needed[0]{Commit};
3736
3737     if (@needed > 1) {
3738         printdebug "multisuite merge nontrivial\n";
3739         my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3740
3741         my $commit = "tree $tree\n";
3742         my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3743                      "Input branches:\n",
3744                      $csuite;
3745
3746         foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3747             printdebug "multisuite merge include $mi->{Info}\n";
3748             $mi->{Character} //= ' ';
3749             $commit .= "parent $mi->{Commit}\n";
3750             $msg .= sprintf " %s  %-25s %s\n",
3751                 $mi->{Character},
3752                 (mergeinfo_version $mi),
3753                 $mi->{Info};
3754         }
3755         my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3756         $msg .= __ "\nKey\n".
3757             " * marks the highest version branch, which choose to use\n".
3758             " + marks each branch which was not already an ancestor\n\n";
3759         $msg .=
3760             "[dgit multi-suite $csuite]\n";
3761         $commit .=
3762             "author $authline\n".
3763             "committer $authline\n\n";
3764         $output = make_commit_text $commit.$msg;
3765         printdebug "multisuite merge generated $output\n";
3766     }
3767
3768     fetch_from_archive_record_1($output);
3769     fetch_from_archive_record_2($output);
3770
3771     progress f_ "calculated combined tracking suite %s", $csuite;
3772
3773     return 1;
3774 }
3775
3776 sub clone_set_head () {
3777     open H, "> .git/HEAD" or confess "$!";
3778     print H "ref: ".lref()."\n" or confess "$!";
3779     close H or confess "$!";
3780 }
3781 sub clone_finish ($) {
3782     my ($dstdir) = @_;
3783     runcmd @git, qw(reset --hard), lrref();
3784     runcmd qw(bash -ec), <<'END';
3785         set -o pipefail
3786         git ls-tree -r --name-only -z HEAD | \
3787         xargs -0r touch -h -r . --
3788 END
3789     printdone f_ "ready for work in %s", $dstdir;
3790 }
3791
3792 sub clone ($) {
3793     # in multisuite, returns twice!
3794     # once in parent after first suite fetched,
3795     # and then again in child after everything is finished
3796     my ($dstdir) = @_;
3797     badusage __ "dry run makes no sense with clone" unless act_local();
3798
3799     my $multi_fetched = fork_for_multisuite(sub {
3800         printdebug "multi clone before fetch merge\n";
3801         changedir $dstdir;
3802         record_maindir();
3803     });
3804     if ($multi_fetched) {
3805         printdebug "multi clone after fetch merge\n";
3806         clone_set_head();
3807         clone_finish($dstdir);
3808         return;
3809     }
3810     printdebug "clone main body\n";
3811
3812     mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3813     changedir $dstdir;
3814     check_bpd_exists();
3815
3816     canonicalise_suite();
3817     my $hasgit = check_for_git();
3818
3819     runcmd @git, qw(init -q);
3820     record_maindir();
3821     setup_new_tree();
3822     clone_set_head();
3823     my $giturl = access_giturl(1);
3824     if (defined $giturl) {
3825         runcmd @git, qw(remote add), 'origin', $giturl;
3826     }
3827     if ($hasgit) {
3828         progress __ "fetching existing git history";
3829         git_fetch_us();
3830         runcmd_ordryrun_local @git, qw(fetch origin);
3831     } else {
3832         progress __ "starting new git history";
3833     }
3834     fetch_from_archive() or no_such_package;
3835     my $vcsgiturl = $dsc->{'Vcs-Git'};
3836     if (length $vcsgiturl) {
3837         $vcsgiturl =~ s/\s+-b\s+\S+//g;
3838         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3839     }
3840     clone_finish($dstdir);
3841 }
3842
3843 sub fetch_one () {
3844     canonicalise_suite();
3845     if (check_for_git()) {
3846         git_fetch_us();
3847     }
3848     fetch_from_archive() or no_such_package();
3849
3850     my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3851     if (length $vcsgiturl and
3852         (grep { $csuite eq $_ }
3853          split /\;/,
3854          cfg 'dgit.vcs-git.suites')) {
3855         my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3856         if (defined $current && $current ne $vcsgiturl) {
3857             print STDERR f_ <<END, $csuite;
3858 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3859  Your vcs-git remote url may be out of date.  Use dgit update-vcs-git ?
3860 END
3861         }
3862     }
3863     printdone f_ "fetched into %s", lrref();
3864 }
3865
3866 sub dofetch () {
3867     my $multi_fetched = fork_for_multisuite(sub { });
3868     fetch_one() unless $multi_fetched; # parent
3869     finish 0 if $multi_fetched eq '0'; # child
3870 }
3871
3872 sub pull () {
3873     dofetch();
3874     runcmd_ordryrun_local @git, qw(merge -m),
3875         (f_ "Merge from %s [dgit]", $csuite),
3876         lrref();
3877     printdone f_ "fetched to %s and merged into HEAD", lrref();
3878 }
3879
3880 sub check_not_dirty () {
3881     my @forbid = qw(local-options local-patch-header);
3882     @forbid = map { "debian/source/$_" } @forbid;
3883     foreach my $f (@forbid) {
3884         if (stat_exists $f) {
3885             fail f_ "git tree contains %s", $f;
3886         }
3887     }
3888
3889     my @cmd = (@git, qw(status -uall --ignored --porcelain));
3890     push @cmd, qw(debian/source/format debian/source/options);
3891     push @cmd, @forbid;
3892
3893     my $bad = cmdoutput @cmd;
3894     if (length $bad) {
3895         fail +(__
3896  "you have uncommitted changes to critical files, cannot continue:\n").
3897               $bad;
3898     }
3899
3900     return if $includedirty;
3901
3902     git_check_unmodified();
3903 }
3904
3905 sub commit_admin ($) {
3906     my ($m) = @_;
3907     progress "$m";
3908     runcmd_ordryrun_local @git, qw(commit -m), $m;
3909 }
3910
3911 sub quiltify_nofix_bail ($$) {
3912     my ($headinfo, $xinfo) = @_;
3913     if ($quilt_mode eq 'nofix') {
3914         fail f_
3915             "quilt fixup required but quilt mode is \`nofix'\n".
3916             "HEAD commit%s differs from tree implied by debian/patches%s",
3917             $headinfo, $xinfo;
3918     }
3919 }
3920
3921 sub commit_quilty_patch () {
3922     my $output = cmdoutput @git, qw(status --ignored --porcelain);
3923     my %adds;
3924     foreach my $l (split /\n/, $output) {
3925         next unless $l =~ m/\S/;
3926         if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3927             $adds{$1}++;
3928         }
3929     }
3930     delete $adds{'.pc'}; # if there wasn't one before, don't add it
3931     if (!%adds) {
3932         progress __ "nothing quilty to commit, ok.";
3933         return;
3934     }
3935     quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3936     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3937     runcmd_ordryrun_local @git, qw(add -f), @adds;
3938     commit_admin +(__ <<ENDT).<<END
3939 Commit Debian 3.0 (quilt) metadata
3940
3941 ENDT
3942 [dgit ($our_version) quilt-fixup]
3943 END
3944 }
3945
3946 sub get_source_format () {
3947     my %options;
3948     if (open F, "debian/source/options") {
3949         while (<F>) {
3950             next if m/^\s*\#/;
3951             next unless m/\S/;
3952             s/\s+$//; # ignore missing final newline
3953             if (m/\s*\#\s*/) {
3954                 my ($k, $v) = ($`, $'); #');
3955                 $v =~ s/^"(.*)"$/$1/;
3956                 $options{$k} = $v;
3957             } else {
3958                 $options{$_} = 1;
3959             }
3960         }
3961         F->error and confess "$!";
3962         close F;
3963     } else {
3964         confess "$!" unless $!==&ENOENT;
3965     }
3966
3967     if (!open F, "debian/source/format") {
3968         confess "$!" unless $!==&ENOENT;
3969         return '';
3970     }
3971     $_ = <F>;
3972     F->error and confess "$!";
3973     chomp;
3974     return ($_, \%options);
3975 }
3976
3977 sub madformat_wantfixup ($) {
3978     my ($format) = @_;
3979     return 0 unless $format eq '3.0 (quilt)';
3980     our $quilt_mode_warned;
3981     if ($quilt_mode eq 'nocheck') {
3982         progress f_ "Not doing any fixup of \`%s'".
3983             " due to ----no-quilt-fixup or --quilt=nocheck", $format
3984             unless $quilt_mode_warned++;
3985         return 0;
3986     }
3987     progress f_ "Format \`%s', need to check/update patch stack", $format
3988         unless $quilt_mode_warned++;
3989     return 1;
3990 }
3991
3992 sub maybe_split_brain_save ($$$) {
3993     my ($headref, $dgitview, $msg) = @_;
3994     # => message fragment "$saved" describing disposition of $dgitview
3995     #    (used inside parens, in the English texts)
3996     my $save = $internal_object_save{'dgit-view'};
3997     return f_ "commit id %s", $dgitview unless defined $save;
3998     my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3999                git_update_ref_cmd
4000                "dgit --dgit-view-save $msg HEAD=$headref",
4001                $save, $dgitview);
4002     runcmd @cmd;
4003     return f_ "and left in %s", $save;
4004 }
4005
4006 # An "infopair" is a tuple [ $thing, $what ]
4007 # (often $thing is a commit hash; $what is a description)
4008
4009 sub infopair_cond_equal ($$) {
4010     my ($x,$y) = @_;
4011     $x->[0] eq $y->[0] or fail <<END;
4012 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4013 END
4014 };
4015
4016 sub infopair_lrf_tag_lookup ($$) {
4017     my ($tagnames, $what) = @_;
4018     # $tagname may be an array ref
4019     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4020     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4021     foreach my $tagname (@tagnames) {
4022         my $lrefname = lrfetchrefs."/tags/$tagname";
4023         my $tagobj = $lrfetchrefs_f{$lrefname};
4024         next unless defined $tagobj;
4025         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4026         return [ git_rev_parse($tagobj), $what ];
4027     }
4028     fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4029 Wanted tag %s (%s) on dgit server, but not found
4030 END
4031                       : (f_ <<END, $what, "@tagnames");
4032 Wanted tag %s (one of: %s) on dgit server, but not found
4033 END
4034 }
4035
4036 sub infopair_cond_ff ($$) {
4037     my ($anc,$desc) = @_;
4038     is_fast_fwd($anc->[0], $desc->[0]) or
4039         fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4040 %s (%s) .. %s (%s) is not fast forward
4041 END
4042 };
4043
4044 sub pseudomerge_version_check ($$) {
4045     my ($clogp, $archive_hash) = @_;
4046
4047     my $arch_clogp = commit_getclogp $archive_hash;
4048     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4049                      __ 'version currently in archive' ];
4050     if (defined $overwrite_version) {
4051         if (length $overwrite_version) {
4052             infopair_cond_equal([ $overwrite_version,
4053                                   '--overwrite= version' ],
4054                                 $i_arch_v);
4055         } else {
4056             my $v = $i_arch_v->[0];
4057             progress f_
4058                 "Checking package changelog for archive version %s ...", $v;
4059             my $cd;
4060             eval {
4061                 my @xa = ("-f$v", "-t$v");
4062                 my $vclogp = parsechangelog @xa;
4063                 my $gf = sub {
4064                     my ($fn) = @_;
4065                     [ (getfield $vclogp, $fn),
4066                       (f_ "%s field from dpkg-parsechangelog %s",
4067                           $fn, "@xa") ];
4068                 };
4069                 my $cv = $gf->('Version');
4070                 infopair_cond_equal($i_arch_v, $cv);
4071                 $cd = $gf->('Distribution');
4072             };
4073             if ($@) {
4074                 $@ =~ s/^\n//s;
4075                 $@ =~ s/^dgit: //gm;
4076                 fail "$@".
4077                     f_ "Perhaps debian/changelog does not mention %s ?", $v;
4078             }
4079             fail f_ <<END, $cd->[1], $cd->[0], $v
4080 %s is %s
4081 Your tree seems to based on earlier (not uploaded) %s.
4082 END
4083                 if $cd->[0] =~ m/UNRELEASED/;
4084         }
4085     }
4086
4087     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4088     return $i_arch_v;
4089 }
4090
4091 sub pseudomerge_make_commit ($$$$ $$) {
4092     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4093         $msg_cmd, $msg_msg) = @_;
4094     progress f_ "Declaring that HEAD includes all changes in %s...",
4095                  $i_arch_v->[0];
4096
4097     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4098     my $authline = clogp_authline $clogp;
4099
4100     chomp $msg_msg;
4101     $msg_cmd .=
4102         !defined $overwrite_version ? ""
4103         : !length  $overwrite_version ? " --overwrite"
4104         : " --overwrite=".$overwrite_version;
4105
4106     # Contributing parent is the first parent - that makes
4107     # git rev-list --first-parent DTRT.
4108     my $pmf = dgit_privdir()."/pseudomerge";
4109     open MC, ">", $pmf or die "$pmf $!";
4110     print MC <<END or confess "$!";
4111 tree $tree
4112 parent $dgitview
4113 parent $archive_hash
4114 author $authline
4115 committer $authline
4116
4117 $msg_msg
4118
4119 [$msg_cmd]
4120 END
4121     close MC or confess "$!";
4122
4123     return make_commit($pmf);
4124 }
4125
4126 sub splitbrain_pseudomerge ($$$$) {
4127     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4128     # => $merged_dgitview
4129     printdebug "splitbrain_pseudomerge...\n";
4130     #
4131     #     We:      debian/PREVIOUS    HEAD($maintview)
4132     # expect:          o ----------------- o
4133     #                    \                   \
4134     #                     o                   o
4135     #                 a/d/PREVIOUS        $dgitview
4136     #                $archive_hash              \
4137     #  If so,                \                   \
4138     #  we do:                 `------------------ o
4139     #   this:                                   $dgitview'
4140     #
4141
4142     return $dgitview unless defined $archive_hash;
4143     return $dgitview if deliberately_not_fast_forward();
4144
4145     printdebug "splitbrain_pseudomerge...\n";
4146
4147     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4148
4149     if (!defined $overwrite_version) {
4150         progress __ "Checking that HEAD includes all changes in archive...";
4151     }
4152
4153     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4154
4155     if (defined $overwrite_version) {
4156     } elsif (!eval {
4157         my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4158         my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4159                                               __ "maintainer view tag");
4160         my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4161         my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4162         my $i_archive = [ $archive_hash, __ "current archive contents" ];
4163
4164         printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4165
4166         infopair_cond_equal($i_dgit, $i_archive);
4167         infopair_cond_ff($i_dep14, $i_dgit);
4168         infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4169         1;
4170     }) {
4171         $@ =~ s/^\n//; chomp $@;
4172         print STDERR <<END.(__ <<ENDT);
4173 $@
4174 END
4175 | Not fast forward; maybe --overwrite is needed ?  Please see dgit(1).
4176 ENDT
4177         finish -1;
4178     }
4179
4180     my $arch_v = $i_arch_v->[0];
4181     my $r = pseudomerge_make_commit
4182         $clogp, $dgitview, $archive_hash, $i_arch_v,
4183         "dgit --quilt=$quilt_mode",
4184         (defined $overwrite_version
4185          ? f_ "Declare fast forward from %s\n", $arch_v
4186          : f_ "Make fast forward from %s\n",    $arch_v);
4187
4188     maybe_split_brain_save $maintview, $r, "pseudomerge";
4189
4190     progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4191     return $r;
4192 }
4193
4194 sub plain_overwrite_pseudomerge ($$$) {
4195     my ($clogp, $head, $archive_hash) = @_;
4196
4197     printdebug "plain_overwrite_pseudomerge...";
4198
4199     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4200
4201     return $head if is_fast_fwd $archive_hash, $head;
4202
4203     my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4204
4205     my $r = pseudomerge_make_commit
4206         $clogp, $head, $archive_hash, $i_arch_v,
4207         "dgit", $m;
4208
4209     runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4210
4211     progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4212     return $r;
4213 }
4214
4215 sub push_parse_changelog ($) {
4216     my ($clogpfn) = @_;
4217
4218     my $clogp = Dpkg::Control::Hash->new();
4219     $clogp->load($clogpfn) or die;
4220
4221     my $clogpackage = getfield $clogp, 'Source';
4222     $package //= $clogpackage;
4223     fail f_ "-p specified %s but changelog specified %s",
4224             $package, $clogpackage
4225         unless $package eq $clogpackage;
4226     my $cversion = getfield $clogp, 'Version';
4227
4228     if (!$we_are_initiator) {
4229         # rpush initiator can't do this because it doesn't have $isuite yet
4230         my $tag = debiantag_new($cversion, access_nomdistro);
4231         runcmd @git, qw(check-ref-format), $tag;
4232     }
4233
4234     my $dscfn = dscfn($cversion);
4235
4236     return ($clogp, $cversion, $dscfn);
4237 }
4238
4239 sub push_parse_dsc ($$$) {
4240     my ($dscfn,$dscfnwhat, $cversion) = @_;
4241     $dsc = parsecontrol($dscfn,$dscfnwhat);
4242     my $dversion = getfield $dsc, 'Version';
4243     my $dscpackage = getfield $dsc, 'Source';
4244     ($dscpackage eq $package && $dversion eq $cversion) or
4245         fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4246                 $dscfn, $dscpackage, $dversion,
4247                         $package,    $cversion;
4248 }
4249
4250 sub push_tagwants ($$$$) {
4251     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4252     my @tagwants;
4253     push @tagwants, {
4254         TagFn => \&debiantag_new,
4255         Objid => $dgithead,
4256         TfSuffix => '',
4257         View => 'dgit',
4258     };
4259     if (defined $maintviewhead) {
4260         push @tagwants, {
4261             TagFn => \&debiantag_maintview,
4262             Objid => $maintviewhead,
4263             TfSuffix => '-maintview',
4264             View => 'maint',
4265         };
4266     } elsif ($dodep14tag ne 'no') {
4267         push @tagwants, {
4268             TagFn => \&debiantag_maintview,
4269             Objid => $dgithead,
4270             TfSuffix => '-dgit',
4271             View => 'dgit',
4272         };
4273     };
4274     foreach my $tw (@tagwants) {
4275         $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4276         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4277     }
4278     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4279     return @tagwants;
4280 }
4281
4282 sub push_mktags ($$ $$ $) {
4283     my ($clogp,$dscfn,
4284         $changesfile,$changesfilewhat,
4285         $tagwants) = @_;
4286
4287     die unless $tagwants->[0]{View} eq 'dgit';
4288
4289     my $declaredistro = access_nomdistro();
4290     my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4291     $dsc->{$ourdscfield[0]} = join " ",
4292         $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4293         $reader_giturl;
4294     $dsc->save("$dscfn.tmp") or confess "$!";
4295
4296     my $changes = parsecontrol($changesfile,$changesfilewhat);
4297     foreach my $field (qw(Source Distribution Version)) {
4298         $changes->{$field} eq $clogp->{$field} or
4299             fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4300                     $field, $changes->{$field}, $clogp->{$field};
4301     }
4302
4303     my $cversion = getfield $clogp, 'Version';
4304     my $clogsuite = getfield $clogp, 'Distribution';
4305
4306     # We make the git tag by hand because (a) that makes it easier
4307     # to control the "tagger" (b) we can do remote signing
4308     my $authline = clogp_authline $clogp;
4309     my $delibs = join(" ", "",@deliberatelies);
4310
4311     my $mktag = sub {
4312         my ($tw) = @_;
4313         my $tfn = $tw->{Tfn};
4314         my $head = $tw->{Objid};
4315         my $tag = $tw->{Tag};
4316
4317         open TO, '>', $tfn->('.tmp') or confess "$!";
4318         print TO <<END or confess "$!";
4319 object $head
4320 type commit
4321 tag $tag
4322 tagger $authline
4323
4324 END
4325         if ($tw->{View} eq 'dgit') {
4326             print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4327 %s release %s for %s (%s) [dgit]
4328 ENDT
4329                 or confess "$!";
4330             print TO <<END or confess "$!";
4331 [dgit distro=$declaredistro$delibs]
4332 END
4333             foreach my $ref (sort keys %previously) {
4334                 print TO <<END or confess "$!";
4335 [dgit previously:$ref=$previously{$ref}]
4336 END
4337             }
4338         } elsif ($tw->{View} eq 'maint') {
4339             print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4340 %s release %s for %s (%s)
4341 (maintainer view tag generated by dgit --quilt=%s)
4342 END
4343                 $quilt_mode
4344                 or confess "$!";
4345         } else {
4346             confess Dumper($tw)."?";
4347         }
4348
4349         close TO or confess "$!";
4350
4351         my $tagobjfn = $tfn->('.tmp');
4352         if ($sign) {
4353             if (!defined $keyid) {
4354                 $keyid = access_cfg('keyid','RETURN-UNDEF');
4355             }
4356             if (!defined $keyid) {
4357                 $keyid = getfield $clogp, 'Maintainer';
4358             }
4359             unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4360             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4361             push @sign_cmd, qw(-u),$keyid if defined $keyid;
4362             push @sign_cmd, $tfn->('.tmp');
4363             runcmd_ordryrun @sign_cmd;
4364             if (act_scary()) {
4365                 $tagobjfn = $tfn->('.signed.tmp');
4366                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4367                     $tfn->('.tmp'), $tfn->('.tmp.asc');
4368             }
4369         }
4370         return $tagobjfn;
4371     };
4372
4373     my @r = map { $mktag->($_); } @$tagwants;
4374     return @r;
4375 }
4376
4377 sub sign_changes ($) {
4378     my ($changesfile) = @_;
4379     if ($sign) {
4380         my @debsign_cmd = @debsign;
4381         push @debsign_cmd, "-k$keyid" if defined $keyid;
4382         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4383         push @debsign_cmd, $changesfile;
4384         runcmd_ordryrun @debsign_cmd;
4385     }
4386 }
4387
4388 sub dopush () {
4389     printdebug "actually entering push\n";
4390
4391     supplementary_message(__ <<'END');
4392 Push failed, while checking state of the archive.
4393 You can retry the push, after fixing the problem, if you like.
4394 END
4395     if (check_for_git()) {
4396         git_fetch_us();
4397     }
4398     my $archive_hash = fetch_from_archive();
4399     if (!$archive_hash) {
4400         $new_package or
4401             fail __ "package appears to be new in this suite;".
4402                     " if this is intentional, use --new";
4403     }
4404
4405     supplementary_message(__ <<'END');
4406 Push failed, while preparing your push.
4407 You can retry the push, after fixing the problem, if you like.
4408 END
4409
4410     prep_ud();
4411
4412     access_giturl(); # check that success is vaguely likely
4413     rpush_handle_protovsn_bothends() if $we_are_initiator;
4414
4415     my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4416     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4417
4418     responder_send_file('parsed-changelog', $clogpfn);
4419
4420     my ($clogp, $cversion, $dscfn) =
4421         push_parse_changelog("$clogpfn");
4422
4423     my $dscpath = "$buildproductsdir/$dscfn";
4424     stat_exists $dscpath or
4425         fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4426                 $dscpath, $!;
4427
4428     responder_send_file('dsc', $dscpath);
4429
4430     push_parse_dsc($dscpath, $dscfn, $cversion);
4431
4432     my $format = getfield $dsc, 'Format';
4433
4434     my $symref = git_get_symref();
4435     my $actualhead = git_rev_parse('HEAD');
4436
4437     if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4438         if (quiltmode_splitbrain()) {
4439             my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4440             fail f_ <<END, $ffq_prev, $quilt_mode;
4441 Branch is managed by git-debrebase (%s
4442 exists), but quilt mode (%s) implies a split view.
4443 Pass the right --quilt option or adjust your git config.
4444 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4445 END
4446         }
4447         runcmd_ordryrun_local @git_debrebase, 'stitch';
4448         $actualhead = git_rev_parse('HEAD');
4449     }
4450
4451     my $dgithead = $actualhead;
4452     my $maintviewhead = undef;
4453
4454     my $upstreamversion = upstreamversion $clogp->{Version};
4455
4456     if (madformat_wantfixup($format)) {
4457         # user might have not used dgit build, so maybe do this now:
4458         if (do_split_brain()) {
4459             changedir $playground;
4460             my $cachekey;
4461             ($dgithead, $cachekey) =
4462                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4463             $dgithead or fail f_
4464  "--quilt=%s but no cached dgit view:
4465  perhaps HEAD changed since dgit build[-source] ?",
4466                               $quilt_mode;
4467         }
4468         if (!do_split_brain()) {
4469             # In split brain mode, do not attempt to incorporate dirty
4470             # stuff from the user's working tree.  That would be mad.
4471             commit_quilty_patch();
4472         }
4473     }
4474     if (do_split_brain()) {
4475         $made_split_brain = 1;
4476         $dgithead = splitbrain_pseudomerge($clogp,
4477                                            $actualhead, $dgithead,
4478                                            $archive_hash);
4479         $maintviewhead = $actualhead;
4480         changedir $maindir;
4481         prep_ud(); # so _only_subdir() works, below
4482     }
4483
4484     if (defined $overwrite_version && !defined $maintviewhead
4485         && $archive_hash) {
4486         $dgithead = plain_overwrite_pseudomerge($clogp,
4487                                                 $dgithead,
4488                                                 $archive_hash);
4489     }
4490
4491     check_not_dirty();
4492
4493     my $forceflag = '';
4494     if ($archive_hash) {
4495         if (is_fast_fwd($archive_hash, $dgithead)) {
4496             # ok
4497         } elsif (deliberately_not_fast_forward) {
4498             $forceflag = '+';
4499         } else {
4500             fail __ "dgit push: HEAD is not a descendant".
4501                 " of the archive's version.\n".
4502                 "To overwrite the archive's contents,".
4503                 " pass --overwrite[=VERSION].\n".
4504                 "To rewind history, if permitted by the archive,".
4505                 " use --deliberately-not-fast-forward.";
4506         }
4507     }
4508
4509     confess unless !!$made_split_brain == do_split_brain();
4510
4511     changedir $playground;
4512     progress f_ "checking that %s corresponds to HEAD", $dscfn;
4513     runcmd qw(dpkg-source -x --),
4514         $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4515     my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4516     check_for_vendor_patches() if madformat($dsc->{format});
4517     changedir $maindir;
4518     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4519     debugcmd "+",@diffcmd;
4520     $!=0; $?=-1;
4521     my $r = system @diffcmd;
4522     if ($r) {
4523         if ($r==256) {
4524             my $referent = $made_split_brain ? $dgithead : 'HEAD';
4525             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4526
4527             my @mode_changes;
4528             my $raw = cmdoutput @git,
4529                 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4530             my $changed;
4531             foreach (split /\0/, $raw) {
4532                 if (defined $changed) {
4533                     push @mode_changes, "$changed: $_\n" if $changed;
4534                     $changed = undef;
4535                     next;
4536                 } elsif (m/^:0+ 0+ /) {
4537                     $changed = '';
4538                 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4539                     $changed = "Mode change from $1 to $2"
4540                 } else {
4541                     die "$_ ?";
4542                 }
4543             }
4544             if (@mode_changes) {
4545                 fail +(f_ <<ENDT, $dscfn).<<END
4546 HEAD specifies a different tree to %s:
4547 ENDT
4548 $diffs
4549 END
4550                     .(join '', @mode_changes)
4551                     .(f_ <<ENDT, $tree, $referent);
4552 There is a problem with your source tree (see dgit(7) for some hints).
4553 To see a full diff, run git diff %s %s
4554 ENDT
4555             }
4556
4557             fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4558 HEAD specifies a different tree to %s:
4559 ENDT
4560 $diffs
4561 END
4562 Perhaps you forgot to build.  Or perhaps there is a problem with your
4563  source tree (see dgit(7) for some hints).  To see a full diff, run
4564    git diff %s %s
4565 ENDT
4566         } else {
4567             failedcmd @diffcmd;
4568         }
4569     }
4570     if (!$changesfile) {
4571         my $pat = changespat $cversion;
4572         my @cs = glob "$buildproductsdir/$pat";
4573         fail f_ "failed to find unique changes file".
4574                 " (looked for %s in %s);".
4575                 " perhaps you need to use dgit -C",
4576                 $pat, $buildproductsdir
4577             unless @cs==1;
4578         ($changesfile) = @cs;
4579     } else {
4580         $changesfile = "$buildproductsdir/$changesfile";
4581     }
4582
4583     # Check that changes and .dsc agree enough
4584     $changesfile =~ m{[^/]*$};
4585     my $changes = parsecontrol($changesfile,$&);
4586     files_compare_inputs($dsc, $changes)
4587         unless forceing [qw(dsc-changes-mismatch)];
4588
4589     # Check whether this is a source only upload
4590     my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4591     my $sourceonlypolicy = access_cfg 'source-only-uploads';
4592     if ($sourceonlypolicy eq 'ok') {
4593     } elsif ($sourceonlypolicy eq 'always') {
4594         forceable_fail [qw(uploading-binaries)],
4595             __ "uploading binaries, although distro policy is source only"
4596             if $hasdebs;
4597     } elsif ($sourceonlypolicy eq 'never') {
4598         forceable_fail [qw(uploading-source-only)],
4599             __ "source-only upload, although distro policy requires .debs"
4600             if !$hasdebs;
4601     } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4602         forceable_fail [qw(uploading-source-only)],
4603             f_ "source-only upload, even though package is entirely NEW\n".
4604                "(this is contrary to policy in %s)",
4605                access_nomdistro()
4606             if !$hasdebs
4607             && $new_package
4608             && !(archive_query('package_not_wholly_new', $package) // 1);
4609     } else {
4610         badcfg f_ "unknown source-only-uploads policy \`%s'",
4611                   $sourceonlypolicy;
4612     }
4613
4614     # Perhaps adjust .dsc to contain right set of origs
4615     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4616                                   $changesfile)
4617         unless forceing [qw(changes-origs-exactly)];
4618
4619     # Checks complete, we're going to try and go ahead:
4620
4621     responder_send_file('changes',$changesfile);
4622     responder_send_command("param head $dgithead");
4623     responder_send_command("param csuite $csuite");
4624     responder_send_command("param isuite $isuite");
4625     responder_send_command("param tagformat new"); # needed in $protovsn==4
4626     if (defined $maintviewhead) {
4627         responder_send_command("param maint-view $maintviewhead");
4628     }
4629
4630     # Perhaps send buildinfo(s) for signing
4631     my $changes_files = getfield $changes, 'Files';
4632     my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4633     foreach my $bi (@buildinfos) {
4634         responder_send_command("param buildinfo-filename $bi");
4635         responder_send_file('buildinfo', "$buildproductsdir/$bi");
4636     }
4637
4638     if (deliberately_not_fast_forward) {
4639         git_for_each_ref(lrfetchrefs, sub {
4640             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4641             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4642             responder_send_command("previously $rrefname=$objid");
4643             $previously{$rrefname} = $objid;
4644         });
4645     }
4646
4647     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4648                                  dgit_privdir()."/tag");
4649     my @tagobjfns;
4650
4651     supplementary_message(__ <<'END');
4652 Push failed, while signing the tag.
4653 You can retry the push, after fixing the problem, if you like.
4654 END
4655     # If we manage to sign but fail to record it anywhere, it's fine.
4656     if ($we_are_responder) {
4657         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4658         responder_receive_files('signed-tag', @tagobjfns);
4659     } else {
4660         @tagobjfns = push_mktags($clogp,$dscpath,
4661                               $changesfile,$changesfile,
4662                               \@tagwants);
4663     }
4664     supplementary_message(__ <<'END');
4665 Push failed, *after* signing the tag.
4666 If you want to try again, you should use a new version number.
4667 END
4668
4669     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4670
4671     foreach my $tw (@tagwants) {
4672         my $tag = $tw->{Tag};
4673         my $tagobjfn = $tw->{TagObjFn};
4674         my $tag_obj_hash =
4675             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4676         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4677         runcmd_ordryrun_local
4678             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4679     }
4680
4681     supplementary_message(__ <<'END');
4682 Push failed, while updating the remote git repository - see messages above.
4683 If you want to try again, you should use a new version number.
4684 END
4685     if (!check_for_git()) {
4686         create_remote_git_repo();
4687     }
4688
4689     my @pushrefs = $forceflag.$dgithead.":".rrref();
4690     foreach my $tw (@tagwants) {
4691         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4692     }
4693
4694     runcmd_ordryrun @git,
4695         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4696     runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4697
4698     supplementary_message(__ <<'END');
4699 Push failed, while obtaining signatures on the .changes and .dsc.
4700 If it was just that the signature failed, you may try again by using
4701 debsign by hand to sign the changes file (see the command dgit tried,
4702 above), and then dput that changes file to complete the upload.
4703 If you need to change the package, you must use a new version number.
4704 END
4705     if ($we_are_responder) {
4706         my $dryrunsuffix = act_local() ? "" : ".tmp";
4707         my @rfiles = ($dscpath, $changesfile);
4708         push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4709         responder_receive_files('signed-dsc-changes',
4710                                 map { "$_$dryrunsuffix" } @rfiles);
4711     } else {
4712         if (act_local()) {
4713             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4714         } else {
4715             progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4716         }
4717         sign_changes $changesfile;
4718     }
4719
4720     supplementary_message(f_ <<END, $changesfile);
4721 Push failed, while uploading package(s) to the archive server.
4722 You can retry the upload of exactly these same files with dput of:
4723   %s
4724 If that .changes file is broken, you will need to use a new version
4725 number for your next attempt at the upload.
4726 END
4727     my $host = access_cfg('upload-host','RETURN-UNDEF');
4728     my @hostarg = defined($host) ? ($host,) : ();
4729     runcmd_ordryrun @dput, @hostarg, $changesfile;
4730     printdone f_ "pushed and uploaded %s", $cversion;
4731
4732     supplementary_message('');
4733     responder_send_command("complete");
4734 }
4735
4736 sub pre_clone () {
4737     not_necessarily_a_tree();
4738 }
4739 sub cmd_clone {
4740     parseopts();
4741     my $dstdir;
4742     badusage __ "-p is not allowed with clone; specify as argument instead"
4743         if defined $package;
4744     if (@ARGV==1) {
4745         ($package) = @ARGV;
4746     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4747         ($package,$isuite) = @ARGV;
4748     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4749         ($package,$dstdir) = @ARGV;
4750     } elsif (@ARGV==3) {
4751         ($package,$isuite,$dstdir) = @ARGV;
4752     } else {
4753         badusage __ "incorrect arguments to dgit clone";
4754     }
4755     notpushing();
4756
4757     $dstdir ||= "$package";
4758     if (stat_exists $dstdir) {
4759         fail f_ "%s already exists", $dstdir;
4760     }
4761
4762     my $cwd_remove;
4763     if ($rmonerror && !$dryrun_level) {
4764         $cwd_remove= getcwd();
4765         unshift @end, sub {
4766             return unless defined $cwd_remove;
4767             if (!chdir "$cwd_remove") {
4768                 return if $!==&ENOENT;
4769                 confess "chdir $cwd_remove: $!";
4770             }
4771             printdebug "clone rmonerror removing $dstdir\n";
4772             if (stat $dstdir) {
4773                 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4774             } elsif (grep { $! == $_ }
4775                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4776             } else {
4777                 print STDERR f_ "check whether to remove %s: %s\n",
4778                                 $dstdir, $!;
4779             }
4780         };
4781     }
4782
4783     clone($dstdir);
4784     $cwd_remove = undef;
4785 }
4786
4787 sub branchsuite () {
4788     my $branch = git_get_symref();
4789     if (defined $branch && $branch =~ m#$lbranch_re#o) {
4790         return $1;
4791     } else {
4792         return undef;
4793     }
4794 }
4795
4796 sub package_from_d_control () {
4797     if (!defined $package) {
4798         my $sourcep = parsecontrol('debian/control','debian/control');
4799         $package = getfield $sourcep, 'Source';
4800     }
4801 }
4802
4803 sub fetchpullargs () {
4804     package_from_d_control();
4805     if (@ARGV==0) {
4806         $isuite = branchsuite();
4807         if (!$isuite) {
4808             my $clogp = parsechangelog();
4809             my $clogsuite = getfield $clogp, 'Distribution';
4810             $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4811         }
4812     } elsif (@ARGV==1) {
4813         ($isuite) = @ARGV;
4814     } else {
4815         badusage __ "incorrect arguments to dgit fetch or dgit pull";
4816     }
4817     notpushing();
4818 }
4819
4820 sub cmd_fetch {
4821     parseopts();
4822     fetchpullargs();
4823     dofetch();
4824 }
4825
4826 sub cmd_pull {
4827     parseopts();
4828     fetchpullargs();
4829     if (quiltmode_splitbrain()) {
4830         my ($format, $fopts) = get_source_format();
4831         madformat($format) and fail f_ <<END, $quilt_mode
4832 dgit pull not yet supported in split view mode (--quilt=%s)
4833 END
4834     }
4835     pull();
4836 }
4837
4838 sub cmd_checkout {
4839     parseopts();
4840     package_from_d_control();
4841     @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4842     ($isuite) = @ARGV;
4843     notpushing();
4844
4845     foreach my $canon (qw(0 1)) {
4846         if (!$canon) {
4847             $csuite= $isuite;
4848         } else {
4849             undef $csuite;
4850             canonicalise_suite();
4851         }
4852         if (length git_get_ref lref()) {
4853             # local branch already exists, yay
4854             last;
4855         }
4856         if (!length git_get_ref lrref()) {
4857             if (!$canon) {
4858                 # nope
4859                 next;
4860             }
4861             dofetch();
4862         }
4863         # now lrref exists
4864         runcmd (@git, qw(update-ref), lref(), lrref(), '');
4865         last;
4866     }
4867     local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4868         "dgit checkout $isuite";
4869     runcmd (@git, qw(checkout), lbranch());
4870 }
4871
4872 sub cmd_update_vcs_git () {
4873     my $specsuite;
4874     if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4875         ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4876     } else {
4877         ($specsuite) = (@ARGV);
4878         shift @ARGV;
4879     }
4880     my $dofetch=1;
4881     if (@ARGV) {
4882         if ($ARGV[0] eq '-') {
4883             $dofetch = 0;
4884         } elsif ($ARGV[0] eq '-') {
4885             shift;
4886         }
4887     }
4888
4889     package_from_d_control();
4890     my $ctrl;
4891     if ($specsuite eq '.') {
4892         $ctrl = parsecontrol 'debian/control', 'debian/control';
4893     } else {
4894         $isuite = $specsuite;
4895         get_archive_dsc();
4896         $ctrl = $dsc;
4897     }
4898     my $url = getfield $ctrl, 'Vcs-Git';
4899
4900     my @cmd;
4901     my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4902     if (!defined $orgurl) {
4903         print STDERR f_ "setting up vcs-git: %s\n", $url;
4904         @cmd = (@git, qw(remote add vcs-git), $url);
4905     } elsif ($orgurl eq $url) {
4906         print STDERR f_ "vcs git already configured: %s\n", $url;
4907     } else {
4908         print STDERR f_ "changing vcs-git url to: %s\n", $url;
4909         @cmd = (@git, qw(remote set-url vcs-git), $url);
4910     }
4911     runcmd_ordryrun_local @cmd;
4912     if ($dofetch) {
4913         print f_ "fetching (%s)\n", "@ARGV";
4914         runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4915     }
4916 }
4917
4918 sub prep_push () {
4919     parseopts();
4920     build_or_push_prep_early();
4921     pushing();
4922     build_or_push_prep_modes();
4923     check_not_dirty();
4924     my $specsuite;
4925     if (@ARGV==0) {
4926     } elsif (@ARGV==1) {
4927         ($specsuite) = (@ARGV);
4928     } else {
4929         badusage f_ "incorrect arguments to dgit %s", $subcommand;
4930     }
4931     if ($new_package) {
4932         local ($package) = $existing_package; # this is a hack
4933         canonicalise_suite();
4934     } else {
4935         canonicalise_suite();
4936     }
4937     if (defined $specsuite &&
4938         $specsuite ne $isuite &&
4939         $specsuite ne $csuite) {
4940             fail f_ "dgit %s: changelog specifies %s (%s)".
4941                     " but command line specifies %s",
4942                     $subcommand, $isuite, $csuite, $specsuite;
4943     }
4944 }
4945
4946 sub cmd_push {
4947     prep_push();
4948     dopush();
4949 }
4950
4951 #---------- remote commands' implementation ----------
4952
4953 sub pre_remote_push_build_host {
4954     my ($nrargs) = shift @ARGV;
4955     my (@rargs) = @ARGV[0..$nrargs-1];
4956     @ARGV = @ARGV[$nrargs..$#ARGV];
4957     die unless @rargs;
4958     my ($dir,$vsnwant) = @rargs;
4959     # vsnwant is a comma-separated list; we report which we have
4960     # chosen in our ready response (so other end can tell if they
4961     # offered several)
4962     $debugprefix = ' ';
4963     $we_are_responder = 1;
4964     $us .= " (build host)";
4965
4966     open PI, "<&STDIN" or confess "$!";
4967     open STDIN, "/dev/null" or confess "$!";
4968     open PO, ">&STDOUT" or confess "$!";
4969     autoflush PO 1;
4970     open STDOUT, ">&STDERR" or confess "$!";
4971     autoflush STDOUT 1;
4972
4973     $vsnwant //= 1;
4974     ($protovsn) = grep {
4975         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4976     } @rpushprotovsn_support;
4977
4978     fail f_ "build host has dgit rpush protocol versions %s".
4979             " but invocation host has %s",
4980             (join ",", @rpushprotovsn_support), $vsnwant
4981         unless defined $protovsn;
4982
4983     changedir $dir;
4984 }
4985 sub cmd_remote_push_build_host {
4986     responder_send_command("dgit-remote-push-ready $protovsn");
4987     &cmd_push;
4988 }
4989
4990 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4991 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4992 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4993 #     a good error message)
4994
4995 sub rpush_handle_protovsn_bothends () {
4996 }
4997
4998 our $i_tmp;
4999
5000 sub i_cleanup {
5001     local ($@, $?);
5002     my $report = i_child_report();
5003     if (defined $report) {
5004         printdebug "($report)\n";
5005     } elsif ($i_child_pid) {
5006         printdebug "(killing build host child $i_child_pid)\n";
5007         kill 15, $i_child_pid;
5008     }
5009     if (defined $i_tmp && !defined $initiator_tempdir) {
5010         changedir "/";
5011         eval { rmtree $i_tmp; };
5012     }
5013 }
5014
5015 END {
5016     return unless forkcheck_mainprocess();
5017     i_cleanup();
5018 }
5019
5020 sub i_method {
5021     my ($base,$selector,@args) = @_;
5022     $selector =~ s/\-/_/g;
5023     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5024 }
5025
5026 sub pre_rpush () {
5027     not_necessarily_a_tree();
5028 }
5029 sub cmd_rpush {
5030     my $host = nextarg;
5031     my $dir;
5032     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5033         $host = $1;
5034         $dir = $'; #';
5035     } else {
5036         $dir = nextarg;
5037     }
5038     $dir =~ s{^-}{./-};
5039     my @rargs = ($dir);
5040     push @rargs, join ",", @rpushprotovsn_support;
5041     my @rdgit;
5042     push @rdgit, @dgit;
5043     push @rdgit, @ropts;
5044     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5045     push @rdgit, @ARGV;
5046     my @cmd = (@ssh, $host, shellquote @rdgit);
5047     debugcmd "+",@cmd;
5048
5049     $we_are_initiator=1;
5050
5051     if (defined $initiator_tempdir) {
5052         rmtree $initiator_tempdir;
5053         mkdir $initiator_tempdir, 0700
5054             or fail f_ "create %s: %s", $initiator_tempdir, $!;
5055         $i_tmp = $initiator_tempdir;
5056     } else {
5057         $i_tmp = tempdir();
5058     }
5059     $i_child_pid = open2(\*RO, \*RI, @cmd);
5060     changedir $i_tmp;
5061     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5062     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5063
5064     for (;;) {
5065         my ($icmd,$iargs) = initiator_expect {
5066             m/^(\S+)(?: (.*))?$/;
5067             ($1,$2);
5068         };
5069         i_method "i_resp", $icmd, $iargs;
5070     }
5071 }
5072
5073 sub i_resp_progress ($) {
5074     my ($rhs) = @_;
5075     my $msg = protocol_read_bytes \*RO, $rhs;
5076     progress $msg;
5077 }
5078
5079 sub i_resp_supplementary_message ($) {
5080     my ($rhs) = @_;
5081     $supplementary_message = protocol_read_bytes \*RO, $rhs;
5082 }
5083
5084 sub i_resp_complete {
5085     my $pid = $i_child_pid;
5086     $i_child_pid = undef; # prevents killing some other process with same pid
5087     printdebug "waiting for build host child $pid...\n";
5088     my $got = waitpid $pid, 0;
5089     confess "$!" unless $got == $pid;
5090     fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5091
5092     i_cleanup();
5093     printdebug __ "all done\n";
5094     finish 0;
5095 }
5096
5097 sub i_resp_file ($) {
5098     my ($keyword) = @_;
5099     my $localname = i_method "i_localname", $keyword;
5100     my $localpath = "$i_tmp/$localname";
5101     stat_exists $localpath and
5102         badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5103     protocol_receive_file \*RO, $localpath;
5104     i_method "i_file", $keyword;
5105 }
5106
5107 our %i_param;
5108
5109 sub i_resp_param ($) {
5110     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5111     $i_param{$1} = $2;
5112 }
5113
5114 sub i_resp_previously ($) {
5115     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5116         or badproto \*RO, __ "bad previously spec";
5117     my $r = system qw(git check-ref-format), $1;
5118     confess "bad previously ref spec ($r)" if $r;
5119     $previously{$1} = $2;
5120 }
5121
5122 our %i_wanted;
5123
5124 sub i_resp_want ($) {
5125     my ($keyword) = @_;
5126     die "$keyword ?" if $i_wanted{$keyword}++;
5127
5128     defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5129     $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5130     die unless $isuite =~ m/^$suite_re$/;
5131
5132     pushing();
5133     rpush_handle_protovsn_bothends();
5134
5135     my @localpaths = i_method "i_want", $keyword;
5136     printdebug "[[  $keyword @localpaths\n";
5137     foreach my $localpath (@localpaths) {
5138         protocol_send_file \*RI, $localpath;
5139     }
5140     print RI "files-end\n" or confess "$!";
5141 }
5142
5143 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5144
5145 sub i_localname_parsed_changelog {
5146     return "remote-changelog.822";
5147 }
5148 sub i_file_parsed_changelog {
5149     ($i_clogp, $i_version, $i_dscfn) =
5150         push_parse_changelog "$i_tmp/remote-changelog.822";
5151     die if $i_dscfn =~ m#/|^\W#;
5152 }
5153
5154 sub i_localname_dsc {
5155     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5156     return $i_dscfn;
5157 }
5158 sub i_file_dsc { }
5159
5160 sub i_localname_buildinfo ($) {
5161     my $bi = $i_param{'buildinfo-filename'};
5162     defined $bi or badproto \*RO, "buildinfo before filename";
5163     defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5164     $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5165         or badproto \*RO, "improper buildinfo filename";
5166     return $&;
5167 }
5168 sub i_file_buildinfo {
5169     my $bi = $i_param{'buildinfo-filename'};
5170     my $bd = parsecontrol "$i_tmp/$bi", $bi;
5171     my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5172     if (!forceing [qw(buildinfo-changes-mismatch)]) {
5173         files_compare_inputs($bd, $ch);
5174         (getfield $bd, $_) eq (getfield $ch, $_) or
5175             fail f_ "buildinfo mismatch in field %s", $_
5176             foreach qw(Source Version);
5177         !defined $bd->{$_} or
5178             fail f_ "buildinfo contains forbidden field %s", $_
5179             foreach qw(Changes Changed-by Distribution);
5180     }
5181     push @i_buildinfos, $bi;
5182     delete $i_param{'buildinfo-filename'};
5183 }
5184
5185 sub i_localname_changes {
5186     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5187     $i_changesfn = $i_dscfn;
5188     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5189     return $i_changesfn;
5190 }
5191 sub i_file_changes { }
5192
5193 sub i_want_signed_tag {
5194     printdebug Dumper(\%i_param, $i_dscfn);
5195     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5196         && defined $i_param{'csuite'}
5197         or badproto \*RO, "premature desire for signed-tag";
5198     my $head = $i_param{'head'};
5199     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5200
5201     my $maintview = $i_param{'maint-view'};
5202     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5203
5204     if ($protovsn == 4) {
5205         my $p = $i_param{'tagformat'} // '<undef>';
5206         $p eq 'new'
5207             or badproto \*RO, "tag format mismatch: $p vs. new";
5208     }
5209
5210     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5211     $csuite = $&;
5212     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5213
5214     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5215
5216     return
5217         push_mktags $i_clogp, $i_dscfn,
5218             $i_changesfn, (__ 'remote changes file'),
5219             \@tagwants;
5220 }
5221
5222 sub i_want_signed_dsc_changes {
5223     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5224     sign_changes $i_changesfn;
5225     return ($i_dscfn, $i_changesfn, @i_buildinfos);
5226 }
5227
5228 #---------- building etc. ----------
5229
5230 our $version;
5231 our $sourcechanges;
5232 our $dscfn;
5233
5234 #----- `3.0 (quilt)' handling -----
5235
5236 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5237
5238 sub quiltify_dpkg_commit ($$$;$) {
5239     my ($patchname,$author,$msg, $xinfo) = @_;
5240     $xinfo //= '';
5241
5242     mkpath '.git/dgit'; # we are in playtree
5243     my $descfn = ".git/dgit/quilt-description.tmp";
5244     open O, '>', $descfn or confess "$descfn: $!";
5245     $msg =~ s/\n+/\n\n/;
5246     print O <<END or confess "$!";
5247 From: $author
5248 ${xinfo}Subject: $msg
5249 ---
5250
5251 END
5252     close O or confess "$!";
5253
5254     {
5255         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5256         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5257         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5258         runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5259     }
5260 }
5261
5262 sub quiltify_trees_differ ($$;$$$) {
5263     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5264     # returns true iff the two tree objects differ other than in debian/
5265     # with $finegrained,
5266     # returns bitmask 01 - differ in upstream files except .gitignore
5267     #                 02 - differ in .gitignore
5268     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5269     #  is set for each modified .gitignore filename $fn
5270     # if $unrepres is defined, array ref to which is appeneded
5271     #  a list of unrepresentable changes (removals of upstream files
5272     #  (as messages)
5273     local $/=undef;
5274     my @cmd = (@git, qw(diff-tree -z --no-renames));
5275     push @cmd, qw(--name-only) unless $unrepres;
5276     push @cmd, qw(-r) if $finegrained || $unrepres;
5277     push @cmd, $x, $y;
5278     my $diffs= cmdoutput @cmd;
5279     my $r = 0;
5280     my @lmodes;
5281     foreach my $f (split /\0/, $diffs) {
5282         if ($unrepres && !@lmodes) {
5283             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5284             next;
5285         }
5286         my ($oldmode,$newmode) = @lmodes;
5287         @lmodes = ();
5288
5289         next if $f =~ m#^debian(?:/.*)?$#s;
5290
5291         if ($unrepres) {
5292             eval {
5293                 die __ "not a plain file or symlink\n"
5294                     unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5295                            $oldmode =~ m/^(?:10|12)\d{4}$/;
5296                 if ($oldmode =~ m/[^0]/ &&
5297                     $newmode =~ m/[^0]/) {
5298                     # both old and new files exist
5299                     die __ "mode or type changed\n" if $oldmode ne $newmode;
5300                     die __ "modified symlink\n" unless $newmode =~ m/^10/;
5301                 } elsif ($oldmode =~ m/[^0]/) {
5302                     # deletion
5303                     die __ "deletion of symlink\n"
5304                         unless $oldmode =~ m/^10/;
5305                 } else {
5306                     # creation
5307                     die __ "creation with non-default mode\n"
5308                         unless $newmode =~ m/^100644$/ or
5309                                $newmode =~ m/^120000$/;
5310                 }
5311             };
5312             if ($@) {
5313                 local $/="\n"; chomp $@;
5314                 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5315             }
5316         }
5317
5318         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5319         $r |= $isignore ? 02 : 01;
5320         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5321     }
5322     printdebug "quiltify_trees_differ $x $y => $r\n";
5323     return $r;
5324 }
5325
5326 sub quiltify_tree_sentinelfiles ($) {
5327     # lists the `sentinel' files present in the tree
5328     my ($x) = @_;
5329     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5330         qw(-- debian/rules debian/control);
5331     $r =~ s/\n/,/g;
5332     return $r;
5333 }
5334
5335 sub quiltify_splitbrain ($$$$$$$) {
5336     my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5337         $editedignores, $cachekey) = @_;
5338     my $gitignore_special = 1;
5339     if ($quilt_mode !~ m/gbp|dpm/) {
5340         # treat .gitignore just like any other upstream file
5341         $diffbits = { %$diffbits };
5342         $_ = !!$_ foreach values %$diffbits;
5343         $gitignore_special = 0;
5344     }
5345     # We would like any commits we generate to be reproducible
5346     my @authline = clogp_authline($clogp);
5347     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
5348     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5349     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
5350     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
5351     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5352     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
5353
5354     confess unless do_split_brain();
5355
5356     my $fulldiffhint = sub {
5357         my ($x,$y) = @_;
5358         my $cmd = "git diff $x $y -- :/ ':!debian'";
5359         $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5360         return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5361                   $cmd;
5362     };
5363
5364     if ($quilt_mode =~ m/gbp|unapplied/ &&
5365         ($diffbits->{O2H} & 01)) {
5366         my $msg = f_
5367  "--quilt=%s specified, implying patches-unapplied git tree\n".
5368  " but git tree differs from orig in upstream files.",
5369                      $quilt_mode;
5370         $msg .= $fulldiffhint->($unapplied, 'HEAD');
5371         if (!stat_exists "debian/patches") {
5372             $msg .= __
5373  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5374         }
5375         fail $msg;
5376     }
5377     if ($quilt_mode =~ m/dpm/ &&
5378         ($diffbits->{H2A} & 01)) {
5379         fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5380 --quilt=%s specified, implying patches-applied git tree
5381  but git tree differs from result of applying debian/patches to upstream
5382 END
5383     }
5384     if ($quilt_mode =~ m/gbp|unapplied/ &&
5385         ($diffbits->{O2A} & 01)) { # some patches
5386         progress __ "dgit view: creating patches-applied version using gbp pq";
5387         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5388         # gbp pq import creates a fresh branch; push back to dgit-view
5389         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5390         runcmd @git, qw(checkout -q dgit-view);
5391     }
5392     if ($quilt_mode =~ m/gbp|dpm/ &&
5393         ($diffbits->{O2A} & 02)) {
5394         fail f_ <<END, $quilt_mode;
5395 --quilt=%s specified, implying that HEAD is for use with a
5396  tool which does not create patches for changes to upstream
5397  .gitignores: but, such patches exist in debian/patches.
5398 END
5399     }
5400     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5401         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5402         progress __
5403             "dgit view: creating patch to represent .gitignore changes";
5404         ensuredir "debian/patches";
5405         my $gipatch = "debian/patches/auto-gitignore";
5406         open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5407         stat GIPATCH or confess "$gipatch: $!";
5408         fail f_ "%s already exists; but want to create it".
5409                 " to record .gitignore changes",
5410                 $gipatch
5411             if (stat _)[7];
5412         print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5413 Subject: Update .gitignore from Debian packaging branch
5414
5415 The Debian packaging git branch contains these updates to the upstream
5416 .gitignore file(s).  This patch is autogenerated, to provide these
5417 updates to users of the official Debian archive view of the package.
5418 END
5419
5420 [dgit ($our_version) update-gitignore]
5421 ---
5422 ENDU
5423         close GIPATCH or die "$gipatch: $!";
5424         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5425             $unapplied, $headref, "--", sort keys %$editedignores;
5426         open SERIES, "+>>", "debian/patches/series" or confess "$!";
5427         defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5428         my $newline;
5429         defined read SERIES, $newline, 1 or confess "$!";
5430         print SERIES "\n" or confess "$!" unless $newline eq "\n";
5431         print SERIES "auto-gitignore\n" or confess "$!";
5432         close SERIES or die  $!;
5433         runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5434         commit_admin +(__ <<END).<<ENDU
5435 Commit patch to update .gitignore
5436 END
5437
5438 [dgit ($our_version) update-gitignore-quilt-fixup]
5439 ENDU
5440     }
5441 }
5442
5443 sub quiltify ($$$$) {
5444     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5445
5446     # Quilt patchification algorithm
5447     #
5448     # We search backwards through the history of the main tree's HEAD
5449     # (T) looking for a start commit S whose tree object is identical
5450     # to to the patch tip tree (ie the tree corresponding to the
5451     # current dpkg-committed patch series).  For these purposes
5452     # `identical' disregards anything in debian/ - this wrinkle is
5453     # necessary because dpkg-source treates debian/ specially.
5454     #
5455     # We can only traverse edges where at most one of the ancestors'
5456     # trees differs (in changes outside in debian/).  And we cannot
5457     # handle edges which change .pc/ or debian/patches.  To avoid
5458     # going down a rathole we avoid traversing edges which introduce
5459     # debian/rules or debian/control.  And we set a limit on the
5460     # number of edges we are willing to look at.
5461     #
5462     # If we succeed, we walk forwards again.  For each traversed edge
5463     # PC (with P parent, C child) (starting with P=S and ending with
5464     # C=T) to we do this:
5465     #  - git checkout C
5466     #  - dpkg-source --commit with a patch name and message derived from C
5467     # After traversing PT, we git commit the changes which
5468     # should be contained within debian/patches.
5469
5470     # The search for the path S..T is breadth-first.  We maintain a
5471     # todo list containing search nodes.  A search node identifies a
5472     # commit, and looks something like this:
5473     #  $p = {
5474     #      Commit => $git_commit_id,
5475     #      Child => $c,                          # or undef if P=T
5476     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
5477     #      Nontrivial => true iff $p..$c has relevant changes
5478     #  };
5479
5480     my @todo;
5481     my @nots;
5482     my $sref_S;
5483     my $max_work=100;
5484     my %considered; # saves being exponential on some weird graphs
5485
5486     my $t_sentinels = quiltify_tree_sentinelfiles $target;
5487
5488     my $not = sub {
5489         my ($search,$whynot) = @_;
5490         printdebug " search NOT $search->{Commit} $whynot\n";
5491         $search->{Whynot} = $whynot;
5492         push @nots, $search;
5493         no warnings qw(exiting);
5494         next;
5495     };
5496
5497     push @todo, {
5498         Commit => $target,
5499     };
5500
5501     while (@todo) {
5502         my $c = shift @todo;
5503         next if $considered{$c->{Commit}}++;
5504
5505         $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5506
5507         printdebug "quiltify investigate $c->{Commit}\n";
5508
5509         # are we done?
5510         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5511             printdebug " search finished hooray!\n";
5512             $sref_S = $c;
5513             last;
5514         }
5515
5516         quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5517         if ($quilt_mode eq 'smash') {
5518             printdebug " search quitting smash\n";
5519             last;
5520         }
5521
5522         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5523         $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5524             if $c_sentinels ne $t_sentinels;
5525
5526         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5527         $commitdata =~ m/\n\n/;
5528         $commitdata =~ $`;
5529         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5530         @parents = map { { Commit => $_, Child => $c } } @parents;
5531
5532         $not->($c, __ "root commit") if !@parents;
5533
5534         foreach my $p (@parents) {
5535             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5536         }
5537         my $ndiffers = grep { $_->{Nontrivial} } @parents;
5538         $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5539             if $ndiffers > 1;
5540
5541         foreach my $p (@parents) {
5542             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5543
5544             my @cmd= (@git, qw(diff-tree -r --name-only),
5545                       $p->{Commit},$c->{Commit},
5546                       qw(-- debian/patches .pc debian/source/format));
5547             my $patchstackchange = cmdoutput @cmd;
5548             if (length $patchstackchange) {
5549                 $patchstackchange =~ s/\n/,/g;
5550                 $not->($p, f_ "changed %s", $patchstackchange);
5551             }
5552
5553             printdebug " search queue P=$p->{Commit} ",
5554                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5555             push @todo, $p;
5556         }
5557     }
5558
5559     if (!$sref_S) {
5560         printdebug "quiltify want to smash\n";
5561
5562         my $abbrev = sub {
5563             my $x = $_[0]{Commit};
5564             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5565             return $x;
5566         };
5567         if ($quilt_mode eq 'linear') {
5568             print STDERR f_
5569                 "\n%s: error: quilt fixup cannot be linear.  Stopped at:\n",
5570                 $us;
5571             my $all_gdr = !!@nots;
5572             foreach my $notp (@nots) {
5573                 my $c = $notp->{Child};
5574                 my $cprange = $abbrev->($notp);
5575                 $cprange .= "..".$abbrev->($c) if $c;
5576                 print STDERR f_ "%s:  %s: %s\n",
5577                     $us, $cprange, $notp->{Whynot};
5578                 $all_gdr &&= $notp->{Child} &&
5579                     (git_cat_file $notp->{Child}{Commit}, 'commit')
5580                     =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5581             }
5582             print STDERR "\n";
5583             $failsuggestion =
5584                 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5585                 if $all_gdr;
5586             print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5587             fail __
5588  "quilt history linearisation failed.  Search \`quilt fixup' in dgit(7).\n";
5589         } elsif ($quilt_mode eq 'smash') {
5590         } elsif ($quilt_mode eq 'auto') {
5591             progress __ "quilt fixup cannot be linear, smashing...";
5592         } else {
5593             confess "$quilt_mode ?";
5594         }
5595
5596         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5597         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5598         my $ncommits = 3;
5599         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5600
5601         quiltify_dpkg_commit "auto-$version-$target-$time",
5602             (getfield $clogp, 'Maintainer'),
5603             (f_ "Automatically generated patch (%s)\n".
5604              "Last (up to) %s git changes, FYI:\n\n",
5605              $clogp->{Version}, $ncommits).
5606              $msg;
5607         return;
5608     }
5609
5610     progress __ "quiltify linearisation planning successful, executing...";
5611
5612     for (my $p = $sref_S;
5613          my $c = $p->{Child};
5614          $p = $p->{Child}) {
5615         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5616         next unless $p->{Nontrivial};
5617
5618         my $cc = $c->{Commit};
5619
5620         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5621         $commitdata =~ m/\n\n/ or die "$c ?";
5622         $commitdata = $`;
5623         my $msg = $'; #';
5624         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5625         my $author = $1;
5626
5627         my $commitdate = cmdoutput
5628             @git, qw(log -n1 --pretty=format:%aD), $cc;
5629
5630         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5631
5632         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5633         $strip_nls->();
5634
5635         my $title = $1;
5636         my $patchname;
5637         my $patchdir;
5638
5639         my $gbp_check_suitable = sub {
5640             $_ = shift;
5641             my ($what) = @_;
5642
5643             eval {
5644                 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5645                 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5646                 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5647                 die __ "is series file\n" if m{$series_filename_re}o;
5648                 die __ "too long\n" if length > 200;
5649             };
5650             return $_ unless $@;
5651             print STDERR f_
5652                 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5653                 $cc, $what, $@;
5654             return undef;
5655         };
5656
5657         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5658                            gbp-pq-name: \s* )
5659                        (\S+) \s* \n //ixm) {
5660             $patchname = $gbp_check_suitable->($1, 'Name');
5661         }
5662         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5663                            gbp-pq-topic: \s* )
5664                        (\S+) \s* \n //ixm) {
5665             $patchdir = $gbp_check_suitable->($1, 'Topic');
5666         }
5667
5668         $strip_nls->();
5669
5670         if (!defined $patchname) {
5671             $patchname = $title;
5672             $patchname =~ s/[.:]$//;
5673             use Text::Iconv;
5674             eval {
5675                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5676                 my $translitname = $converter->convert($patchname);
5677                 die unless defined $translitname;
5678                 $patchname = $translitname;
5679             };
5680             print STDERR
5681                 +(f_ "dgit: patch title transliteration error: %s", $@)
5682                 if $@;
5683             $patchname =~ y/ A-Z/-a-z/;
5684             $patchname =~ y/-a-z0-9_.+=~//cd;
5685             $patchname =~ s/^\W/x-$&/;
5686             $patchname = substr($patchname,0,40);
5687             $patchname .= ".patch";
5688         }
5689         if (!defined $patchdir) {
5690             $patchdir = '';
5691         }
5692         if (length $patchdir) {
5693             $patchname = "$patchdir/$patchname";
5694         }
5695         if ($patchname =~ m{^(.*)/}) {
5696             mkpath "debian/patches/$1";
5697         }
5698
5699         my $index;
5700         for ($index='';
5701              stat "debian/patches/$patchname$index";
5702              $index++) { }
5703         $!==ENOENT or confess "$patchname$index $!";
5704
5705         runcmd @git, qw(checkout -q), $cc;
5706
5707         # We use the tip's changelog so that dpkg-source doesn't
5708         # produce complaining messages from dpkg-parsechangelog.  None
5709         # of the information dpkg-source gets from the changelog is
5710         # actually relevant - it gets put into the original message
5711         # which dpkg-source provides our stunt editor, and then
5712         # overwritten.
5713         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5714
5715         quiltify_dpkg_commit "$patchname$index", $author, $msg,
5716             "Date: $commitdate\n".
5717             "X-Dgit-Generated: $clogp->{Version} $cc\n";
5718
5719         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5720     }
5721 }
5722
5723 sub build_maybe_quilt_fixup () {
5724     my ($format,$fopts) = get_source_format;
5725     return unless madformat_wantfixup $format;
5726     # sigh
5727
5728     check_for_vendor_patches();
5729
5730     my $clogp = parsechangelog();
5731     my $headref = git_rev_parse('HEAD');
5732     my $symref = git_get_symref();
5733     my $upstreamversion = upstreamversion $version;
5734
5735     prep_ud();
5736     changedir $playground;
5737
5738     my $splitbrain_cachekey;
5739
5740     if (do_split_brain()) {
5741         my $cachehit;
5742         ($cachehit, $splitbrain_cachekey) =
5743             quilt_check_splitbrain_cache($headref, $upstreamversion);
5744         if ($cachehit) {
5745             changedir $maindir;
5746             return;
5747         }
5748     }
5749
5750     unpack_playtree_need_cd_work($headref);
5751     if (do_split_brain()) {
5752         runcmd @git, qw(checkout -q -b dgit-view);
5753         # so long as work is not deleted, its current branch will
5754         # remain dgit-view, rather than master, so subsequent calls to
5755         #  unpack_playtree_need_cd_work
5756         # will DTRT, resetting dgit-view.
5757         confess if $made_split_brain;
5758         $made_split_brain = 1;
5759     }
5760     chdir '..';
5761
5762     if ($fopts->{'single-debian-patch'}) {
5763         fail f_
5764  "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5765             $quilt_mode
5766             if quiltmode_splitbrain();
5767         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5768     } else {
5769         quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5770                               $splitbrain_cachekey);
5771     }
5772
5773     if (do_split_brain()) {
5774         my $dgitview = git_rev_parse 'HEAD';
5775
5776         changedir $maindir;
5777         reflog_cache_insert "refs/$splitbraincache",
5778             $splitbrain_cachekey, $dgitview;
5779
5780         changedir "$playground/work";
5781
5782         my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5783         progress f_ "dgit view: created (%s)", $saved;
5784     }
5785
5786     changedir $maindir;
5787     runcmd_ordryrun_local
5788         @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5789 }
5790
5791 sub build_check_quilt_splitbrain () {
5792     build_maybe_quilt_fixup();
5793 }
5794
5795 sub unpack_playtree_need_cd_work ($) {
5796     my ($headref) = @_;
5797
5798     # prep_ud() must have been called already.
5799     if (!chdir "work") {
5800         # Check in the filesystem because sometimes we run prep_ud
5801         # in between multiple calls to unpack_playtree_need_cd_work.
5802         confess "$!" unless $!==ENOENT;
5803         mkdir "work" or confess "$!";
5804         changedir "work";
5805         mktree_in_ud_here();
5806     }
5807     runcmd @git, qw(reset -q --hard), $headref;
5808 }
5809
5810 sub unpack_playtree_linkorigs ($$) {
5811     my ($upstreamversion, $fn) = @_;
5812     # calls $fn->($leafname);
5813
5814     my $bpd_abs = bpd_abs();
5815
5816     dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5817
5818     opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5819     while ($!=0, defined(my $leaf = readdir QFD)) {
5820         my $f = bpd_abs()."/".$leaf;
5821         {
5822             local ($debuglevel) = $debuglevel-1;
5823             printdebug "QF linkorigs bpd $leaf, $f ?\n";
5824         }
5825         next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5826         printdebug "QF linkorigs $leaf, $f Y\n";
5827         link_ltarget $f, $leaf or die "$leaf $!";
5828         $fn->($leaf);
5829     }
5830     die "$buildproductsdir: $!" if $!;
5831     closedir QFD;
5832 }
5833
5834 sub quilt_fixup_delete_pc () {
5835     runcmd @git, qw(rm -rqf .pc);
5836     commit_admin +(__ <<END).<<ENDU
5837 Commit removal of .pc (quilt series tracking data)
5838 END
5839
5840 [dgit ($our_version) upgrade quilt-remove-pc]
5841 ENDU
5842 }
5843
5844 sub quilt_fixup_singlepatch ($$$) {
5845     my ($clogp, $headref, $upstreamversion) = @_;
5846
5847     progress __ "starting quiltify (single-debian-patch)";
5848
5849     # dpkg-source --commit generates new patches even if
5850     # single-debian-patch is in debian/source/options.  In order to
5851     # get it to generate debian/patches/debian-changes, it is
5852     # necessary to build the source package.
5853
5854     unpack_playtree_linkorigs($upstreamversion, sub { });
5855     unpack_playtree_need_cd_work($headref);
5856
5857     rmtree("debian/patches");
5858
5859     runcmd @dpkgsource, qw(-b .);
5860     changedir "..";
5861     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5862     rename srcfn("$upstreamversion", "/debian/patches"),
5863         "work/debian/patches"
5864         or $!==ENOENT
5865         or confess "install d/patches: $!";
5866
5867     changedir "work";
5868     commit_quilty_patch();
5869 }
5870
5871 sub quilt_need_fake_dsc ($) {
5872     # cwd should be playground
5873     my ($upstreamversion) = @_;
5874
5875     return if stat_exists "fake.dsc";
5876     # ^ OK to test this as a sentinel because if we created it
5877     # we must either have done the rest too, or crashed.
5878
5879     my $fakeversion="$upstreamversion-~~DGITFAKE";
5880
5881     my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5882     print $fakedsc <<END or confess "$!";
5883 Format: 3.0 (quilt)
5884 Source: $package
5885 Version: $fakeversion
5886 Files:
5887 END
5888
5889     my $dscaddfile=sub {
5890         my ($leaf) = @_;
5891
5892         my $md = new Digest::MD5;
5893
5894         my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5895         stat $fh or confess "$!";
5896         my $size = -s _;
5897
5898         $md->addfile($fh);
5899         print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5900     };
5901
5902     unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5903
5904     my @files=qw(debian/source/format debian/rules
5905                  debian/control debian/changelog);
5906     foreach my $maybe (qw(debian/patches debian/source/options
5907                           debian/tests/control)) {
5908         next unless stat_exists "$maindir/$maybe";
5909         push @files, $maybe;
5910     }
5911
5912     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5913     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5914
5915     $dscaddfile->($debtar);
5916     close $fakedsc or confess "$!";
5917 }
5918
5919 sub quilt_fakedsc2unapplied ($$) {
5920     my ($headref, $upstreamversion) = @_;
5921     # must be run in the playground
5922     # quilt_need_fake_dsc must have been called
5923
5924     quilt_need_fake_dsc($upstreamversion);
5925     runcmd qw(sh -ec),
5926         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5927
5928     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5929     rename $fakexdir, "fake" or die "$fakexdir $!";
5930
5931     changedir 'fake';
5932
5933     remove_stray_gits(__ "source package");
5934     mktree_in_ud_here();
5935
5936     rmtree '.pc';
5937
5938     rmtree 'debian'; # git checkout commitish paths does not delete!
5939     runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5940     my $unapplied=git_add_write_tree();
5941     printdebug "fake orig tree object $unapplied\n";
5942     return $unapplied;
5943 }
5944
5945 sub quilt_check_splitbrain_cache ($$) {
5946     my ($headref, $upstreamversion) = @_;
5947     # Called only if we are in (potentially) split brain mode.
5948     # Called in playground.
5949     # Computes the cache key and looks in the cache.
5950     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5951
5952     quilt_need_fake_dsc($upstreamversion);
5953
5954     my $splitbrain_cachekey;
5955
5956     progress f_
5957  "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5958                 $quilt_mode;
5959     # we look in the reflog of dgit-intern/quilt-cache
5960     # we look for an entry whose message is the key for the cache lookup
5961     my @cachekey = (qw(dgit), $our_version);
5962     push @cachekey, $upstreamversion;
5963     push @cachekey, $quilt_mode;
5964     push @cachekey, $headref;
5965
5966     push @cachekey, hashfile('fake.dsc');
5967
5968     my $srcshash = Digest::SHA->new(256);
5969     my %sfs = ( %INC, '$0(dgit)' => $0 );
5970     foreach my $sfk (sort keys %sfs) {
5971         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5972         $srcshash->add($sfk,"  ");
5973         $srcshash->add(hashfile($sfs{$sfk}));
5974         $srcshash->add("\n");
5975     }
5976     push @cachekey, $srcshash->hexdigest();
5977     $splitbrain_cachekey = "@cachekey";
5978
5979     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5980
5981     my $cachehit = reflog_cache_lookup
5982         "refs/$splitbraincache", $splitbrain_cachekey;
5983
5984     if ($cachehit) {
5985         unpack_playtree_need_cd_work($headref);
5986         my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5987         if ($cachehit ne $headref) {
5988             progress f_ "dgit view: found cached (%s)", $saved;
5989             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5990             $made_split_brain = 1;
5991             return ($cachehit, $splitbrain_cachekey);
5992         }
5993         progress __ "dgit view: found cached, no changes required";
5994         return ($headref, $splitbrain_cachekey);
5995     }
5996
5997     printdebug "splitbrain cache miss\n";
5998     return (undef, $splitbrain_cachekey);
5999 }
6000
6001 sub quilt_fixup_multipatch ($$$) {
6002     my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6003
6004     progress f_ "examining quilt state (multiple patches, %s mode)",
6005                 $quilt_mode;
6006
6007     # Our objective is:
6008     #  - honour any existing .pc in case it has any strangeness
6009     #  - determine the git commit corresponding to the tip of
6010     #    the patch stack (if there is one)
6011     #  - if there is such a git commit, convert each subsequent
6012     #    git commit into a quilt patch with dpkg-source --commit
6013     #  - otherwise convert all the differences in the tree into
6014     #    a single git commit
6015     #
6016     # To do this we:
6017
6018     # Our git tree doesn't necessarily contain .pc.  (Some versions of
6019     # dgit would include the .pc in the git tree.)  If there isn't
6020     # one, we need to generate one by unpacking the patches that we
6021     # have.
6022     #
6023     # We first look for a .pc in the git tree.  If there is one, we
6024     # will use it.  (This is not the normal case.)
6025     #
6026     # Otherwise need to regenerate .pc so that dpkg-source --commit
6027     # can work.  We do this as follows:
6028     #     1. Collect all relevant .orig from parent directory
6029     #     2. Generate a debian.tar.gz out of
6030     #         debian/{patches,rules,source/format,source/options}
6031     #     3. Generate a fake .dsc containing just these fields:
6032     #          Format Source Version Files
6033     #     4. Extract the fake .dsc
6034     #        Now the fake .dsc has a .pc directory.
6035     # (In fact we do this in every case, because in future we will
6036     # want to search for a good base commit for generating patches.)
6037     #
6038     # Then we can actually do the dpkg-source --commit
6039     #     1. Make a new working tree with the same object
6040     #        store as our main tree and check out the main
6041     #        tree's HEAD.
6042     #     2. Copy .pc from the fake's extraction, if necessary
6043     #     3. Run dpkg-source --commit
6044     #     4. If the result has changes to debian/, then
6045     #          - git add them them
6046     #          - git add .pc if we had a .pc in-tree
6047     #          - git commit
6048     #     5. If we had a .pc in-tree, delete it, and git commit
6049     #     6. Back in the main tree, fast forward to the new HEAD
6050
6051     # Another situation we may have to cope with is gbp-style
6052     # patches-unapplied trees.
6053     #
6054     # We would want to detect these, so we know to escape into
6055     # quilt_fixup_gbp.  However, this is in general not possible.
6056     # Consider a package with a one patch which the dgit user reverts
6057     # (with git revert or the moral equivalent).
6058     #
6059     # That is indistinguishable in contents from a patches-unapplied
6060     # tree.  And looking at the history to distinguish them is not
6061     # useful because the user might have made a confusing-looking git
6062     # history structure (which ought to produce an error if dgit can't
6063     # cope, not a silent reintroduction of an unwanted patch).
6064     #
6065     # So gbp users will have to pass an option.  But we can usually
6066     # detect their failure to do so: if the tree is not a clean
6067     # patches-applied tree, quilt linearisation fails, but the tree
6068     # _is_ a clean patches-unapplied tree, we can suggest that maybe
6069     # they want --quilt=unapplied.
6070     #
6071     # To help detect this, when we are extracting the fake dsc, we
6072     # first extract it with --skip-patches, and then apply the patches
6073     # afterwards with dpkg-source --before-build.  That lets us save a
6074     # tree object corresponding to .origs.
6075
6076     if ($quilt_mode eq 'linear'
6077         && branch_is_gdr($headref)) {
6078         # This is much faster.  It also makes patches that gdr
6079         # likes better for future updates without laundering.
6080         #
6081         # However, it can fail in some casses where we would
6082         # succeed: if there are existing patches, which correspond
6083         # to a prefix of the branch, but are not in gbp/gdr
6084         # format, gdr will fail (exiting status 7), but we might
6085         # be able to figure out where to start linearising.  That
6086         # will be slower so hopefully there's not much to do.
6087
6088         unpack_playtree_need_cd_work $headref;
6089
6090         my @cmd = (@git_debrebase,
6091                    qw(--noop-ok -funclean-mixed -funclean-ordering
6092                       make-patches --quiet-would-amend));
6093         # We tolerate soe snags that gdr wouldn't, by default.
6094         if (act_local()) {
6095             debugcmd "+",@cmd;
6096             $!=0; $?=-1;
6097             failedcmd @cmd
6098                 if system @cmd
6099                 and not ($? == 7*256 or
6100                          $? == -1 && $!==ENOENT);
6101         } else {
6102             dryrun_report @cmd;
6103         }
6104         $headref = git_rev_parse('HEAD');
6105
6106         chdir '..';
6107     }
6108
6109     my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6110
6111     ensuredir '.pc';
6112
6113     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6114     $!=0; $?=-1;
6115     if (system @bbcmd) {
6116         failedcmd @bbcmd if $? < 0;
6117         fail __ <<END;
6118 failed to apply your git tree's patch stack (from debian/patches/) to
6119  the corresponding upstream tarball(s).  Your source tree and .orig
6120  are probably too inconsistent.  dgit can only fix up certain kinds of
6121  anomaly (depending on the quilt mode).  Please see --quilt= in dgit(1).
6122 END
6123     }
6124
6125     changedir '..';
6126
6127     unpack_playtree_need_cd_work($headref);
6128
6129     my $mustdeletepc=0;
6130     if (stat_exists ".pc") {
6131         -d _ or die;
6132         progress __ "Tree already contains .pc - will use it then delete it.";
6133         $mustdeletepc=1;
6134     } else {
6135         rename '../fake/.pc','.pc' or confess "$!";
6136     }
6137
6138     changedir '../fake';
6139     rmtree '.pc';
6140     my $oldtiptree=git_add_write_tree();
6141     printdebug "fake o+d/p tree object $unapplied\n";
6142     changedir '../work';
6143
6144
6145     # We calculate some guesswork now about what kind of tree this might
6146     # be.  This is mostly for error reporting.
6147
6148     my %editedignores;
6149     my @unrepres;
6150     my $diffbits = {
6151         # H = user's HEAD
6152         # O = orig, without patches applied
6153         # A = "applied", ie orig with H's debian/patches applied
6154         O2H => quiltify_trees_differ($unapplied,$headref,   1,
6155                                      \%editedignores, \@unrepres),
6156         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
6157         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6158     };
6159
6160     my @dl;
6161     foreach my $bits (qw(01 02)) {
6162         foreach my $v (qw(O2H O2A H2A)) {
6163             push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6164         }
6165     }
6166     printdebug "differences \@dl @dl.\n";
6167
6168     progress f_
6169 "%s: base trees orig=%.20s o+d/p=%.20s",
6170               $us, $unapplied, $oldtiptree;
6171     progress f_
6172 "%s: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
6173 "%s: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
6174   $us,                      $dl[0], $dl[1],              $dl[3], $dl[4],
6175   $us,                          $dl[2],                     $dl[5];
6176
6177     if (@unrepres) {
6178         print STDERR f_ "dgit:  cannot represent change: %s: %s\n",
6179                         $_->[1], $_->[0]
6180             foreach @unrepres;
6181         forceable_fail [qw(unrepresentable)], __ <<END;
6182 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6183 END
6184     }
6185
6186     my @failsuggestion;
6187     if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6188         push @failsuggestion, [ 'unapplied', __
6189  "This might be a patches-unapplied branch." ];
6190     } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6191         push @failsuggestion, [ 'applied', __
6192  "This might be a patches-applied branch." ];
6193     }
6194     push @failsuggestion, [ 'quilt-mode', __
6195  "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6196
6197     push @failsuggestion, [ 'gitattrs', __
6198  "Warning: Tree has .gitattributes.  See GITATTRIBUTES in dgit(7)." ]
6199         if stat_exists '.gitattributes';
6200
6201     push @failsuggestion, [ 'origs', __
6202  "Maybe orig tarball(s) are not identical to git representation?" ];
6203
6204     if (quiltmode_splitbrain()) {
6205         quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6206                             $diffbits, \%editedignores,
6207                             $splitbrain_cachekey);
6208         return;
6209     }
6210
6211     progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6212     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6213     runcmd @git, qw(checkout -q), (qw(master dgit-view)[do_split_brain()]);
6214
6215     if (!open P, '>>', ".pc/applied-patches") {
6216         $!==&ENOENT or confess "$!";
6217     } else {
6218         close P;
6219     }
6220
6221     commit_quilty_patch();
6222
6223     if ($mustdeletepc) {
6224         quilt_fixup_delete_pc();
6225     }
6226 }
6227
6228 sub quilt_fixup_editor () {
6229     my $descfn = $ENV{$fakeeditorenv};
6230     my $editing = $ARGV[$#ARGV];
6231     open I1, '<', $descfn or confess "$descfn: $!";
6232     open I2, '<', $editing or confess "$editing: $!";
6233     unlink $editing or confess "$editing: $!";
6234     open O, '>', $editing or confess "$editing: $!";
6235     while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6236     my $copying = 0;
6237     while (<I2>) {
6238         $copying ||= m/^\-\-\- /;
6239         next unless $copying;
6240         print O or confess "$!";
6241     }
6242     I2->error and confess "$!";
6243     close O or die $1;
6244     finish 0;
6245 }
6246
6247 sub maybe_apply_patches_dirtily () {
6248     return unless $quilt_mode =~ m/gbp|unapplied/;
6249     print STDERR __ <<END or confess "$!";
6250
6251 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6252 dgit: Have to apply the patches - making the tree dirty.
6253 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6254
6255 END
6256     $patches_applied_dirtily = 01;
6257     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6258     runcmd qw(dpkg-source --before-build .);
6259 }
6260
6261 sub maybe_unapply_patches_again () {
6262     progress __ "dgit: Unapplying patches again to tidy up the tree."
6263         if $patches_applied_dirtily;
6264     runcmd qw(dpkg-source --after-build .)
6265         if $patches_applied_dirtily & 01;
6266     rmtree '.pc'
6267         if $patches_applied_dirtily & 02;
6268     $patches_applied_dirtily = 0;
6269 }
6270
6271 #----- other building -----
6272
6273 sub clean_tree_check_git ($$$) {
6274     my ($honour_ignores, $message, $ignmessage) = @_;
6275     my @cmd = (@git, qw(clean -dn));
6276     push @cmd, qw(-x) unless $honour_ignores;
6277     my $leftovers = cmdoutput @cmd;
6278     if (length $leftovers) {
6279         print STDERR $leftovers, "\n" or confess "$!";
6280         $message .= $ignmessage if $honour_ignores;
6281         fail $message;
6282     }
6283 }
6284
6285 sub clean_tree_check_git_wd ($) {
6286     my ($message) = @_;
6287     return if $cleanmode =~ m{no-check};
6288     return if $patches_applied_dirtily; # yuk
6289     clean_tree_check_git +($cleanmode !~ m{all-check}),
6290         $message, "\n".__ <<END;
6291 If this is just missing .gitignore entries, use a different clean
6292 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6293 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6294 END
6295 }
6296
6297 sub clean_tree_check () {
6298     # This function needs to not care about modified but tracked files.
6299     # That was done by check_not_dirty, and by now we may have run
6300     # the rules clean target which might modify tracked files (!)
6301     if ($cleanmode =~ m{^check}) {
6302         clean_tree_check_git +($cleanmode =~ m{ignores}), __
6303  "tree contains uncommitted files and --clean=check specified", '';
6304     } elsif ($cleanmode =~ m{^dpkg-source}) {
6305         clean_tree_check_git_wd __
6306  "tree contains uncommitted files (NB dgit didn't run rules clean)";
6307     } elsif ($cleanmode =~ m{^git}) {
6308         clean_tree_check_git 1, __
6309  "tree contains uncommited, untracked, unignored files\n".
6310  "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6311     } elsif ($cleanmode eq 'none') {
6312     } else {
6313         confess "$cleanmode ?";
6314     }
6315 }
6316
6317 sub clean_tree () {
6318     # We always clean the tree ourselves, rather than leave it to the
6319     # builder (dpkg-source, or soemthing which calls dpkg-source).
6320     if ($cleanmode =~ m{^dpkg-source}) {
6321         my @cmd = @dpkgbuildpackage;
6322         push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6323         push @cmd, qw(-T clean);
6324         maybe_apply_patches_dirtily();
6325         runcmd_ordryrun_local @cmd;
6326         clean_tree_check_git_wd __
6327  "tree contains uncommitted files (after running rules clean)";
6328     } elsif ($cleanmode =~ m{^git(?!-)}) {
6329         runcmd_ordryrun_local @git, qw(clean -xdf);
6330     } elsif ($cleanmode =~ m{^git-ff}) {
6331         runcmd_ordryrun_local @git, qw(clean -xdff);
6332     } elsif ($cleanmode =~ m{^check}) {
6333         clean_tree_check();
6334     } elsif ($cleanmode eq 'none') {
6335     } else {
6336         confess "$cleanmode ?";
6337     }
6338 }
6339
6340 sub cmd_clean () {
6341     badusage __ "clean takes no additional arguments" if @ARGV;
6342     notpushing();
6343     clean_tree();
6344     maybe_unapply_patches_again();
6345 }
6346
6347 # return values from massage_dbp_args are one or both of these flags
6348 sub WANTSRC_SOURCE  () { 01; } # caller should build source (separately)
6349 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6350
6351 sub build_or_push_prep_early () {
6352     our $build_or_push_prep_early_done //= 0;
6353     return if $build_or_push_prep_early_done++;
6354     badusage f_ "-p is not allowed with dgit %s", $subcommand
6355         if defined $package;
6356     my $clogp = parsechangelog();
6357     $isuite = getfield $clogp, 'Distribution';
6358     $package = getfield $clogp, 'Source';
6359     $version = getfield $clogp, 'Version';
6360     $dscfn = dscfn($version);
6361 }
6362
6363 sub determine_whether_split_brain () {
6364     my ($format,) = get_source_format();
6365     printdebug "format $format, quilt mode $quilt_mode\n";
6366     if (madformat_wantfixup($format) && quiltmode_splitbrain()) {
6367         $do_split_brain = 1;
6368     }
6369     $do_split_brain //= 0;
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;