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             $do_split_brain = 1;
4497             changedir $playground;
4498             quilt_make_fake_dsc($upstreamversion);
4499             my $cachekey;
4500             ($dgithead, $cachekey) =
4501                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4502             $dgithead or fail f_
4503  "--quilt=%s but no cached dgit view:
4504  perhaps HEAD changed since dgit build[-source] ?",
4505                               $quilt_mode;
4506         }
4507         if (!$do_split_brain) {
4508             # In split brain mode, do not attempt to incorporate dirty
4509             # stuff from the user's working tree.  That would be mad.
4510             commit_quilty_patch();
4511         }
4512     }
4513     if ($do_split_brain) {
4514         $split_brain = 1;
4515         $dgithead = splitbrain_pseudomerge($clogp,
4516                                            $actualhead, $dgithead,
4517                                            $archive_hash);
4518         $maintviewhead = $actualhead;
4519         changedir $maindir;
4520         prep_ud(); # so _only_subdir() works, below
4521     }
4522
4523     if (defined $overwrite_version && !defined $maintviewhead
4524         && $archive_hash) {
4525         $dgithead = plain_overwrite_pseudomerge($clogp,
4526                                                 $dgithead,
4527                                                 $archive_hash);
4528     }
4529
4530     check_not_dirty();
4531
4532     my $forceflag = '';
4533     if ($archive_hash) {
4534         if (is_fast_fwd($archive_hash, $dgithead)) {
4535             # ok
4536         } elsif (deliberately_not_fast_forward) {
4537             $forceflag = '+';
4538         } else {
4539             fail __ "dgit push: HEAD is not a descendant".
4540                 " of the archive's version.\n".
4541                 "To overwrite the archive's contents,".
4542                 " pass --overwrite[=VERSION].\n".
4543                 "To rewind history, if permitted by the archive,".
4544                 " use --deliberately-not-fast-forward.";
4545         }
4546     }
4547
4548     changedir $playground;
4549     progress f_ "checking that %s corresponds to HEAD", $dscfn;
4550     runcmd qw(dpkg-source -x --),
4551         $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4552     my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4553     check_for_vendor_patches() if madformat($dsc->{format});
4554     changedir $maindir;
4555     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4556     debugcmd "+",@diffcmd;
4557     $!=0; $?=-1;
4558     my $r = system @diffcmd;
4559     if ($r) {
4560         if ($r==256) {
4561             my $referent = $split_brain ? $dgithead : 'HEAD';
4562             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4563
4564             my @mode_changes;
4565             my $raw = cmdoutput @git,
4566                 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4567             my $changed;
4568             foreach (split /\0/, $raw) {
4569                 if (defined $changed) {
4570                     push @mode_changes, "$changed: $_\n" if $changed;
4571                     $changed = undef;
4572                     next;
4573                 } elsif (m/^:0+ 0+ /) {
4574                     $changed = '';
4575                 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4576                     $changed = "Mode change from $1 to $2"
4577                 } else {
4578                     die "$_ ?";
4579                 }
4580             }
4581             if (@mode_changes) {
4582                 fail +(f_ <<ENDT, $dscfn).<<END
4583 HEAD specifies a different tree to %s:
4584 ENDT
4585 $diffs
4586 END
4587                     .(join '', @mode_changes)
4588                     .(f_ <<ENDT, $tree, $referent);
4589 There is a problem with your source tree (see dgit(7) for some hints).
4590 To see a full diff, run git diff %s %s
4591 ENDT
4592             }
4593
4594             fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4595 HEAD specifies a different tree to %s:
4596 ENDT
4597 $diffs
4598 END
4599 Perhaps you forgot to build.  Or perhaps there is a problem with your
4600  source tree (see dgit(7) for some hints).  To see a full diff, run
4601    git diff %s %s
4602 ENDT
4603         } else {
4604             failedcmd @diffcmd;
4605         }
4606     }
4607     if (!$changesfile) {
4608         my $pat = changespat $cversion;
4609         my @cs = glob "$buildproductsdir/$pat";
4610         fail f_ "failed to find unique changes file".
4611                 " (looked for %s in %s);".
4612                 " perhaps you need to use dgit -C",
4613                 $pat, $buildproductsdir
4614             unless @cs==1;
4615         ($changesfile) = @cs;
4616     } else {
4617         $changesfile = "$buildproductsdir/$changesfile";
4618     }
4619
4620     # Check that changes and .dsc agree enough
4621     $changesfile =~ m{[^/]*$};
4622     my $changes = parsecontrol($changesfile,$&);
4623     files_compare_inputs($dsc, $changes)
4624         unless forceing [qw(dsc-changes-mismatch)];
4625
4626     # Check whether this is a source only upload
4627     my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4628     my $sourceonlypolicy = access_cfg 'source-only-uploads';
4629     if ($sourceonlypolicy eq 'ok') {
4630     } elsif ($sourceonlypolicy eq 'always') {
4631         forceable_fail [qw(uploading-binaries)],
4632             __ "uploading binaries, although distro policy is source only"
4633             if $hasdebs;
4634     } elsif ($sourceonlypolicy eq 'never') {
4635         forceable_fail [qw(uploading-source-only)],
4636             __ "source-only upload, although distro policy requires .debs"
4637             if !$hasdebs;
4638     } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4639         forceable_fail [qw(uploading-source-only)],
4640             f_ "source-only upload, even though package is entirely NEW\n".
4641                "(this is contrary to policy in %s)",
4642                access_nomdistro()
4643             if !$hasdebs
4644             && $new_package
4645             && !(archive_query('package_not_wholly_new', $package) // 1);
4646     } else {
4647         badcfg f_ "unknown source-only-uploads policy \`%s'",
4648                   $sourceonlypolicy;
4649     }
4650
4651     # Perhaps adjust .dsc to contain right set of origs
4652     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4653                                   $changesfile)
4654         unless forceing [qw(changes-origs-exactly)];
4655
4656     # Checks complete, we're going to try and go ahead:
4657
4658     responder_send_file('changes',$changesfile);
4659     responder_send_command("param head $dgithead");
4660     responder_send_command("param csuite $csuite");
4661     responder_send_command("param isuite $isuite");
4662     responder_send_command("param tagformat $tagformat");
4663     if (defined $maintviewhead) {
4664         confess "internal error (protovsn=$protovsn)"
4665             if defined $protovsn and $protovsn < 4;
4666         responder_send_command("param maint-view $maintviewhead");
4667     }
4668
4669     # Perhaps send buildinfo(s) for signing
4670     my $changes_files = getfield $changes, 'Files';
4671     my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4672     foreach my $bi (@buildinfos) {
4673         responder_send_command("param buildinfo-filename $bi");
4674         responder_send_file('buildinfo', "$buildproductsdir/$bi");
4675     }
4676
4677     if (deliberately_not_fast_forward) {
4678         git_for_each_ref(lrfetchrefs, sub {
4679             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4680             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4681             responder_send_command("previously $rrefname=$objid");
4682             $previously{$rrefname} = $objid;
4683         });
4684     }
4685
4686     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4687                                  dgit_privdir()."/tag");
4688     my @tagobjfns;
4689
4690     supplementary_message(__ <<'END');
4691 Push failed, while signing the tag.
4692 You can retry the push, after fixing the problem, if you like.
4693 END
4694     # If we manage to sign but fail to record it anywhere, it's fine.
4695     if ($we_are_responder) {
4696         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4697         responder_receive_files('signed-tag', @tagobjfns);
4698     } else {
4699         @tagobjfns = push_mktags($clogp,$dscpath,
4700                               $changesfile,$changesfile,
4701                               \@tagwants);
4702     }
4703     supplementary_message(__ <<'END');
4704 Push failed, *after* signing the tag.
4705 If you want to try again, you should use a new version number.
4706 END
4707
4708     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4709
4710     foreach my $tw (@tagwants) {
4711         my $tag = $tw->{Tag};
4712         my $tagobjfn = $tw->{TagObjFn};
4713         my $tag_obj_hash =
4714             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4715         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4716         runcmd_ordryrun_local
4717             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4718     }
4719
4720     supplementary_message(__ <<'END');
4721 Push failed, while updating the remote git repository - see messages above.
4722 If you want to try again, you should use a new version number.
4723 END
4724     if (!check_for_git()) {
4725         create_remote_git_repo();
4726     }
4727
4728     my @pushrefs = $forceflag.$dgithead.":".rrref();
4729     foreach my $tw (@tagwants) {
4730         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4731     }
4732
4733     runcmd_ordryrun @git,
4734         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4735     runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4736
4737     supplementary_message(__ <<'END');
4738 Push failed, while obtaining signatures on the .changes and .dsc.
4739 If it was just that the signature failed, you may try again by using
4740 debsign by hand to sign the changes file (see the command dgit tried,
4741 above), and then dput that changes file to complete the upload.
4742 If you need to change the package, you must use a new version number.
4743 END
4744     if ($we_are_responder) {
4745         my $dryrunsuffix = act_local() ? "" : ".tmp";
4746         my @rfiles = ($dscpath, $changesfile);
4747         push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4748         responder_receive_files('signed-dsc-changes',
4749                                 map { "$_$dryrunsuffix" } @rfiles);
4750     } else {
4751         if (act_local()) {
4752             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4753         } else {
4754             progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4755         }
4756         sign_changes $changesfile;
4757     }
4758
4759     supplementary_message(f_ <<END, $changesfile);
4760 Push failed, while uploading package(s) to the archive server.
4761 You can retry the upload of exactly these same files with dput of:
4762   %s
4763 If that .changes file is broken, you will need to use a new version
4764 number for your next attempt at the upload.
4765 END
4766     my $host = access_cfg('upload-host','RETURN-UNDEF');
4767     my @hostarg = defined($host) ? ($host,) : ();
4768     runcmd_ordryrun @dput, @hostarg, $changesfile;
4769     printdone f_ "pushed and uploaded %s", $cversion;
4770
4771     supplementary_message('');
4772     responder_send_command("complete");
4773 }
4774
4775 sub pre_clone () {
4776     not_necessarily_a_tree();
4777 }
4778 sub cmd_clone {
4779     parseopts();
4780     my $dstdir;
4781     badusage __ "-p is not allowed with clone; specify as argument instead"
4782         if defined $package;
4783     if (@ARGV==1) {
4784         ($package) = @ARGV;
4785     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4786         ($package,$isuite) = @ARGV;
4787     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4788         ($package,$dstdir) = @ARGV;
4789     } elsif (@ARGV==3) {
4790         ($package,$isuite,$dstdir) = @ARGV;
4791     } else {
4792         badusage __ "incorrect arguments to dgit clone";
4793     }
4794     notpushing();
4795
4796     $dstdir ||= "$package";
4797     if (stat_exists $dstdir) {
4798         fail f_ "%s already exists", $dstdir;
4799     }
4800
4801     my $cwd_remove;
4802     if ($rmonerror && !$dryrun_level) {
4803         $cwd_remove= getcwd();
4804         unshift @end, sub {
4805             return unless defined $cwd_remove;
4806             if (!chdir "$cwd_remove") {
4807                 return if $!==&ENOENT;
4808                 confess "chdir $cwd_remove: $!";
4809             }
4810             printdebug "clone rmonerror removing $dstdir\n";
4811             if (stat $dstdir) {
4812                 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4813             } elsif (grep { $! == $_ }
4814                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4815             } else {
4816                 print STDERR f_ "check whether to remove %s: %s\n",
4817                                 $dstdir, $!;
4818             }
4819         };
4820     }
4821
4822     clone($dstdir);
4823     $cwd_remove = undef;
4824 }
4825
4826 sub branchsuite () {
4827     my $branch = git_get_symref();
4828     if (defined $branch && $branch =~ m#$lbranch_re#o) {
4829         return $1;
4830     } else {
4831         return undef;
4832     }
4833 }
4834
4835 sub package_from_d_control () {
4836     if (!defined $package) {
4837         my $sourcep = parsecontrol('debian/control','debian/control');
4838         $package = getfield $sourcep, 'Source';
4839     }
4840 }
4841
4842 sub fetchpullargs () {
4843     package_from_d_control();
4844     if (@ARGV==0) {
4845         $isuite = branchsuite();
4846         if (!$isuite) {
4847             my $clogp = parsechangelog();
4848             my $clogsuite = getfield $clogp, 'Distribution';
4849             $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4850         }
4851     } elsif (@ARGV==1) {
4852         ($isuite) = @ARGV;
4853     } else {
4854         badusage __ "incorrect arguments to dgit fetch or dgit pull";
4855     }
4856     notpushing();
4857 }
4858
4859 sub cmd_fetch {
4860     parseopts();
4861     fetchpullargs();
4862     dofetch();
4863 }
4864
4865 sub cmd_pull {
4866     parseopts();
4867     fetchpullargs();
4868     if (quiltmode_splitbrain()) {
4869         my ($format, $fopts) = get_source_format();
4870         madformat($format) and fail f_ <<END, $quilt_mode
4871 dgit pull not yet supported in split view mode (--quilt=%s)
4872 END
4873     }
4874     pull();
4875 }
4876
4877 sub cmd_checkout {
4878     parseopts();
4879     package_from_d_control();
4880     @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4881     ($isuite) = @ARGV;
4882     notpushing();
4883
4884     foreach my $canon (qw(0 1)) {
4885         if (!$canon) {
4886             $csuite= $isuite;
4887         } else {
4888             undef $csuite;
4889             canonicalise_suite();
4890         }
4891         if (length git_get_ref lref()) {
4892             # local branch already exists, yay
4893             last;
4894         }
4895         if (!length git_get_ref lrref()) {
4896             if (!$canon) {
4897                 # nope
4898                 next;
4899             }
4900             dofetch();
4901         }
4902         # now lrref exists
4903         runcmd (@git, qw(update-ref), lref(), lrref(), '');
4904         last;
4905     }
4906     local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4907         "dgit checkout $isuite";
4908     runcmd (@git, qw(checkout), lbranch());
4909 }
4910
4911 sub cmd_update_vcs_git () {
4912     my $specsuite;
4913     if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4914         ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4915     } else {
4916         ($specsuite) = (@ARGV);
4917         shift @ARGV;
4918     }
4919     my $dofetch=1;
4920     if (@ARGV) {
4921         if ($ARGV[0] eq '-') {
4922             $dofetch = 0;
4923         } elsif ($ARGV[0] eq '-') {
4924             shift;
4925         }
4926     }
4927
4928     package_from_d_control();
4929     my $ctrl;
4930     if ($specsuite eq '.') {
4931         $ctrl = parsecontrol 'debian/control', 'debian/control';
4932     } else {
4933         $isuite = $specsuite;
4934         get_archive_dsc();
4935         $ctrl = $dsc;
4936     }
4937     my $url = getfield $ctrl, 'Vcs-Git';
4938
4939     my @cmd;
4940     my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4941     if (!defined $orgurl) {
4942         print STDERR f_ "setting up vcs-git: %s\n", $url;
4943         @cmd = (@git, qw(remote add vcs-git), $url);
4944     } elsif ($orgurl eq $url) {
4945         print STDERR f_ "vcs git already configured: %s\n", $url;
4946     } else {
4947         print STDERR f_ "changing vcs-git url to: %s\n", $url;
4948         @cmd = (@git, qw(remote set-url vcs-git), $url);
4949     }
4950     runcmd_ordryrun_local @cmd;
4951     if ($dofetch) {
4952         print f_ "fetching (%s)\n", "@ARGV";
4953         runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4954     }
4955 }
4956
4957 sub prep_push () {
4958     parseopts();
4959     build_or_push_prep_early();
4960     pushing();
4961     check_not_dirty();
4962     my $specsuite;
4963     if (@ARGV==0) {
4964     } elsif (@ARGV==1) {
4965         ($specsuite) = (@ARGV);
4966     } else {
4967         badusage f_ "incorrect arguments to dgit %s", $subcommand;
4968     }
4969     if ($new_package) {
4970         local ($package) = $existing_package; # this is a hack
4971         canonicalise_suite();
4972     } else {
4973         canonicalise_suite();
4974     }
4975     if (defined $specsuite &&
4976         $specsuite ne $isuite &&
4977         $specsuite ne $csuite) {
4978             fail f_ "dgit %s: changelog specifies %s (%s)".
4979                     " but command line specifies %s",
4980                     $subcommand, $isuite, $csuite, $specsuite;
4981     }
4982 }
4983
4984 sub cmd_push {
4985     prep_push();
4986     dopush();
4987 }
4988
4989 #---------- remote commands' implementation ----------
4990
4991 sub pre_remote_push_build_host {
4992     my ($nrargs) = shift @ARGV;
4993     my (@rargs) = @ARGV[0..$nrargs-1];
4994     @ARGV = @ARGV[$nrargs..$#ARGV];
4995     die unless @rargs;
4996     my ($dir,$vsnwant) = @rargs;
4997     # vsnwant is a comma-separated list; we report which we have
4998     # chosen in our ready response (so other end can tell if they
4999     # offered several)
5000     $debugprefix = ' ';
5001     $we_are_responder = 1;
5002     $us .= " (build host)";
5003
5004     open PI, "<&STDIN" or confess "$!";
5005     open STDIN, "/dev/null" or confess "$!";
5006     open PO, ">&STDOUT" or confess "$!";
5007     autoflush PO 1;
5008     open STDOUT, ">&STDERR" or confess "$!";
5009     autoflush STDOUT 1;
5010
5011     $vsnwant //= 1;
5012     ($protovsn) = grep {
5013         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
5014     } @rpushprotovsn_support;
5015
5016     fail f_ "build host has dgit rpush protocol versions %s".
5017             " but invocation host has %s",
5018             (join ",", @rpushprotovsn_support), $vsnwant
5019         unless defined $protovsn;
5020
5021     changedir $dir;
5022 }
5023 sub cmd_remote_push_build_host {
5024     responder_send_command("dgit-remote-push-ready $protovsn");
5025     &cmd_push;
5026 }
5027
5028 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5029 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5030 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5031 #     a good error message)
5032
5033 sub rpush_handle_protovsn_bothends () {
5034     if ($protovsn < 4) {
5035         need_tagformat 'old', "rpush negotiated protocol $protovsn";
5036     }
5037     select_tagformat();
5038 }
5039
5040 our $i_tmp;
5041
5042 sub i_cleanup {
5043     local ($@, $?);
5044     my $report = i_child_report();
5045     if (defined $report) {
5046         printdebug "($report)\n";
5047     } elsif ($i_child_pid) {
5048         printdebug "(killing build host child $i_child_pid)\n";
5049         kill 15, $i_child_pid;
5050     }
5051     if (defined $i_tmp && !defined $initiator_tempdir) {
5052         changedir "/";
5053         eval { rmtree $i_tmp; };
5054     }
5055 }
5056
5057 END {
5058     return unless forkcheck_mainprocess();
5059     i_cleanup();
5060 }
5061
5062 sub i_method {
5063     my ($base,$selector,@args) = @_;
5064     $selector =~ s/\-/_/g;
5065     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5066 }
5067
5068 sub pre_rpush () {
5069     not_necessarily_a_tree();
5070 }
5071 sub cmd_rpush {
5072     my $host = nextarg;
5073     my $dir;
5074     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5075         $host = $1;
5076         $dir = $'; #';
5077     } else {
5078         $dir = nextarg;
5079     }
5080     $dir =~ s{^-}{./-};
5081     my @rargs = ($dir);
5082     push @rargs, join ",", @rpushprotovsn_support;
5083     my @rdgit;
5084     push @rdgit, @dgit;
5085     push @rdgit, @ropts;
5086     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5087     push @rdgit, @ARGV;
5088     my @cmd = (@ssh, $host, shellquote @rdgit);
5089     debugcmd "+",@cmd;
5090
5091     $we_are_initiator=1;
5092
5093     if (defined $initiator_tempdir) {
5094         rmtree $initiator_tempdir;
5095         mkdir $initiator_tempdir, 0700
5096             or fail f_ "create %s: %s", $initiator_tempdir, $!;
5097         $i_tmp = $initiator_tempdir;
5098     } else {
5099         $i_tmp = tempdir();
5100     }
5101     $i_child_pid = open2(\*RO, \*RI, @cmd);
5102     changedir $i_tmp;
5103     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5104     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5105     $supplementary_message = '' unless $protovsn >= 3;
5106
5107     for (;;) {
5108         my ($icmd,$iargs) = initiator_expect {
5109             m/^(\S+)(?: (.*))?$/;
5110             ($1,$2);
5111         };
5112         i_method "i_resp", $icmd, $iargs;
5113     }
5114 }
5115
5116 sub i_resp_progress ($) {
5117     my ($rhs) = @_;
5118     my $msg = protocol_read_bytes \*RO, $rhs;
5119     progress $msg;
5120 }
5121
5122 sub i_resp_supplementary_message ($) {
5123     my ($rhs) = @_;
5124     $supplementary_message = protocol_read_bytes \*RO, $rhs;
5125 }
5126
5127 sub i_resp_complete {
5128     my $pid = $i_child_pid;
5129     $i_child_pid = undef; # prevents killing some other process with same pid
5130     printdebug "waiting for build host child $pid...\n";
5131     my $got = waitpid $pid, 0;
5132     confess "$!" unless $got == $pid;
5133     fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5134
5135     i_cleanup();
5136     printdebug __ "all done\n";
5137     finish 0;
5138 }
5139
5140 sub i_resp_file ($) {
5141     my ($keyword) = @_;
5142     my $localname = i_method "i_localname", $keyword;
5143     my $localpath = "$i_tmp/$localname";
5144     stat_exists $localpath and
5145         badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5146     protocol_receive_file \*RO, $localpath;
5147     i_method "i_file", $keyword;
5148 }
5149
5150 our %i_param;
5151
5152 sub i_resp_param ($) {
5153     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5154     $i_param{$1} = $2;
5155 }
5156
5157 sub i_resp_previously ($) {
5158     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5159         or badproto \*RO, __ "bad previously spec";
5160     my $r = system qw(git check-ref-format), $1;
5161     confess "bad previously ref spec ($r)" if $r;
5162     $previously{$1} = $2;
5163 }
5164
5165 our %i_wanted;
5166
5167 sub i_resp_want ($) {
5168     my ($keyword) = @_;
5169     die "$keyword ?" if $i_wanted{$keyword}++;
5170
5171     defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5172     $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5173     die unless $isuite =~ m/^$suite_re$/;
5174
5175     pushing();
5176     rpush_handle_protovsn_bothends();
5177
5178     fail f_ "rpush negotiated protocol version %s".
5179         " which does not support quilt mode %s",
5180         $protovsn, $quilt_mode
5181         if quiltmode_splitbrain && $protovsn < 4;
5182
5183     my @localpaths = i_method "i_want", $keyword;
5184     printdebug "[[  $keyword @localpaths\n";
5185     foreach my $localpath (@localpaths) {
5186         protocol_send_file \*RI, $localpath;
5187     }
5188     print RI "files-end\n" or confess "$!";
5189 }
5190
5191 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5192
5193 sub i_localname_parsed_changelog {
5194     return "remote-changelog.822";
5195 }
5196 sub i_file_parsed_changelog {
5197     ($i_clogp, $i_version, $i_dscfn) =
5198         push_parse_changelog "$i_tmp/remote-changelog.822";
5199     die if $i_dscfn =~ m#/|^\W#;
5200 }
5201
5202 sub i_localname_dsc {
5203     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5204     return $i_dscfn;
5205 }
5206 sub i_file_dsc { }
5207
5208 sub i_localname_buildinfo ($) {
5209     my $bi = $i_param{'buildinfo-filename'};
5210     defined $bi or badproto \*RO, "buildinfo before filename";
5211     defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5212     $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5213         or badproto \*RO, "improper buildinfo filename";
5214     return $&;
5215 }
5216 sub i_file_buildinfo {
5217     my $bi = $i_param{'buildinfo-filename'};
5218     my $bd = parsecontrol "$i_tmp/$bi", $bi;
5219     my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5220     if (!forceing [qw(buildinfo-changes-mismatch)]) {
5221         files_compare_inputs($bd, $ch);
5222         (getfield $bd, $_) eq (getfield $ch, $_) or
5223             fail f_ "buildinfo mismatch in field %s", $_
5224             foreach qw(Source Version);
5225         !defined $bd->{$_} or
5226             fail f_ "buildinfo contains forbidden field %s", $_
5227             foreach qw(Changes Changed-by Distribution);
5228     }
5229     push @i_buildinfos, $bi;
5230     delete $i_param{'buildinfo-filename'};
5231 }
5232
5233 sub i_localname_changes {
5234     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5235     $i_changesfn = $i_dscfn;
5236     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5237     return $i_changesfn;
5238 }
5239 sub i_file_changes { }
5240
5241 sub i_want_signed_tag {
5242     printdebug Dumper(\%i_param, $i_dscfn);
5243     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5244         && defined $i_param{'csuite'}
5245         or badproto \*RO, "premature desire for signed-tag";
5246     my $head = $i_param{'head'};
5247     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5248
5249     my $maintview = $i_param{'maint-view'};
5250     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5251
5252     select_tagformat();
5253     if ($protovsn >= 4) {
5254         my $p = $i_param{'tagformat'} // '<undef>';
5255         $p eq $tagformat
5256             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5257     }
5258
5259     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5260     $csuite = $&;
5261     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5262
5263     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5264
5265     return
5266         push_mktags $i_clogp, $i_dscfn,
5267             $i_changesfn, (__ 'remote changes file'),
5268             \@tagwants;
5269 }
5270
5271 sub i_want_signed_dsc_changes {
5272     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5273     sign_changes $i_changesfn;
5274     return ($i_dscfn, $i_changesfn, @i_buildinfos);
5275 }
5276
5277 #---------- building etc. ----------
5278
5279 our $version;
5280 our $sourcechanges;
5281 our $dscfn;
5282
5283 #----- `3.0 (quilt)' handling -----
5284
5285 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5286
5287 sub quiltify_dpkg_commit ($$$;$) {
5288     my ($patchname,$author,$msg, $xinfo) = @_;
5289     $xinfo //= '';
5290
5291     mkpath '.git/dgit'; # we are in playtree
5292     my $descfn = ".git/dgit/quilt-description.tmp";
5293     open O, '>', $descfn or confess "$descfn: $!";
5294     $msg =~ s/\n+/\n\n/;
5295     print O <<END or confess "$!";
5296 From: $author
5297 ${xinfo}Subject: $msg
5298 ---
5299
5300 END
5301     close O or confess "$!";
5302
5303     {
5304         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5305         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5306         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5307         runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5308     }
5309 }
5310
5311 sub quiltify_trees_differ ($$;$$$) {
5312     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5313     # returns true iff the two tree objects differ other than in debian/
5314     # with $finegrained,
5315     # returns bitmask 01 - differ in upstream files except .gitignore
5316     #                 02 - differ in .gitignore
5317     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5318     #  is set for each modified .gitignore filename $fn
5319     # if $unrepres is defined, array ref to which is appeneded
5320     #  a list of unrepresentable changes (removals of upstream files
5321     #  (as messages)
5322     local $/=undef;
5323     my @cmd = (@git, qw(diff-tree -z --no-renames));
5324     push @cmd, qw(--name-only) unless $unrepres;
5325     push @cmd, qw(-r) if $finegrained || $unrepres;
5326     push @cmd, $x, $y;
5327     my $diffs= cmdoutput @cmd;
5328     my $r = 0;
5329     my @lmodes;
5330     foreach my $f (split /\0/, $diffs) {
5331         if ($unrepres && !@lmodes) {
5332             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5333             next;
5334         }
5335         my ($oldmode,$newmode) = @lmodes;
5336         @lmodes = ();
5337
5338         next if $f =~ m#^debian(?:/.*)?$#s;
5339
5340         if ($unrepres) {
5341             eval {
5342                 die __ "not a plain file or symlink\n"
5343                     unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5344                            $oldmode =~ m/^(?:10|12)\d{4}$/;
5345                 if ($oldmode =~ m/[^0]/ &&
5346                     $newmode =~ m/[^0]/) {
5347                     # both old and new files exist
5348                     die __ "mode or type changed\n" if $oldmode ne $newmode;
5349                     die __ "modified symlink\n" unless $newmode =~ m/^10/;
5350                 } elsif ($oldmode =~ m/[^0]/) {
5351                     # deletion
5352                     die __ "deletion of symlink\n"
5353                         unless $oldmode =~ m/^10/;
5354                 } else {
5355                     # creation
5356                     die __ "creation with non-default mode\n"
5357                         unless $newmode =~ m/^100644$/ or
5358                                $newmode =~ m/^120000$/;
5359                 }
5360             };
5361             if ($@) {
5362                 local $/="\n"; chomp $@;
5363                 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5364             }
5365         }
5366
5367         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5368         $r |= $isignore ? 02 : 01;
5369         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5370     }
5371     printdebug "quiltify_trees_differ $x $y => $r\n";
5372     return $r;
5373 }
5374
5375 sub quiltify_tree_sentinelfiles ($) {
5376     # lists the `sentinel' files present in the tree
5377     my ($x) = @_;
5378     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5379         qw(-- debian/rules debian/control);
5380     $r =~ s/\n/,/g;
5381     return $r;
5382 }
5383
5384 sub quiltify_splitbrain ($$$$$$$) {
5385     my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5386         $editedignores, $cachekey) = @_;
5387     my $gitignore_special = 1;
5388     if ($quilt_mode !~ m/gbp|dpm/) {
5389         # treat .gitignore just like any other upstream file
5390         $diffbits = { %$diffbits };
5391         $_ = !!$_ foreach values %$diffbits;
5392         $gitignore_special = 0;
5393     }
5394     # We would like any commits we generate to be reproducible
5395     my @authline = clogp_authline($clogp);
5396     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
5397     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5398     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
5399     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
5400     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5401     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
5402
5403     die unless $do_split_brain;
5404
5405     my $fulldiffhint = sub {
5406         my ($x,$y) = @_;
5407         my $cmd = "git diff $x $y -- :/ ':!debian'";
5408         $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5409         return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5410                   $cmd;
5411     };
5412
5413     if ($quilt_mode =~ m/gbp|unapplied/ &&
5414         ($diffbits->{O2H} & 01)) {
5415         my $msg = f_
5416  "--quilt=%s specified, implying patches-unapplied git tree\n".
5417  " but git tree differs from orig in upstream files.",
5418                      $quilt_mode;
5419         $msg .= $fulldiffhint->($unapplied, 'HEAD');
5420         if (!stat_exists "debian/patches") {
5421             $msg .= __
5422  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5423         }
5424         fail $msg;
5425     }
5426     if ($quilt_mode =~ m/dpm/ &&
5427         ($diffbits->{H2A} & 01)) {
5428         fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5429 --quilt=%s specified, implying patches-applied git tree
5430  but git tree differs from result of applying debian/patches to upstream
5431 END
5432     }
5433     if ($quilt_mode =~ m/gbp|unapplied/ &&
5434         ($diffbits->{O2A} & 01)) { # some patches
5435         progress __ "dgit view: creating patches-applied version using gbp pq";
5436         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5437         # gbp pq import creates a fresh branch; push back to dgit-view
5438         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5439         runcmd @git, qw(checkout -q dgit-view);
5440     }
5441     if ($quilt_mode =~ m/gbp|dpm/ &&
5442         ($diffbits->{O2A} & 02)) {
5443         fail f_ <<END, $quilt_mode;
5444 --quilt=%s specified, implying that HEAD is for use with a
5445  tool which does not create patches for changes to upstream
5446  .gitignores: but, such patches exist in debian/patches.
5447 END
5448     }
5449     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5450         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5451         progress __
5452             "dgit view: creating patch to represent .gitignore changes";
5453         ensuredir "debian/patches";
5454         my $gipatch = "debian/patches/auto-gitignore";
5455         open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5456         stat GIPATCH or confess "$gipatch: $!";
5457         fail f_ "%s already exists; but want to create it".
5458                 " to record .gitignore changes",
5459                 $gipatch
5460             if (stat _)[7];
5461         print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5462 Subject: Update .gitignore from Debian packaging branch
5463
5464 The Debian packaging git branch contains these updates to the upstream
5465 .gitignore file(s).  This patch is autogenerated, to provide these
5466 updates to users of the official Debian archive view of the package.
5467 END
5468
5469 [dgit ($our_version) update-gitignore]
5470 ---
5471 ENDU
5472         close GIPATCH or die "$gipatch: $!";
5473         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5474             $unapplied, $headref, "--", sort keys %$editedignores;
5475         open SERIES, "+>>", "debian/patches/series" or confess "$!";
5476         defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5477         my $newline;
5478         defined read SERIES, $newline, 1 or confess "$!";
5479         print SERIES "\n" or confess "$!" unless $newline eq "\n";
5480         print SERIES "auto-gitignore\n" or confess "$!";
5481         close SERIES or die  $!;
5482         runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5483         commit_admin +(__ <<END).<<ENDU
5484 Commit patch to update .gitignore
5485 END
5486
5487 [dgit ($our_version) update-gitignore-quilt-fixup]
5488 ENDU
5489     }
5490
5491     my $dgitview = git_rev_parse 'HEAD';
5492
5493     changedir $maindir;
5494     reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5495
5496     changedir "$playground/work";
5497
5498     my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5499     progress f_ "dgit view: created (%s)", $saved;
5500 }
5501
5502 sub quiltify ($$$$) {
5503     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5504
5505     # Quilt patchification algorithm
5506     #
5507     # We search backwards through the history of the main tree's HEAD
5508     # (T) looking for a start commit S whose tree object is identical
5509     # to to the patch tip tree (ie the tree corresponding to the
5510     # current dpkg-committed patch series).  For these purposes
5511     # `identical' disregards anything in debian/ - this wrinkle is
5512     # necessary because dpkg-source treates debian/ specially.
5513     #
5514     # We can only traverse edges where at most one of the ancestors'
5515     # trees differs (in changes outside in debian/).  And we cannot
5516     # handle edges which change .pc/ or debian/patches.  To avoid
5517     # going down a rathole we avoid traversing edges which introduce
5518     # debian/rules or debian/control.  And we set a limit on the
5519     # number of edges we are willing to look at.
5520     #
5521     # If we succeed, we walk forwards again.  For each traversed edge
5522     # PC (with P parent, C child) (starting with P=S and ending with
5523     # C=T) to we do this:
5524     #  - git checkout C
5525     #  - dpkg-source --commit with a patch name and message derived from C
5526     # After traversing PT, we git commit the changes which
5527     # should be contained within debian/patches.
5528
5529     # The search for the path S..T is breadth-first.  We maintain a
5530     # todo list containing search nodes.  A search node identifies a
5531     # commit, and looks something like this:
5532     #  $p = {
5533     #      Commit => $git_commit_id,
5534     #      Child => $c,                          # or undef if P=T
5535     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
5536     #      Nontrivial => true iff $p..$c has relevant changes
5537     #  };
5538
5539     my @todo;
5540     my @nots;
5541     my $sref_S;
5542     my $max_work=100;
5543     my %considered; # saves being exponential on some weird graphs
5544
5545     my $t_sentinels = quiltify_tree_sentinelfiles $target;
5546
5547     my $not = sub {
5548         my ($search,$whynot) = @_;
5549         printdebug " search NOT $search->{Commit} $whynot\n";
5550         $search->{Whynot} = $whynot;
5551         push @nots, $search;
5552         no warnings qw(exiting);
5553         next;
5554     };
5555
5556     push @todo, {
5557         Commit => $target,
5558     };
5559
5560     while (@todo) {
5561         my $c = shift @todo;
5562         next if $considered{$c->{Commit}}++;
5563
5564         $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5565
5566         printdebug "quiltify investigate $c->{Commit}\n";
5567
5568         # are we done?
5569         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5570             printdebug " search finished hooray!\n";
5571             $sref_S = $c;
5572             last;
5573         }
5574
5575         quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5576         if ($quilt_mode eq 'smash') {
5577             printdebug " search quitting smash\n";
5578             last;
5579         }
5580
5581         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5582         $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5583             if $c_sentinels ne $t_sentinels;
5584
5585         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5586         $commitdata =~ m/\n\n/;
5587         $commitdata =~ $`;
5588         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5589         @parents = map { { Commit => $_, Child => $c } } @parents;
5590
5591         $not->($c, __ "root commit") if !@parents;
5592
5593         foreach my $p (@parents) {
5594             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5595         }
5596         my $ndiffers = grep { $_->{Nontrivial} } @parents;
5597         $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5598             if $ndiffers > 1;
5599
5600         foreach my $p (@parents) {
5601             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5602
5603             my @cmd= (@git, qw(diff-tree -r --name-only),
5604                       $p->{Commit},$c->{Commit},
5605                       qw(-- debian/patches .pc debian/source/format));
5606             my $patchstackchange = cmdoutput @cmd;
5607             if (length $patchstackchange) {
5608                 $patchstackchange =~ s/\n/,/g;
5609                 $not->($p, f_ "changed %s", $patchstackchange);
5610             }
5611
5612             printdebug " search queue P=$p->{Commit} ",
5613                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5614             push @todo, $p;
5615         }
5616     }
5617
5618     if (!$sref_S) {
5619         printdebug "quiltify want to smash\n";
5620
5621         my $abbrev = sub {
5622             my $x = $_[0]{Commit};
5623             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5624             return $x;
5625         };
5626         if ($quilt_mode eq 'linear') {
5627             print STDERR f_
5628                 "\n%s: error: quilt fixup cannot be linear.  Stopped at:\n",
5629                 $us;
5630             my $all_gdr = !!@nots;
5631             foreach my $notp (@nots) {
5632                 my $c = $notp->{Child};
5633                 my $cprange = $abbrev->($notp);
5634                 $cprange .= "..".$abbrev->($c) if $c;
5635                 print STDERR f_ "%s:  %s: %s\n",
5636                     $us, $cprange, $notp->{Whynot};
5637                 $all_gdr &&= $notp->{Child} &&
5638                     (git_cat_file $notp->{Child}{Commit}, 'commit')
5639                     =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5640             }
5641             print STDERR "\n";
5642             $failsuggestion =
5643                 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5644                 if $all_gdr;
5645             print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5646             fail __
5647  "quilt history linearisation failed.  Search \`quilt fixup' in dgit(7).\n";
5648         } elsif ($quilt_mode eq 'smash') {
5649         } elsif ($quilt_mode eq 'auto') {
5650             progress __ "quilt fixup cannot be linear, smashing...";
5651         } else {
5652             confess "$quilt_mode ?";
5653         }
5654
5655         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5656         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5657         my $ncommits = 3;
5658         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5659
5660         quiltify_dpkg_commit "auto-$version-$target-$time",
5661             (getfield $clogp, 'Maintainer'),
5662             (f_ "Automatically generated patch (%s)\n".
5663              "Last (up to) %s git changes, FYI:\n\n",
5664              $clogp->{Version}, $ncommits).
5665              $msg;
5666         return;
5667     }
5668
5669     progress __ "quiltify linearisation planning successful, executing...";
5670
5671     for (my $p = $sref_S;
5672          my $c = $p->{Child};
5673          $p = $p->{Child}) {
5674         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5675         next unless $p->{Nontrivial};
5676
5677         my $cc = $c->{Commit};
5678
5679         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5680         $commitdata =~ m/\n\n/ or die "$c ?";
5681         $commitdata = $`;
5682         my $msg = $'; #';
5683         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5684         my $author = $1;
5685
5686         my $commitdate = cmdoutput
5687             @git, qw(log -n1 --pretty=format:%aD), $cc;
5688
5689         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5690
5691         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5692         $strip_nls->();
5693
5694         my $title = $1;
5695         my $patchname;
5696         my $patchdir;
5697
5698         my $gbp_check_suitable = sub {
5699             $_ = shift;
5700             my ($what) = @_;
5701
5702             eval {
5703                 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5704                 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5705                 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5706                 die __ "is series file\n" if m{$series_filename_re}o;
5707                 die __ "too long\n" if length > 200;
5708             };
5709             return $_ unless $@;
5710             print STDERR f_
5711                 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5712                 $cc, $what, $@;
5713             return undef;
5714         };
5715
5716         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5717                            gbp-pq-name: \s* )
5718                        (\S+) \s* \n //ixm) {
5719             $patchname = $gbp_check_suitable->($1, 'Name');
5720         }
5721         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5722                            gbp-pq-topic: \s* )
5723                        (\S+) \s* \n //ixm) {
5724             $patchdir = $gbp_check_suitable->($1, 'Topic');
5725         }
5726
5727         $strip_nls->();
5728
5729         if (!defined $patchname) {
5730             $patchname = $title;
5731             $patchname =~ s/[.:]$//;
5732             use Text::Iconv;
5733             eval {
5734                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5735                 my $translitname = $converter->convert($patchname);
5736                 die unless defined $translitname;
5737                 $patchname = $translitname;
5738             };
5739             print STDERR
5740                 +(f_ "dgit: patch title transliteration error: %s", $@)
5741                 if $@;
5742             $patchname =~ y/ A-Z/-a-z/;
5743             $patchname =~ y/-a-z0-9_.+=~//cd;
5744             $patchname =~ s/^\W/x-$&/;
5745             $patchname = substr($patchname,0,40);
5746             $patchname .= ".patch";
5747         }
5748         if (!defined $patchdir) {
5749             $patchdir = '';
5750         }
5751         if (length $patchdir) {
5752             $patchname = "$patchdir/$patchname";
5753         }
5754         if ($patchname =~ m{^(.*)/}) {
5755             mkpath "debian/patches/$1";
5756         }
5757
5758         my $index;
5759         for ($index='';
5760              stat "debian/patches/$patchname$index";
5761              $index++) { }
5762         $!==ENOENT or confess "$patchname$index $!";
5763
5764         runcmd @git, qw(checkout -q), $cc;
5765
5766         # We use the tip's changelog so that dpkg-source doesn't
5767         # produce complaining messages from dpkg-parsechangelog.  None
5768         # of the information dpkg-source gets from the changelog is
5769         # actually relevant - it gets put into the original message
5770         # which dpkg-source provides our stunt editor, and then
5771         # overwritten.
5772         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5773
5774         quiltify_dpkg_commit "$patchname$index", $author, $msg,
5775             "Date: $commitdate\n".
5776             "X-Dgit-Generated: $clogp->{Version} $cc\n";
5777
5778         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5779     }
5780
5781     runcmd @git, qw(checkout -q master);
5782 }
5783
5784 sub build_maybe_quilt_fixup () {
5785     my ($format,$fopts) = get_source_format;
5786     return unless madformat_wantfixup $format;
5787     # sigh
5788
5789     check_for_vendor_patches();
5790
5791     $do_split_brain = 1 if quiltmode_splitbrain();
5792
5793     my $clogp = parsechangelog();
5794     my $headref = git_rev_parse('HEAD');
5795     my $symref = git_get_symref();
5796
5797     if ($quilt_mode eq 'linear'
5798         && !$fopts->{'single-debian-patch'}
5799         && branch_is_gdr($headref)) {
5800         # This is much faster.  It also makes patches that gdr
5801         # likes better for future updates without laundering.
5802         #
5803         # However, it can fail in some casses where we would
5804         # succeed: if there are existing patches, which correspond
5805         # to a prefix of the branch, but are not in gbp/gdr
5806         # format, gdr will fail (exiting status 7), but we might
5807         # be able to figure out where to start linearising.  That
5808         # will be slower so hopefully there's not much to do.
5809         my @cmd = (@git_debrebase,
5810                    qw(--noop-ok -funclean-mixed -funclean-ordering
5811                       make-patches --quiet-would-amend));
5812         # We tolerate soe snags that gdr wouldn't, by default.
5813         if (act_local()) {
5814             debugcmd "+",@cmd;
5815             $!=0; $?=-1;
5816             failedcmd @cmd
5817                 if system @cmd
5818                 and not ($? == 7*256 or
5819                          $? == -1 && $!==ENOENT);
5820         } else {
5821             dryrun_report @cmd;
5822         }
5823         $headref = git_rev_parse('HEAD');
5824     }
5825
5826     prep_ud();
5827     changedir $playground;
5828
5829     my $upstreamversion = upstreamversion $version;
5830
5831     if ($fopts->{'single-debian-patch'}) {
5832         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5833     } else {
5834         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5835     }
5836
5837     changedir $maindir;
5838     runcmd_ordryrun_local
5839         @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5840 }
5841
5842 sub build_check_quilt_splitbrain () {
5843     build_maybe_quilt_fixup();
5844
5845     if ($do_split_brain) {
5846         fail <<END unless access_cfg_tagformats_can_splitbrain;
5847 quilt mode $quilt_mode requires split view so server needs to support
5848  both "new" and "maint" tag formats, but config says it doesn't.
5849 END
5850     }
5851 }
5852
5853 sub unpack_playtree_mkwork ($) {
5854     my ($headref) = @_;
5855
5856     mkdir "work" or confess "$!";
5857     changedir "work";
5858     mktree_in_ud_here();
5859     runcmd @git, qw(reset -q --hard), $headref;
5860 }
5861
5862 sub unpack_playtree_linkorigs ($$) {
5863     my ($upstreamversion, $fn) = @_;
5864     # calls $fn->($leafname);
5865
5866     my $bpd_abs = bpd_abs();
5867
5868     dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5869
5870     opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5871     while ($!=0, defined(my $leaf = readdir QFD)) {
5872         my $f = bpd_abs()."/".$leaf;
5873         {
5874             local ($debuglevel) = $debuglevel-1;
5875             printdebug "QF linkorigs bpd $leaf, $f ?\n";
5876         }
5877         next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5878         printdebug "QF linkorigs $leaf, $f Y\n";
5879         link_ltarget $f, $leaf or die "$leaf $!";
5880         $fn->($leaf);
5881     }
5882     die "$buildproductsdir: $!" if $!;
5883     closedir QFD;
5884 }
5885
5886 sub quilt_fixup_delete_pc () {
5887     runcmd @git, qw(rm -rqf .pc);
5888     commit_admin +(__ <<END).<<ENDU
5889 Commit removal of .pc (quilt series tracking data)
5890 END
5891
5892 [dgit ($our_version) upgrade quilt-remove-pc]
5893 ENDU
5894 }
5895
5896 sub quilt_fixup_singlepatch ($$$) {
5897     my ($clogp, $headref, $upstreamversion) = @_;
5898
5899     progress __ "starting quiltify (single-debian-patch)";
5900
5901     # dpkg-source --commit generates new patches even if
5902     # single-debian-patch is in debian/source/options.  In order to
5903     # get it to generate debian/patches/debian-changes, it is
5904     # necessary to build the source package.
5905
5906     unpack_playtree_linkorigs($upstreamversion, sub { });
5907     unpack_playtree_mkwork($headref);
5908
5909     rmtree("debian/patches");
5910
5911     runcmd @dpkgsource, qw(-b .);
5912     changedir "..";
5913     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5914     rename srcfn("$upstreamversion", "/debian/patches"),
5915         "work/debian/patches"
5916         or $!==ENOENT
5917         or confess "install d/patches: $!";
5918
5919     changedir "work";
5920     commit_quilty_patch();
5921 }
5922
5923 sub quilt_make_fake_dsc ($) {
5924     my ($upstreamversion) = @_;
5925
5926     my $fakeversion="$upstreamversion-~~DGITFAKE";
5927
5928     my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5929     print $fakedsc <<END or confess "$!";
5930 Format: 3.0 (quilt)
5931 Source: $package
5932 Version: $fakeversion
5933 Files:
5934 END
5935
5936     my $dscaddfile=sub {
5937         my ($leaf) = @_;
5938
5939         my $md = new Digest::MD5;
5940
5941         my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5942         stat $fh or confess "$!";
5943         my $size = -s _;
5944
5945         $md->addfile($fh);
5946         print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5947     };
5948
5949     unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5950
5951     my @files=qw(debian/source/format debian/rules
5952                  debian/control debian/changelog);
5953     foreach my $maybe (qw(debian/patches debian/source/options
5954                           debian/tests/control)) {
5955         next unless stat_exists "$maindir/$maybe";
5956         push @files, $maybe;
5957     }
5958
5959     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5960     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5961
5962     $dscaddfile->($debtar);
5963     close $fakedsc or confess "$!";
5964 }
5965
5966 sub quilt_fakedsc2unapplied ($$) {
5967     my ($headref, $upstreamversion) = @_;
5968     # must be run in the playground
5969     # quilt_make_fake_dsc must have been called
5970
5971     runcmd qw(sh -ec),
5972         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5973
5974     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5975     rename $fakexdir, "fake" or die "$fakexdir $!";
5976
5977     changedir 'fake';
5978
5979     remove_stray_gits(__ "source package");
5980     mktree_in_ud_here();
5981
5982     rmtree '.pc';
5983
5984     rmtree 'debian'; # git checkout commitish paths does not delete!
5985     runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5986     my $unapplied=git_add_write_tree();
5987     printdebug "fake orig tree object $unapplied\n";
5988     return $unapplied;
5989 }
5990
5991 sub quilt_check_splitbrain_cache ($$) {
5992     my ($headref, $upstreamversion) = @_;
5993     # Called only if we are in (potentially) split brain mode.
5994     # Called in playground.
5995     # Computes the cache key and looks in the cache.
5996     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5997
5998     my $splitbrain_cachekey;
5999
6000     progress f_
6001  "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
6002                 $quilt_mode;
6003     # we look in the reflog of dgit-intern/quilt-cache
6004     # we look for an entry whose message is the key for the cache lookup
6005     my @cachekey = (qw(dgit), $our_version);
6006     push @cachekey, $upstreamversion;
6007     push @cachekey, $quilt_mode;
6008     push @cachekey, $headref;
6009
6010     push @cachekey, hashfile('fake.dsc');
6011
6012     my $srcshash = Digest::SHA->new(256);
6013     my %sfs = ( %INC, '$0(dgit)' => $0 );
6014     foreach my $sfk (sort keys %sfs) {
6015         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6016         $srcshash->add($sfk,"  ");
6017         $srcshash->add(hashfile($sfs{$sfk}));
6018         $srcshash->add("\n");
6019     }
6020     push @cachekey, $srcshash->hexdigest();
6021     $splitbrain_cachekey = "@cachekey";
6022
6023     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6024
6025     my $cachehit = reflog_cache_lookup
6026         "refs/$splitbraincache", $splitbrain_cachekey;
6027
6028     if ($cachehit) {
6029         unpack_playtree_mkwork($headref);
6030         my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6031         if ($cachehit ne $headref) {
6032             progress f_ "dgit view: found cached (%s)", $saved;
6033             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6034             $split_brain = 1;
6035             return ($cachehit, $splitbrain_cachekey);
6036         }
6037         progress __ "dgit view: found cached, no changes required";
6038         return ($headref, $splitbrain_cachekey);
6039     }
6040
6041     printdebug "splitbrain cache miss\n";
6042     return (undef, $splitbrain_cachekey);
6043 }
6044
6045 sub quilt_fixup_multipatch ($$$) {
6046     my ($clogp, $headref, $upstreamversion) = @_;
6047
6048     progress f_ "examining quilt state (multiple patches, %s mode)",
6049                 $quilt_mode;
6050
6051     # Our objective is:
6052     #  - honour any existing .pc in case it has any strangeness
6053     #  - determine the git commit corresponding to the tip of
6054     #    the patch stack (if there is one)
6055     #  - if there is such a git commit, convert each subsequent
6056     #    git commit into a quilt patch with dpkg-source --commit
6057     #  - otherwise convert all the differences in the tree into
6058     #    a single git commit
6059     #
6060     # To do this we:
6061
6062     # Our git tree doesn't necessarily contain .pc.  (Some versions of
6063     # dgit would include the .pc in the git tree.)  If there isn't
6064     # one, we need to generate one by unpacking the patches that we
6065     # have.
6066     #
6067     # We first look for a .pc in the git tree.  If there is one, we
6068     # will use it.  (This is not the normal case.)
6069     #
6070     # Otherwise need to regenerate .pc so that dpkg-source --commit
6071     # can work.  We do this as follows:
6072     #     1. Collect all relevant .orig from parent directory
6073     #     2. Generate a debian.tar.gz out of
6074     #         debian/{patches,rules,source/format,source/options}
6075     #     3. Generate a fake .dsc containing just these fields:
6076     #          Format Source Version Files
6077     #     4. Extract the fake .dsc
6078     #        Now the fake .dsc has a .pc directory.
6079     # (In fact we do this in every case, because in future we will
6080     # want to search for a good base commit for generating patches.)
6081     #
6082     # Then we can actually do the dpkg-source --commit
6083     #     1. Make a new working tree with the same object
6084     #        store as our main tree and check out the main
6085     #        tree's HEAD.
6086     #     2. Copy .pc from the fake's extraction, if necessary
6087     #     3. Run dpkg-source --commit
6088     #     4. If the result has changes to debian/, then
6089     #          - git add them them
6090     #          - git add .pc if we had a .pc in-tree
6091     #          - git commit
6092     #     5. If we had a .pc in-tree, delete it, and git commit
6093     #     6. Back in the main tree, fast forward to the new HEAD
6094
6095     # Another situation we may have to cope with is gbp-style
6096     # patches-unapplied trees.
6097     #
6098     # We would want to detect these, so we know to escape into
6099     # quilt_fixup_gbp.  However, this is in general not possible.
6100     # Consider a package with a one patch which the dgit user reverts
6101     # (with git revert or the moral equivalent).
6102     #
6103     # That is indistinguishable in contents from a patches-unapplied
6104     # tree.  And looking at the history to distinguish them is not
6105     # useful because the user might have made a confusing-looking git
6106     # history structure (which ought to produce an error if dgit can't
6107     # cope, not a silent reintroduction of an unwanted patch).
6108     #
6109     # So gbp users will have to pass an option.  But we can usually
6110     # detect their failure to do so: if the tree is not a clean
6111     # patches-applied tree, quilt linearisation fails, but the tree
6112     # _is_ a clean patches-unapplied tree, we can suggest that maybe
6113     # they want --quilt=unapplied.
6114     #
6115     # To help detect this, when we are extracting the fake dsc, we
6116     # first extract it with --skip-patches, and then apply the patches
6117     # afterwards with dpkg-source --before-build.  That lets us save a
6118     # tree object corresponding to .origs.
6119
6120     my $splitbrain_cachekey;
6121
6122     quilt_make_fake_dsc($upstreamversion);
6123
6124     if (quiltmode_splitbrain()) {
6125         my $cachehit;
6126         ($cachehit, $splitbrain_cachekey) =
6127             quilt_check_splitbrain_cache($headref, $upstreamversion);
6128         return if $cachehit;
6129     }
6130     my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6131
6132     ensuredir '.pc';
6133
6134     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6135     $!=0; $?=-1;
6136     if (system @bbcmd) {
6137         failedcmd @bbcmd if $? < 0;
6138         fail __ <<END;
6139 failed to apply your git tree's patch stack (from debian/patches/) to
6140  the corresponding upstream tarball(s).  Your source tree and .orig
6141  are probably too inconsistent.  dgit can only fix up certain kinds of
6142  anomaly (depending on the quilt mode).  Please see --quilt= in dgit(1).
6143 END
6144     }
6145
6146     changedir '..';
6147
6148     unpack_playtree_mkwork($headref);
6149
6150     my $mustdeletepc=0;
6151     if (stat_exists ".pc") {
6152         -d _ or die;
6153         progress __ "Tree already contains .pc - will use it then delete it.";
6154         $mustdeletepc=1;
6155     } else {
6156         rename '../fake/.pc','.pc' or confess "$!";
6157     }
6158
6159     changedir '../fake';
6160     rmtree '.pc';
6161     my $oldtiptree=git_add_write_tree();
6162     printdebug "fake o+d/p tree object $unapplied\n";
6163     changedir '../work';
6164
6165
6166     # We calculate some guesswork now about what kind of tree this might
6167     # be.  This is mostly for error reporting.
6168
6169     my %editedignores;
6170     my @unrepres;
6171     my $diffbits = {
6172         # H = user's HEAD
6173         # O = orig, without patches applied
6174         # A = "applied", ie orig with H's debian/patches applied
6175         O2H => quiltify_trees_differ($unapplied,$headref,   1,
6176                                      \%editedignores, \@unrepres),
6177         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
6178         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6179     };
6180
6181     my @dl;
6182     foreach my $bits (qw(01 02)) {
6183         foreach my $v (qw(O2H O2A H2A)) {
6184             push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6185         }
6186     }
6187     printdebug "differences \@dl @dl.\n";
6188
6189     progress f_
6190 "%s: base trees orig=%.20s o+d/p=%.20s",
6191               $us, $unapplied, $oldtiptree;
6192     progress f_
6193 "%s: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
6194 "%s: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
6195   $us,                      $dl[0], $dl[1],              $dl[3], $dl[4],
6196   $us,                          $dl[2],                     $dl[5];
6197
6198     if (@unrepres) {
6199         print STDERR f_ "dgit:  cannot represent change: %s: %s\n",
6200                         $_->[1], $_->[0]
6201             foreach @unrepres;
6202         forceable_fail [qw(unrepresentable)], __ <<END;
6203 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6204 END
6205     }
6206
6207     my @failsuggestion;
6208     if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6209         push @failsuggestion, [ 'unapplied', __
6210  "This might be a patches-unapplied branch." ];
6211     } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6212         push @failsuggestion, [ 'applied', __
6213  "This might be a patches-applied branch." ];
6214     }
6215     push @failsuggestion, [ 'quilt-mode', __
6216  "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6217
6218     push @failsuggestion, [ 'gitattrs', __
6219  "Warning: Tree has .gitattributes.  See GITATTRIBUTES in dgit(7)." ]
6220         if stat_exists '.gitattributes';
6221
6222     push @failsuggestion, [ 'origs', __
6223  "Maybe orig tarball(s) are not identical to git representation?" ];
6224
6225     if ($do_split_brain) {
6226         runcmd @git, qw(checkout -q -b dgit-view);
6227         die if $split_brain;
6228         $split_brain = 1;
6229     }
6230     if (quiltmode_splitbrain()) {
6231         quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6232                             $diffbits, \%editedignores,
6233                             $splitbrain_cachekey);
6234         return;
6235     }
6236
6237     progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6238     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6239
6240     if (!open P, '>>', ".pc/applied-patches") {
6241         $!==&ENOENT or confess "$!";
6242     } else {
6243         close P;
6244     }
6245
6246     commit_quilty_patch();
6247
6248     if ($mustdeletepc) {
6249         quilt_fixup_delete_pc();
6250     }
6251 }
6252
6253 sub quilt_fixup_editor () {
6254     my $descfn = $ENV{$fakeeditorenv};
6255     my $editing = $ARGV[$#ARGV];
6256     open I1, '<', $descfn or confess "$descfn: $!";
6257     open I2, '<', $editing or confess "$editing: $!";
6258     unlink $editing or confess "$editing: $!";
6259     open O, '>', $editing or confess "$editing: $!";
6260     while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6261     my $copying = 0;
6262     while (<I2>) {
6263         $copying ||= m/^\-\-\- /;
6264         next unless $copying;
6265         print O or confess "$!";
6266     }
6267     I2->error and confess "$!";
6268     close O or die $1;
6269     finish 0;
6270 }
6271
6272 sub maybe_apply_patches_dirtily () {
6273     return unless $quilt_mode =~ m/gbp|unapplied/;
6274     print STDERR __ <<END or confess "$!";
6275
6276 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6277 dgit: Have to apply the patches - making the tree dirty.
6278 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6279
6280 END
6281     $patches_applied_dirtily = 01;
6282     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6283     runcmd qw(dpkg-source --before-build .);
6284 }
6285
6286 sub maybe_unapply_patches_again () {
6287     progress __ "dgit: Unapplying patches again to tidy up the tree."
6288         if $patches_applied_dirtily;
6289     runcmd qw(dpkg-source --after-build .)
6290         if $patches_applied_dirtily & 01;
6291     rmtree '.pc'
6292         if $patches_applied_dirtily & 02;
6293     $patches_applied_dirtily = 0;
6294 }
6295
6296 #----- other building -----
6297
6298 sub clean_tree_check_git ($$$) {
6299     my ($honour_ignores, $message, $ignmessage) = @_;
6300     my @cmd = (@git, qw(clean -dn));
6301     push @cmd, qw(-x) unless $honour_ignores;
6302     my $leftovers = cmdoutput @cmd;
6303     if (length $leftovers) {
6304         print STDERR $leftovers, "\n" or confess "$!";
6305         $message .= $ignmessage if $honour_ignores;
6306         fail $message;
6307     }
6308 }
6309
6310 sub clean_tree_check_git_wd ($) {
6311     my ($message) = @_;
6312     return if $cleanmode =~ m{no-check};
6313     return if $patches_applied_dirtily; # yuk
6314     clean_tree_check_git +($cleanmode !~ m{all-check}),
6315         $message, "\n".__ <<END;
6316 If this is just missing .gitignore entries, use a different clean
6317 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6318 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6319 END
6320 }
6321
6322 sub clean_tree_check () {
6323     # This function needs to not care about modified but tracked files.
6324     # That was done by check_not_dirty, and by now we may have run
6325     # the rules clean target which might modify tracked files (!)
6326     if ($cleanmode =~ m{^check}) {
6327         clean_tree_check_git +($cleanmode =~ m{ignores}), __
6328  "tree contains uncommitted files and --clean=check specified", '';
6329     } elsif ($cleanmode =~ m{^dpkg-source}) {
6330         clean_tree_check_git_wd __
6331  "tree contains uncommitted files (NB dgit didn't run rules clean)";
6332     } elsif ($cleanmode =~ m{^git}) {
6333         clean_tree_check_git 1, __
6334  "tree contains uncommited, untracked, unignored files\n".
6335  "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6336     } elsif ($cleanmode eq 'none') {
6337     } else {
6338         confess "$cleanmode ?";
6339     }
6340 }
6341
6342 sub clean_tree () {
6343     # We always clean the tree ourselves, rather than leave it to the
6344     # builder (dpkg-source, or soemthing which calls dpkg-source).
6345     if ($cleanmode =~ m{^dpkg-source}) {
6346         my @cmd = @dpkgbuildpackage;
6347         push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6348         push @cmd, qw(-T clean);
6349         maybe_apply_patches_dirtily();
6350         runcmd_ordryrun_local @cmd;
6351         clean_tree_check_git_wd __
6352  "tree contains uncommitted files (after running rules clean)";
6353     } elsif ($cleanmode =~ m{^git(?!-)}) {
6354         runcmd_ordryrun_local @git, qw(clean -xdf);
6355     } elsif ($cleanmode =~ m{^git-ff}) {
6356         runcmd_ordryrun_local @git, qw(clean -xdff);
6357     } elsif ($cleanmode =~ m{^check}) {
6358         clean_tree_check();
6359     } elsif ($cleanmode eq 'none') {
6360     } else {
6361         confess "$cleanmode ?";
6362     }
6363 }
6364
6365 sub cmd_clean () {
6366     badusage __ "clean takes no additional arguments" if @ARGV;
6367     notpushing();
6368     clean_tree();
6369     maybe_unapply_patches_again();
6370 }
6371
6372 # return values from massage_dbp_args are one or both of these flags
6373 sub WANTSRC_SOURCE  () { 01; } # caller should build source (separately)
6374 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6375
6376 sub build_or_push_prep_early () {
6377     our $build_or_push_prep_early_done //= 0;
6378     return if $build_or_push_prep_early_done++;
6379     badusage f_ "-p is not allowed with dgit %s", $subcommand
6380         if defined $package;
6381     my $clogp = parsechangelog();
6382     $isuite = getfield $clogp, 'Distribution';
6383     $package = getfield $clogp, 'Source';
6384     $version = getfield $clogp, 'Version';
6385     $dscfn = dscfn($version);
6386 }
6387
6388 sub build_prep_early () {
6389     build_or_push_prep_early();
6390     notpushing();
6391     check_not_dirty();
6392 }
6393
6394 sub build_prep ($) {
6395     my ($wantsrc) = @_;
6396     build_prep_early();
6397     check_bpd_exists();
6398     if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6399         # Clean the tree because we're going to use the contents of
6400         # $maindir.  (We trying to include dirty changes in the source
6401         # package, or we are running the builder in $maindir.)
6402         || $cleanmode =~ m{always}) {
6403         # Or because the user asked us to.
6404         clean_tree();
6405     } else {
6406         # We don't actually need to do anything in $maindir, but we
6407         # should do some kind of cleanliness check because (i) the
6408         # user may have forgotten a `git add', and (ii) if the user
6409         # said -wc we should still do the check.
6410         clean_tree_check();
6411     }
6412     build_check_quilt_splitbrain();
6413     if ($rmchanges) {
6414         my $pat = changespat $version;
6415         foreach my $f (glob "$buildproductsdir/$pat") {
6416             if (act_local()) {
6417                 unlink $f or
6418                     fail f_ "remove old changes file %s: %s", $f, $!;
6419             } else {
6420                 progress f_ "would remove %s", $f;
6421             }
6422         }
6423     }
6424 }
6425
6426 sub changesopts_initial () {
6427     my @opts =@changesopts[1..$#changesopts];
6428 }
6429
6430 sub changesopts_version () {
6431     if (!defined $changes_since_version) {
6432         my @vsns;
6433         unless (eval {
6434             @vsns = archive_query('archive_query');
6435             my @quirk = access_quirk();
6436             if ($quirk[0] eq 'backports') {
6437                 local $isuite = $quirk[2];
6438                 local $csuite;
6439                 canonicalise_suite();
6440                 push @vsns, archive_query('archive_query');
6441             }
6442             1;
6443         }) {
6444             print STDERR $@;
6445             fail __
6446  "archive query failed (queried because --since-version not specified)";
6447         }
6448         if (@vsns) {
6449             @vsns = map { $_->[0] } @vsns;
6450             @vsns = sort { -version_compare($a, $b) } @vsns;
6451             $changes_since_version = $vsns[0];
6452             progress f_ "changelog will contain changes since %s", $vsns[0];
6453         } else {
6454             $changes_since_version = '_';
6455             progress __ "package seems new, not specifying -v<version>";
6456         }
6457     }
6458     if ($changes_since_version ne '_') {
6459         return ("-v$changes_since_version");
6460     } else {
6461         return ();
6462     }
6463 }
6464
6465 sub changesopts () {
6466     return (changesopts_initial(), changesopts_version());
6467 }
6468
6469 sub massage_dbp_args ($;$) {
6470     my ($cmd,$xargs) = @_;
6471     # Since we split the source build out so we can do strange things
6472     # to it, massage the arguments to dpkg-buildpackage so that the
6473     # main build doessn't build source (or add an argument to stop it
6474     # building source by default).
6475     debugcmd '#massaging#', @$cmd if $debuglevel>1;
6476     # -nc has the side effect of specifying -b if nothing else specified
6477     # and some combinations of -S, -b, et al, are errors, rather than
6478     # later simply overriding earlie.  So we need to:
6479     #  - search the command line for these options
6480     #  - pick the last one
6481     #  - perhaps add our own as a default
6482     #  - perhaps adjust it to the corresponding non-source-building version
6483     my $dmode = '-F';
6484     foreach my $l ($cmd, $xargs) {
6485         next unless $l;
6486         @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6487     }
6488     push @$cmd, '-nc';
6489 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6490     my $r = WANTSRC_BUILDER;
6491     printdebug "massage split $dmode.\n";
6492     if ($dmode =~ s/^--build=//) {
6493         $r = 0;
6494         my @d = split /,/, $dmode;
6495         $r |= WANTSRC_SOURCE  if grep { s/^full$/binary/ } @d;
6496         $r |= WANTSRC_SOURCE  if grep { s/^source$// } @d;
6497         $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6498         fail __ "Wanted to build nothing!" unless $r;
6499         $dmode = '--build='. join ',', grep m/./, @d;
6500     } else {
6501         $r =
6502           $dmode =~ m/[S]/     ?  WANTSRC_SOURCE :
6503           $dmode =~ y/gGF/ABb/ ?  WANTSRC_SOURCE | WANTSRC_BUILDER :
6504           $dmode =~ m/[ABb]/   ?                   WANTSRC_BUILDER :
6505           confess "$dmode ?";
6506     }
6507     printdebug "massage done $r $dmode.\n";
6508     push @$cmd, $dmode;
6509 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6510     return $r;
6511 }
6512
6513 sub in_bpd (&) {
6514     my ($fn) = @_;
6515     my $wasdir = must_getcwd();
6516     changedir $buildproductsdir;
6517     $fn->();
6518     changedir $wasdir;
6519 }
6520
6521 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6522 sub postbuild_mergechanges ($) {
6523     my ($msg_if_onlyone) = @_;
6524     # If there is only one .changes file, fail with $msg_if_onlyone,
6525     # or if that is undef, be a no-op.
6526     # Returns the changes file to report to the user.
6527     my $pat = changespat $version;
6528     my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6529     @changesfiles = sort {
6530         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6531             or $a cmp $b
6532     } @changesfiles;
6533     my $result;
6534     if (@changesfiles==1) {
6535         fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6536 only one changes file from build (%s)
6537 END
6538             if defined $msg_if_onlyone;
6539         $result = $changesfiles[0];
6540     } elsif (@changesfiles==2) {
6541         my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6542         foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6543             fail f_ "%s found in binaries changes file %s", $l, $binchanges
6544                 if $l =~ m/\.dsc$/;
6545         }
6546         runcmd_ordryrun_local @mergechanges, @changesfiles;
6547         my $multichanges = changespat $version,'multi';
6548         if (act_local()) {
6549             stat_exists $multichanges or fail f_
6550                 "%s unexpectedly not created by build", $multichanges;
6551             foreach my $cf (glob $pat) {
6552                 next if $cf eq $multichanges;
6553                 rename "$cf", "$cf.inmulti" or fail f_
6554                     "install new changes %s\{,.inmulti}: %s", $cf, $!;
6555             }
6556         }
6557         $result = $multichanges;
6558     } else {
6559         fail f_ "wrong number of different changes files (%s)",
6560                 "@changesfiles";
6561     }
6562     printdone f_ "build successful, results in %s\n", $result
6563         or confess "$!";
6564 }
6565
6566 sub midbuild_checkchanges () {
6567     my $pat = changespat $version;
6568     return if $rmchanges;
6569     my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6570     @unwanted = grep {
6571         $_ ne changespat $version,'source' and
6572         $_ ne changespat $version,'multi'
6573     } @unwanted;
6574     fail +(f_ <<END, $pat, "@unwanted")
6575 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6576 Suggest you delete %s.
6577 END
6578         if @unwanted;
6579 }
6580
6581 sub midbuild_checkchanges_vanilla ($) {
6582     my ($wantsrc) = @_;
6583     midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6584 }
6585
6586 sub postbuild_mergechanges_vanilla ($) {
6587     my ($wantsrc) = @_;
6588     if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6589         in_bpd {
6590             postbuild_mergechanges(undef);
6591         };
6592     } else {
6593         printdone __ "build successful\n";
6594     }
6595 }
6596
6597 sub cmd_build {
6598     build_prep_early();
6599     $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6600 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6601 %s: warning: build-products-dir will be ignored; files will go to ..
6602 END
6603     $buildproductsdir = '..';
6604     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6605     my $wantsrc = massage_dbp_args \@dbp;
6606     build_prep($wantsrc);
6607     if ($wantsrc & WANTSRC_SOURCE) {
6608         build_source();
6609         midbuild_checkchanges_vanilla $wantsrc;
6610     }
6611     if ($wantsrc & WANTSRC_BUILDER) {
6612         push @dbp, changesopts_version();
6613         maybe_apply_patches_dirtily();
6614         runcmd_ordryrun_local @dbp;
6615     }
6616     maybe_unapply_patches_again();
6617     postbuild_mergechanges_vanilla $wantsrc;
6618 }
6619
6620 sub pre_gbp_build {
6621     $quilt_mode //= 'gbp';
6622 }
6623
6624 sub cmd_gbp_build {
6625     build_prep_early();
6626
6627     # gbp can make .origs out of thin air.  In my tests it does this
6628     # even for a 1.0 format package, with no origs present.  So I
6629     # guess it keys off just the version number.  We don't know
6630     # exactly what .origs ought to exist, but let's assume that we
6631     # should run gbp if: the version has an upstream part and the main
6632     # orig is absent.
6633     my $upstreamversion = upstreamversion $version;
6634     my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6635     my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6636
6637     if ($gbp_make_orig) {
6638         clean_tree();
6639         $cleanmode = 'none'; # don't do it again
6640     }
6641
6642     my @dbp = @dpkgbuildpackage;
6643
6644     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6645
6646     if (!length $gbp_build[0]) {
6647         if (length executable_on_path('git-buildpackage')) {
6648             $gbp_build[0] = qw(git-buildpackage);
6649         } else {
6650             $gbp_build[0] = 'gbp buildpackage';
6651         }
6652     }
6653     my @cmd = opts_opt_multi_cmd [], @gbp_build;
6654
6655     push @cmd, (qw(-us -uc --git-no-sign-tags),
6656                 "--git-builder=".(shellquote @dbp));
6657
6658     if ($gbp_make_orig) {
6659         my $priv = dgit_privdir();
6660         my $ok = "$priv/origs-gen-ok";
6661         unlink $ok or $!==&ENOENT or confess "$!";
6662         my @origs_cmd = @cmd;
6663         push @origs_cmd, qw(--git-cleaner=true);
6664         push @origs_cmd, "--git-prebuild=".
6665             "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6666         push @origs_cmd, @ARGV;
6667         if (act_local()) {
6668             debugcmd @origs_cmd;
6669             system @origs_cmd;
6670             do { local $!; stat_exists $ok; }
6671                 or failedcmd @origs_cmd;
6672         } else {
6673             dryrun_report @origs_cmd;
6674         }
6675     }
6676
6677     build_prep($wantsrc);
6678     if ($wantsrc & WANTSRC_SOURCE) {
6679         build_source();
6680         midbuild_checkchanges_vanilla $wantsrc;
6681     } else {
6682         push @cmd, '--git-cleaner=true';
6683     }
6684     maybe_unapply_patches_again();
6685     if ($wantsrc & WANTSRC_BUILDER) {
6686         push @cmd, changesopts();
6687         runcmd_ordryrun_local @cmd, @ARGV;
6688     }
6689     postbuild_mergechanges_vanilla $wantsrc;
6690 }
6691 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6692
6693 sub building_source_in_playtree {
6694     # If $includedirty, we have to build the source package from the
6695     # working tree, not a playtree, so that uncommitted changes are
6696     # included (copying or hardlinking them into the playtree could
6697     # cause trouble).
6698     #
6699     # Note that if we are building a source package in split brain
6700     # mode we do not support including uncommitted changes, because
6701     # that makes quilt fixup too hard.  I.e. ($split_brain && (dgit is
6702     # building a source package)) => !$includedirty
6703     return !$includedirty;
6704 }
6705
6706 sub build_source {
6707     $sourcechanges = changespat $version,'source';
6708     if (act_local()) {
6709         unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6710             or fail f_ "remove %s: %s", $sourcechanges, $!;
6711     }
6712     my @cmd = (@dpkgsource, qw(-b --));
6713     my $leafdir;
6714     if (building_source_in_playtree()) {
6715         $leafdir = 'work';
6716         my $headref = git_rev_parse('HEAD');
6717         # If we are in split brain, there is already a playtree with
6718         # the thing we should package into a .dsc (thanks to quilt
6719         # fixup).  If not, make a playtree
6720         prep_ud() unless $split_brain;
6721         changedir $playground;
6722         unless ($split_brain) {
6723             my $upstreamversion = upstreamversion $version;
6724             unpack_playtree_linkorigs($upstreamversion, sub { });
6725             unpack_playtree_mkwork($headref);
6726             changedir '..';
6727         }
6728     } else {
6729         $leafdir = basename $maindir;
6730
6731         if ($buildproductsdir ne '..') {
6732             # Well, we are going to run dpkg-source -b which consumes
6733             # origs from .. and generates output there.  To make this
6734             # work when the bpd is not .. , we would have to (i) link
6735             # origs from bpd to .. , (ii) check for files that
6736             # dpkg-source -b would/might overwrite, and afterwards
6737             # (iii) move all the outputs back to the bpd (iv) except
6738             # for the origs which should be deleted from .. if they
6739             # weren't there beforehand.  And if there is an error and
6740             # we don't run to completion we would necessarily leave a
6741             # mess.  This is too much.  The real way to fix this
6742             # is for dpkg-source to have bpd support.
6743             confess unless $includedirty;
6744             fail __
6745  "--include-dirty not supported with --build-products-dir, sorry";
6746         }
6747
6748         changedir '..';
6749     }
6750     runcmd_ordryrun_local @cmd, $leafdir;
6751
6752     changedir $leafdir;
6753     runcmd_ordryrun_local qw(sh -ec),
6754       'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6755       @dpkggenchanges, qw(-S), changesopts();
6756     changedir '..';
6757
6758     printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6759     $dsc = parsecontrol($dscfn, "source package");
6760
6761     my $mv = sub {
6762         my ($why, $l) = @_;
6763         printdebug " renaming ($why) $l\n";
6764         rename_link_xf 0, "$l", bpd_abs()."/$l"
6765             or fail f_ "put in place new built file (%s): %s", $l, $@;
6766     };
6767     foreach my $l (split /\n/, getfield $dsc, 'Files') {
6768         $l =~ m/\S+$/ or next;
6769         $mv->('Files', $&);
6770     }
6771     $mv->('dsc', $dscfn);
6772     $mv->('changes', $sourcechanges);
6773
6774     changedir $maindir;
6775 }
6776
6777 sub cmd_build_source {
6778     badusage __ "build-source takes no additional arguments" if @ARGV;
6779     build_prep(WANTSRC_SOURCE);
6780     build_source();
6781     maybe_unapply_patches_again();
6782     printdone f_ "source built, results in %s and %s",
6783                  $dscfn, $sourcechanges;
6784 }
6785
6786 sub cmd_push_source {
6787     prep_push();
6788     fail __
6789         "dgit push-source: --include-dirty/--ignore-dirty does not make".
6790         "sense with push-source!"
6791         if $includedirty;
6792     build_check_quilt_splitbrain();
6793     if ($changesfile) {
6794         my $changes = parsecontrol("$buildproductsdir/$changesfile",
6795                                    __ "source changes file");
6796         unless (test_source_only_changes($changes)) {
6797             fail __ "user-specified changes file is not source-only";
6798         }
6799     } else {
6800         # Building a source package is very fast, so just do it
6801         build_source();
6802         confess "er, patches are applied dirtily but shouldn't be.."
6803             if $patches_applied_dirtily;
6804         $changesfile = $sourcechanges;
6805     }
6806     dopush();
6807 }
6808
6809 sub binary_builder {
6810     my ($bbuilder, $pbmc_msg, @args) = @_;
6811     build_prep(WANTSRC_SOURCE);
6812     build_source();
6813     midbuild_checkchanges();
6814     in_bpd {
6815         if (act_local()) {
6816             stat_exists $dscfn or fail f_
6817                 "%s (in build products dir): %s", $dscfn, $!;
6818             stat_exists $sourcechanges or fail f_
6819                 "%s (in build products dir): %s", $sourcechanges, $!;
6820         }
6821         runcmd_ordryrun_local @$bbuilder, @args;
6822     };
6823     maybe_unapply_patches_again();
6824     in_bpd {
6825         postbuild_mergechanges($pbmc_msg);
6826     };
6827 }
6828
6829 sub cmd_sbuild {
6830     build_prep_early();
6831     binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6832 perhaps you need to pass -A ?  (sbuild's default is to build only
6833 arch-specific binaries; dgit 1.4 used to override that.)
6834 END
6835 }
6836
6837 sub pbuilder ($) {
6838     my ($pbuilder) = @_;
6839     build_prep_early();
6840     # @ARGV is allowed to contain only things that should be passed to
6841     # pbuilder under debbuildopts; just massage those
6842     my $wantsrc = massage_dbp_args \@ARGV;
6843     fail __
6844         "you asked for a builder but your debbuildopts didn't ask for".
6845         " any binaries -- is this really what you meant?"
6846         unless $wantsrc & WANTSRC_BUILDER;
6847     fail __
6848         "we must build a .dsc to pass to the builder but your debbuiltopts".
6849         " forbids the building of a source package; cannot continue"
6850       unless $wantsrc & WANTSRC_SOURCE;
6851     # We do not want to include the verb "build" in @pbuilder because
6852     # the user can customise @pbuilder and they shouldn't be required
6853     # to include "build" in their customised value.  However, if the
6854     # user passes any additional args to pbuilder using the dgit
6855     # option --pbuilder:foo, such args need to come after the "build"
6856     # verb.  opts_opt_multi_cmd does all of that.
6857     binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6858                    qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6859                    $dscfn);
6860 }
6861
6862 sub cmd_pbuilder {
6863     pbuilder(\@pbuilder);
6864 }
6865
6866 sub cmd_cowbuilder {
6867     pbuilder(\@cowbuilder);
6868 }
6869
6870 sub cmd_quilt_fixup {
6871     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6872     build_prep_early();
6873     clean_tree();
6874     build_maybe_quilt_fixup();
6875 }
6876
6877 sub cmd_print_unapplied_treeish {
6878     badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6879         if @ARGV;
6880     my $headref = git_rev_parse('HEAD');
6881     my $clogp = commit_getclogp $headref;
6882     $package = getfield $clogp, 'Source';
6883     $version = getfield $clogp, 'Version';
6884     $isuite = getfield $clogp, 'Distribution';
6885     $csuite = $isuite; # we want this to be offline!
6886     notpushing();
6887
6888     prep_ud();
6889     changedir $playground;
6890     my $uv = upstreamversion $version;
6891     quilt_make_fake_dsc($uv);
6892     my $u = quilt_fakedsc2unapplied($headref, $uv);
6893     print $u, "\n" or confess "$!";
6894 }
6895
6896 sub import_dsc_result {
6897     my ($dstref, $newhash, $what_log, $what_msg) = @_;
6898     my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6899     runcmd @cmd;
6900     check_gitattrs($newhash, __ "source tree");
6901
6902     progress f_ "dgit: import-dsc: %s", $what_msg;
6903 }
6904
6905 sub cmd_import_dsc {
6906     my $needsig = 0;
6907
6908     while (@ARGV) {
6909         last unless $ARGV[0] =~ m/^-/;
6910         $_ = shift @ARGV;
6911         last if m/^--?$/;
6912         if (m/^--require-valid-signature$/) {
6913             $needsig = 1;
6914         } else {
6915             badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6916         }
6917     }
6918
6919     badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6920         unless @ARGV==2;
6921     my ($dscfn, $dstbranch) = @ARGV;
6922
6923     badusage __ "dry run makes no sense with import-dsc"
6924         unless act_local();
6925
6926     my $force = $dstbranch =~ s/^\+//   ? +1 :
6927                 $dstbranch =~ s/^\.\.// ? -1 :
6928                                            0;
6929     my $info = $force ? " $&" : '';
6930     $info = "$dscfn$info";
6931
6932     my $specbranch = $dstbranch;
6933     $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6934     $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6935
6936     my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6937     my $chead = cmdoutput_errok @symcmd;
6938     defined $chead or $?==256 or failedcmd @symcmd;
6939
6940     fail f_ "%s is checked out - will not update it", $dstbranch
6941         if defined $chead and $chead eq $dstbranch;
6942
6943     my $oldhash = git_get_ref $dstbranch;
6944
6945     open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6946     $dscdata = do { local $/ = undef; <D>; };
6947     D->error and fail f_ "read %s: %s", $dscfn, $!;
6948     close C;
6949
6950     # we don't normally need this so import it here
6951     use Dpkg::Source::Package;
6952     my $dp = new Dpkg::Source::Package filename => $dscfn,
6953         require_valid_signature => $needsig;
6954     {
6955         local $SIG{__WARN__} = sub {
6956             print STDERR $_[0];
6957             return unless $needsig;
6958             fail __ "import-dsc signature check failed";
6959         };
6960         if (!$dp->is_signed()) {
6961             warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6962         } else {
6963             my $r = $dp->check_signature();
6964             confess "->check_signature => $r" if $needsig && $r;
6965         }
6966     }
6967
6968     parse_dscdata();
6969
6970     $package = getfield $dsc, 'Source';
6971
6972     parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6973         unless forceing [qw(import-dsc-with-dgit-field)];
6974     parse_dsc_field_def_dsc_distro();
6975
6976     $isuite = 'DGIT-IMPORT-DSC';
6977     $idistro //= $dsc_distro;
6978
6979     notpushing();
6980
6981     if (defined $dsc_hash) {
6982         progress __
6983             "dgit: import-dsc of .dsc with Dgit field, using git hash";
6984         resolve_dsc_field_commit undef, undef;
6985     }
6986     if (defined $dsc_hash) {
6987         my @cmd = (qw(sh -ec),
6988                    "echo $dsc_hash | git cat-file --batch-check");
6989         my $objgot = cmdoutput @cmd;
6990         if ($objgot =~ m#^\w+ missing\b#) {
6991             fail f_ <<END, $dsc_hash
6992 .dsc contains Dgit field referring to object %s
6993 Your git tree does not have that object.  Try `git fetch' from a
6994 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
6995 END
6996         }
6997         if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6998             if ($force > 0) {
6999                 progress __ "Not fast forward, forced update.";
7000             } else {
7001                 fail f_ "Not fast forward to %s", $dsc_hash;
7002             }
7003         }
7004         import_dsc_result $dstbranch, $dsc_hash,
7005             "dgit import-dsc (Dgit): $info",
7006             f_ "updated git ref %s", $dstbranch;
7007         return 0;
7008     }
7009
7010     fail f_ <<END, $dstbranch, $specbranch, $specbranch
7011 Branch %s already exists
7012 Specify ..%s for a pseudo-merge, binding in existing history
7013 Specify  +%s to overwrite, discarding existing history
7014 END
7015         if $oldhash && !$force;
7016
7017     my @dfi = dsc_files_info();
7018     foreach my $fi (@dfi) {
7019         my $f = $fi->{Filename};
7020         # We transfer all the pieces of the dsc to the bpd, not just
7021         # origs.  This is by analogy with dgit fetch, which wants to
7022         # keep them somewhere to avoid downloading them again.
7023         # We make symlinks, though.  If the user wants copies, then
7024         # they can copy the parts of the dsc to the bpd using dcmd,
7025         # or something.
7026         my $here = "$buildproductsdir/$f";
7027         if (lstat $here) {
7028             if (stat $here) {
7029                 next;
7030             }
7031             fail f_ "lstat %s works but stat gives %s !", $here, $!;
7032         }
7033         fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7034         printdebug "not in bpd, $f ...\n";
7035         # $f does not exist in bpd, we need to transfer it
7036         my $there = $dscfn;
7037         $there =~ s{[^/]+$}{$f} or confess "$there ?";
7038         # $there is file we want, relative to user's cwd, or abs
7039         printdebug "not in bpd, $f, test $there ...\n";
7040         stat $there or fail f_
7041             "import %s requires %s, but: %s", $dscfn, $there, $!;
7042         if ($there =~ m#^(?:\./+)?\.\./+#) {
7043             # $there is relative to user's cwd
7044             my $there_from_parent = $';
7045             if ($buildproductsdir !~ m{^/}) {
7046                 # abs2rel, despite its name, can take two relative paths
7047                 $there = File::Spec->abs2rel($there,$buildproductsdir);
7048                 # now $there is relative to bpd, great
7049                 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7050             } else {
7051                 $there = (dirname $maindir)."/$there_from_parent";
7052                 # now $there is absoute
7053                 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7054             }
7055         } elsif ($there =~ m#^/#) {
7056             # $there is absolute already
7057             printdebug "not in bpd, $f, abs, $there ...\n";
7058         } else {
7059             fail f_
7060                 "cannot import %s which seems to be inside working tree!",
7061                 $dscfn;
7062         }
7063         symlink $there, $here or fail f_
7064             "symlink %s to %s: %s", $there, $here, $!;
7065         progress f_ "made symlink %s -> %s", $here, $there;
7066 #       print STDERR Dumper($fi);
7067     }
7068     my @mergeinputs = generate_commits_from_dsc();
7069     die unless @mergeinputs == 1;
7070
7071     my $newhash = $mergeinputs[0]{Commit};
7072
7073     if ($oldhash) {
7074         if ($force > 0) {
7075             progress __
7076                 "Import, forced update - synthetic orphan git history.";
7077         } elsif ($force < 0) {
7078             progress __ "Import, merging.";
7079             my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7080             my $version = getfield $dsc, 'Version';
7081             my $clogp = commit_getclogp $newhash;
7082             my $authline = clogp_authline $clogp;
7083             $newhash = make_commit_text <<ENDU
7084 tree $tree
7085 parent $newhash
7086 parent $oldhash
7087 author $authline
7088 committer $authline
7089
7090 ENDU
7091                 .(f_ <<END, $package, $version, $dstbranch);
7092 Merge %s (%s) import into %s
7093 END
7094         } else {
7095             die; # caught earlier
7096         }
7097     }
7098
7099     import_dsc_result $dstbranch, $newhash,
7100         "dgit import-dsc: $info",
7101         f_ "results are in git ref %s", $dstbranch;
7102 }
7103
7104 sub pre_archive_api_query () {
7105     not_necessarily_a_tree();
7106 }
7107 sub cmd_archive_api_query {
7108     badusage __ "need only 1 subpath argument" unless @ARGV==1;
7109     my ($subpath) = @ARGV;
7110     local $isuite = 'DGIT-API-QUERY-CMD';
7111     my @cmd = archive_api_query_cmd($subpath);
7112     push @cmd, qw(-f);
7113     debugcmd ">",@cmd;
7114     exec @cmd or fail f_ "exec curl: %s\n", $!;
7115 }
7116
7117 sub repos_server_url () {
7118     $package = '_dgit-repos-server';
7119     local $access_forpush = 1;
7120     local $isuite = 'DGIT-REPOS-SERVER';
7121     my $url = access_giturl();
7122 }
7123
7124 sub pre_clone_dgit_repos_server () {
7125     not_necessarily_a_tree();
7126 }
7127 sub cmd_clone_dgit_repos_server {
7128     badusage __ "need destination argument" unless @ARGV==1;
7129     my ($destdir) = @ARGV;
7130     my $url = repos_server_url();
7131     my @cmd = (@git, qw(clone), $url, $destdir);
7132     debugcmd ">",@cmd;
7133     exec @cmd or fail f_ "exec git clone: %s\n", $!;
7134 }
7135
7136 sub pre_print_dgit_repos_server_source_url () {
7137     not_necessarily_a_tree();
7138 }
7139 sub cmd_print_dgit_repos_server_source_url {
7140     badusage __
7141         "no arguments allowed to dgit print-dgit-repos-server-source-url"
7142         if @ARGV;
7143     my $url = repos_server_url();
7144     print $url, "\n" or confess "$!";
7145 }
7146
7147 sub pre_print_dpkg_source_ignores {
7148     not_necessarily_a_tree();
7149 }
7150 sub cmd_print_dpkg_source_ignores {
7151     badusage __
7152         "no arguments allowed to dgit print-dpkg-source-ignores"
7153         if @ARGV;
7154     print "@dpkg_source_ignores\n" or confess "$!";
7155 }
7156
7157 sub cmd_setup_mergechangelogs {
7158     badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7159         if @ARGV;
7160     local $isuite = 'DGIT-SETUP-TREE';
7161     setup_mergechangelogs(1);
7162 }
7163
7164 sub cmd_setup_useremail {
7165     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7166     local $isuite = 'DGIT-SETUP-TREE';
7167     setup_useremail(1);
7168 }
7169
7170 sub cmd_setup_gitattributes {
7171     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7172     local $isuite = 'DGIT-SETUP-TREE';
7173     setup_gitattrs(1);
7174 }
7175
7176 sub cmd_setup_new_tree {
7177     badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7178     local $isuite = 'DGIT-SETUP-TREE';
7179     setup_new_tree();
7180 }
7181
7182 #---------- argument parsing and main program ----------
7183
7184 sub cmd_version {
7185     print "dgit version $our_version\n" or confess "$!";
7186     finish 0;
7187 }
7188
7189 our (%valopts_long, %valopts_short);
7190 our (%funcopts_long);
7191 our @rvalopts;
7192 our (@modeopt_cfgs);
7193
7194 sub defvalopt ($$$$) {
7195     my ($long,$short,$val_re,$how) = @_;
7196     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7197     $valopts_long{$long} = $oi;
7198     $valopts_short{$short} = $oi;
7199     # $how subref should:
7200     #   do whatever assignemnt or thing it likes with $_[0]
7201     #   if the option should not be passed on to remote, @rvalopts=()
7202     # or $how can be a scalar ref, meaning simply assign the value
7203 }
7204
7205 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7206 defvalopt '--distro',        '-d', '.+',      \$idistro;
7207 defvalopt '',                '-k', '.+',      \$keyid;
7208 defvalopt '--existing-package','', '.*',      \$existing_package;
7209 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
7210 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
7211 defvalopt '--package',   '-p',   $package_re, \$package;
7212 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
7213
7214 defvalopt '', '-C', '.+', sub {
7215     ($changesfile) = (@_);
7216     if ($changesfile =~ s#^(.*)/##) {
7217         $buildproductsdir = $1;
7218     }
7219 };
7220
7221 defvalopt '--initiator-tempdir','','.*', sub {
7222     ($initiator_tempdir) = (@_);
7223     $initiator_tempdir =~ m#^/# or
7224         badusage __ "--initiator-tempdir must be used specify an".
7225                     " absolute, not relative, directory."
7226 };
7227
7228 sub defoptmodes ($@) {
7229     my ($varref, $cfgkey, $default, %optmap) = @_;
7230     my %permit;
7231     while (my ($opt,$val) = each %optmap) {
7232         $funcopts_long{$opt} = sub { $$varref = $val; };
7233         $permit{$val} = $val;
7234     }
7235     push @modeopt_cfgs, {
7236         Var => $varref,
7237         Key => $cfgkey,
7238         Default => $default,
7239         Vals => \%permit
7240     };
7241 }
7242
7243 defoptmodes \$dodep14tag, qw( dep14tag          want
7244                               --dep14tag        want
7245                               --no-dep14tag     no
7246                               --always-dep14tag always );
7247
7248 sub parseopts () {
7249     my $om;
7250
7251     if (defined $ENV{'DGIT_SSH'}) {
7252         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7253     } elsif (defined $ENV{'GIT_SSH'}) {
7254         @ssh = ($ENV{'GIT_SSH'});
7255     }
7256
7257     my $oi;
7258     my $val;
7259     my $valopt = sub {
7260         my ($what) = @_;
7261         @rvalopts = ($_);
7262         if (!defined $val) {
7263             badusage f_ "%s needs a value", $what unless @ARGV;
7264             $val = shift @ARGV;
7265             push @rvalopts, $val;
7266         }
7267         badusage f_ "bad value \`%s' for %s", $val, $what unless
7268             $val =~ m/^$oi->{Re}$(?!\n)/s;
7269         my $how = $oi->{How};
7270         if (ref($how) eq 'SCALAR') {
7271             $$how = $val;
7272         } else {
7273             $how->($val);
7274         }
7275         push @ropts, @rvalopts;
7276     };
7277
7278     while (@ARGV) {
7279         last unless $ARGV[0] =~ m/^-/;
7280         $_ = shift @ARGV;
7281         last if m/^--?$/;
7282         if (m/^--/) {
7283             if (m/^--dry-run$/) {
7284                 push @ropts, $_;
7285                 $dryrun_level=2;
7286             } elsif (m/^--damp-run$/) {
7287                 push @ropts, $_;
7288                 $dryrun_level=1;
7289             } elsif (m/^--no-sign$/) {
7290                 push @ropts, $_;
7291                 $sign=0;
7292             } elsif (m/^--help$/) {
7293                 cmd_help();
7294             } elsif (m/^--version$/) {
7295                 cmd_version();
7296             } elsif (m/^--new$/) {
7297                 push @ropts, $_;
7298                 $new_package=1;
7299             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7300                      ($om = $opts_opt_map{$1}) &&
7301                      length $om->[0]) {
7302                 push @ropts, $_;
7303                 $om->[0] = $2;
7304             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7305                      !$opts_opt_cmdonly{$1} &&
7306                      ($om = $opts_opt_map{$1})) {
7307                 push @ropts, $_;
7308                 push @$om, $2;
7309             } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7310                      !$opts_opt_cmdonly{$1} &&
7311                      ($om = $opts_opt_map{$1})) {
7312                 push @ropts, $_;
7313                 my $cmd = shift @$om;
7314                 @$om = ($cmd, grep { $_ ne $2 } @$om);
7315             } elsif (m/^--(gbp|dpm)$/s) {
7316                 push @ropts, "--quilt=$1";
7317                 $quilt_mode = $1;
7318             } elsif (m/^--(?:ignore|include)-dirty$/s) {
7319                 push @ropts, $_;
7320                 $includedirty = 1;
7321             } elsif (m/^--no-quilt-fixup$/s) {
7322                 push @ropts, $_;
7323                 $quilt_mode = 'nocheck';
7324             } elsif (m/^--no-rm-on-error$/s) {
7325                 push @ropts, $_;
7326                 $rmonerror = 0;
7327             } elsif (m/^--no-chase-dsc-distro$/s) {
7328                 push @ropts, $_;
7329                 $chase_dsc_distro = 0;
7330             } elsif (m/^--overwrite$/s) {
7331                 push @ropts, $_;
7332                 $overwrite_version = '';
7333             } elsif (m/^--overwrite=(.+)$/s) {
7334                 push @ropts, $_;
7335                 $overwrite_version = $1;
7336             } elsif (m/^--delayed=(\d+)$/s) {
7337                 push @ropts, $_;
7338                 push @dput, $_;
7339             } elsif (my ($k,$v) =
7340                      m/^--save-(dgit-view)=(.+)$/s ||
7341                      m/^--(dgit-view)-save=(.+)$/s
7342                      ) {
7343                 push @ropts, $_;
7344                 $v =~ s#^(?!refs/)#refs/heads/#;
7345                 $internal_object_save{$k} = $v;
7346             } elsif (m/^--(no-)?rm-old-changes$/s) {
7347                 push @ropts, $_;
7348                 $rmchanges = !$1;
7349             } elsif (m/^--deliberately-($deliberately_re)$/s) {
7350                 push @ropts, $_;
7351                 push @deliberatelies, $&;
7352             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7353                 push @ropts, $&;
7354                 $forceopts{$1} = 1;
7355                 $_='';
7356             } elsif (m/^--force-/) {
7357                 print STDERR
7358                     f_ "%s: warning: ignoring unknown force option %s\n",
7359                        $us, $_;
7360                 $_='';
7361             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7362                 # undocumented, for testing
7363                 push @ropts, $_;
7364                 $tagformat_want = [ $1, 'command line', 1 ];
7365                 # 1 menas overrides distro configuration
7366             } elsif (m/^--config-lookup-explode=(.+)$/s) {
7367                 # undocumented, for testing
7368                 push @ropts, $_;
7369                 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7370                 # ^ it's supposed to be an array ref
7371             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7372                 $val = $2 ? $' : undef; #';
7373                 $valopt->($oi->{Long});
7374             } elsif ($funcopts_long{$_}) {
7375                 push @ropts, $_;
7376                 $funcopts_long{$_}();
7377             } else {
7378                 badusage f_ "unknown long option \`%s'", $_;
7379             }
7380         } else {
7381             while (m/^-./s) {
7382                 if (s/^-n/-/) {
7383                     push @ropts, $&;
7384                     $dryrun_level=2;
7385                 } elsif (s/^-L/-/) {
7386                     push @ropts, $&;
7387                     $dryrun_level=1;
7388                 } elsif (s/^-h/-/) {
7389                     cmd_help();
7390                 } elsif (s/^-D/-/) {
7391                     push @ropts, $&;
7392                     $debuglevel++;
7393                     enabledebug();
7394                 } elsif (s/^-N/-/) {
7395                     push @ropts, $&;
7396                     $new_package=1;
7397                 } elsif (m/^-m/) {
7398                     push @ropts, $&;
7399                     push @changesopts, $_;
7400                     $_ = '';
7401                 } elsif (s/^-wn$//s) {
7402                     push @ropts, $&;
7403                     $cleanmode = 'none';
7404                 } elsif (s/^-wg(f?)(a?)$//s) {
7405                     push @ropts, $&;
7406                     $cleanmode = 'git';
7407                     $cleanmode .= '-ff' if $1;
7408                     $cleanmode .= ',always' if $2;
7409                 } elsif (s/^-wd(d?)([na]?)$//s) {
7410                     push @ropts, $&;
7411                     $cleanmode = 'dpkg-source';
7412                     $cleanmode .= '-d' if $1;
7413                     $cleanmode .= ',no-check' if $2 eq 'n';
7414                     $cleanmode .= ',all-check' if $2 eq 'a';
7415                 } elsif (s/^-wc$//s) {
7416                     push @ropts, $&;
7417                     $cleanmode = 'check';
7418                 } elsif (s/^-wci$//s) {
7419                     push @ropts, $&;
7420                     $cleanmode = 'check,ignores';
7421                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7422                     push @git, '-c', $&;
7423                     $gitcfgs{cmdline}{$1} = [ $2 ];
7424                 } elsif (s/^-c([^=]+)$//s) {
7425                     push @git, '-c', $&;
7426                     $gitcfgs{cmdline}{$1} = [ 'true' ];
7427                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7428                     $val = $'; #';
7429                     $val = undef unless length $val;
7430                     $valopt->($oi->{Short});
7431                     $_ = '';
7432                 } else {
7433                     badusage f_ "unknown short option \`%s'", $_;
7434                 }
7435             }
7436         }
7437     }
7438 }
7439
7440 sub check_env_sanity () {
7441     my $blocked = new POSIX::SigSet;
7442     sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7443
7444     eval {
7445         foreach my $name (qw(PIPE CHLD)) {
7446             my $signame = "SIG$name";
7447             my $signum = eval "POSIX::$signame" // die;
7448             die f_ "%s is set to something other than SIG_DFL\n",
7449                 $signame
7450                 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7451             $blocked->ismember($signum) and
7452                 die f_ "%s is blocked\n", $signame;
7453         }
7454     };
7455     return unless $@;
7456     chomp $@;
7457     fail f_ <<END, $@;
7458 On entry to dgit, %s
7459 This is a bug produced by something in your execution environment.
7460 Giving up.
7461 END
7462 }
7463
7464
7465 sub parseopts_late_defaults () {
7466     $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7467         if defined $idistro;
7468     $isuite //= cfg('dgit.default.default-suite');
7469
7470     foreach my $k (keys %opts_opt_map) {
7471         my $om = $opts_opt_map{$k};
7472
7473         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7474         if (defined $v) {
7475             badcfg f_ "cannot set command for %s", $k
7476                 unless length $om->[0];
7477             $om->[0] = $v;
7478         }
7479
7480         foreach my $c (access_cfg_cfgs("opts-$k")) {
7481             my @vl =
7482                 map { $_ ? @$_ : () }
7483                 map { $gitcfgs{$_}{$c} }
7484                 reverse @gitcfgsources;
7485             printdebug "CL $c ", (join " ", map { shellquote } @vl),
7486                 "\n" if $debuglevel >= 4;
7487             next unless @vl;
7488             badcfg f_ "cannot configure options for %s", $k
7489                 if $opts_opt_cmdonly{$k};
7490             my $insertpos = $opts_cfg_insertpos{$k};
7491             @$om = ( @$om[0..$insertpos-1],
7492                      @vl,
7493                      @$om[$insertpos..$#$om] );
7494         }
7495     }
7496
7497     if (!defined $rmchanges) {
7498         local $access_forpush;
7499         $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7500     }
7501
7502     if (!defined $quilt_mode) {
7503         local $access_forpush;
7504         $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7505             // access_cfg('quilt-mode', 'RETURN-UNDEF')
7506             // 'linear';
7507         $quilt_mode =~ m/^($quilt_modes_re)$/
7508             or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7509         $quilt_mode = $1;
7510     }
7511
7512     foreach my $moc (@modeopt_cfgs) {
7513         local $access_forpush;
7514         my $vr = $moc->{Var};
7515         next if defined $$vr;
7516         $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7517         my $v = $moc->{Vals}{$$vr};
7518         badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7519             unless defined $v;
7520         $$vr = $v;
7521     }
7522
7523     fail __ "dgit: --include-dirty is not supported in split view quilt mode"
7524         if $split_brain && $includedirty;
7525
7526     if (!defined $cleanmode) {
7527         local $access_forpush;
7528         $cleanmode = access_cfg('clean-mode-newer', 'RETURN-UNDEF');
7529         $cleanmode = undef if $cleanmode && $cleanmode !~ m/^$cleanmode_re$/;
7530
7531         $cleanmode //= access_cfg('clean-mode', 'RETURN-UNDEF');
7532         $cleanmode //= 'dpkg-source';
7533
7534         badcfg f_ "unknown clean-mode \`%s'", $cleanmode unless
7535             $cleanmode =~ m/$cleanmode_re/;
7536     }
7537
7538     $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7539     $buildproductsdir //= '..';
7540     $bpd_glob = $buildproductsdir;
7541     $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7542 }
7543
7544 setlocale(LC_MESSAGES, "");
7545 textdomain("dgit");
7546
7547 if ($ENV{$fakeeditorenv}) {
7548     git_slurp_config();
7549     quilt_fixup_editor();
7550 }
7551
7552 parseopts();
7553 check_env_sanity();
7554
7555 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7556 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7557     if $dryrun_level == 1;
7558 if (!@ARGV) {
7559     print STDERR __ $helpmsg or confess "$!";
7560     finish 8;
7561 }
7562 $cmd = $subcommand = shift @ARGV;
7563 $cmd =~ y/-/_/;
7564
7565 my $pre_fn = ${*::}{"pre_$cmd"};
7566 $pre_fn->() if $pre_fn;
7567
7568 if ($invoked_in_git_tree) {
7569     changedir_git_toplevel();
7570     record_maindir();
7571 }
7572 git_slurp_config();
7573
7574 my $fn = ${*::}{"cmd_$cmd"};
7575 $fn or badusage f_ "unknown operation %s", $cmd;
7576 $fn->();
7577
7578 finish 0;