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