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