dgit

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