dgit

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