dgit

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