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