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