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