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