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