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