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