dgit

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