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