dgit

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