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