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