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 / Sanger Institute
   8 #
   9 # This program is free software: you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation, either version 3 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
  23 use Debian::Dgit::ExitStatus;
  24 use Debian::Dgit::I18n;
  25
  26 use strict;
  27
  28 use Debian::Dgit qw(:DEFAULT :playground);
  29 setup_sigwarn();
  30
  31 use IO::Handle;
  32 use Data::Dumper;
  33 use LWP::UserAgent;
  34 use Dpkg::Control::Hash;
  35 use File::Path;
  36 use File::Spec;
  37 use File::Temp qw(tempdir);
  38 use File::Basename;
  39 use Dpkg::Version;
  40 use Dpkg::Compression;
  41 use Dpkg::Compression::Process;
  42 use POSIX;
  43 use Locale::gettext;
  44 use IPC::Open2;
  45 use Digest::SHA;
  46 use Digest::MD5;
  47 use List::MoreUtils qw(pairwise);
  48 use Text::Glob qw(match_glob);
  49 use Fcntl qw(:DEFAULT :flock);
  50 use Carp;
  51
  52 use Debian::Dgit;
  53
  54 our $our_version = 'UNRELEASED'; ###substituted###
  55 our $absurdity = undef; ###substituted###
  56
  57 our @rpushprotovsn_support = qw(6 5 4); # Reverse order!
  58 our $protovsn;
  59
  60 our $cmd;
  61 our $subcommand;
  62 our $isuite;
  63 our $idistro;
  64 our $package;
  65 our @ropts;
  66
  67 our $sign = 1;
  68 our $dryrun_level = 0;
  69 our $changesfile;
  70 our $buildproductsdir;
  71 our $bpd_glob;
  72 our $new_package = 0;
  73 our $includedirty = 0;
  74 our $rmonerror = 1;
  75 our @deliberatelies;
  76 our %previously;
  77 our $existing_package = 'dpkg';
  78 our $cleanmode;
  79 our $changes_since_version;
  80 our $rmchanges;
  81 our $overwrite_version; # undef: not specified; '': check changelog
  82 our $quilt_mode;
  83 our $quilt_upstream_commitish;
  84 our $quilt_upstream_commitish_used;
  85 our $quilt_upstream_commitish_message;
  86 our $quilt_options_re = 'gbp|dpm|baredebian(?:\+tarball|\+git)?';
  87 our $quilt_modes_re = "linear|smash|auto|nofix|nocheck|unapplied|$quilt_options_re";
  88 our $splitview_mode;
  89 our $splitview_modes_re = qr{auto|always|never};
  90 our $dodep14tag;
  91 our %internal_object_save;
  92 our $we_are_responder;
  93 our $we_are_initiator;
  94 our $initiator_tempdir;
  95 our $patches_applied_dirtily = 00;
  96 our $chase_dsc_distro=1;
  97
  98 our %forceopts = map { $_=>0 }
  99     qw(unrepresentable unsupported-source-format
 100        dsc-changes-mismatch changes-origs-exactly
 101        uploading-binaries uploading-source-only
 102        import-gitapply-absurd
 103        import-gitapply-no-absurd
 104        import-dsc-with-dgit-field);
 105
 106 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
 107
 108 our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
 109                      | (?: git | git-ff ) (?: ,always )?
 110                          | check (?: ,ignores )?
 111                          | none
 112                          )}x;
 113
 114 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
 115 our $splitbraincache = 'dgit-intern/quilt-cache';
 116 our $rewritemap = 'dgit-rewrite/map';
 117
 118 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
 119
 120 our (@dget) = qw(dget);
 121 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
 122 our (@dput) = qw(dput);
 123 our (@debsign) = qw(debsign);
 124 our (@gpg) = qw(gpg);
 125 our (@sbuild) = (qw(sbuild --no-source));
 126 our (@ssh) = 'ssh';
 127 our (@dgit) = qw(dgit);
 128 our (@git_debrebase) = qw(git-debrebase);
 129 our (@aptget) = qw(apt-get);
 130 our (@aptcache) = qw(apt-cache);
 131 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
 132 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
 133 our (@dpkggenchanges) = qw(dpkg-genchanges);
 134 our (@mergechanges) = qw(mergechanges -f);
 135 our (@gbp_build) = ('');
 136 our (@gbp_pq) = ('gbp pq');
 137 our (@changesopts) = ('');
 138 our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
 139 our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
 140
 141 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
 142                      'curl' => \@curl,
 143                      'dput' => \@dput,
 144                      'debsign' => \@debsign,
 145                      'gpg' => \@gpg,
 146                      'sbuild' => \@sbuild,
 147                      'ssh' => \@ssh,
 148                      'dgit' => \@dgit,
 149                      'git' => \@git,
 150                      'git-debrebase' => \@git_debrebase,
 151                      'apt-get' => \@aptget,
 152                      'apt-cache' => \@aptcache,
 153                      'dpkg-source' => \@dpkgsource,
 154                      'dpkg-buildpackage' => \@dpkgbuildpackage,
 155                      'dpkg-genchanges' => \@dpkggenchanges,
 156                      'gbp-build' => \@gbp_build,
 157                      'gbp-pq' => \@gbp_pq,
 158                      'ch' => \@changesopts,
 159                      'mergechanges' => \@mergechanges,
 160                      'pbuilder' => \@pbuilder,
 161                      'cowbuilder' => \@cowbuilder);
 162
 163 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
 164 our %opts_cfg_insertpos = map {
 165     $_,
 166     scalar @{ $opts_opt_map{$_} }
 167 } keys %opts_opt_map;
 168
 169 sub parseopts_late_defaults();
 170 sub quiltify_trees_differ ($$;$$$);
 171 sub setup_gitattrs(;$);
 172 sub check_gitattrs($$);
 173
 174 our $playground;
 175 our $keyid;
 176
 177 autoflush STDOUT 1;
 178
 179 our $supplementary_message = '';
 180 our $made_split_brain = 0;
 181 our $do_split_brain;
 182
 183 # Interactions between quilt mode and split brain
 184 # (currently, split brain only implemented iff
 185 #  madformat_wantfixup && quiltmode_splitting)
 186 #
 187 #   source format        sane           `3.0 (quilt)'
 188 #                                       madformat_wantfixup()
 189 #
 190 #   quilt mode                          normal              quiltmode
 191 #                                       (eg linear)         _splitbrain
 192 #
 193 #   ------------      ------------------------------------------------
 194 #
 195 #   no split          no q cache        no q cache          forbidden,
 196 #     brain           PM on master      q fixup on master   prevented
 197 #   !do_split_brain()                    PM on master
 198 #
 199 #   split brain       no q cache        q fixup cached, to dgit view
 200 #                     PM in dgit view   PM in dgit view
 201 #
 202 # PM = pseudomerge to make ff, due to overwrite (or split view)
 203 # "no q cache" = do not record in cache on build, do not check cache
 204 # `3.0 (quilt)' with --quilt=nocheck is treated as sane format
 205
 206 END {
 207     local ($@, $?);
 208     return unless forkcheck_mainprocess();
 209     print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
 210 }
 211
 212 our $remotename = 'dgit';
 213 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
 214 our $csuite;
 215 our $instead_distro;
 216
 217 if (!defined $absurdity) {
 218     $absurdity = $0;
 219     $absurdity =~ s{/[^/]+$}{/absurd} or die;
 220 }
 221
 222 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
 223
 224 sub lbranch () { return "$branchprefix/$csuite"; }
 225 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
 226 sub lref () { return "refs/heads/".lbranch(); }
 227 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
 228 sub rrref () { return server_ref($csuite); }
 229
 230 sub srcfn ($$) {
 231     my ($vsn, $sfx) = @_;
 232     return &source_file_leafname($package, $vsn, $sfx);
 233 }
 234 sub is_orig_file_of_vsn ($$) {
 235     my ($f, $upstreamvsn) = @_;
 236     return is_orig_file_of_p_v($f, $package, $upstreamvsn);
 237 }
 238
 239 sub dscfn ($) {
 240     my ($vsn) = @_;
 241     return srcfn($vsn,".dsc");
 242 }
 243
 244 sub changespat ($;$) {
 245     my ($vsn, $arch) = @_;
 246     return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
 247 }
 248
 249 our $us = 'dgit';
 250 initdebug('');
 251
 252 our @end;
 253 END {
 254     local ($?);
 255     return unless forkcheck_mainprocess();
 256     foreach my $f (@end) {
 257         eval { $f->(); };
 258         print STDERR "$us: cleanup: $@" if length $@;
 259     }
 260 };
 261
 262 sub badcfg {
 263     print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
 264     finish 12;
 265 }
 266
 267 sub forceable_fail ($$) {
 268     my ($forceoptsl, $msg) = @_;
 269     fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
 270     print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
 271 }
 272
 273 sub forceing ($) {
 274     my ($forceoptsl) = @_;
 275     my @got = grep { $forceopts{$_} } @$forceoptsl;
 276     return 0 unless @got;
 277     print STDERR f_
 278         "warning: skipping checks or functionality due to --force-%s\n",
 279         $got[0];
 280 }
 281
 282 sub no_such_package () {
 283     print STDERR f_ "%s: source package %s does not exist in suite %s\n",
 284         $us, $package, $isuite;
 285     finish 4;
 286 }
 287
 288 sub deliberately ($) {
 289     my ($enquiry) = @_;
 290     return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
 291 }
 292
 293 sub deliberately_not_fast_forward () {
 294     foreach (qw(not-fast-forward fresh-repo)) {
 295         return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
 296     }
 297 }
 298
 299 sub quiltmode_splitting () {
 300     $quilt_mode =~ m/gbp|dpm|unapplied|baredebian/;
 301 }
 302 sub format_quiltmode_splitting ($) {
 303     my ($format) = @_;
 304     return madformat_wantfixup($format) && quiltmode_splitting();
 305 }
 306
 307 sub do_split_brain () { !!($do_split_brain // confess) }
 308
 309 sub opts_opt_multi_cmd {
 310     my $extra = shift;
 311     my @cmd;
 312     push @cmd, split /\s+/, shift @_;
 313     push @cmd, @$extra;
 314     push @cmd, @_;
 315     @cmd;
 316 }
 317
 318 sub gbp_pq {
 319     return opts_opt_multi_cmd [], @gbp_pq;
 320 }
 321
 322 sub dgit_privdir () {
 323     our $dgit_privdir_made //= ensure_a_playground 'dgit';
 324 }
 325
 326 sub bpd_abs () {
 327     my $r = $buildproductsdir;
 328     $r = "$maindir/$r" unless $r =~ m{^/};
 329     return $r;
 330 }
 331
 332 sub get_tree_of_commit ($) {
 333     my ($commitish) = @_;
 334     my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
 335     $cdata =~ m/\n\n/;  $cdata = $`;
 336     $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
 337     return $1;
 338 }
 339
 340 sub branch_gdr_info ($$) {
 341     my ($symref, $head) = @_;
 342     my ($status, $msg, $current, $ffq_prev, $gdrlast) =
 343         gdr_ffq_prev_branchinfo($symref);
 344     return () unless $status eq 'branch';
 345     $ffq_prev = git_get_ref $ffq_prev;
 346     $gdrlast  = git_get_ref $gdrlast;
 347     $gdrlast &&= is_fast_fwd $gdrlast, $head;
 348     return ($ffq_prev, $gdrlast);
 349 }
 350
 351 sub branch_is_gdr_unstitched_ff ($$$) {
 352     my ($symref, $head, $ancestor) = @_;
 353     my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
 354     return 0 unless $ffq_prev;
 355     return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
 356     return 1;
 357 }
 358
 359 sub branch_is_gdr ($) {
 360     my ($head) = @_;
 361     # This is quite like git-debrebase's keycommits.
 362     # We have our own implementation because:
 363     #  - our algorighm can do fewer tests so is faster
 364     #  - it saves testing to see if gdr is installed
 365
 366     # NB we use this jsut for deciding whether to run gdr make-patches
 367     # Before reusing this algorithm for somthing else, its
 368     # suitability should be reconsidered.
 369
 370     my $walk = $head;
 371     local $Debian::Dgit::debugcmd_when_debuglevel = 3;
 372     printdebug "branch_is_gdr $head...\n";
 373     my $get_patches = sub {
 374         my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
 375         return $t // '';
 376     };
 377     my $tip_patches = $get_patches->($head);
 378   WALK:
 379     for (;;) {
 380         my $cdata = git_cat_file $walk, 'commit';
 381         my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
 382         if ($msg =~ m{^\[git-debrebase\ (
 383                           anchor | changelog | make-patches |
 384                           merged-breakwater | pseudomerge
 385                       ) [: ] }mx) {
 386             # no need to analyse this - it's sufficient
 387             # (gdr classifications: Anchor, MergedBreakwaters)
 388             # (made by gdr: Pseudomerge, Changelog)
 389             printdebug "branch_is_gdr  $walk gdr $1 YES\n";
 390             return 1;
 391         }
 392         my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
 393         if (@parents==2) {
 394             my $walk_tree = get_tree_of_commit $walk;
 395             foreach my $p (@parents) {
 396                 my $p_tree = get_tree_of_commit $p;
 397                 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
 398                     # (gdr classification: Pseudomerge; not made by gdr)
 399                     printdebug "branch_is_gdr  $walk unmarked pseudomerge\n"
 400                         if $debuglevel >= 2;
 401                     $walk = $p;
 402                     next WALK;
 403                 }
 404             }
 405             # some other non-gdr merge
 406             # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
 407             printdebug "branch_is_gdr  $walk ?-2-merge NO\n";
 408             return 0;
 409         }
 410         if (@parents>2) {
 411             # (gdr classification: ?)
 412             printdebug "branch_is_gdr  $walk ?-octopus NO\n";
 413             return 0;
 414         }
 415         if (!@parents) {
 416             printdebug "branch_is_gdr  $walk origin\n";
 417             return 0;
 418         }
 419         if ($get_patches->($walk) ne $tip_patches) {
 420             # Our parent added, removed, or edited patches, and wasn't
 421             # a gdr make-patches commit.  gdr make-patches probably
 422             # won't do that well, then.
 423             # (gdr classification of parent: AddPatches or ?)
 424             printdebug "branch_is_gdr  $walk ?-patches NO\n";
 425             return 0;
 426         }
 427         if ($tip_patches eq '' and
 428             !defined git_cat_file "$walk~:debian" and
 429             !quiltify_trees_differ "$walk~", $walk
 430            ) {
 431             # (gdr classification of parent: BreakwaterStart
 432             printdebug "branch_is_gdr  $walk unmarked BreakwaterStart YES\n";
 433             return 1;
 434         }
 435         # (gdr classification: Upstream Packaging Mixed Changelog)
 436         printdebug "branch_is_gdr  $walk plain\n"
 437             if $debuglevel >= 2;
 438         $walk = $parents[0];
 439     }
 440 }
 441
 442 #---------- remote protocol support, common ----------
 443
 444 # remote push initiator/responder protocol:
 445 #  $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
 446 #  where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
 447 #  < dgit-remote-push-ready <actual-proto-vsn>
 448 #
 449 # occasionally:
 450 #
 451 #  > progress NBYTES
 452 #  [NBYTES message]
 453 #
 454 #  > supplementary-message NBYTES
 455 #  [NBYTES message]
 456 #
 457 # main sequence:
 458 #
 459 #  > file parsed-changelog
 460 #  [indicates that output of dpkg-parsechangelog follows]
 461 #  > data-block NBYTES
 462 #  > [NBYTES bytes of data (no newline)]
 463 #  [maybe some more blocks]
 464 #  > data-end
 465 #
 466 #  > file dsc
 467 #  [etc]
 468 #
 469 #  > file changes
 470 #  [etc]
 471 #
 472 #  > param head DGIT-VIEW-HEAD
 473 #  > param csuite SUITE
 474 #  > param tagformat new              # $protovsn == 4
 475 #  > param splitbrain 0|1             # $protovsn >= 6
 476 #  > param maint-view MAINT-VIEW-HEAD
 477 #
 478 #  > param buildinfo-filename P_V_X.buildinfo   # zero or more times
 479 #  > file buildinfo                             # for buildinfos to sign
 480 #
 481 #  > previously REFNAME=OBJNAME       # if --deliberately-not-fast-forward
 482 #                                     # goes into tag, for replay prevention
 483 #
 484 #  > want signed-tag
 485 #  [indicates that signed tag is wanted]
 486 #  < data-block NBYTES
 487 #  < [NBYTES bytes of data (no newline)]
 488 #  [maybe some more blocks]
 489 #  < data-end
 490 #  < files-end
 491 #
 492 #  > want signed-dsc-changes
 493 #  < data-block NBYTES    [transfer of signed dsc]
 494 #  [etc]
 495 #  < data-block NBYTES    [transfer of signed changes]
 496 #  [etc]
 497 #  < data-block NBYTES    [transfer of each signed buildinfo
 498 #  [etc]                   same number and order as "file buildinfo"]
 499 #  ...
 500 #  < files-end
 501 #
 502 #  > complete
 503
 504 our $i_child_pid;
 505
 506 sub i_child_report () {
 507     # Sees if our child has died, and reap it if so.  Returns a string
 508     # describing how it died if it failed, or undef otherwise.
 509     return undef unless $i_child_pid;
 510     my $got = waitpid $i_child_pid, WNOHANG;
 511     return undef if $got <= 0;
 512     die unless $got == $i_child_pid;
 513     $i_child_pid = undef;
 514     return undef unless $?;
 515     return f_ "build host child %s", waitstatusmsg();
 516 }
 517
 518 sub badproto ($$) {
 519     my ($fh, $m) = @_;
 520     fail f_ "connection lost: %s", $! if $fh->error;
 521     fail f_ "protocol violation; %s not expected", $m;
 522 }
 523
 524 sub badproto_badread ($$) {
 525     my ($fh, $wh) = @_;
 526     fail f_ "connection lost: %s", $! if $!;
 527     my $report = i_child_report();
 528     fail $report if defined $report;
 529     badproto $fh, f_ "eof (reading %s)", $wh;
 530 }
 531
 532 sub protocol_expect (&$) {
 533     my ($match, $fh) = @_;
 534     local $_;
 535     $_ = <$fh>;
 536     defined && chomp or badproto_badread $fh, __ "protocol message";
 537     if (wantarray) {
 538         my @r = &$match;
 539         return @r if @r;
 540     } else {
 541         my $r = &$match;
 542         return $r if $r;
 543     }
 544     badproto $fh, f_ "\`%s'", $_;
 545 }
 546
 547 sub protocol_send_file ($$) {
 548     my ($fh, $ourfn) = @_;
 549     open PF, "<", $ourfn or die "$ourfn: $!";
 550     for (;;) {
 551         my $d;
 552         my $got = read PF, $d, 65536;
 553         die "$ourfn: $!" unless defined $got;
 554         last if !$got;
 555         print $fh "data-block ".length($d)."\n" or confess "$!";
 556         print $fh $d or confess "$!";
 557     }
 558     PF->error and die "$ourfn $!";
 559     print $fh "data-end\n" or confess "$!";
 560     close PF;
 561 }
 562
 563 sub protocol_read_bytes ($$) {
 564     my ($fh, $nbytes) = @_;
 565     $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
 566     my $d;
 567     my $got = read $fh, $d, $nbytes;
 568     $got==$nbytes or badproto_badread $fh, __ "data block";
 569     return $d;
 570 }
 571
 572 sub protocol_receive_file ($$) {
 573     my ($fh, $ourfn) = @_;
 574     printdebug "() $ourfn\n";
 575     open PF, ">", $ourfn or die "$ourfn: $!";
 576     for (;;) {
 577         my ($y,$l) = protocol_expect {
 578             m/^data-block (.*)$/ ? (1,$1) :
 579             m/^data-end$/ ? (0,) :
 580             ();
 581         } $fh;
 582         last unless $y;
 583         my $d = protocol_read_bytes $fh, $l;
 584         print PF $d or confess "$!";
 585     }
 586     close PF or confess "$!";
 587 }
 588
 589 #---------- remote protocol support, responder ----------
 590
 591 sub responder_send_command ($) {
 592     my ($command) = @_;
 593     return unless $we_are_responder;
 594     # called even without $we_are_responder
 595     printdebug ">> $command\n";
 596     print PO $command, "\n" or confess "$!";
 597 }
 598
 599 sub responder_send_file ($$) {
 600     my ($keyword, $ourfn) = @_;
 601     return unless $we_are_responder;
 602     printdebug "]] $keyword $ourfn\n";
 603     responder_send_command "file $keyword";
 604     protocol_send_file \*PO, $ourfn;
 605 }
 606
 607 sub responder_receive_files ($@) {
 608     my ($keyword, @ourfns) = @_;
 609     die unless $we_are_responder;
 610     printdebug "[[ $keyword @ourfns\n";
 611     responder_send_command "want $keyword";
 612     foreach my $fn (@ourfns) {
 613         protocol_receive_file \*PI, $fn;
 614     }
 615     printdebug "[[\$\n";
 616     protocol_expect { m/^files-end$/ } \*PI;
 617 }
 618
 619 #---------- remote protocol support, initiator ----------
 620
 621 sub initiator_expect (&) {
 622     my ($match) = @_;
 623     protocol_expect { &$match } \*RO;
 624 }
 625
 626 #---------- end remote code ----------
 627
 628 sub progress {
 629     if ($we_are_responder) {
 630         my $m = join '', @_;
 631         responder_send_command "progress ".length($m) or confess "$!";
 632         print PO $m or confess "$!";
 633     } else {
 634         print @_, "\n";
 635     }
 636 }
 637
 638 our $ua;
 639
 640 sub url_get {
 641     if (!$ua) {
 642         $ua = LWP::UserAgent->new();
 643         $ua->env_proxy;
 644     }
 645     my $what = $_[$#_];
 646     progress "downloading $what...";
 647     my $r = $ua->get(@_) or confess "$!";
 648     return undef if $r->code == 404;
 649     $r->is_success or fail f_ "failed to fetch %s: %s",
 650         $what, $r->status_line;
 651     return $r->decoded_content(charset => 'none');
 652 }
 653
 654 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
 655
 656 sub act_local () { return $dryrun_level <= 1; }
 657 sub act_scary () { return !$dryrun_level; }
 658
 659 sub printdone {
 660     if (!$dryrun_level) {
 661         progress f_ "%s ok: %s", $us, "@_";
 662     } else {
 663         progress f_ "would be ok: %s (but dry run only)", "@_";
 664     }
 665 }
 666
 667 sub dryrun_report {
 668     printcmd(\*STDERR,$debugprefix."#",@_);
 669 }
 670
 671 sub runcmd_ordryrun {
 672     if (act_scary()) {
 673         runcmd @_;
 674     } else {
 675         dryrun_report @_;
 676     }
 677 }
 678
 679 sub runcmd_ordryrun_local {
 680     if (act_local()) {
 681         runcmd @_;
 682     } else {
 683         dryrun_report @_;
 684     }
 685 }
 686
 687 our $helpmsg = i_ <<END;
 688 main usages:
 689   dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
 690   dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
 691   dgit [dgit-opts] build [dpkg-buildpackage-opts]
 692   dgit [dgit-opts] sbuild [sbuild-opts]
 693   dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
 694   dgit [dgit-opts] push [dgit-opts] [suite]
 695   dgit [dgit-opts] push-source [dgit-opts] [suite]
 696   dgit [dgit-opts] rpush build-host:build-dir ...
 697 important dgit options:
 698   -k<keyid>           sign tag and package with <keyid> instead of default
 699   --dry-run -n        do not change anything, but go through the motions
 700   --damp-run -L       like --dry-run but make local changes, without signing
 701   --new -N            allow introducing a new package
 702   --debug -D          increase debug level
 703   -c<name>=<value>    set git config option (used directly by dgit too)
 704 END
 705
 706 our $later_warning_msg = i_ <<END;
 707 Perhaps the upload is stuck in incoming.  Using the version from git.
 708 END
 709
 710 sub badusage {
 711     print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
 712     finish 8;
 713 }
 714
 715 sub nextarg {
 716     @ARGV or badusage __ "too few arguments";
 717     return scalar shift @ARGV;
 718 }
 719
 720 sub pre_help () {
 721     not_necessarily_a_tree();
 722 }
 723 sub cmd_help () {
 724     print __ $helpmsg or confess "$!";
 725     finish 0;
 726 }
 727
 728 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
 729
 730 our %defcfg = ('dgit.default.distro' => 'debian',
 731                'dgit.default.default-suite' => 'unstable',
 732                'dgit.default.old-dsc-distro' => 'debian',
 733                'dgit-suite.*-security.distro' => 'debian-security',
 734                'dgit.default.username' => '',
 735                'dgit.default.archive-query-default-component' => 'main',
 736                'dgit.default.ssh' => 'ssh',
 737                'dgit.default.archive-query' => 'madison:',
 738                'dgit.default.sshpsql-dbname' => 'service=projectb',
 739                'dgit.default.aptget-components' => 'main',
 740                'dgit.default.source-only-uploads' => 'ok',
 741                'dgit.dsc-url-proto-ok.http'    => 'true',
 742                'dgit.dsc-url-proto-ok.https'   => 'true',
 743                'dgit.dsc-url-proto-ok.git'     => 'true',
 744                'dgit.vcs-git.suites',          => 'sid', # ;-separated
 745                'dgit.default.dsc-url-proto-ok' => 'false',
 746                # old means "repo server accepts pushes with old dgit tags"
 747                # new means "repo server accepts pushes with new dgit tags"
 748                # maint means "repo server accepts split brain pushes"
 749                # hist means "repo server may have old pushes without new tag"
 750                #   ("hist" is implied by "old")
 751                'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
 752                'dgit-distro.debian.git-check' => 'url',
 753                'dgit-distro.debian.git-check-suffix' => '/info/refs',
 754                'dgit-distro.debian.new-private-pushers' => 't',
 755                'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
 756                'dgit-distro.debian/push.git-url' => '',
 757                'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
 758                'dgit-distro.debian/push.git-user-force' => 'dgit',
 759                'dgit-distro.debian/push.git-proto' => 'git+ssh://',
 760                'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
 761                'dgit-distro.debian/push.git-create' => 'true',
 762                'dgit-distro.debian/push.git-check' => 'ssh-cmd',
 763  'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
 764 # 'dgit-distro.debian.archive-query-tls-key',
 765 #    '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
 766 # ^ this does not work because curl is broken nowadays
 767 # Fixing #790093 properly will involve providing providing the key
 768 # in some pacagke and maybe updating these paths.
 769 #
 770 # 'dgit-distro.debian.archive-query-tls-curl-args',
 771 #   '--ca-path=/etc/ssl/ca-debian',
 772 # ^ this is a workaround but works (only) on DSA-administered machines
 773                'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
 774                'dgit-distro.debian.git-url-suffix' => '',
 775                'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
 776                'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
 777  'dgit-distro.debian-security.archive-query' => 'aptget:',
 778  'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
 779  'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
 780  'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
 781  'dgit-distro.debian-security.nominal-distro' => 'debian',
 782  'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
 783  'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
 784                'dgit-distro.ubuntu.git-check' => 'false',
 785  'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
 786                'dgit-distro.ubuntucloud.git-check' => 'false',
 787  'dgit-distro.ubuntucloud.nominal-distro' => 'ubuntu',
 788  'dgit-distro.ubuntucloud.archive-query' => 'aptget:',
 789  'dgit-distro.ubuntucloud.mirror' => 'http://ubuntu-cloud.archive.canonical.com/ubuntu',
 790  'dgit-distro.ubuntucloud.aptget-suite-map' => 's#^([^-]+):([^:]+)$#${1}-updates/$2#; s#^(.+)-(.+):(.+)#$1-$2/$3#;',
 791  'dgit-distro.ubuntucloud.aptget-suite-rmap' => 's#/(.+)$#-$1#',
 792                'dgit-distro.test-dummy.ssh' => "$td/ssh",
 793                'dgit-distro.test-dummy.username' => "alice",
 794                'dgit-distro.test-dummy.git-check' => "ssh-cmd",
 795                'dgit-distro.test-dummy.git-create' => "ssh-cmd",
 796                'dgit-distro.test-dummy.git-url' => "$td/git",
 797                'dgit-distro.test-dummy.git-host' => "git",
 798                'dgit-distro.test-dummy.git-path' => "$td/git",
 799                'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
 800                'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
 801                'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
 802                'dgit-distro.test-dummy.upload-host' => 'test-dummy',
 803                );
 804
 805 our %gitcfgs;
 806 our @gitcfgsources = qw(cmdline local global system);
 807 our $invoked_in_git_tree = 1;
 808
 809 sub git_slurp_config () {
 810     # This algoritm is a bit subtle, but this is needed so that for
 811     # options which we want to be single-valued, we allow the
 812     # different config sources to override properly.  See #835858.
 813     foreach my $src (@gitcfgsources) {
 814         next if $src eq 'cmdline';
 815         # we do this ourselves since git doesn't handle it
 816
 817         $gitcfgs{$src} = git_slurp_config_src $src;
 818     }
 819 }
 820
 821 sub git_get_config ($) {
 822     my ($c) = @_;
 823     foreach my $src (@gitcfgsources) {
 824         my $l = $gitcfgs{$src}{$c};
 825         confess "internal error ($l $c)" if $l && !ref $l;
 826         printdebug"C $c ".(defined $l ?
 827                            join " ", map { messagequote "'$_'" } @$l :
 828                            "undef")."\n"
 829             if $debuglevel >= 4;
 830         $l or next;
 831         @$l==1 or badcfg
 832             f_ "multiple values for %s (in %s git config)", $c, $src
 833             if @$l > 1;
 834         $l->[0] =~ m/\n/ and badcfg f_
 835  "value for config option %s (in %s git config) contains newline(s)!",
 836             $c, $src;
 837         return $l->[0];
 838     }
 839     return undef;
 840 }
 841
 842 sub cfg {
 843     foreach my $c (@_) {
 844         return undef if $c =~ /RETURN-UNDEF/;
 845         printdebug "C? $c\n" if $debuglevel >= 5;
 846         my $v = git_get_config($c);
 847         return $v if defined $v;
 848         my $dv = $defcfg{$c};
 849         if (defined $dv) {
 850             printdebug "CD $c $dv\n" if $debuglevel >= 4;
 851             return $dv;
 852         }
 853     }
 854     badcfg f_
 855         "need value for one of: %s\n".
 856         "%s: distro or suite appears not to be (properly) supported",
 857         "@_", $us;
 858 }
 859
 860 sub not_necessarily_a_tree () {
 861     # needs to be called from pre_*
 862     @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
 863     $invoked_in_git_tree = 0;
 864 }
 865
 866 sub access_basedistro__noalias () {
 867     if (defined $idistro) {
 868         return $idistro;
 869     } else {
 870         my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
 871         return $def if defined $def;
 872         foreach my $src (@gitcfgsources, 'internal') {
 873             my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
 874             next unless $kl;
 875             foreach my $k (keys %$kl) {
 876                 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
 877                 my $dpat = $1;
 878                 next unless match_glob $dpat, $isuite;
 879                 return $kl->{$k};
 880             }
 881         }
 882         return cfg("dgit.default.distro");
 883     }
 884 }
 885
 886 sub access_basedistro () {
 887     my $noalias = access_basedistro__noalias();
 888     my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
 889     return $canon // $noalias;
 890 }
 891
 892 sub access_nomdistro () {
 893     my $base = access_basedistro();
 894     my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
 895     $r =~ m/^$distro_re$/ or badcfg
 896         f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
 897         $r, "/^$distro_re$/";
 898     return $r;
 899 }
 900
 901 sub access_quirk () {
 902     # returns (quirk name, distro to use instead or undef, quirk-specific info)
 903     my $basedistro = access_basedistro();
 904     my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
 905                               'RETURN-UNDEF');
 906     if (defined $backports_quirk) {
 907         my $re = $backports_quirk;
 908         $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
 909         $re =~ s/\*/.*/g;
 910         $re =~ s/\%/([-0-9a-z_]+)/
 911             or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
 912         if ($isuite =~ m/^$re$/) {
 913             return ('backports',"$basedistro-backports",$1);
 914         }
 915     }
 916     return ('none',undef);
 917 }
 918
 919 our $access_forpush;
 920
 921 sub parse_cfg_bool ($$$) {
 922     my ($what,$def,$v) = @_;
 923     $v //= $def;
 924     return
 925         $v =~ m/^[ty1]/ ? 1 :
 926         $v =~ m/^[fn0]/ ? 0 :
 927         badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
 928             $what, $v;
 929 }
 930
 931 sub access_forpush_config () {
 932     my $d = access_basedistro();
 933
 934     return 1 if
 935         $new_package &&
 936         parse_cfg_bool('new-private-pushers', 0,
 937                        cfg("dgit-distro.$d.new-private-pushers",
 938                            'RETURN-UNDEF'));
 939
 940     my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
 941     $v //= 'a';
 942     return
 943         $v =~ m/^[ty1]/ ? 0 : # force readonly,    forpush = 0
 944         $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
 945         $v =~ m/^[a]/  ? '' : # auto,              forpush = ''
 946         badcfg __
 947             "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
 948 }
 949
 950 sub access_forpush () {
 951     $access_forpush //= access_forpush_config();
 952     return $access_forpush;
 953 }
 954
 955 sub default_from_access_cfg ($$$;$) {
 956     my ($var, $keybase, $defval, $permit_re) = @_;
 957     return if defined $$var;
 958
 959     $$var = access_cfg("$keybase-newer", 'RETURN-UNDEF');
 960     $$var = undef if $$var && $$var !~ m/^$permit_re$/;
 961
 962     $$var //= access_cfg($keybase, 'RETURN-UNDEF');
 963     $$var //= $defval;
 964
 965     badcfg f_ "unknown %s \`%s'", $keybase, $$var
 966         if defined $permit_re and $$var !~ m/$permit_re/;
 967 }
 968
 969 sub pushing () {
 970     confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
 971         defined $access_forpush and !$access_forpush;
 972     badcfg __ "pushing but distro is configured readonly"
 973         if access_forpush_config() eq '0';
 974     $access_forpush = 1;
 975     $supplementary_message = __ <<'END' unless $we_are_responder;
 976 Push failed, before we got started.
 977 You can retry the push, after fixing the problem, if you like.
 978 END
 979     parseopts_late_defaults();
 980 }
 981
 982 sub notpushing () {
 983     parseopts_late_defaults();
 984 }
 985
 986 sub determine_whether_split_brain ($) {
 987     my ($format) = @_;
 988     {
 989         local $access_forpush;
 990         default_from_access_cfg(\$splitview_mode, 'split-view', 'auto',
 991                                 $splitview_modes_re);
 992         $do_split_brain = 1 if $splitview_mode eq 'always';
 993     }
 994
 995     printdebug "format $format, quilt mode $quilt_mode\n";
 996
 997     if (format_quiltmode_splitting $format) {
 998         $splitview_mode ne 'never' or
 999             fail f_ "dgit: quilt mode \`%s' (for format \`%s')".
1000                     " implies split view, but split-view set to \`%s'",
1001                     $quilt_mode, $format, $splitview_mode;
1002         $do_split_brain = 1;
1003     }
1004     $do_split_brain //= 0;
1005 }
1006
1007 sub supplementary_message ($) {
1008     my ($msg) = @_;
1009     if (!$we_are_responder) {
1010         $supplementary_message = $msg;
1011         return;
1012     } else {
1013         responder_send_command "supplementary-message ".length($msg)
1014             or confess "$!";
1015         print PO $msg or confess "$!";
1016     }
1017 }
1018
1019 sub access_distros () {
1020     # Returns list of distros to try, in order
1021     #
1022     # We want to try:
1023     #    0. `instead of' distro name(s) we have been pointed to
1024     #    1. the access_quirk distro, if any
1025     #    2a. the user's specified distro, or failing that  } basedistro
1026     #    2b. the distro calculated from the suite          }
1027     my @l = access_basedistro();
1028
1029     my (undef,$quirkdistro) = access_quirk();
1030     unshift @l, $quirkdistro;
1031     unshift @l, $instead_distro;
1032     @l = grep { defined } @l;
1033
1034     push @l, access_nomdistro();
1035
1036     if (access_forpush()) {
1037         @l = map { ("$_/push", $_) } @l;
1038     }
1039     @l;
1040 }
1041
1042 sub access_cfg_cfgs (@) {
1043     my (@keys) = @_;
1044     my @cfgs;
1045     # The nesting of these loops determines the search order.  We put
1046     # the key loop on the outside so that we search all the distros
1047     # for each key, before going on to the next key.  That means that
1048     # if access_cfg is called with a more specific, and then a less
1049     # specific, key, an earlier distro can override the less specific
1050     # without necessarily overriding any more specific keys.  (If the
1051     # distro wants to override the more specific keys it can simply do
1052     # so; whereas if we did the loop the other way around, it would be
1053     # impossible to for an earlier distro to override a less specific
1054     # key but not the more specific ones without restating the unknown
1055     # values of the more specific keys.
1056     my @realkeys;
1057     my @rundef;
1058     # We have to deal with RETURN-UNDEF specially, so that we don't
1059     # terminate the search prematurely.
1060     foreach (@keys) {
1061         if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
1062         push @realkeys, $_
1063     }
1064     foreach my $d (access_distros()) {
1065         push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
1066     }
1067     push @cfgs, map { "dgit.default.$_" } @realkeys;
1068     push @cfgs, @rundef;
1069     return @cfgs;
1070 }
1071
1072 sub access_cfg (@) {
1073     my (@keys) = @_;
1074     my (@cfgs) = access_cfg_cfgs(@keys);
1075     my $value = cfg(@cfgs);
1076     return $value;
1077 }
1078
1079 sub access_cfg_bool ($$) {
1080     my ($def, @keys) = @_;
1081     parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1082 }
1083
1084 sub string_to_ssh ($) {
1085     my ($spec) = @_;
1086     if ($spec =~ m/\s/) {
1087         return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1088     } else {
1089         return ($spec);
1090     }
1091 }
1092
1093 sub access_cfg_ssh () {
1094     my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1095     if (!defined $gitssh) {
1096         return @ssh;
1097     } else {
1098         return string_to_ssh $gitssh;
1099     }
1100 }
1101
1102 sub access_runeinfo ($) {
1103     my ($info) = @_;
1104     return ": dgit ".access_basedistro()." $info ;";
1105 }
1106
1107 sub access_someuserhost ($) {
1108     my ($some) = @_;
1109     my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1110     defined($user) && length($user) or
1111         $user = access_cfg("$some-user",'username');
1112     my $host = access_cfg("$some-host");
1113     return length($user) ? "$user\@$host" : $host;
1114 }
1115
1116 sub access_gituserhost () {
1117     return access_someuserhost('git');
1118 }
1119
1120 sub access_giturl (;$) {
1121     my ($optional) = @_;
1122     my $url = access_cfg('git-url','RETURN-UNDEF');
1123     my $suffix;
1124     if (!length $url) {
1125         my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1126         return undef unless defined $proto;
1127         $url =
1128             $proto.
1129             access_gituserhost().
1130             access_cfg('git-path');
1131     } else {
1132         $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1133     }
1134     $suffix //= '.git';
1135     return "$url/$package$suffix";
1136 }
1137
1138 sub commit_getclogp ($) {
1139     # Returns the parsed changelog hashref for a particular commit
1140     my ($objid) = @_;
1141     our %commit_getclogp_memo;
1142     my $memo = $commit_getclogp_memo{$objid};
1143     return $memo if $memo;
1144
1145     my $mclog = dgit_privdir()."clog";
1146     runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1147         "$objid:debian/changelog";
1148     $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1149 }
1150
1151 sub parse_dscdata () {
1152     my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
1153     printdebug Dumper($dscdata) if $debuglevel>1;
1154     $dsc = parsecontrolfh($dscfh,$dscurl,1);
1155     printdebug Dumper($dsc) if $debuglevel>1;
1156 }
1157
1158 our %rmad;
1159
1160 sub archive_query ($;@) {
1161     my ($method) = shift @_;
1162     fail __ "this operation does not support multiple comma-separated suites"
1163         if $isuite =~ m/,/;
1164     my $query = access_cfg('archive-query','RETURN-UNDEF');
1165     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1166     my $proto = $1;
1167     my $data = $'; #';
1168     { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1169 }
1170
1171 sub archive_query_prepend_mirror {
1172     my $m = access_cfg('mirror');
1173     return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1174 }
1175
1176 sub pool_dsc_subpath ($$) {
1177     my ($vsn,$component) = @_; # $package is implict arg
1178     my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1179     return "/pool/$component/$prefix/$package/".dscfn($vsn);
1180 }
1181
1182 sub cfg_apply_map ($$$) {
1183     my ($varref, $what, $mapspec) = @_;
1184     return unless $mapspec;
1185
1186     printdebug "config $what EVAL{ $mapspec; }\n";
1187     $_ = $$varref;
1188     eval "package Dgit::Config; $mapspec;";
1189     die $@ if $@;
1190     $$varref = $_;
1191 }
1192
1193 #---------- `ftpmasterapi' archive query method (nascent) ----------
1194
1195 sub archive_api_query_cmd ($) {
1196     my ($subpath) = @_;
1197     my @cmd = (@curl, qw(-sS));
1198     my $url = access_cfg('archive-query-url');
1199     if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1200         my $host = $1;
1201         my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1202         foreach my $key (split /\:/, $keys) {
1203             $key =~ s/\%HOST\%/$host/g;
1204             if (!stat $key) {
1205                 fail "for $url: stat $key: $!" unless $!==ENOENT;
1206                 next;
1207             }
1208             fail f_ "config requested specific TLS key but do not know".
1209                     " how to get curl to use exactly that EE key (%s)",
1210                     $key;
1211 #           push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1212 #           # Sadly the above line does not work because of changes
1213 #           # to gnutls.   The real fix for #790093 may involve
1214 #           # new curl options.
1215             last;
1216         }
1217         # Fixing #790093 properly will involve providing a value
1218         # for this on clients.
1219         my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1220         push @cmd, split / /, $kargs if defined $kargs;
1221     }
1222     push @cmd, $url.$subpath;
1223     return @cmd;
1224 }
1225
1226 sub api_query ($$;$) {
1227     use JSON;
1228     my ($data, $subpath, $ok404) = @_;
1229     badcfg __ "ftpmasterapi archive query method takes no data part"
1230         if length $data;
1231     my @cmd = archive_api_query_cmd($subpath);
1232     my $url = $cmd[$#cmd];
1233     push @cmd, qw(-w %{http_code});
1234     my $json = cmdoutput @cmd;
1235     unless ($json =~ s/\d+\d+\d$//) {
1236         failedcmd_report_cmd undef, @cmd;
1237         fail __ "curl failed to print 3-digit HTTP code";
1238     }
1239     my $code = $&;
1240     return undef if $code eq '404' && $ok404;
1241     fail f_ "fetch of %s gave HTTP code %s", $url, $code
1242         unless $url =~ m#^file://# or $code =~ m/^2/;
1243     return decode_json($json);
1244 }
1245
1246 sub canonicalise_suite_ftpmasterapi {
1247     my ($proto,$data) = @_;
1248     my $suites = api_query($data, 'suites');
1249     my @matched;
1250     foreach my $entry (@$suites) {
1251         next unless grep {
1252             my $v = $entry->{$_};
1253             defined $v && $v eq $isuite;
1254         } qw(codename name);
1255         push @matched, $entry;
1256     }
1257     fail f_ "unknown suite %s, maybe -d would help", $isuite
1258         unless @matched;
1259     my $cn;
1260     eval {
1261         @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1262         $cn = "$matched[0]{codename}";
1263         defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1264         $cn =~ m/^$suite_re$/
1265             or die f_ "suite %s maps to bad codename\n", $isuite;
1266     };
1267     die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1268         if length $@;
1269     return $cn;
1270 }
1271
1272 sub archive_query_ftpmasterapi {
1273     my ($proto,$data) = @_;
1274     my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1275     my @rows;
1276     my $digester = Digest::SHA->new(256);
1277     foreach my $entry (@$info) {
1278         eval {
1279             my $vsn = "$entry->{version}";
1280             my ($ok,$msg) = version_check $vsn;
1281             die f_ "bad version: %s\n", $msg unless $ok;
1282             my $component = "$entry->{component}";
1283             $component =~ m/^$component_re$/ or die __ "bad component";
1284             my $filename = "$entry->{filename}";
1285             $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1286                 or die __ "bad filename";
1287             my $sha256sum = "$entry->{sha256sum}";
1288             $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1289             push @rows, [ $vsn, "/pool/$component/$filename",
1290                           $digester, $sha256sum ];
1291         };
1292         die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1293             if length $@;
1294     }
1295     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1296     return archive_query_prepend_mirror @rows;
1297 }
1298
1299 sub file_in_archive_ftpmasterapi {
1300     my ($proto,$data,$filename) = @_;
1301     my $pat = $filename;
1302     $pat =~ s/_/\\_/g;
1303     $pat = "%/$pat";
1304     $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1305     my $info = api_query($data, "file_in_archive/$pat", 1);
1306 }
1307
1308 sub package_not_wholly_new_ftpmasterapi {
1309     my ($proto,$data,$pkg) = @_;
1310     my $info = api_query($data,"madison?package=${pkg}&f=json");
1311     return !!@$info;
1312 }
1313
1314 #---------- `aptget' archive query method ----------
1315
1316 our $aptget_base;
1317 our $aptget_releasefile;
1318 our $aptget_configpath;
1319
1320 sub aptget_aptget   () { return @aptget,   qw(-c), $aptget_configpath; }
1321 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1322
1323 sub aptget_cache_clean {
1324     runcmd_ordryrun_local qw(sh -ec),
1325         'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1326         'x', $aptget_base;
1327 }
1328
1329 sub aptget_lock_acquire () {
1330     my $lockfile = "$aptget_base/lock";
1331     open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1332     flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1333 }
1334
1335 sub aptget_prep ($) {
1336     my ($data) = @_;
1337     return if defined $aptget_base;
1338
1339     badcfg __ "aptget archive query method takes no data part"
1340         if length $data;
1341
1342     my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1343
1344     ensuredir $cache;
1345     ensuredir "$cache/dgit";
1346     my $cachekey =
1347         access_cfg('aptget-cachekey','RETURN-UNDEF')
1348         // access_nomdistro();
1349
1350     $aptget_base = "$cache/dgit/aptget";
1351     ensuredir $aptget_base;
1352
1353     my $quoted_base = $aptget_base;
1354     confess "$quoted_base contains bad chars, cannot continue"
1355         if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1356
1357     ensuredir $aptget_base;
1358
1359     aptget_lock_acquire();
1360
1361     aptget_cache_clean();
1362
1363     $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1364     my $sourceslist = "source.list#$cachekey";
1365
1366     my $aptsuites = $isuite;
1367     cfg_apply_map(\$aptsuites, 'suite map',
1368                   access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1369
1370     open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
1371     printf SRCS "deb-src %s %s %s\n",
1372         access_cfg('mirror'),
1373         $aptsuites,
1374         access_cfg('aptget-components')
1375         or confess "$!";
1376
1377     ensuredir "$aptget_base/cache";
1378     ensuredir "$aptget_base/lists";
1379
1380     open CONF, ">", $aptget_configpath or confess "$!";
1381     print CONF <<END;
1382 Debug::NoLocking "true";
1383 APT::Get::List-Cleanup "false";
1384 #clear APT::Update::Post-Invoke-Success;
1385 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1386 Dir::State::Lists "$quoted_base/lists";
1387 Dir::Etc::preferences "$quoted_base/preferences";
1388 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1389 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1390 END
1391
1392     foreach my $key (qw(
1393                         Dir::Cache
1394                         Dir::State
1395                         Dir::Cache::Archives
1396                         Dir::Etc::SourceParts
1397                         Dir::Etc::preferencesparts
1398                       )) {
1399         ensuredir "$aptget_base/$key";
1400         print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
1401     };
1402
1403     my $oldatime = (time // confess "$!") - 1;
1404     foreach my $oldlist (<$aptget_base/lists/*Release>) {
1405         next unless stat_exists $oldlist;
1406         my ($mtime) = (stat _)[9];
1407         utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1408     }
1409
1410     runcmd_ordryrun_local aptget_aptget(), qw(update);
1411
1412     my @releasefiles;
1413     foreach my $oldlist (<$aptget_base/lists/*Release>) {
1414         next unless stat_exists $oldlist;
1415         my ($atime) = (stat _)[8];
1416         next if $atime == $oldatime;
1417         push @releasefiles, $oldlist;
1418     }
1419     my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1420     @releasefiles = @inreleasefiles if @inreleasefiles;
1421     if (!@releasefiles) {
1422         fail f_ <<END, $isuite, $cache;
1423 apt seemed to not to update dgit's cached Release files for %s.
1424 (Perhaps %s
1425  is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1426 END
1427     }
1428     confess "apt updated too many Release files (@releasefiles), erk"
1429         unless @releasefiles == 1;
1430
1431     ($aptget_releasefile) = @releasefiles;
1432 }
1433
1434 sub canonicalise_suite_aptget {
1435     my ($proto,$data) = @_;
1436     aptget_prep($data);
1437
1438     my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1439
1440     foreach my $name (qw(Codename Suite)) {
1441         my $val = $release->{$name};
1442         if (defined $val) {
1443             printdebug "release file $name: $val\n";
1444             cfg_apply_map(\$val, 'suite rmap',
1445                           access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1446             $val =~ m/^$suite_re$/o or fail f_
1447                 "Release file (%s) specifies intolerable %s",
1448                 $aptget_releasefile, $name;
1449             return $val
1450         }
1451     }
1452     return $isuite;
1453 }
1454
1455 sub archive_query_aptget {
1456     my ($proto,$data) = @_;
1457     aptget_prep($data);
1458
1459     ensuredir "$aptget_base/source";
1460     foreach my $old (<$aptget_base/source/*.dsc>) {
1461         unlink $old or die "$old: $!";
1462     }
1463
1464     my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1465     return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1466     # avoids apt-get source failing with ambiguous error code
1467
1468     runcmd_ordryrun_local
1469         shell_cmd 'cd "$1"/source; shift', $aptget_base,
1470         aptget_aptget(), qw(--download-only --only-source source), $package;
1471
1472     my @dscs = <$aptget_base/source/*.dsc>;
1473     fail __ "apt-get source did not produce a .dsc" unless @dscs;
1474     fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1475         unless @dscs==1;
1476
1477     my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1478
1479     use URI::Escape;
1480     my $uri = "file://". uri_escape $dscs[0];
1481     $uri =~ s{\%2f}{/}gi;
1482     return [ (getfield $pre_dsc, 'Version'), $uri ];
1483 }
1484
1485 sub file_in_archive_aptget () { return undef; }
1486 sub package_not_wholly_new_aptget () { return undef; }
1487
1488 #---------- `dummyapicat' archive query method ----------
1489 # (untranslated, because this is for testing purposes etc.)
1490
1491 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1492 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1493
1494 sub dummycatapi_run_in_mirror ($@) {
1495     # runs $fn with FIA open onto rune
1496     my ($rune, $argl, $fn) = @_;
1497
1498     my $mirror = access_cfg('mirror');
1499     $mirror =~ s#^file://#/# or die "$mirror ?";
1500     my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1501                qw(x), $mirror, @$argl);
1502     debugcmd "-|", @cmd;
1503     open FIA, "-|", @cmd or confess "$!";
1504     my $r = $fn->();
1505     close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1506     return $r;
1507 }
1508
1509 sub file_in_archive_dummycatapi ($$$) {
1510     my ($proto,$data,$filename) = @_;
1511     my @out;
1512     dummycatapi_run_in_mirror '
1513             find -name "$1" -print0 |
1514             xargs -0r sha256sum
1515     ', [$filename], sub {
1516         while (<FIA>) {
1517             chomp or die;
1518             printdebug "| $_\n";
1519             m/^(\w+)  (\S+)$/ or die "$_ ?";
1520             push @out, { sha256sum => $1, filename => $2 };
1521         }
1522     };
1523     return \@out;
1524 }
1525
1526 sub package_not_wholly_new_dummycatapi {
1527     my ($proto,$data,$pkg) = @_;
1528     dummycatapi_run_in_mirror "
1529             find -name ${pkg}_*.dsc
1530     ", [], sub {
1531         local $/ = undef;
1532         !!<FIA>;
1533     };
1534 }
1535
1536 #---------- `madison' archive query method ----------
1537
1538 sub archive_query_madison {
1539     return archive_query_prepend_mirror
1540         map { [ @$_[0..1] ] } madison_get_parse(@_);
1541 }
1542
1543 sub madison_get_parse {
1544     my ($proto,$data) = @_;
1545     die unless $proto eq 'madison';
1546     if (!length $data) {
1547         $data= access_cfg('madison-distro','RETURN-UNDEF');
1548         $data //= access_basedistro();
1549     }
1550     $rmad{$proto,$data,$package} ||= cmdoutput
1551         qw(rmadison -asource),"-s$isuite","-u$data",$package;
1552     my $rmad = $rmad{$proto,$data,$package};
1553
1554     my @out;
1555     foreach my $l (split /\n/, $rmad) {
1556         $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1557                   \s*( [^ \t|]+ )\s* \|
1558                   \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1559                   \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1560         $1 eq $package or die "$rmad $package ?";
1561         my $vsn = $2;
1562         my $newsuite = $3;
1563         my $component;
1564         if (defined $4) {
1565             $component = $4;
1566         } else {
1567             $component = access_cfg('archive-query-default-component');
1568         }
1569         $5 eq 'source' or die "$rmad ?";
1570         push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1571     }
1572     return sort { -version_compare($a->[0],$b->[0]); } @out;
1573 }
1574
1575 sub canonicalise_suite_madison {
1576     # madison canonicalises for us
1577     my @r = madison_get_parse(@_);
1578     @r or fail f_
1579         "unable to canonicalise suite using package %s".
1580         " which does not appear to exist in suite %s;".
1581         " --existing-package may help",
1582         $package, $isuite;
1583     return $r[0][2];
1584 }
1585
1586 sub file_in_archive_madison { return undef; }
1587 sub package_not_wholly_new_madison { return undef; }
1588
1589 #---------- `sshpsql' archive query method ----------
1590 # (untranslated, because this is obsolete)
1591
1592 sub sshpsql ($$$) {
1593     my ($data,$runeinfo,$sql) = @_;
1594     if (!length $data) {
1595         $data= access_someuserhost('sshpsql').':'.
1596             access_cfg('sshpsql-dbname');
1597     }
1598     $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1599     my ($userhost,$dbname) = ($`,$'); #';
1600     my @rows;
1601     my @cmd = (access_cfg_ssh, $userhost,
1602                access_runeinfo("ssh-psql $runeinfo").
1603                " export LC_MESSAGES=C; export LC_CTYPE=C;".
1604                " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1605     debugcmd "|",@cmd;
1606     open P, "-|", @cmd or confess "$!";
1607     while (<P>) {
1608         chomp or die;
1609         printdebug(">|$_|\n");
1610         push @rows, $_;
1611     }
1612     $!=0; $?=0; close P or failedcmd @cmd;
1613     @rows or die;
1614     my $nrows = pop @rows;
1615     $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1616     @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1617     @rows = map { [ split /\|/, $_ ] } @rows;
1618     my $ncols = scalar @{ shift @rows };
1619     die if grep { scalar @$_ != $ncols } @rows;
1620     return @rows;
1621 }
1622
1623 sub sql_injection_check {
1624     foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1625 }
1626
1627 sub archive_query_sshpsql ($$) {
1628     my ($proto,$data) = @_;
1629     sql_injection_check $isuite, $package;
1630     my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1631         SELECT source.version, component.name, files.filename, files.sha256sum
1632           FROM source
1633           JOIN src_associations ON source.id = src_associations.source
1634           JOIN suite ON suite.id = src_associations.suite
1635           JOIN dsc_files ON dsc_files.source = source.id
1636           JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1637           JOIN component ON component.id = files_archive_map.component_id
1638           JOIN files ON files.id = dsc_files.file
1639          WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1640            AND source.source='$package'
1641            AND files.filename LIKE '%.dsc';
1642 END
1643     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1644     my $digester = Digest::SHA->new(256);
1645     @rows = map {
1646         my ($vsn,$component,$filename,$sha256sum) = @$_;
1647         [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1648     } @rows;
1649     return archive_query_prepend_mirror @rows;
1650 }
1651
1652 sub canonicalise_suite_sshpsql ($$) {
1653     my ($proto,$data) = @_;
1654     sql_injection_check $isuite;
1655     my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1656         SELECT suite.codename
1657           FROM suite where suite_name='$isuite' or codename='$isuite';
1658 END
1659     @rows = map { $_->[0] } @rows;
1660     fail "unknown suite $isuite" unless @rows;
1661     die "ambiguous $isuite: @rows ?" if @rows>1;
1662     return $rows[0];
1663 }
1664
1665 sub file_in_archive_sshpsql ($$$) { return undef; }
1666 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1667
1668 #---------- `dummycat' archive query method ----------
1669 # (untranslated, because this is for testing purposes etc.)
1670
1671 sub canonicalise_suite_dummycat ($$) {
1672     my ($proto,$data) = @_;
1673     my $dpath = "$data/suite.$isuite";
1674     if (!open C, "<", $dpath) {
1675         $!==ENOENT or die "$dpath: $!";
1676         printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1677         return $isuite;
1678     }
1679     $!=0; $_ = <C>;
1680     chomp or die "$dpath: $!";
1681     close C;
1682     printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1683     return $_;
1684 }
1685
1686 sub archive_query_dummycat ($$) {
1687     my ($proto,$data) = @_;
1688     canonicalise_suite();
1689     my $dpath = "$data/package.$csuite.$package";
1690     if (!open C, "<", $dpath) {
1691         $!==ENOENT or die "$dpath: $!";
1692         printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1693         return ();
1694     }
1695     my @rows;
1696     while (<C>) {
1697         next if m/^\#/;
1698         next unless m/\S/;
1699         die unless chomp;
1700         printdebug "dummycat query $csuite $package $dpath | $_\n";
1701         my @row = split /\s+/, $_;
1702         @row==2 or die "$dpath: $_ ?";
1703         push @rows, \@row;
1704     }
1705     C->error and die "$dpath: $!";
1706     close C;
1707     return archive_query_prepend_mirror
1708         sort { -version_compare($a->[0],$b->[0]); } @rows;
1709 }
1710
1711 sub file_in_archive_dummycat () { return undef; }
1712 sub package_not_wholly_new_dummycat () { return undef; }
1713
1714 #---------- archive query entrypoints and rest of program ----------
1715
1716 sub canonicalise_suite () {
1717     return if defined $csuite;
1718     fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1719     $csuite = archive_query('canonicalise_suite');
1720     if ($isuite ne $csuite) {
1721         progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1722     } else {
1723         progress f_ "canonical suite name is %s", $csuite;
1724     }
1725 }
1726
1727 sub get_archive_dsc () {
1728     canonicalise_suite();
1729     my @vsns = archive_query('archive_query');
1730     foreach my $vinfo (@vsns) {
1731         my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1732         $dscurl = $vsn_dscurl;
1733         $dscdata = url_get($dscurl);
1734         if (!$dscdata) {
1735             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1736             next;
1737         }
1738         if ($digester) {
1739             $digester->reset();
1740             $digester->add($dscdata);
1741             my $got = $digester->hexdigest();
1742             $got eq $digest or
1743                 fail f_ "%s has hash %s but archive told us to expect %s",
1744                         $dscurl, $got, $digest;
1745         }
1746         parse_dscdata();
1747         my $fmt = getfield $dsc, 'Format';
1748         $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1749             f_ "unsupported source format %s, sorry", $fmt;
1750
1751         $dsc_checked = !!$digester;
1752         printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1753         return;
1754     }
1755     $dsc = undef;
1756     printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1757 }
1758
1759 sub check_for_git ();
1760 sub check_for_git () {
1761     # returns 0 or 1
1762     my $how = access_cfg('git-check');
1763     if ($how eq 'ssh-cmd') {
1764         my @cmd =
1765             (access_cfg_ssh, access_gituserhost(),
1766              access_runeinfo("git-check $package").
1767              " set -e; cd ".access_cfg('git-path').";".
1768              " if test -d $package.git; then echo 1; else echo 0; fi");
1769         my $r= cmdoutput @cmd;
1770         if (defined $r and $r =~ m/^divert (\w+)$/) {
1771             my $divert=$1;
1772             my ($usedistro,) = access_distros();
1773             # NB that if we are pushing, $usedistro will be $distro/push
1774             $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1775             $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1776             progress f_ "diverting to %s (using config for %s)",
1777                         $divert, $instead_distro;
1778             return check_for_git();
1779         }
1780         failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1781         return $r+0;
1782     } elsif ($how eq 'url') {
1783         my $prefix = access_cfg('git-check-url','git-url');
1784         my $suffix = access_cfg('git-check-suffix','git-suffix',
1785                                 'RETURN-UNDEF') // '.git';
1786         my $url = "$prefix/$package$suffix";
1787         my @cmd = (@curl, qw(-sS -I), $url);
1788         my $result = cmdoutput @cmd;
1789         $result =~ s/^\S+ 200 .*\n\r?\n//;
1790         # curl -sS -I with https_proxy prints
1791         # HTTP/1.0 200 Connection established
1792         $result =~ m/^\S+ (404|200) /s or
1793             fail +(__ "unexpected results from git check query - ").
1794                 Dumper($prefix, $result);
1795         my $code = $1;
1796         if ($code eq '404') {
1797             return 0;
1798         } elsif ($code eq '200') {
1799             return 1;
1800         } else {
1801             die;
1802         }
1803     } elsif ($how eq 'true') {
1804         return 1;
1805     } elsif ($how eq 'false') {
1806         return 0;
1807     } else {
1808         badcfg f_ "unknown git-check \`%s'", $how;
1809     }
1810 }
1811
1812 sub create_remote_git_repo () {
1813     my $how = access_cfg('git-create');
1814     if ($how eq 'ssh-cmd') {
1815         runcmd_ordryrun
1816             (access_cfg_ssh, access_gituserhost(),
1817              access_runeinfo("git-create $package").
1818              "set -e; cd ".access_cfg('git-path').";".
1819              " cp -a _template $package.git");
1820     } elsif ($how eq 'true') {
1821         # nothing to do
1822     } else {
1823         badcfg f_ "unknown git-create \`%s'", $how;
1824     }
1825 }
1826
1827 our ($dsc_hash,$lastpush_mergeinput);
1828 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1829
1830
1831 sub prep_ud () {
1832     dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1833     $playground = fresh_playground 'dgit/unpack';
1834 }
1835
1836 sub mktree_in_ud_here () {
1837     playtree_setup $gitcfgs{local};
1838 }
1839
1840 sub git_write_tree () {
1841     my $tree = cmdoutput @git, qw(write-tree);
1842     $tree =~ m/^\w+$/ or die "$tree ?";
1843     return $tree;
1844 }
1845
1846 sub git_add_write_tree () {
1847     runcmd @git, qw(add -Af .);
1848     return git_write_tree();
1849 }
1850
1851 sub remove_stray_gits ($) {
1852     my ($what) = @_;
1853     my @gitscmd = qw(find -name .git -prune -print0);
1854     debugcmd "|",@gitscmd;
1855     open GITS, "-|", @gitscmd or confess "$!";
1856     {
1857         local $/="\0";
1858         while (<GITS>) {
1859             chomp or die;
1860             print STDERR f_ "%s: warning: removing from %s: %s\n",
1861                 $us, $what, (messagequote $_);
1862             rmtree $_;
1863         }
1864     }
1865     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1866 }
1867
1868 sub mktree_in_ud_from_only_subdir ($;$) {
1869     my ($what,$raw) = @_;
1870     # changes into the subdir
1871
1872     my (@dirs) = <*/.>;
1873     confess "expected one subdir but found @dirs ?" unless @dirs==1;
1874     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1875     my $dir = $1;
1876     changedir $dir;
1877
1878     remove_stray_gits($what);
1879     mktree_in_ud_here();
1880     if (!$raw) {
1881         my ($format, $fopts) = get_source_format();
1882         if (madformat($format)) {
1883             rmtree '.pc';
1884         }
1885     }
1886
1887     my $tree=git_add_write_tree();
1888     return ($tree,$dir);
1889 }
1890
1891 our @files_csum_info_fields =
1892     (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1893      ['Checksums-Sha1',  'Digest::SHA', 'new(1)',   'sha1sum'],
1894      ['Files',           'Digest::MD5', 'new()',    'md5sum']);
1895
1896 sub dsc_files_info () {
1897     foreach my $csumi (@files_csum_info_fields) {
1898         my ($fname, $module, $method) = @$csumi;
1899         my $field = $dsc->{$fname};
1900         next unless defined $field;
1901         eval "use $module; 1;" or die $@;
1902         my @out;
1903         foreach (split /\n/, $field) {
1904             next unless m/\S/;
1905             m/^(\w+) (\d+) (\S+)$/ or
1906                 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1907             my $digester = eval "$module"."->$method;" or die $@;
1908             push @out, {
1909                 Hash => $1,
1910                 Bytes => $2,
1911                 Filename => $3,
1912                 Digester => $digester,
1913             };
1914         }
1915         return @out;
1916     }
1917     fail f_ "missing any supported Checksums-* or Files field in %s",
1918             $dsc->get_option('name');
1919 }
1920
1921 sub dsc_files () {
1922     map { $_->{Filename} } dsc_files_info();
1923 }
1924
1925 sub files_compare_inputs (@) {
1926     my $inputs = \@_;
1927     my %record;
1928     my %fchecked;
1929
1930     my $showinputs = sub {
1931         return join "; ", map { $_->get_option('name') } @$inputs;
1932     };
1933
1934     foreach my $in (@$inputs) {
1935         my $expected_files;
1936         my $in_name = $in->get_option('name');
1937
1938         printdebug "files_compare_inputs $in_name\n";
1939
1940         foreach my $csumi (@files_csum_info_fields) {
1941             my ($fname) = @$csumi;
1942             printdebug "files_compare_inputs $in_name $fname\n";
1943
1944             my $field = $in->{$fname};
1945             next unless defined $field;
1946
1947             my @files;
1948             foreach (split /\n/, $field) {
1949                 next unless m/\S/;
1950
1951                 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1952                     fail "could not parse $in_name $fname line \`$_'";
1953
1954                 printdebug "files_compare_inputs $in_name $fname $f\n";
1955
1956                 push @files, $f;
1957
1958                 my $re = \ $record{$f}{$fname};
1959                 if (defined $$re) {
1960                     $fchecked{$f}{$in_name} = 1;
1961                     $$re eq $info or
1962                         fail f_
1963               "hash or size of %s varies in %s fields (between: %s)",
1964                                  $f, $fname, $showinputs->();
1965                 } else {
1966                     $$re = $info;
1967                 }
1968             }
1969             @files = sort @files;
1970             $expected_files //= \@files;
1971             "@$expected_files" eq "@files" or
1972                 fail f_ "file list in %s varies between hash fields!",
1973                         $in_name;
1974         }
1975         $expected_files or
1976             fail f_ "%s has no files list field(s)", $in_name;
1977     }
1978     printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1979         if $debuglevel>=2;
1980
1981     grep { keys %$_ == @$inputs-1 } values %fchecked
1982         or fail f_ "no file appears in all file lists (looked in: %s)",
1983                    $showinputs->();
1984 }
1985
1986 sub is_orig_file_in_dsc ($$) {
1987     my ($f, $dsc_files_info) = @_;
1988     return 0 if @$dsc_files_info <= 1;
1989     # One file means no origs, and the filename doesn't have a "what
1990     # part of dsc" component.  (Consider versions ending `.orig'.)
1991     return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1992     return 1;
1993 }
1994
1995 # This function determines whether a .changes file is source-only from
1996 # the point of view of dak.  Thus, it permits *_source.buildinfo
1997 # files.
1998 #
1999 # It does not, however, permit any other buildinfo files.  After a
2000 # source-only upload, the buildds will try to upload files like
2001 # foo_1.2.3_amd64.buildinfo.  If the package maintainer included files
2002 # named like this in their (otherwise) source-only upload, the uploads
2003 # of the buildd can be rejected by dak.  Fixing the resultant
2004 # situation can require manual intervention.  So we block such
2005 # .buildinfo files when the user tells us to perform a source-only
2006 # upload (such as when using the push-source subcommand with the -C
2007 # option, which calls this function).
2008 #
2009 # Note, though, that when dgit is told to prepare a source-only
2010 # upload, such as when subcommands like build-source and push-source
2011 # without -C are used, dgit has a more restrictive notion of
2012 # source-only .changes than dak: such uploads will never include
2013 # *_source.buildinfo files.  This is because there is no use for such
2014 # files when using a tool like dgit to produce the source package, as
2015 # dgit ensures the source is identical to git HEAD.
2016 sub test_source_only_changes ($) {
2017     my ($changes) = @_;
2018     foreach my $l (split /\n/, getfield $changes, 'Files') {
2019         $l =~ m/\S+$/ or next;
2020         # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
2021         unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
2022             print f_ "purportedly source-only changes polluted by %s\n", $&;
2023             return 0;
2024         }
2025     }
2026     return 1;
2027 }
2028
2029 sub changes_update_origs_from_dsc ($$$$) {
2030     my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
2031     my %changes_f;
2032     printdebug "checking origs needed ($upstreamvsn)...\n";
2033     $_ = getfield $changes, 'Files';
2034     m/^\w+ \d+ (\S+ \S+) \S+$/m or
2035         fail __ "cannot find section/priority from .changes Files field";
2036     my $placementinfo = $1;
2037     my %changed;
2038     printdebug "checking origs needed placement '$placementinfo'...\n";
2039     foreach my $l (split /\n/, getfield $dsc, 'Files') {
2040         $l =~ m/\S+$/ or next;
2041         my $file = $&;
2042         printdebug "origs $file | $l\n";
2043         next unless is_orig_file_of_vsn $file, $upstreamvsn;
2044         printdebug "origs $file is_orig\n";
2045         my $have = archive_query('file_in_archive', $file);
2046         if (!defined $have) {
2047             print STDERR __ <<END;
2048 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2049 END
2050             return;
2051         }
2052         my $found_same = 0;
2053         my @found_differ;
2054         printdebug "origs $file \$#\$have=$#$have\n";
2055         foreach my $h (@$have) {
2056             my $same = 0;
2057             my @differ;
2058             foreach my $csumi (@files_csum_info_fields) {
2059                 my ($fname, $module, $method, $archivefield) = @$csumi;
2060                 next unless defined $h->{$archivefield};
2061                 $_ = $dsc->{$fname};
2062                 next unless defined;
2063                 m/^(\w+) .* \Q$file\E$/m or
2064                     fail f_ ".dsc %s missing entry for %s", $fname, $file;
2065                 if ($h->{$archivefield} eq $1) {
2066                     $same++;
2067                 } else {
2068                     push @differ, f_
2069                         "%s: %s (archive) != %s (local .dsc)",
2070                         $archivefield, $h->{$archivefield}, $1;
2071                 }
2072             }
2073             confess "$file ".Dumper($h)." ?!" if $same && @differ;
2074             $found_same++
2075                 if $same;
2076             push @found_differ,
2077                 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2078                 if @differ;
2079         }
2080         printdebug "origs $file f.same=$found_same".
2081             " #f._differ=$#found_differ\n";
2082         if (@found_differ && !$found_same) {
2083             fail join "\n",
2084                 (f_ "archive contains %s with different checksum", $file),
2085                 @found_differ;
2086         }
2087         # Now we edit the changes file to add or remove it
2088         foreach my $csumi (@files_csum_info_fields) {
2089             my ($fname, $module, $method, $archivefield) = @$csumi;
2090             next unless defined $changes->{$fname};
2091             if ($found_same) {
2092                 # in archive, delete from .changes if it's there
2093                 $changed{$file} = "removed" if
2094                     $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2095             } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2096                 # not in archive, but it's here in the .changes
2097             } else {
2098                 my $dsc_data = getfield $dsc, $fname;
2099                 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2100                 my $extra = $1;
2101                 $extra =~ s/ \d+ /$&$placementinfo /
2102                     or confess "$fname $extra >$dsc_data< ?"
2103                     if $fname eq 'Files';
2104                 $changes->{$fname} .= "\n". $extra;
2105                 $changed{$file} = "added";
2106             }
2107         }
2108     }
2109     if (%changed) {
2110         foreach my $file (keys %changed) {
2111             progress f_
2112                 "edited .changes for archive .orig contents: %s %s",
2113                 $changed{$file}, $file;
2114         }
2115         my $chtmp = "$changesfile.tmp";
2116         $changes->save($chtmp);
2117         if (act_local()) {
2118             rename $chtmp,$changesfile or die "$changesfile $!";
2119         } else {
2120             progress f_ "[new .changes left in %s]", $changesfile;
2121         }
2122     } else {
2123         progress f_ "%s already has appropriate .orig(s) (if any)",
2124                     $changesfile;
2125     }
2126 }
2127
2128 sub clogp_authline ($) {
2129     my ($clogp) = @_;
2130     my $author = getfield $clogp, 'Maintainer';
2131     if ($author =~ m/^[^"\@]+\,/) {
2132         # single entry Maintainer field with unquoted comma
2133         $author = ($& =~ y/,//rd).$'; # strip the comma
2134     }
2135     # git wants a single author; any remaining commas in $author
2136     # are by now preceded by @ (or ").  It seems safer to punt on
2137     # "..." for now rather than attempting to dequote or something.
2138     $author =~ s#,.*##ms unless $author =~ m/"/;
2139     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2140     my $authline = "$author $date";
2141     $authline =~ m/$git_authline_re/o or
2142         fail f_ "unexpected commit author line format \`%s'".
2143                 " (was generated from changelog Maintainer field)",
2144                 $authline;
2145     return ($1,$2,$3) if wantarray;
2146     return $authline;
2147 }
2148
2149 sub vendor_patches_distro ($$) {
2150     my ($checkdistro, $what) = @_;
2151     return unless defined $checkdistro;
2152
2153     my $series = "debian/patches/\L$checkdistro\E.series";
2154     printdebug "checking for vendor-specific $series ($what)\n";
2155
2156     if (!open SERIES, "<", $series) {
2157         confess "$series $!" unless $!==ENOENT;
2158         return;
2159     }
2160     while (<SERIES>) {
2161         next unless m/\S/;
2162         next if m/^\s+\#/;
2163
2164         print STDERR __ <<END;
2165
2166 Unfortunately, this source package uses a feature of dpkg-source where
2167 the same source package unpacks to different source code on different
2168 distros.  dgit cannot safely operate on such packages on affected
2169 distros, because the meaning of source packages is not stable.
2170
2171 Please ask the distro/maintainer to remove the distro-specific series
2172 files and use a different technique (if necessary, uploading actually
2173 different packages, if different distros are supposed to have
2174 different code).
2175
2176 END
2177         fail f_ "Found active distro-specific series file for".
2178                 " %s (%s): %s, cannot continue",
2179                 $checkdistro, $what, $series;
2180     }
2181     die "$series $!" if SERIES->error;
2182     close SERIES;
2183 }
2184
2185 sub check_for_vendor_patches () {
2186     # This dpkg-source feature doesn't seem to be documented anywhere!
2187     # But it can be found in the changelog (reformatted):
2188
2189     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
2190     #   Author: Raphael Hertzog <hertzog@debian.org>
2191     #   Date: Sun  Oct  3  09:36:48  2010 +0200
2192
2193     #   dpkg-source: correctly create .pc/.quilt_series with alternate
2194     #   series files
2195     #
2196     #   If you have debian/patches/ubuntu.series and you were
2197     #   unpacking the source package on ubuntu, quilt was still
2198     #   directed to debian/patches/series instead of
2199     #   debian/patches/ubuntu.series.
2200     #
2201     #   debian/changelog                        |    3 +++
2202     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
2203     #   2 files changed, 6 insertions(+), 1 deletion(-)
2204
2205     use Dpkg::Vendor;
2206     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2207     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2208                           __ "Dpkg::Vendor \`current vendor'");
2209     vendor_patches_distro(access_basedistro(),
2210                           __ "(base) distro being accessed");
2211     vendor_patches_distro(access_nomdistro(),
2212                           __ "(nominal) distro being accessed");
2213 }
2214
2215 sub check_bpd_exists () {
2216     stat $buildproductsdir
2217         or fail f_ "build-products-dir %s is not accessible: %s\n",
2218         $buildproductsdir, $!;
2219 }
2220
2221 sub dotdot_bpd_transfer_origs ($$$) {
2222     my ($bpd_abs, $upstreamversion, $wanted) = @_;
2223     # checks is_orig_file_of_vsn and if
2224     # calls $wanted->{$leaf} and expects boolish
2225
2226     return if $buildproductsdir eq '..';
2227
2228     my $warned;
2229     my $dotdot = $maindir;
2230     $dotdot =~ s{/[^/]+$}{};
2231     opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2232     while ($!=0, defined(my $leaf = readdir DD)) {
2233         {
2234             local ($debuglevel) = $debuglevel-1;
2235             printdebug "DD_BPD $leaf ?\n";
2236         }
2237         next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2238         next unless $wanted->($leaf);
2239         next if lstat "$bpd_abs/$leaf";
2240
2241         print STDERR f_
2242  "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2243             $us
2244             unless $warned++;
2245         $! == &ENOENT or fail f_
2246             "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2247         lstat "$dotdot/$leaf" or fail f_
2248             "check orig file %s in ..: %s", $leaf, $!;
2249         if (-l _) {
2250             stat "$dotdot/$leaf" or fail f_
2251                 "check target of orig symlink %s in ..: %s", $leaf, $!;
2252             my $ltarget = readlink "$dotdot/$leaf" or
2253                 die "readlink $dotdot/$leaf: $!";
2254             if ($ltarget !~ m{^/}) {
2255                 $ltarget = "$dotdot/$ltarget";
2256             }
2257             symlink $ltarget, "$bpd_abs/$leaf"
2258                 or die "$ltarget $bpd_abs $leaf: $!";
2259             print STDERR f_
2260  "%s: cloned orig symlink from ..: %s\n",
2261                 $us, $leaf;
2262         } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2263             print STDERR f_
2264  "%s: hardlinked orig from ..: %s\n",
2265                 $us, $leaf;
2266         } elsif ($! != EXDEV) {
2267             fail f_ "failed to make %s a hardlink to %s: %s",
2268                 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2269         } else {
2270             symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2271                 or die "$bpd_abs $dotdot $leaf $!";
2272             print STDERR f_
2273  "%s: symmlinked orig from .. on other filesystem: %s\n",
2274                 $us, $leaf;
2275         }
2276     }
2277     die "$dotdot; $!" if $!;
2278     closedir DD;
2279 }
2280
2281 sub import_tarball_tartrees ($$) {
2282     my ($upstreamv, $dfi) = @_;
2283     # cwd should be the playground
2284
2285     # We unpack and record the orig tarballs first, so that we only
2286     # need disk space for one private copy of the unpacked source.
2287     # But we can't make them into commits until we have the metadata
2288     # from the debian/changelog, so we record the tree objects now and
2289     # make them into commits later.
2290     my @tartrees;
2291     my $orig_f_base = srcfn $upstreamv, '';
2292
2293     foreach my $fi (@$dfi) {
2294         # We actually import, and record as a commit, every tarball
2295         # (unless there is only one file, in which case there seems
2296         # little point.
2297
2298         my $f = $fi->{Filename};
2299         printdebug "import considering $f ";
2300         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2301         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2302         my $compr_ext = $1;
2303
2304         my ($orig_f_part) =
2305             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2306
2307         printdebug "Y ", (join ' ', map { $_//"(none)" }
2308                           $compr_ext, $orig_f_part
2309                          ), "\n";
2310
2311         my $path = $fi->{Path} // $f;
2312         my $input = new IO::File $f, '<' or die "$f $!";
2313         my $compr_pid;
2314         my @compr_cmd;
2315
2316         if (defined $compr_ext) {
2317             my $cname =
2318                 Dpkg::Compression::compression_guess_from_filename $f;
2319             fail "Dpkg::Compression cannot handle file $f in source package"
2320                 if defined $compr_ext && !defined $cname;
2321             my $compr_proc =
2322                 new Dpkg::Compression::Process compression => $cname;
2323             @compr_cmd = $compr_proc->get_uncompress_cmdline();
2324             my $compr_fh = new IO::Handle;
2325             my $compr_pid = open $compr_fh, "-|" // confess "$!";
2326             if (!$compr_pid) {
2327                 open STDIN, "<&", $input or confess "$!";
2328                 exec @compr_cmd;
2329                 die "dgit (child): exec $compr_cmd[0]: $!\n";
2330             }
2331             $input = $compr_fh;
2332         }
2333
2334         rmtree "_unpack-tar";
2335         mkdir "_unpack-tar" or confess "$!";
2336         my @tarcmd = qw(tar -x -f -
2337                         --no-same-owner --no-same-permissions
2338                         --no-acls --no-xattrs --no-selinux);
2339         my $tar_pid = fork // confess "$!";
2340         if (!$tar_pid) {
2341             chdir "_unpack-tar" or confess "$!";
2342             open STDIN, "<&", $input or confess "$!";
2343             exec @tarcmd;
2344             die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2345         }
2346         $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2347         !$? or failedcmd @tarcmd;
2348
2349         close $input or
2350             (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2351              : confess "$!");
2352         # finally, we have the results in "tarball", but maybe
2353         # with the wrong permissions
2354
2355         runcmd qw(chmod -R +rwX _unpack-tar);
2356         changedir "_unpack-tar";
2357         remove_stray_gits($f);
2358         mktree_in_ud_here();
2359
2360         my ($tree) = git_add_write_tree();
2361         my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2362         if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2363             $tree = $1;
2364             printdebug "one subtree $1\n";
2365         } else {
2366             printdebug "multiple subtrees\n";
2367         }
2368         changedir "..";
2369         rmtree "_unpack-tar";
2370
2371         my $ent = [ $f, $tree ];
2372         push @tartrees, {
2373             Orig => !!$orig_f_part,
2374             Sort => (!$orig_f_part         ? 2 :
2375                      $orig_f_part =~ m/-/g ? 1 :
2376                                              0),
2377             OrigPart => $orig_f_part, # 'orig', 'orig-XXX', or undef
2378             F => $f,
2379             Tree => $tree,
2380         };
2381     }
2382
2383     @tartrees = sort {
2384         # put any without "_" first (spec is not clear whether files
2385         # are always in the usual order).  Tarballs without "_" are
2386         # the main orig or the debian tarball.
2387         $a->{Sort} <=> $b->{Sort} or
2388         $a->{F}    cmp $b->{F}
2389     } @tartrees;
2390
2391     @tartrees;
2392 }
2393
2394 sub import_tarball_commits ($$) {
2395     my ($tartrees, $upstreamv) = @_;
2396     # cwd should be a playtree which has a relevant debian/changelog
2397     # fills in $tt->{Commit} for each one
2398
2399     my $any_orig = grep { $_->{Orig} } @$tartrees;
2400
2401     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2402     my $clogp;
2403     my $r1clogp;
2404
2405     printdebug "import clog search...\n";
2406     parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2407         my ($thisstanza, $desc) = @_;
2408         no warnings qw(exiting);
2409
2410         $clogp //= $thisstanza;
2411
2412         printdebug "import clog $thisstanza->{version} $desc...\n";
2413
2414         last if !$any_orig; # we don't need $r1clogp
2415
2416         # We look for the first (most recent) changelog entry whose
2417         # version number is lower than the upstream version of this
2418         # package.  Then the last (least recent) previous changelog
2419         # entry is treated as the one which introduced this upstream
2420         # version and used for the synthetic commits for the upstream
2421         # tarballs.
2422
2423         # One might think that a more sophisticated algorithm would be
2424         # necessary.  But: we do not want to scan the whole changelog
2425         # file.  Stopping when we see an earlier version, which
2426         # necessarily then is an earlier upstream version, is the only
2427         # realistic way to do that.  Then, either the earliest
2428         # changelog entry we have seen so far is indeed the earliest
2429         # upload of this upstream version; or there are only changelog
2430         # entries relating to later upstream versions (which is not
2431         # possible unless the changelog and .dsc disagree about the
2432         # version).  Then it remains to choose between the physically
2433         # last entry in the file, and the one with the lowest version
2434         # number.  If these are not the same, we guess that the
2435         # versions were created in a non-monotonic order rather than
2436         # that the changelog entries have been misordered.
2437
2438         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2439
2440         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2441         $r1clogp = $thisstanza;
2442
2443         printdebug "import clog $r1clogp->{version} becomes r1\n";
2444     };
2445
2446     $clogp or fail __ "package changelog has no entries!";
2447
2448     my $authline = clogp_authline $clogp;
2449     my $changes = getfield $clogp, 'Changes';
2450     $changes =~ s/^\n//; # Changes: \n
2451     my $cversion = getfield $clogp, 'Version';
2452
2453     my $r1authline;
2454     if (@$tartrees) {
2455         $r1clogp //= $clogp; # maybe there's only one entry;
2456         $r1authline = clogp_authline $r1clogp;
2457         # Strictly, r1authline might now be wrong if it's going to be
2458         # unused because !$any_orig.  Whatever.
2459
2460         printdebug "import tartrees authline   $authline\n";
2461         printdebug "import tartrees r1authline $r1authline\n";
2462
2463         foreach my $tt (@$tartrees) {
2464             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2465
2466             # untranslated so that different people's imports are identical
2467             my $mbody = sprintf "Import %s", $tt->{F};
2468             $tt->{Commit} = hash_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2469 tree $tt->{Tree}
2470 author $r1authline
2471 committer $r1authline
2472
2473 $mbody
2474
2475 [dgit import orig $tt->{F}]
2476 END_O
2477 tree $tt->{Tree}
2478 author $authline
2479 committer $authline
2480
2481 $mbody
2482
2483 [dgit import tarball $package $cversion $tt->{F}]
2484 END_T
2485         }
2486     }
2487
2488     return ($authline, $r1authline, $clogp, $changes);
2489 }
2490
2491 sub generate_commits_from_dsc () {
2492     # See big comment in fetch_from_archive, below.
2493     # See also README.dsc-import.
2494     prep_ud();
2495     changedir $playground;
2496
2497     my $bpd_abs = bpd_abs();
2498     my $upstreamv = upstreamversion $dsc->{version};
2499     my @dfi = dsc_files_info();
2500
2501     dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2502         sub { grep { $_->{Filename} eq $_[0] } @dfi };
2503
2504     foreach my $fi (@dfi) {
2505         my $f = $fi->{Filename};
2506         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2507         my $upper_f = "$bpd_abs/$f";
2508
2509         printdebug "considering reusing $f: ";
2510
2511         if (link_ltarget "$upper_f,fetch", $f) {
2512             printdebug "linked (using ...,fetch).\n";
2513         } elsif ((printdebug "($!) "),
2514                  $! != ENOENT) {
2515             fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2516         } elsif (link_ltarget $upper_f, $f) {
2517             printdebug "linked.\n";
2518         } elsif ((printdebug "($!) "),
2519                  $! != ENOENT) {
2520             fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2521         } else {
2522             printdebug "absent.\n";
2523         }
2524
2525         my $refetched;
2526         complete_file_from_dsc('.', $fi, \$refetched)
2527             or next;
2528
2529         printdebug "considering saving $f: ";
2530
2531         if (rename_link_xf 1, $f, $upper_f) {
2532             printdebug "linked.\n";
2533         } elsif ((printdebug "($@) "),
2534                  $! != EEXIST) {
2535             fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2536         } elsif (!$refetched) {
2537             printdebug "no need.\n";
2538         } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2539             printdebug "linked (using ...,fetch).\n";
2540         } elsif ((printdebug "($@) "),
2541                  $! != EEXIST) {
2542             fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2543         } else {
2544             printdebug "cannot.\n";
2545         }
2546     }
2547
2548     my @tartrees;
2549     @tartrees = import_tarball_tartrees($upstreamv, \@dfi)
2550         unless @dfi == 1; # only one file in .dsc
2551
2552     my $dscfn = "$package.dsc";
2553
2554     my $treeimporthow = 'package';
2555
2556     open D, ">", $dscfn or die "$dscfn: $!";
2557     print D $dscdata or die "$dscfn: $!";
2558     close D or die "$dscfn: $!";
2559     my @cmd = qw(dpkg-source);
2560     push @cmd, '--no-check' if $dsc_checked;
2561     if (madformat $dsc->{format}) {
2562         push @cmd, '--skip-patches';
2563         $treeimporthow = 'unpatched';
2564     }
2565     push @cmd, qw(-x --), $dscfn;
2566     runcmd @cmd;
2567
2568     my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2569     if (madformat $dsc->{format}) {
2570         check_for_vendor_patches();
2571     }
2572
2573     my $dappliedtree;
2574     if (madformat $dsc->{format}) {
2575         my @pcmd = qw(dpkg-source --before-build .);
2576         runcmd shell_cmd 'exec >/dev/null', @pcmd;
2577         rmtree '.pc';
2578         $dappliedtree = git_add_write_tree();
2579     }
2580
2581     my ($authline, $r1authline, $clogp, $changes) =
2582         import_tarball_commits(\@tartrees, $upstreamv);
2583
2584     my $cversion = getfield $clogp, 'Version';
2585
2586     printdebug "import main commit\n";
2587
2588     open C, ">../commit.tmp" or confess "$!";
2589     print C <<END or confess "$!";
2590 tree $tree
2591 END
2592     print C <<END or confess "$!" foreach @tartrees;
2593 parent $_->{Commit}
2594 END
2595     print C <<END or confess "$!";
2596 author $authline
2597 committer $authline
2598
2599 $changes
2600
2601 [dgit import $treeimporthow $package $cversion]
2602 END
2603
2604     close C or confess "$!";
2605     my $rawimport_hash = hash_commit qw(../commit.tmp);
2606
2607     if (madformat $dsc->{format}) {
2608         printdebug "import apply patches...\n";
2609
2610         # regularise the state of the working tree so that
2611         # the checkout of $rawimport_hash works nicely.
2612         my $dappliedcommit = hash_commit_text(<<END);
2613 tree $dappliedtree
2614 author $authline
2615 committer $authline
2616
2617 [dgit dummy commit]
2618 END
2619         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2620
2621         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2622
2623         # We need the answers to be reproducible
2624         my @authline = clogp_authline($clogp);
2625         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2626         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2627         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2628         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
2629         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2630         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
2631
2632         my $path = $ENV{PATH} or die;
2633
2634         # we use ../../gbp-pq-output, which (given that we are in
2635         # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2636         # is .git/dgit.
2637
2638         foreach my $use_absurd (qw(0 1)) {
2639             runcmd @git, qw(checkout -q unpa);
2640             runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2641             local $ENV{PATH} = $path;
2642             if ($use_absurd) {
2643                 chomp $@;
2644                 progress "warning: $@";
2645                 $path = "$absurdity:$path";
2646                 progress f_ "%s: trying slow absurd-git-apply...", $us;
2647                 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2648                     or $!==ENOENT
2649                     or confess "$!";
2650             }
2651             eval {
2652                 die "forbid absurd git-apply\n" if $use_absurd
2653                     && forceing [qw(import-gitapply-no-absurd)];
2654                 die "only absurd git-apply!\n" if !$use_absurd
2655                     && forceing [qw(import-gitapply-absurd)];
2656
2657                 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2658                 local $ENV{PATH} = $path                    if $use_absurd;
2659
2660                 my @showcmd = (gbp_pq, qw(import));
2661                 my @realcmd = shell_cmd
2662                     'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2663                 debugcmd "+",@realcmd;
2664                 if (system @realcmd) {
2665                     die f_ "%s failed: %s\n",
2666                         +(shellquote @showcmd),
2667                         failedcmd_waitstatus();
2668                 }
2669
2670                 my $gapplied = git_rev_parse('HEAD');
2671                 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2672                 $gappliedtree eq $dappliedtree or
2673                     fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2674 gbp-pq import and dpkg-source disagree!
2675  gbp-pq import gave commit %s
2676  gbp-pq import gave tree %s
2677  dpkg-source --before-build gave tree %s
2678 END
2679                 $rawimport_hash = $gapplied;
2680             };
2681             last unless $@;
2682         }
2683         if ($@) {
2684             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2685             die $@;
2686         }
2687     }
2688
2689     progress f_ "synthesised git commit from .dsc %s", $cversion;
2690
2691     my $rawimport_mergeinput = {
2692         Commit => $rawimport_hash,
2693         Info => __ "Import of source package",
2694     };
2695     my @output = ($rawimport_mergeinput);
2696
2697     if ($lastpush_mergeinput) {
2698         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2699         my $oversion = getfield $oldclogp, 'Version';
2700         my $vcmp =
2701             version_compare($oversion, $cversion);
2702         if ($vcmp < 0) {
2703             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2704                 { ReverseParents => 1,
2705                   # untranslated so that different people's pseudomerges
2706                   # are not needlessly different (although they will
2707                   # still differ if the series of pulls is different)
2708                   Message => (sprintf <<END, $package, $cversion, $csuite) });
2709 Record %s (%s) in archive suite %s
2710 END
2711         } elsif ($vcmp > 0) {
2712             print STDERR f_ <<END, $cversion, $oversion,
2713
2714 Version actually in archive:   %s (older)
2715 Last version pushed with dgit: %s (newer or same)
2716 %s
2717 END
2718                 __ $later_warning_msg or confess "$!";
2719             @output = $lastpush_mergeinput;
2720         } else {
2721             # Same version.  Use what's in the server git branch,
2722             # discarding our own import.  (This could happen if the
2723             # server automatically imports all packages into git.)
2724             @output = $lastpush_mergeinput;
2725         }
2726     }
2727     changedir $maindir;
2728     rmtree $playground;
2729     return @output;
2730 }
2731
2732 sub complete_file_from_dsc ($$;$) {
2733     our ($dstdir, $fi, $refetched) = @_;
2734     # Ensures that we have, in $dstdir, the file $fi, with the correct
2735     # contents.  (Downloading it from alongside $dscurl if necessary.)
2736     # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2737     # and will set $$refetched=1 if it did so (or tried to).
2738
2739     my $f = $fi->{Filename};
2740     my $tf = "$dstdir/$f";
2741     my $downloaded = 0;
2742
2743     my $got;
2744     my $checkhash = sub {
2745         open F, "<", "$tf" or die "$tf: $!";
2746         $fi->{Digester}->reset();
2747         $fi->{Digester}->addfile(*F);
2748         F->error and confess "$!";
2749         $got = $fi->{Digester}->hexdigest();
2750         return $got eq $fi->{Hash};
2751     };
2752
2753     if (stat_exists $tf) {
2754         if ($checkhash->()) {
2755             progress f_ "using existing %s", $f;
2756             return 1;
2757         }
2758         if (!$refetched) {
2759             fail f_ "file %s has hash %s but .dsc demands hash %s".
2760                     " (perhaps you should delete this file?)",
2761                     $f, $got, $fi->{Hash};
2762         }
2763         progress f_ "need to fetch correct version of %s", $f;
2764         unlink $tf or die "$tf $!";
2765         $$refetched = 1;
2766     } else {
2767         printdebug "$tf does not exist, need to fetch\n";
2768     }
2769
2770     my $furl = $dscurl;
2771     $furl =~ s{/[^/]+$}{};
2772     $furl .= "/$f";
2773     die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2774     die "$f ?" if $f =~ m#/#;
2775     runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2776     return 0 if !act_local();
2777
2778     $checkhash->() or
2779         fail f_ "file %s has hash %s but .dsc demands hash %s".
2780                 " (got wrong file from archive!)",
2781                 $f, $got, $fi->{Hash};
2782
2783     return 1;
2784 }
2785
2786 sub ensure_we_have_orig () {
2787     my @dfi = dsc_files_info();
2788     foreach my $fi (@dfi) {
2789         my $f = $fi->{Filename};
2790         next unless is_orig_file_in_dsc($f, \@dfi);
2791         complete_file_from_dsc($buildproductsdir, $fi)
2792             or next;
2793     }
2794 }
2795
2796 #---------- git fetch ----------
2797
2798 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2799 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2800
2801 # We fetch some parts of lrfetchrefs/*.  Ideally we delete these
2802 # locally fetched refs because they have unhelpful names and clutter
2803 # up gitk etc.  So we track whether we have "used up" head ref (ie,
2804 # whether we have made another local ref which refers to this object).
2805 #
2806 # (If we deleted them unconditionally, then we might end up
2807 # re-fetching the same git objects each time dgit fetch was run.)
2808 #
2809 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2810 # in git_fetch_us to fetch the refs in question, and possibly a call
2811 # to lrfetchref_used.
2812
2813 our (%lrfetchrefs_f, %lrfetchrefs_d);
2814 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2815
2816 sub lrfetchref_used ($) {
2817     my ($fullrefname) = @_;
2818     my $objid = $lrfetchrefs_f{$fullrefname};
2819     $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2820 }
2821
2822 sub git_lrfetch_sane {
2823     my ($url, $supplementary, @specs) = @_;
2824     # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2825     # at least as regards @specs.  Also leave the results in
2826     # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2827     # able to clean these up.
2828     #
2829     # With $supplementary==1, @specs must not contain wildcards
2830     # and we add to our previous fetches (non-atomically).
2831
2832     # This is rather miserable:
2833     # When git fetch --prune is passed a fetchspec ending with a *,
2834     # it does a plausible thing.  If there is no * then:
2835     # - it matches subpaths too, even if the supplied refspec
2836     #   starts refs, and behaves completely madly if the source
2837     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2838     # - if there is no matching remote ref, it bombs out the whole
2839     #   fetch.
2840     # We want to fetch a fixed ref, and we don't know in advance
2841     # if it exists, so this is not suitable.
2842     #
2843     # Our workaround is to use git ls-remote.  git ls-remote has its
2844     # own qairks.  Notably, it has the absurd multi-tail-matching
2845     # behaviour: git ls-remote R refs/foo can report refs/foo AND
2846     # refs/refs/foo etc.
2847     #
2848     # Also, we want an idempotent snapshot, but we have to make two
2849     # calls to the remote: one to git ls-remote and to git fetch.  The
2850     # solution is use git ls-remote to obtain a target state, and
2851     # git fetch to try to generate it.  If we don't manage to generate
2852     # the target state, we try again.
2853
2854     printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2855
2856     my $specre = join '|', map {
2857         my $x = $_;
2858         $x =~ s/\W/\\$&/g;
2859         my $wildcard = $x =~ s/\\\*$/.*/;
2860         die if $wildcard && $supplementary;
2861         "(?:refs/$x)";
2862     } @specs;
2863     printdebug "git_lrfetch_sane specre=$specre\n";
2864     my $wanted_rref = sub {
2865         local ($_) = @_;
2866         return m/^(?:$specre)$/;
2867     };
2868
2869     my $fetch_iteration = 0;
2870     FETCH_ITERATION:
2871     for (;;) {
2872         printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2873         if (++$fetch_iteration > 10) {
2874             fail __ "too many iterations trying to get sane fetch!";
2875         }
2876
2877         my @look = map { "refs/$_" } @specs;
2878         my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2879         debugcmd "|",@lcmd;
2880
2881         my %wantr;
2882         open GITLS, "-|", @lcmd or confess "$!";
2883         while (<GITLS>) {
2884             printdebug "=> ", $_;
2885             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2886             my ($objid,$rrefname) = ($1,$2);
2887             if (!$wanted_rref->($rrefname)) {
2888                 print STDERR f_ <<END, "@look", $rrefname;
2889 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2890 END
2891                 next;
2892             }
2893             $wantr{$rrefname} = $objid;
2894         }
2895         $!=0; $?=0;
2896         close GITLS or failedcmd @lcmd;
2897
2898         # OK, now %want is exactly what we want for refs in @specs
2899         my @fspecs = map {
2900             !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2901             "+refs/$_:".lrfetchrefs."/$_";
2902         } @specs;
2903
2904         printdebug "git_lrfetch_sane fspecs @fspecs\n";
2905
2906         my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2907         runcmd_ordryrun_local @fcmd if @fspecs;
2908
2909         if (!$supplementary) {
2910             %lrfetchrefs_f = ();
2911         }
2912         my %objgot;
2913
2914         git_for_each_ref(lrfetchrefs, sub {
2915             my ($objid,$objtype,$lrefname,$reftail) = @_;
2916             $lrfetchrefs_f{$lrefname} = $objid;
2917             $objgot{$objid} = 1;
2918         });
2919
2920         if ($supplementary) {
2921             last;
2922         }
2923
2924         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2925             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2926             if (!exists $wantr{$rrefname}) {
2927                 if ($wanted_rref->($rrefname)) {
2928                     printdebug <<END;
2929 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2930 END
2931                 } else {
2932                     print STDERR f_ <<END, "@fspecs", $lrefname
2933 warning: git fetch %s created %s; this is silly, deleting it.
2934 END
2935                 }
2936                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2937                 delete $lrfetchrefs_f{$lrefname};
2938                 next;
2939             }
2940         }
2941         foreach my $rrefname (sort keys %wantr) {
2942             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2943             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2944             my $want = $wantr{$rrefname};
2945             next if $got eq $want;
2946             if (!defined $objgot{$want}) {
2947                 fail __ <<END unless act_local();
2948 --dry-run specified but we actually wanted the results of git fetch,
2949 so this is not going to work.  Try running dgit fetch first,
2950 or using --damp-run instead of --dry-run.
2951 END
2952                 print STDERR f_ <<END, $lrefname, $want;
2953 warning: git ls-remote suggests we want %s
2954 warning:  and it should refer to %s
2955 warning:  but git fetch didn't fetch that object to any relevant ref.
2956 warning:  This may be due to a race with someone updating the server.
2957 warning:  Will try again...
2958 END
2959                 next FETCH_ITERATION;
2960             }
2961             printdebug <<END;
2962 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2963 END
2964             runcmd_ordryrun_local @git, qw(update-ref -m),
2965                 "dgit fetch git fetch fixup", $lrefname, $want;
2966             $lrfetchrefs_f{$lrefname} = $want;
2967         }
2968         last;
2969     }
2970
2971     if (defined $csuite) {
2972         printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2973         git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2974             my ($objid,$objtype,$lrefname,$reftail) = @_;
2975             next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2976             runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2977         });
2978     }
2979
2980     printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2981         Dumper(\%lrfetchrefs_f);
2982 }
2983
2984 sub git_fetch_us () {
2985     # Want to fetch only what we are going to use, unless
2986     # deliberately-not-ff, in which case we must fetch everything.
2987
2988     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2989         map { "tags/$_" } debiantags('*',access_nomdistro);
2990     push @specs, server_branch($csuite);
2991     push @specs, $rewritemap;
2992     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2993
2994     my $url = access_giturl();
2995     git_lrfetch_sane $url, 0, @specs;
2996
2997     my %here;
2998     my @tagpats = debiantags('*',access_nomdistro);
2999
3000     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
3001         my ($objid,$objtype,$fullrefname,$reftail) = @_;
3002         printdebug "currently $fullrefname=$objid\n";
3003         $here{$fullrefname} = $objid;
3004     });
3005     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
3006         my ($objid,$objtype,$fullrefname,$reftail) = @_;
3007         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
3008         printdebug "offered $lref=$objid\n";
3009         if (!defined $here{$lref}) {
3010             my @upd = (@git, qw(update-ref), $lref, $objid, '');
3011             runcmd_ordryrun_local @upd;
3012             lrfetchref_used $fullrefname;
3013         } elsif ($here{$lref} eq $objid) {
3014             lrfetchref_used $fullrefname;
3015         } else {
3016             print STDERR f_ "Not updating %s from %s to %s.\n",
3017                             $lref, $here{$lref}, $objid;
3018         }
3019     });
3020 }
3021
3022 #---------- dsc and archive handling ----------
3023
3024 sub mergeinfo_getclogp ($) {
3025     # Ensures thit $mi->{Clogp} exists and returns it
3026     my ($mi) = @_;
3027     $mi->{Clogp} = commit_getclogp($mi->{Commit});
3028 }
3029
3030 sub mergeinfo_version ($) {
3031     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
3032 }
3033
3034 sub fetch_from_archive_record_1 ($) {
3035     my ($hash) = @_;
3036     runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
3037     cmdoutput @git, qw(log -n2), $hash;
3038     # ... gives git a chance to complain if our commit is malformed
3039 }
3040
3041 sub fetch_from_archive_record_2 ($) {
3042     my ($hash) = @_;
3043     my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
3044     if (act_local()) {
3045         cmdoutput @upd_cmd;
3046     } else {
3047         dryrun_report @upd_cmd;
3048     }
3049 }
3050
3051 sub parse_dsc_field_def_dsc_distro () {
3052     $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
3053                            dgit.default.distro);
3054 }
3055
3056 sub parse_dsc_field ($$) {
3057     my ($dsc, $what) = @_;
3058     my $f;
3059     foreach my $field (@ourdscfield) {
3060         $f = $dsc->{$field};
3061         last if defined $f;
3062     }
3063
3064     if (!defined $f) {
3065         progress f_ "%s: NO git hash", $what;
3066         parse_dsc_field_def_dsc_distro();
3067     } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3068              = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3069         progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3070         $dsc_hint_tag = [ $dsc_hint_tag ];
3071     } elsif ($f =~ m/^\w+\s*$/) {
3072         $dsc_hash = $&;
3073         parse_dsc_field_def_dsc_distro();
3074         $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3075                           $dsc_distro ];
3076         progress f_ "%s: specified git hash", $what;
3077     } else {
3078         fail f_ "%s: invalid Dgit info", $what;
3079     }
3080 }
3081
3082 sub resolve_dsc_field_commit ($$) {
3083     my ($already_distro, $already_mapref) = @_;
3084
3085     return unless defined $dsc_hash;
3086
3087     my $mapref =
3088         defined $already_mapref &&
3089         ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3090         ? $already_mapref : undef;
3091
3092     my $do_fetch;
3093     $do_fetch = sub {
3094         my ($what, @fetch) = @_;
3095
3096         local $idistro = $dsc_distro;
3097         my $lrf = lrfetchrefs;
3098
3099         if (!$chase_dsc_distro) {
3100             progress f_ "not chasing .dsc distro %s: not fetching %s",
3101                         $dsc_distro, $what;
3102             return 0;
3103         }
3104
3105         progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3106
3107         my $url = access_giturl();
3108         if (!defined $url) {
3109             defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3110 .dsc Dgit metadata is in context of distro %s
3111 for which we have no configured url and .dsc provides no hint
3112 END
3113             my $proto =
3114                 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3115                 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3116             parse_cfg_bool "dsc-url-proto-ok", 'false',
3117                 cfg("dgit.dsc-url-proto-ok.$proto",
3118                     "dgit.default.dsc-url-proto-ok")
3119                 or fail f_ <<END, $dsc_distro, $proto;
3120 .dsc Dgit metadata is in context of distro %s
3121 for which we have no configured url;
3122 .dsc provides hinted url with protocol %s which is unsafe.
3123 (can be overridden by config - consult documentation)
3124 END
3125             $url = $dsc_hint_url;
3126         }
3127
3128         git_lrfetch_sane $url, 1, @fetch;
3129
3130         return $lrf;
3131     };
3132
3133     my $rewrite_enable = do {
3134         local $idistro = $dsc_distro;
3135         access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3136     };
3137
3138     if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3139         if (!defined $mapref) {
3140             my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3141             $mapref = $lrf.'/'.$rewritemap;
3142         }
3143         my $rewritemapdata = git_cat_file $mapref.':map';
3144         if (defined $rewritemapdata
3145             && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3146             progress __
3147                 "server's git history rewrite map contains a relevant entry!";
3148
3149             $dsc_hash = $1;
3150             if (defined $dsc_hash) {
3151                 progress __ "using rewritten git hash in place of .dsc value";
3152             } else {
3153                 progress __ "server data says .dsc hash is to be disregarded";
3154             }
3155         }
3156     }
3157
3158     if (!defined git_cat_file $dsc_hash) {
3159         my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3160         my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3161             defined git_cat_file $dsc_hash
3162             or fail f_ <<END, $dsc_hash;
3163 .dsc Dgit metadata requires commit %s
3164 but we could not obtain that object anywhere.
3165 END
3166         foreach my $t (@tags) {
3167             my $fullrefname = $lrf.'/'.$t;
3168 #           print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3169             next unless $lrfetchrefs_f{$fullrefname};
3170             next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3171             lrfetchref_used $fullrefname;
3172         }
3173     }
3174 }
3175
3176 sub fetch_from_archive () {
3177     check_bpd_exists();
3178     ensure_setup_existing_tree();
3179
3180     # Ensures that lrref() is what is actually in the archive, one way
3181     # or another, according to us - ie this client's
3182     # appropritaely-updated archive view.  Also returns the commit id.
3183     # If there is nothing in the archive, leaves lrref alone and
3184     # returns undef.  git_fetch_us must have already been called.
3185     get_archive_dsc();
3186
3187     if ($dsc) {
3188         parse_dsc_field($dsc, __ 'last upload to archive');
3189         resolve_dsc_field_commit access_basedistro,
3190             lrfetchrefs."/".$rewritemap
3191     } else {
3192         progress __ "no version available from the archive";
3193     }
3194
3195     # If the archive's .dsc has a Dgit field, there are three
3196     # relevant git commitids we need to choose between and/or merge
3197     # together:
3198     #   1. $dsc_hash: the Dgit field from the archive
3199     #   2. $lastpush_hash: the suite branch on the dgit git server
3200     #   3. $lastfetch_hash: our local tracking brach for the suite
3201     #
3202     # These may all be distinct and need not be in any fast forward
3203     # relationship:
3204     #
3205     # If the dsc was pushed to this suite, then the server suite
3206     # branch will have been updated; but it might have been pushed to
3207     # a different suite and copied by the archive.  Conversely a more
3208     # recent version may have been pushed with dgit but not appeared
3209     # in the archive (yet).
3210     #
3211     # $lastfetch_hash may be awkward because archive imports
3212     # (particularly, imports of Dgit-less .dscs) are performed only as
3213     # needed on individual clients, so different clients may perform a
3214     # different subset of them - and these imports are only made
3215     # public during push.  So $lastfetch_hash may represent a set of
3216     # imports different to a subsequent upload by a different dgit
3217     # client.
3218     #
3219     # Our approach is as follows:
3220     #
3221     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3222     # descendant of $dsc_hash, then it was pushed by a dgit user who
3223     # had based their work on $dsc_hash, so we should prefer it.
3224     # Otherwise, $dsc_hash was installed into this suite in the
3225     # archive other than by a dgit push, and (necessarily) after the
3226     # last dgit push into that suite (since a dgit push would have
3227     # been descended from the dgit server git branch); thus, in that
3228     # case, we prefer the archive's version (and produce a
3229     # pseudo-merge to overwrite the dgit server git branch).
3230     #
3231     # (If there is no Dgit field in the archive's .dsc then
3232     # generate_commit_from_dsc uses the version numbers to decide
3233     # whether the suite branch or the archive is newer.  If the suite
3234     # branch is newer it ignores the archive's .dsc; otherwise it
3235     # generates an import of the .dsc, and produces a pseudo-merge to
3236     # overwrite the suite branch with the archive contents.)
3237     #
3238     # The outcome of that part of the algorithm is the `public view',
3239     # and is same for all dgit clients: it does not depend on any
3240     # unpublished history in the local tracking branch.
3241     #
3242     # As between the public view and the local tracking branch: The
3243     # local tracking branch is only updated by dgit fetch, and
3244     # whenever dgit fetch runs it includes the public view in the
3245     # local tracking branch.  Therefore if the public view is not
3246     # descended from the local tracking branch, the local tracking
3247     # branch must contain history which was imported from the archive
3248     # but never pushed; and, its tip is now out of date.  So, we make
3249     # a pseudo-merge to overwrite the old imports and stitch the old
3250     # history in.
3251     #
3252     # Finally: we do not necessarily reify the public view (as
3253     # described above).  This is so that we do not end up stacking two
3254     # pseudo-merges.  So what we actually do is figure out the inputs
3255     # to any public view pseudo-merge and put them in @mergeinputs.
3256
3257     my @mergeinputs;
3258     # $mergeinputs[]{Commit}
3259     # $mergeinputs[]{Info}
3260     # $mergeinputs[0] is the one whose tree we use
3261     # @mergeinputs is in the order we use in the actual commit)
3262     #
3263     # Also:
3264     # $mergeinputs[]{Message} is a commit message to use
3265     # $mergeinputs[]{ReverseParents} if def specifies that parent
3266     #                                list should be in opposite order
3267     # Such an entry has no Commit or Info.  It applies only when found
3268     # in the last entry.  (This ugliness is to support making
3269     # identical imports to previous dgit versions.)
3270
3271     my $lastpush_hash = git_get_ref(lrfetchref());
3272     printdebug "previous reference hash=$lastpush_hash\n";
3273     $lastpush_mergeinput = $lastpush_hash && {
3274         Commit => $lastpush_hash,
3275         Info => (__ "dgit suite branch on dgit git server"),
3276     };
3277
3278     my $lastfetch_hash = git_get_ref(lrref());
3279     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3280     my $lastfetch_mergeinput = $lastfetch_hash && {
3281         Commit => $lastfetch_hash,
3282         Info => (__ "dgit client's archive history view"),
3283     };
3284
3285     my $dsc_mergeinput = $dsc_hash && {
3286         Commit => $dsc_hash,
3287         Info => (__ "Dgit field in .dsc from archive"),
3288     };
3289
3290     my $cwd = getcwd();
3291     my $del_lrfetchrefs = sub {
3292         changedir $cwd;
3293         my $gur;
3294         printdebug "del_lrfetchrefs...\n";
3295         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3296             my $objid = $lrfetchrefs_d{$fullrefname};
3297             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3298             if (!$gur) {
3299                 $gur ||= new IO::Handle;
3300                 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3301             }
3302             printf $gur "delete %s %s\n", $fullrefname, $objid;
3303         }
3304         if ($gur) {
3305             close $gur or failedcmd "git update-ref delete lrfetchrefs";
3306         }
3307     };
3308
3309     if (defined $dsc_hash) {
3310         ensure_we_have_orig();
3311         if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3312             @mergeinputs = $dsc_mergeinput
3313         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3314             print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3315
3316 Git commit in archive is behind the last version allegedly pushed/uploaded.
3317 Commit referred to by archive: %s
3318 Last version pushed with dgit: %s
3319 %s
3320 END
3321                 __ $later_warning_msg or confess "$!";
3322             @mergeinputs = ($lastpush_mergeinput);
3323         } else {
3324             # Archive has .dsc which is not a descendant of the last dgit
3325             # push.  This can happen if the archive moves .dscs about.
3326             # Just follow its lead.
3327             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3328                 progress __ "archive .dsc names newer git commit";
3329                 @mergeinputs = ($dsc_mergeinput);
3330             } else {
3331                 progress __ "archive .dsc names other git commit, fixing up";
3332                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3333             }
3334         }
3335     } elsif ($dsc) {
3336         @mergeinputs = generate_commits_from_dsc();
3337         # We have just done an import.  Now, our import algorithm might
3338         # have been improved.  But even so we do not want to generate
3339         # a new different import of the same package.  So if the
3340         # version numbers are the same, just use our existing version.
3341         # If the version numbers are different, the archive has changed
3342         # (perhaps, rewound).
3343         if ($lastfetch_mergeinput &&
3344             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3345                               (mergeinfo_version $mergeinputs[0]) )) {
3346             @mergeinputs = ($lastfetch_mergeinput);
3347         }
3348     } elsif ($lastpush_hash) {
3349         # only in git, not in the archive yet
3350         @mergeinputs = ($lastpush_mergeinput);
3351         print STDERR f_ <<END,
3352
3353 Package not found in the archive, but has allegedly been pushed using dgit.
3354 %s
3355 END
3356             __ $later_warning_msg or confess "$!";
3357     } else {
3358         printdebug "nothing found!\n";
3359         if (defined $skew_warning_vsn) {
3360             print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3361
3362 Warning: relevant archive skew detected.
3363 Archive allegedly contains %s
3364 But we were not able to obtain any version from the archive or git.
3365
3366 END
3367         }
3368         unshift @end, $del_lrfetchrefs;
3369         return undef;
3370     }
3371
3372     if ($lastfetch_hash &&
3373         !grep {
3374             my $h = $_->{Commit};
3375             $h and is_fast_fwd($lastfetch_hash, $h);
3376             # If true, one of the existing parents of this commit
3377             # is a descendant of the $lastfetch_hash, so we'll
3378             # be ff from that automatically.
3379         } @mergeinputs
3380         ) {
3381         # Otherwise:
3382         push @mergeinputs, $lastfetch_mergeinput;
3383     }
3384
3385     printdebug "fetch mergeinfos:\n";
3386     foreach my $mi (@mergeinputs) {
3387         if ($mi->{Info}) {
3388             printdebug " commit $mi->{Commit} $mi->{Info}\n";
3389         } else {
3390             printdebug sprintf " ReverseParents=%d Message=%s",
3391                 $mi->{ReverseParents}, $mi->{Message};
3392         }
3393     }
3394
3395     my $compat_info= pop @mergeinputs
3396         if $mergeinputs[$#mergeinputs]{Message};
3397
3398     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3399
3400     my $hash;
3401     if (@mergeinputs > 1) {
3402         # here we go, then:
3403         my $tree_commit = $mergeinputs[0]{Commit};
3404
3405         my $tree = get_tree_of_commit $tree_commit;;
3406
3407         # We use the changelog author of the package in question the
3408         # author of this pseudo-merge.  This is (roughly) correct if
3409         # this commit is simply representing aa non-dgit upload.
3410         # (Roughly because it does not record sponsorship - but we
3411         # don't have sponsorship info because that's in the .changes,
3412         # which isn't in the archivw.)
3413         #
3414         # But, it might be that we are representing archive history
3415         # updates (including in-archive copies).  These are not really
3416         # the responsibility of the person who created the .dsc, but
3417         # there is no-one whose name we should better use.  (The
3418         # author of the .dsc-named commit is clearly worse.)
3419
3420         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3421         my $author = clogp_authline $useclogp;
3422         my $cversion = getfield $useclogp, 'Version';
3423
3424         my $mcf = dgit_privdir()."/mergecommit";
3425         open MC, ">", $mcf or die "$mcf $!";
3426         print MC <<END or confess "$!";
3427 tree $tree
3428 END
3429
3430         my @parents = grep { $_->{Commit} } @mergeinputs;
3431         @parents = reverse @parents if $compat_info->{ReverseParents};
3432         print MC <<END or confess "$!" foreach @parents;
3433 parent $_->{Commit}
3434 END
3435
3436         print MC <<END or confess "$!";
3437 author $author
3438 committer $author
3439
3440 END
3441
3442         if (defined $compat_info->{Message}) {
3443             print MC $compat_info->{Message} or confess "$!";
3444         } else {
3445             print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3446 Record %s (%s) in archive suite %s
3447
3448 Record that
3449 END
3450             my $message_add_info = sub {
3451                 my ($mi) = (@_);
3452                 my $mversion = mergeinfo_version $mi;
3453                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
3454                     or confess "$!";
3455             };
3456
3457             $message_add_info->($mergeinputs[0]);
3458             print MC __ <<END or confess "$!";
3459 should be treated as descended from
3460 END
3461             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3462         }
3463
3464         close MC or confess "$!";
3465         $hash = hash_commit $mcf;
3466     } else {
3467         $hash = $mergeinputs[0]{Commit};
3468     }
3469     printdebug "fetch hash=$hash\n";
3470
3471     my $chkff = sub {
3472         my ($lasth, $what) = @_;
3473         return unless $lasth;
3474         confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3475     };
3476
3477     $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3478         if $lastpush_hash;
3479     $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3480
3481     fetch_from_archive_record_1($hash);
3482
3483     if (defined $skew_warning_vsn) {
3484         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3485         my $gotclogp = commit_getclogp($hash);
3486         my $got_vsn = getfield $gotclogp, 'Version';
3487         printdebug "SKEW CHECK GOT $got_vsn\n";
3488         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3489             print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3490
3491 Warning: archive skew detected.  Using the available version:
3492 Archive allegedly contains    %s
3493 We were able to obtain only   %s
3494
3495 END
3496         }
3497     }
3498
3499     if ($lastfetch_hash ne $hash) {
3500         fetch_from_archive_record_2($hash);
3501     }
3502
3503     lrfetchref_used lrfetchref();
3504
3505     check_gitattrs($hash, __ "fetched source tree");
3506
3507     unshift @end, $del_lrfetchrefs;
3508     return $hash;
3509 }
3510
3511 sub set_local_git_config ($$) {
3512     my ($k, $v) = @_;
3513     runcmd @git, qw(config), $k, $v;
3514 }
3515
3516 sub setup_mergechangelogs (;$) {
3517     my ($always) = @_;
3518     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3519
3520     my $driver = 'dpkg-mergechangelogs';
3521     my $cb = "merge.$driver";
3522     confess unless defined $maindir;
3523     my $attrs = "$maindir_gitcommon/info/attributes";
3524     ensuredir "$maindir_gitcommon/info";
3525
3526     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3527     if (!open ATTRS, "<", $attrs) {
3528         $!==ENOENT or die "$attrs: $!";
3529     } else {
3530         while (<ATTRS>) {
3531             chomp;
3532             next if m{^debian/changelog\s};
3533             print NATTRS $_, "\n" or confess "$!";
3534         }
3535         ATTRS->error and confess "$!";
3536         close ATTRS;
3537     }
3538     print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3539     close NATTRS;
3540
3541     set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3542     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3543
3544     rename "$attrs.new", "$attrs" or die "$attrs: $!";
3545 }
3546
3547 sub setup_useremail (;$) {
3548     my ($always) = @_;
3549     return unless $always || access_cfg_bool(1, 'setup-useremail');
3550
3551     my $setup = sub {
3552         my ($k, $envvar) = @_;
3553         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3554         return unless defined $v;
3555         set_local_git_config "user.$k", $v;
3556     };
3557
3558     $setup->('email', 'DEBEMAIL');
3559     $setup->('name', 'DEBFULLNAME');
3560 }
3561
3562 sub ensure_setup_existing_tree () {
3563     my $k = "remote.$remotename.skipdefaultupdate";
3564     my $c = git_get_config $k;
3565     return if defined $c;
3566     set_local_git_config $k, 'true';
3567 }
3568
3569 sub open_main_gitattrs () {
3570     confess 'internal error no maindir' unless defined $maindir;
3571     my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3572         or $!==ENOENT
3573         or die "open $maindir_gitcommon/info/attributes: $!";
3574     return $gai;
3575 }
3576
3577 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3578
3579 sub is_gitattrs_setup () {
3580     # return values:
3581     #  trueish
3582     #     1: gitattributes set up and should be left alone
3583     #  falseish
3584     #     0: there is a dgit-defuse-attrs but it needs fixing
3585     #     undef: there is none
3586     my $gai = open_main_gitattrs();
3587     return 0 unless $gai;
3588     while (<$gai>) {
3589         next unless m{$gitattrs_ourmacro_re};
3590         return 1 if m{\s-working-tree-encoding\s};
3591         printdebug "is_gitattrs_setup: found old macro\n";
3592         return 0;
3593     }
3594     $gai->error and confess "$!";
3595     printdebug "is_gitattrs_setup: found nothing\n";
3596     return undef;
3597 }
3598
3599 sub setup_gitattrs (;$) {
3600     my ($always) = @_;
3601     return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3602
3603     my $already = is_gitattrs_setup();
3604     if ($already) {
3605         progress __ <<END;
3606 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3607  not doing further gitattributes setup
3608 END
3609         return;
3610     }
3611     my $new = "[attr]dgit-defuse-attrs  $negate_harmful_gitattrs";
3612     my $af = "$maindir_gitcommon/info/attributes";
3613     ensuredir "$maindir_gitcommon/info";
3614
3615     open GAO, "> $af.new" or confess "$!";
3616     print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3617 *       dgit-defuse-attrs
3618 $new
3619 END
3620 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3621 ENDT
3622     my $gai = open_main_gitattrs();
3623     if ($gai) {
3624         while (<$gai>) {
3625             if (m{$gitattrs_ourmacro_re}) {
3626                 die unless defined $already;
3627                 $_ = $new;
3628             }
3629             chomp;
3630             print GAO $_, "\n" or confess "$!";
3631         }
3632         $gai->error and confess "$!";
3633     }
3634     close GAO or confess "$!";
3635     rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3636 }
3637
3638 sub setup_new_tree () {
3639     setup_mergechangelogs();
3640     setup_useremail();
3641     setup_gitattrs();
3642 }
3643
3644 sub check_gitattrs ($$) {
3645     my ($treeish, $what) = @_;
3646
3647     return if is_gitattrs_setup;
3648
3649     local $/="\0";
3650     my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3651     debugcmd "|",@cmd;
3652     my $gafl = new IO::File;
3653     open $gafl, "-|", @cmd or confess "$!";
3654     while (<$gafl>) {
3655         chomp or die;
3656         s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3657         next if $1 == 0;
3658         next unless m{(?:^|/)\.gitattributes$};
3659
3660         # oh dear, found one
3661         print STDERR f_ <<END, $what;
3662 dgit: warning: %s contains .gitattributes
3663 dgit: .gitattributes not (fully) defused.  Recommended: dgit setup-new-tree.
3664 END
3665         close $gafl;
3666         return;
3667     }
3668     # tree contains no .gitattributes files
3669     $?=0; $!=0; close $gafl or failedcmd @cmd;
3670 }
3671
3672
3673 sub multisuite_suite_child ($$$) {
3674     my ($tsuite, $mergeinputs, $fn) = @_;
3675     # in child, sets things up, calls $fn->(), and returns undef
3676     # in parent, returns canonical suite name for $tsuite
3677     my $canonsuitefh = IO::File::new_tmpfile;
3678     my $pid = fork // confess "$!";
3679     if (!$pid) {
3680         forkcheck_setup();
3681         $isuite = $tsuite;
3682         $us .= " [$isuite]";
3683         $debugprefix .= " ";
3684         progress f_ "fetching %s...", $tsuite;
3685         canonicalise_suite();
3686         print $canonsuitefh $csuite, "\n" or confess "$!";
3687         close $canonsuitefh or confess "$!";
3688         $fn->();
3689         return undef;
3690     }
3691     waitpid $pid,0 == $pid or confess "$!";
3692     fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3693         if $? && $?!=256*4;
3694     seek $canonsuitefh,0,0 or confess "$!";
3695     local $csuite = <$canonsuitefh>;
3696     confess "$!" unless defined $csuite && chomp $csuite;
3697     if ($? == 256*4) {
3698         printdebug "multisuite $tsuite missing\n";
3699         return $csuite;
3700     }
3701     printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3702     push @$mergeinputs, {
3703         Ref => lrref,
3704         Info => $csuite,
3705     };
3706     return $csuite;
3707 }
3708
3709 sub fork_for_multisuite ($) {
3710     my ($before_fetch_merge) = @_;
3711     # if nothing unusual, just returns ''
3712     #
3713     # if multisuite:
3714     # returns 0 to caller in child, to do first of the specified suites
3715     # in child, $csuite is not yet set
3716     #
3717     # returns 1 to caller in parent, to finish up anything needed after
3718     # in parent, $csuite is set to canonicalised portmanteau
3719
3720     my $org_isuite = $isuite;
3721     my @suites = split /\,/, $isuite;
3722     return '' unless @suites > 1;
3723     printdebug "fork_for_multisuite: @suites\n";
3724
3725     my @mergeinputs;
3726
3727     my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3728                                             sub { });
3729     return 0 unless defined $cbasesuite;
3730
3731     fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3732         unless @mergeinputs;
3733
3734     my @csuites = ($cbasesuite);
3735
3736     $before_fetch_merge->();
3737
3738     foreach my $tsuite (@suites[1..$#suites]) {
3739         $tsuite =~ s/^-/$cbasesuite-/;
3740         my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3741                                                sub {
3742             @end = ();
3743             fetch_one();
3744             finish 0;
3745         });
3746
3747         $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3748         push @csuites, $csubsuite;
3749     }
3750
3751     foreach my $mi (@mergeinputs) {
3752         my $ref = git_get_ref $mi->{Ref};
3753         die "$mi->{Ref} ?" unless length $ref;
3754         $mi->{Commit} = $ref;
3755     }
3756
3757     $csuite = join ",", @csuites;
3758
3759     my $previous = git_get_ref lrref;
3760     if ($previous) {
3761         unshift @mergeinputs, {
3762             Commit => $previous,
3763             Info => (__ "local combined tracking branch"),
3764             Warning => (__
3765  "archive seems to have rewound: local tracking branch is ahead!"),
3766         };
3767     }
3768
3769     foreach my $ix (0..$#mergeinputs) {
3770         $mergeinputs[$ix]{Index} = $ix;
3771     }
3772
3773     @mergeinputs = sort {
3774         -version_compare(mergeinfo_version $a,
3775                          mergeinfo_version $b) # highest version first
3776             or
3777         $a->{Index} <=> $b->{Index}; # earliest in spec first
3778     } @mergeinputs;
3779
3780     my @needed;
3781
3782   NEEDED:
3783     foreach my $mi (@mergeinputs) {
3784         printdebug "multisuite merge check $mi->{Info}\n";
3785         foreach my $previous (@needed) {
3786             next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3787             printdebug "multisuite merge un-needed $previous->{Info}\n";
3788             next NEEDED;
3789         }
3790         push @needed, $mi;
3791         printdebug "multisuite merge this-needed\n";
3792         $mi->{Character} = '+';
3793     }
3794
3795     $needed[0]{Character} = '*';
3796
3797     my $output = $needed[0]{Commit};
3798
3799     if (@needed > 1) {
3800         printdebug "multisuite merge nontrivial\n";
3801         my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3802
3803         my $commit = "tree $tree\n";
3804         my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3805                      "Input branches:\n",
3806                      $csuite;
3807
3808         foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3809             printdebug "multisuite merge include $mi->{Info}\n";
3810             $mi->{Character} //= ' ';
3811             $commit .= "parent $mi->{Commit}\n";
3812             $msg .= sprintf " %s  %-25s %s\n",
3813                 $mi->{Character},
3814                 (mergeinfo_version $mi),
3815                 $mi->{Info};
3816         }
3817         my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3818         $msg .= __ "\nKey\n".
3819             " * marks the highest version branch, which choose to use\n".
3820             " + marks each branch which was not already an ancestor\n\n";
3821         $msg .=
3822             "[dgit multi-suite $csuite]\n";
3823         $commit .=
3824             "author $authline\n".
3825             "committer $authline\n\n";
3826         $output = hash_commit_text $commit.$msg;
3827         printdebug "multisuite merge generated $output\n";
3828     }
3829
3830     fetch_from_archive_record_1($output);
3831     fetch_from_archive_record_2($output);
3832
3833     progress f_ "calculated combined tracking suite %s", $csuite;
3834
3835     return 1;
3836 }
3837
3838 sub clone_set_head () {
3839     open H, "> .git/HEAD" or confess "$!";
3840     print H "ref: ".lref()."\n" or confess "$!";
3841     close H or confess "$!";
3842 }
3843 sub clone_finish ($) {
3844     my ($dstdir) = @_;
3845     runcmd @git, qw(reset --hard), lrref();
3846     runcmd qw(bash -ec), <<'END';
3847         set -o pipefail
3848         git ls-tree -r --name-only -z HEAD | \
3849         xargs -0r touch -h -r . --
3850 END
3851     printdone f_ "ready for work in %s", $dstdir;
3852 }
3853
3854 sub clone ($) {
3855     # in multisuite, returns twice!
3856     # once in parent after first suite fetched,
3857     # and then again in child after everything is finished
3858     my ($dstdir) = @_;
3859     badusage __ "dry run makes no sense with clone" unless act_local();
3860
3861     my $multi_fetched = fork_for_multisuite(sub {
3862         printdebug "multi clone before fetch merge\n";
3863         changedir $dstdir;
3864         record_maindir();
3865     });
3866     if ($multi_fetched) {
3867         printdebug "multi clone after fetch merge\n";
3868         clone_set_head();
3869         clone_finish($dstdir);
3870         return;
3871     }
3872     printdebug "clone main body\n";
3873
3874     mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3875     changedir $dstdir;
3876     check_bpd_exists();
3877
3878     canonicalise_suite();
3879     my $hasgit = check_for_git();
3880
3881     runcmd @git, qw(init -q);
3882     record_maindir();
3883     setup_new_tree();
3884     clone_set_head();
3885     my $giturl = access_giturl(1);
3886     if (defined $giturl) {
3887         runcmd @git, qw(remote add), 'origin', $giturl;
3888     }
3889     if ($hasgit) {
3890         progress __ "fetching existing git history";
3891         git_fetch_us();
3892         runcmd_ordryrun_local @git, qw(fetch origin);
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 @cmd = archive_api_query_cmd($subpath);
7349     push @cmd, qw(-f);
7350     debugcmd ">",@cmd;
7351     exec @cmd or fail f_ "exec curl: %s\n", $!;
7352 }
7353
7354 sub repos_server_url () {
7355     $package = '_dgit-repos-server';
7356     local $access_forpush = 1;
7357     local $isuite = 'DGIT-REPOS-SERVER';
7358     my $url = access_giturl();
7359 }
7360
7361 sub pre_clone_dgit_repos_server () {
7362     not_necessarily_a_tree();
7363 }
7364 sub cmd_clone_dgit_repos_server {
7365     badusage __ "need destination argument" unless @ARGV==1;
7366     my ($destdir) = @ARGV;
7367     my $url = repos_server_url();
7368     my @cmd = (@git, qw(clone), $url, $destdir);
7369     debugcmd ">",@cmd;
7370     exec @cmd or fail f_ "exec git clone: %s\n", $!;
7371 }
7372
7373 sub pre_print_dgit_repos_server_source_url () {
7374     not_necessarily_a_tree();
7375 }
7376 sub cmd_print_dgit_repos_server_source_url {
7377     badusage __
7378         "no arguments allowed to dgit print-dgit-repos-server-source-url"
7379         if @ARGV;
7380     my $url = repos_server_url();
7381     print $url, "\n" or confess "$!";
7382 }
7383
7384 sub pre_print_dpkg_source_ignores {
7385     not_necessarily_a_tree();
7386 }
7387 sub cmd_print_dpkg_source_ignores {
7388     badusage __
7389         "no arguments allowed to dgit print-dpkg-source-ignores"
7390         if @ARGV;
7391     print "@dpkg_source_ignores\n" or confess "$!";
7392 }
7393
7394 sub cmd_setup_mergechangelogs {
7395     badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7396         if @ARGV;
7397     local $isuite = 'DGIT-SETUP-TREE';
7398     setup_mergechangelogs(1);
7399 }
7400
7401 sub cmd_setup_useremail {
7402     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7403     local $isuite = 'DGIT-SETUP-TREE';
7404     setup_useremail(1);
7405 }
7406
7407 sub cmd_setup_gitattributes {
7408     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7409     local $isuite = 'DGIT-SETUP-TREE';
7410     setup_gitattrs(1);
7411 }
7412
7413 sub cmd_setup_new_tree {
7414     badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7415     local $isuite = 'DGIT-SETUP-TREE';
7416     setup_new_tree();
7417 }
7418
7419 #---------- argument parsing and main program ----------
7420
7421 sub cmd_version {
7422     print "dgit version $our_version\n" or confess "$!";
7423     finish 0;
7424 }
7425
7426 our (%valopts_long, %valopts_short);
7427 our (%funcopts_long);
7428 our @rvalopts;
7429 our (@modeopt_cfgs);
7430
7431 sub defvalopt ($$$$) {
7432     my ($long,$short,$val_re,$how) = @_;
7433     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7434     $valopts_long{$long} = $oi;
7435     $valopts_short{$short} = $oi;
7436     # $how subref should:
7437     #   do whatever assignemnt or thing it likes with $_[0]
7438     #   if the option should not be passed on to remote, @rvalopts=()
7439     # or $how can be a scalar ref, meaning simply assign the value
7440 }
7441
7442 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7443 defvalopt '--distro',        '-d', '.+',      \$idistro;
7444 defvalopt '',                '-k', '.+',      \$keyid;
7445 defvalopt '--existing-package','', '.*',      \$existing_package;
7446 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
7447 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
7448 defvalopt '--package',   '-p',   $package_re, \$package;
7449 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
7450
7451 defvalopt '', '-C', '.+', sub {
7452     ($changesfile) = (@_);
7453     if ($changesfile =~ s#^(.*)/##) {
7454         $buildproductsdir = $1;
7455     }
7456 };
7457
7458 defvalopt '--initiator-tempdir','','.*', sub {
7459     ($initiator_tempdir) = (@_);
7460     $initiator_tempdir =~ m#^/# or
7461         badusage __ "--initiator-tempdir must be used specify an".
7462                     " absolute, not relative, directory."
7463 };
7464
7465 sub defoptmodes ($@) {
7466     my ($varref, $cfgkey, $default, %optmap) = @_;
7467     my %permit;
7468     while (my ($opt,$val) = each %optmap) {
7469         $funcopts_long{$opt} = sub { $$varref = $val; };
7470         $permit{$val} = $val;
7471     }
7472     push @modeopt_cfgs, {
7473         Var => $varref,
7474         Key => $cfgkey,
7475         Default => $default,
7476         Vals => \%permit
7477     };
7478 }
7479
7480 defoptmodes \$dodep14tag, qw( dep14tag          want
7481                               --dep14tag        want
7482                               --no-dep14tag     no
7483                               --always-dep14tag always );
7484
7485 sub parseopts () {
7486     my $om;
7487
7488     if (defined $ENV{'DGIT_SSH'}) {
7489         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7490     } elsif (defined $ENV{'GIT_SSH'}) {
7491         @ssh = ($ENV{'GIT_SSH'});
7492     }
7493
7494     my $oi;
7495     my $val;
7496     my $valopt = sub {
7497         my ($what) = @_;
7498         @rvalopts = ($_);
7499         if (!defined $val) {
7500             badusage f_ "%s needs a value", $what unless @ARGV;
7501             $val = shift @ARGV;
7502             push @rvalopts, $val;
7503         }
7504         badusage f_ "bad value \`%s' for %s", $val, $what unless
7505             $val =~ m/^$oi->{Re}$(?!\n)/s;
7506         my $how = $oi->{How};
7507         if (ref($how) eq 'SCALAR') {
7508             $$how = $val;
7509         } else {
7510             $how->($val);
7511         }
7512         push @ropts, @rvalopts;
7513     };
7514
7515     while (@ARGV) {
7516         last unless $ARGV[0] =~ m/^-/;
7517         $_ = shift @ARGV;
7518         last if m/^--?$/;
7519         if (m/^--/) {
7520             if (m/^--dry-run$/) {
7521                 push @ropts, $_;
7522                 $dryrun_level=2;
7523             } elsif (m/^--damp-run$/) {
7524                 push @ropts, $_;
7525                 $dryrun_level=1;
7526             } elsif (m/^--no-sign$/) {
7527                 push @ropts, $_;
7528                 $sign=0;
7529             } elsif (m/^--help$/) {
7530                 cmd_help();
7531             } elsif (m/^--version$/) {
7532                 cmd_version();
7533             } elsif (m/^--new$/) {
7534                 push @ropts, $_;
7535                 $new_package=1;
7536             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7537                      ($om = $opts_opt_map{$1}) &&
7538                      length $om->[0]) {
7539                 push @ropts, $_;
7540                 $om->[0] = $2;
7541             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7542                      !$opts_opt_cmdonly{$1} &&
7543                      ($om = $opts_opt_map{$1})) {
7544                 push @ropts, $_;
7545                 push @$om, $2;
7546             } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7547                      !$opts_opt_cmdonly{$1} &&
7548                      ($om = $opts_opt_map{$1})) {
7549                 push @ropts, $_;
7550                 my $cmd = shift @$om;
7551                 @$om = ($cmd, grep { $_ ne $2 } @$om);
7552             } elsif (m/^--($quilt_options_re)$/s) {
7553                 push @ropts, "--quilt=$1";
7554                 $quilt_mode = $1;
7555             } elsif (m/^--(?:ignore|include)-dirty$/s) {
7556                 push @ropts, $_;
7557                 $includedirty = 1;
7558             } elsif (m/^--no-quilt-fixup$/s) {
7559                 push @ropts, $_;
7560                 $quilt_mode = 'nocheck';
7561             } elsif (m/^--no-rm-on-error$/s) {
7562                 push @ropts, $_;
7563                 $rmonerror = 0;
7564             } elsif (m/^--no-chase-dsc-distro$/s) {
7565                 push @ropts, $_;
7566                 $chase_dsc_distro = 0;
7567             } elsif (m/^--overwrite$/s) {
7568                 push @ropts, $_;
7569                 $overwrite_version = '';
7570             } elsif (m/^--split-(?:view|brain)$/s) {
7571                 push @ropts, $_;
7572                 $splitview_mode = 'always';
7573             } elsif (m/^--split-(?:view|brain)=($splitview_modes_re)$/s) {
7574                 push @ropts, $_;
7575                 $splitview_mode = $1;
7576             } elsif (m/^--overwrite=(.+)$/s) {
7577                 push @ropts, $_;
7578                 $overwrite_version = $1;
7579             } elsif (m/^--delayed=(\d+)$/s) {
7580                 push @ropts, $_;
7581                 push @dput, $_;
7582             } elsif (m/^--upstream-commitish=(.+)$/s) {
7583                 push @ropts, $_;
7584                 $quilt_upstream_commitish = $1;
7585             } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7586                      m/^--(dgit-view)-save=(.+)$/s
7587                      ) {
7588                 my ($k,$v) = ($1,$2);
7589                 push @ropts, $_;
7590                 $v =~ s#^(?!refs/)#refs/heads/#;
7591                 $internal_object_save{$k} = $v;
7592             } elsif (m/^--(no-)?rm-old-changes$/s) {
7593                 push @ropts, $_;
7594                 $rmchanges = !$1;
7595             } elsif (m/^--deliberately-($deliberately_re)$/s) {
7596                 push @ropts, $_;
7597                 push @deliberatelies, $&;
7598             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7599                 push @ropts, $&;
7600                 $forceopts{$1} = 1;
7601                 $_='';
7602             } elsif (m/^--force-/) {
7603                 print STDERR
7604                     f_ "%s: warning: ignoring unknown force option %s\n",
7605                        $us, $_;
7606                 $_='';
7607             } elsif (m/^--config-lookup-explode=(.+)$/s) {
7608                 # undocumented, for testing
7609                 push @ropts, $_;
7610                 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7611                 # ^ it's supposed to be an array ref
7612             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7613                 $val = $2 ? $' : undef; #';
7614                 $valopt->($oi->{Long});
7615             } elsif ($funcopts_long{$_}) {
7616                 push @ropts, $_;
7617                 $funcopts_long{$_}();
7618             } else {
7619                 badusage f_ "unknown long option \`%s'", $_;
7620             }
7621         } else {
7622             while (m/^-./s) {
7623                 if (s/^-n/-/) {
7624                     push @ropts, $&;
7625                     $dryrun_level=2;
7626                 } elsif (s/^-L/-/) {
7627                     push @ropts, $&;
7628                     $dryrun_level=1;
7629                 } elsif (s/^-h/-/) {
7630                     cmd_help();
7631                 } elsif (s/^-D/-/) {
7632                     push @ropts, $&;
7633                     $debuglevel++;
7634                     enabledebug();
7635                 } elsif (s/^-N/-/) {
7636                     push @ropts, $&;
7637                     $new_package=1;
7638                 } elsif (m/^-m/) {
7639                     push @ropts, $&;
7640                     push @changesopts, $_;
7641                     $_ = '';
7642                 } elsif (s/^-wn$//s) {
7643                     push @ropts, $&;
7644                     $cleanmode = 'none';
7645                 } elsif (s/^-wg(f?)(a?)$//s) {
7646                     push @ropts, $&;
7647                     $cleanmode = 'git';
7648                     $cleanmode .= '-ff' if $1;
7649                     $cleanmode .= ',always' if $2;
7650                 } elsif (s/^-wd(d?)([na]?)$//s) {
7651                     push @ropts, $&;
7652                     $cleanmode = 'dpkg-source';
7653                     $cleanmode .= '-d' if $1;
7654                     $cleanmode .= ',no-check' if $2 eq 'n';
7655                     $cleanmode .= ',all-check' if $2 eq 'a';
7656                 } elsif (s/^-wc$//s) {
7657                     push @ropts, $&;
7658                     $cleanmode = 'check';
7659                 } elsif (s/^-wci$//s) {
7660                     push @ropts, $&;
7661                     $cleanmode = 'check,ignores';
7662                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7663                     push @git, '-c', $&;
7664                     $gitcfgs{cmdline}{$1} = [ $2 ];
7665                 } elsif (s/^-c([^=]+)$//s) {
7666                     push @git, '-c', $&;
7667                     $gitcfgs{cmdline}{$1} = [ 'true' ];
7668                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7669                     $val = $'; #';
7670                     $val = undef unless length $val;
7671                     $valopt->($oi->{Short});
7672                     $_ = '';
7673                 } else {
7674                     badusage f_ "unknown short option \`%s'", $_;
7675                 }
7676             }
7677         }
7678     }
7679 }
7680
7681 sub check_env_sanity () {
7682     my $blocked = new POSIX::SigSet;
7683     sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7684
7685     eval {
7686         foreach my $name (qw(PIPE CHLD)) {
7687             my $signame = "SIG$name";
7688             my $signum = eval "POSIX::$signame" // die;
7689             die f_ "%s is set to something other than SIG_DFL\n",
7690                 $signame
7691                 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7692             $blocked->ismember($signum) and
7693                 die f_ "%s is blocked\n", $signame;
7694         }
7695     };
7696     return unless $@;
7697     chomp $@;
7698     fail f_ <<END, $@;
7699 On entry to dgit, %s
7700 This is a bug produced by something in your execution environment.
7701 Giving up.
7702 END
7703 }
7704
7705
7706 sub parseopts_late_defaults () {
7707     $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7708         if defined $idistro;
7709     $isuite //= cfg('dgit.default.default-suite');
7710
7711     foreach my $k (keys %opts_opt_map) {
7712         my $om = $opts_opt_map{$k};
7713
7714         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7715         if (defined $v) {
7716             badcfg f_ "cannot set command for %s", $k
7717                 unless length $om->[0];
7718             $om->[0] = $v;
7719         }
7720
7721         foreach my $c (access_cfg_cfgs("opts-$k")) {
7722             my @vl =
7723                 map { $_ ? @$_ : () }
7724                 map { $gitcfgs{$_}{$c} }
7725                 reverse @gitcfgsources;
7726             printdebug "CL $c ", (join " ", map { shellquote } @vl),
7727                 "\n" if $debuglevel >= 4;
7728             next unless @vl;
7729             badcfg f_ "cannot configure options for %s", $k
7730                 if $opts_opt_cmdonly{$k};
7731             my $insertpos = $opts_cfg_insertpos{$k};
7732             @$om = ( @$om[0..$insertpos-1],
7733                      @vl,
7734                      @$om[$insertpos..$#$om] );
7735         }
7736     }
7737
7738     if (!defined $rmchanges) {
7739         local $access_forpush;
7740         $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7741     }
7742
7743     if (!defined $quilt_mode) {
7744         local $access_forpush;
7745         $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7746             // access_cfg('quilt-mode', 'RETURN-UNDEF')
7747             // 'linear';
7748         $quilt_mode =~ m/^($quilt_modes_re)$/
7749             or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7750         $quilt_mode = $1;
7751     }
7752     $quilt_mode =~ s/^(baredebian)\+git$/$1/;
7753
7754     foreach my $moc (@modeopt_cfgs) {
7755         local $access_forpush;
7756         my $vr = $moc->{Var};
7757         next if defined $$vr;
7758         $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7759         my $v = $moc->{Vals}{$$vr};
7760         badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7761             unless defined $v;
7762         $$vr = $v;
7763     }
7764
7765     {
7766         local $access_forpush;
7767         default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7768                                 $cleanmode_re);
7769     }
7770
7771     $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7772     $buildproductsdir //= '..';
7773     $bpd_glob = $buildproductsdir;
7774     $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7775 }
7776
7777 setlocale(LC_MESSAGES, "");
7778 textdomain("dgit");
7779
7780 if ($ENV{$fakeeditorenv}) {
7781     git_slurp_config();
7782     quilt_fixup_editor();
7783 }
7784
7785 parseopts();
7786 check_env_sanity();
7787
7788 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7789 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7790     if $dryrun_level == 1;
7791 if (!@ARGV) {
7792     print STDERR __ $helpmsg or confess "$!";
7793     finish 8;
7794 }
7795 $cmd = $subcommand = shift @ARGV;
7796 $cmd =~ y/-/_/;
7797
7798 my $pre_fn = ${*::}{"pre_$cmd"};
7799 $pre_fn->() if $pre_fn;
7800
7801 if ($invoked_in_git_tree) {
7802     changedir_git_toplevel();
7803     record_maindir();
7804 }
7805 git_slurp_config();
7806
7807 my $fn = ${*::}{"cmd_$cmd"};
7808 $fn or badusage f_ "unknown operation %s", $cmd;
7809 $fn->();
7810
7811 finish 0;