dgit

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