dgit

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