dgit

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