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