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