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