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