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