dgit

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