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