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             my $dtxinfo = join(" ", "",@dtxinfo);
4389             print TO <<END or confess "$!";
4390 [dgit distro=$declaredistro$dtxinfo]
4391 END
4392             foreach my $ref (sort keys %previously) {
4393                 print TO <<END or confess "$!";
4394 [dgit previously:$ref=$previously{$ref}]
4395 END
4396             }
4397         } elsif ($tw->{View} eq 'maint') {
4398             print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4399 %s release %s for %s (%s)
4400 (maintainer view tag generated by dgit --quilt=%s)
4401 END
4402                 $quilt_mode
4403                 or confess "$!";
4404         } else {
4405             confess Dumper($tw)."?";
4406         }
4407
4408         close TO or confess "$!";
4409
4410         my $tagobjfn = $tfn->('.tmp');
4411         if ($sign) {
4412             if (!defined $keyid) {
4413                 $keyid = access_cfg('keyid','RETURN-UNDEF');
4414             }
4415             if (!defined $keyid) {
4416                 $keyid = getfield $clogp, 'Maintainer';
4417             }
4418             unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4419             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4420             push @sign_cmd, qw(-u),$keyid if defined $keyid;
4421             push @sign_cmd, $tfn->('.tmp');
4422             runcmd_ordryrun @sign_cmd;
4423             if (act_scary()) {
4424                 $tagobjfn = $tfn->('.signed.tmp');
4425                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4426                     $tfn->('.tmp'), $tfn->('.tmp.asc');
4427             }
4428         }
4429         return $tagobjfn;
4430     };
4431
4432     my @r = map { $mktag->($_); } @$tagwants;
4433     return @r;
4434 }
4435
4436 sub sign_changes ($) {
4437     my ($changesfile) = @_;
4438     if ($sign) {
4439         my @debsign_cmd = @debsign;
4440         push @debsign_cmd, "-k$keyid" if defined $keyid;
4441         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4442         push @debsign_cmd, $changesfile;
4443         runcmd_ordryrun @debsign_cmd;
4444     }
4445 }
4446
4447 sub dopush () {
4448     printdebug "actually entering push\n";
4449
4450     supplementary_message(__ <<'END');
4451 Push failed, while checking state of the archive.
4452 You can retry the push, after fixing the problem, if you like.
4453 END
4454     if (check_for_git()) {
4455         git_fetch_us();
4456     }
4457     my $archive_hash = fetch_from_archive();
4458     if (!$archive_hash) {
4459         $new_package or
4460             fail __ "package appears to be new in this suite;".
4461                     " if this is intentional, use --new";
4462     }
4463
4464     supplementary_message(__ <<'END');
4465 Push failed, while preparing your push.
4466 You can retry the push, after fixing the problem, if you like.
4467 END
4468
4469     prep_ud();
4470
4471     access_giturl(); # check that success is vaguely likely
4472     rpush_handle_protovsn_bothends() if $we_are_initiator;
4473
4474     my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4475     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4476
4477     responder_send_file('parsed-changelog', $clogpfn);
4478
4479     my ($clogp, $cversion, $dscfn) =
4480         push_parse_changelog("$clogpfn");
4481
4482     my $dscpath = "$buildproductsdir/$dscfn";
4483     stat_exists $dscpath or
4484         fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4485                 $dscpath, $!;
4486
4487     responder_send_file('dsc', $dscpath);
4488
4489     push_parse_dsc($dscpath, $dscfn, $cversion);
4490
4491     my $format = getfield $dsc, 'Format';
4492
4493     my $symref = git_get_symref();
4494     my $actualhead = git_rev_parse('HEAD');
4495
4496     if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4497         if (quiltmode_splitting()) {
4498             my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4499             fail f_ <<END, $ffq_prev, $quilt_mode;
4500 Branch is managed by git-debrebase (%s
4501 exists), but quilt mode (%s) implies a split view.
4502 Pass the right --quilt option or adjust your git config.
4503 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4504 END
4505         }
4506         runcmd_ordryrun_local @git_debrebase, 'stitch';
4507         $actualhead = git_rev_parse('HEAD');
4508     }
4509
4510     my $dgithead = $actualhead;
4511     my $maintviewhead = undef;
4512
4513     my $upstreamversion = upstreamversion $clogp->{Version};
4514
4515     if (madformat_wantfixup($format)) {
4516         # user might have not used dgit build, so maybe do this now:
4517         if (do_split_brain()) {
4518             changedir $playground;
4519             my $cachekey;
4520             ($dgithead, $cachekey) =
4521                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4522             $dgithead or fail f_
4523  "--quilt=%s but no cached dgit view:
4524  perhaps HEAD changed since dgit build[-source] ?",
4525                               $quilt_mode;
4526         }
4527         if (!do_split_brain()) {
4528             # In split brain mode, do not attempt to incorporate dirty
4529             # stuff from the user's working tree.  That would be mad.
4530             commit_quilty_patch();
4531         }
4532     }
4533     if (do_split_brain()) {
4534         $made_split_brain = 1;
4535         $dgithead = splitbrain_pseudomerge($clogp,
4536                                            $actualhead, $dgithead,
4537                                            $archive_hash);
4538         $maintviewhead = $actualhead;
4539         changedir $maindir;
4540         prep_ud(); # so _only_subdir() works, below
4541     }
4542
4543     if (defined $overwrite_version && !defined $maintviewhead
4544         && $archive_hash) {
4545         $dgithead = plain_overwrite_pseudomerge($clogp,
4546                                                 $dgithead,
4547                                                 $archive_hash);
4548     }
4549
4550     check_not_dirty();
4551
4552     my $forceflag = '';
4553     if ($archive_hash) {
4554         if (is_fast_fwd($archive_hash, $dgithead)) {
4555             # ok
4556         } elsif (deliberately_not_fast_forward) {
4557             $forceflag = '+';
4558         } else {
4559             fail __ "dgit push: HEAD is not a descendant".
4560                 " of the archive's version.\n".
4561                 "To overwrite the archive's contents,".
4562                 " pass --overwrite[=VERSION].\n".
4563                 "To rewind history, if permitted by the archive,".
4564                 " use --deliberately-not-fast-forward.";
4565         }
4566     }
4567
4568     confess unless !!$made_split_brain == do_split_brain();
4569
4570     changedir $playground;
4571     progress f_ "checking that %s corresponds to HEAD", $dscfn;
4572     runcmd qw(dpkg-source -x --),
4573         $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4574     my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4575     check_for_vendor_patches() if madformat($dsc->{format});
4576     changedir $maindir;
4577     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4578     debugcmd "+",@diffcmd;
4579     $!=0; $?=-1;
4580     my $r = system @diffcmd;
4581     if ($r) {
4582         if ($r==256) {
4583             my $referent = $made_split_brain ? $dgithead : 'HEAD';
4584             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4585
4586             my @mode_changes;
4587             my $raw = cmdoutput @git,
4588                 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4589             my $changed;
4590             foreach (split /\0/, $raw) {
4591                 if (defined $changed) {
4592                     push @mode_changes, "$changed: $_\n" if $changed;
4593                     $changed = undef;
4594                     next;
4595                 } elsif (m/^:0+ 0+ /) {
4596                     $changed = '';
4597                 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4598                     $changed = "Mode change from $1 to $2"
4599                 } else {
4600                     die "$_ ?";
4601                 }
4602             }
4603             if (@mode_changes) {
4604                 fail +(f_ <<ENDT, $dscfn).<<END
4605 HEAD specifies a different tree to %s:
4606 ENDT
4607 $diffs
4608 END
4609                     .(join '', @mode_changes)
4610                     .(f_ <<ENDT, $tree, $referent);
4611 There is a problem with your source tree (see dgit(7) for some hints).
4612 To see a full diff, run git diff %s %s
4613 ENDT
4614             }
4615
4616             fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4617 HEAD specifies a different tree to %s:
4618 ENDT
4619 $diffs
4620 END
4621 Perhaps you forgot to build.  Or perhaps there is a problem with your
4622  source tree (see dgit(7) for some hints).  To see a full diff, run
4623    git diff %s %s
4624 ENDT
4625         } else {
4626             failedcmd @diffcmd;
4627         }
4628     }
4629     if (!$changesfile) {
4630         my $pat = changespat $cversion;
4631         my @cs = glob "$buildproductsdir/$pat";
4632         fail f_ "failed to find unique changes file".
4633                 " (looked for %s in %s);".
4634                 " perhaps you need to use dgit -C",
4635                 $pat, $buildproductsdir
4636             unless @cs==1;
4637         ($changesfile) = @cs;
4638     } else {
4639         $changesfile = "$buildproductsdir/$changesfile";
4640     }
4641
4642     # Check that changes and .dsc agree enough
4643     $changesfile =~ m{[^/]*$};
4644     my $changes = parsecontrol($changesfile,$&);
4645     files_compare_inputs($dsc, $changes)
4646         unless forceing [qw(dsc-changes-mismatch)];
4647
4648     # Check whether this is a source only upload
4649     my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4650     my $sourceonlypolicy = access_cfg 'source-only-uploads';
4651     if ($sourceonlypolicy eq 'ok') {
4652     } elsif ($sourceonlypolicy eq 'always') {
4653         forceable_fail [qw(uploading-binaries)],
4654             __ "uploading binaries, although distro policy is source only"
4655             if $hasdebs;
4656     } elsif ($sourceonlypolicy eq 'never') {
4657         forceable_fail [qw(uploading-source-only)],
4658             __ "source-only upload, although distro policy requires .debs"
4659             if !$hasdebs;
4660     } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4661         forceable_fail [qw(uploading-source-only)],
4662             f_ "source-only upload, even though package is entirely NEW\n".
4663                "(this is contrary to policy in %s)",
4664                access_nomdistro()
4665             if !$hasdebs
4666             && $new_package
4667             && !(archive_query('package_not_wholly_new', $package) // 1);
4668     } else {
4669         badcfg f_ "unknown source-only-uploads policy \`%s'",
4670                   $sourceonlypolicy;
4671     }
4672
4673     # Perhaps adjust .dsc to contain right set of origs
4674     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4675                                   $changesfile)
4676         unless forceing [qw(changes-origs-exactly)];
4677
4678     # Checks complete, we're going to try and go ahead:
4679
4680     responder_send_file('changes',$changesfile);
4681     responder_send_command("param head $dgithead");
4682     responder_send_command("param csuite $csuite");
4683     responder_send_command("param isuite $isuite");
4684     responder_send_command("param tagformat new"); # needed in $protovsn==4
4685     responder_send_command("param splitbrain $do_split_brain");
4686     if (defined $maintviewhead) {
4687         responder_send_command("param maint-view $maintviewhead");
4688     }
4689
4690     # Perhaps send buildinfo(s) for signing
4691     my $changes_files = getfield $changes, 'Files';
4692     my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4693     foreach my $bi (@buildinfos) {
4694         responder_send_command("param buildinfo-filename $bi");
4695         responder_send_file('buildinfo', "$buildproductsdir/$bi");
4696     }
4697
4698     if (deliberately_not_fast_forward) {
4699         git_for_each_ref(lrfetchrefs, sub {
4700             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4701             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4702             responder_send_command("previously $rrefname=$objid");
4703             $previously{$rrefname} = $objid;
4704         });
4705     }
4706
4707     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4708                                  dgit_privdir()."/tag");
4709     my @tagobjfns;
4710
4711     supplementary_message(__ <<'END');
4712 Push failed, while signing the tag.
4713 You can retry the push, after fixing the problem, if you like.
4714 END
4715     # If we manage to sign but fail to record it anywhere, it's fine.
4716     if ($we_are_responder) {
4717         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4718         responder_receive_files('signed-tag', @tagobjfns);
4719     } else {
4720         @tagobjfns = push_mktags($clogp,$dscpath,
4721                               $changesfile,$changesfile,
4722                               \@tagwants);
4723     }
4724     supplementary_message(__ <<'END');
4725 Push failed, *after* signing the tag.
4726 If you want to try again, you should use a new version number.
4727 END
4728
4729     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4730
4731     foreach my $tw (@tagwants) {
4732         my $tag = $tw->{Tag};
4733         my $tagobjfn = $tw->{TagObjFn};
4734         my $tag_obj_hash =
4735             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4736         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4737         runcmd_ordryrun_local
4738             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4739     }
4740
4741     supplementary_message(__ <<'END');
4742 Push failed, while updating the remote git repository - see messages above.
4743 If you want to try again, you should use a new version number.
4744 END
4745     if (!check_for_git()) {
4746         create_remote_git_repo();
4747     }
4748
4749     my @pushrefs = $forceflag.$dgithead.":".rrref();
4750     foreach my $tw (@tagwants) {
4751         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4752     }
4753
4754     runcmd_ordryrun @git,
4755         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4756     runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4757
4758     supplementary_message(__ <<'END');
4759 Push failed, while obtaining signatures on the .changes and .dsc.
4760 If it was just that the signature failed, you may try again by using
4761 debsign by hand to sign the changes file (see the command dgit tried,
4762 above), and then dput that changes file to complete the upload.
4763 If you need to change the package, you must use a new version number.
4764 END
4765     if ($we_are_responder) {
4766         my $dryrunsuffix = act_local() ? "" : ".tmp";
4767         my @rfiles = ($dscpath, $changesfile);
4768         push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4769         responder_receive_files('signed-dsc-changes',
4770                                 map { "$_$dryrunsuffix" } @rfiles);
4771     } else {
4772         if (act_local()) {
4773             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4774         } else {
4775             progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4776         }
4777         sign_changes $changesfile;
4778     }
4779
4780     supplementary_message(f_ <<END, $changesfile);
4781 Push failed, while uploading package(s) to the archive server.
4782 You can retry the upload of exactly these same files with dput of:
4783   %s
4784 If that .changes file is broken, you will need to use a new version
4785 number for your next attempt at the upload.
4786 END
4787     my $host = access_cfg('upload-host','RETURN-UNDEF');
4788     my @hostarg = defined($host) ? ($host,) : ();
4789     runcmd_ordryrun @dput, @hostarg, $changesfile;
4790     printdone f_ "pushed and uploaded %s", $cversion;
4791
4792     supplementary_message('');
4793     responder_send_command("complete");
4794 }
4795
4796 sub pre_clone () {
4797     not_necessarily_a_tree();
4798 }
4799 sub cmd_clone {
4800     parseopts();
4801     my $dstdir;
4802     badusage __ "-p is not allowed with clone; specify as argument instead"
4803         if defined $package;
4804     if (@ARGV==1) {
4805         ($package) = @ARGV;
4806     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4807         ($package,$isuite) = @ARGV;
4808     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4809         ($package,$dstdir) = @ARGV;
4810     } elsif (@ARGV==3) {
4811         ($package,$isuite,$dstdir) = @ARGV;
4812     } else {
4813         badusage __ "incorrect arguments to dgit clone";
4814     }
4815     notpushing();
4816
4817     $dstdir ||= "$package";
4818     if (stat_exists $dstdir) {
4819         fail f_ "%s already exists", $dstdir;
4820     }
4821
4822     my $cwd_remove;
4823     if ($rmonerror && !$dryrun_level) {
4824         $cwd_remove= getcwd();
4825         unshift @end, sub {
4826             return unless defined $cwd_remove;
4827             if (!chdir "$cwd_remove") {
4828                 return if $!==&ENOENT;
4829                 confess "chdir $cwd_remove: $!";
4830             }
4831             printdebug "clone rmonerror removing $dstdir\n";
4832             if (stat $dstdir) {
4833                 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4834             } elsif (grep { $! == $_ }
4835                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4836             } else {
4837                 print STDERR f_ "check whether to remove %s: %s\n",
4838                                 $dstdir, $!;
4839             }
4840         };
4841     }
4842
4843     clone($dstdir);
4844     $cwd_remove = undef;
4845 }
4846
4847 sub branchsuite () {
4848     my $branch = git_get_symref();
4849     if (defined $branch && $branch =~ m#$lbranch_re#o) {
4850         return $1;
4851     } else {
4852         return undef;
4853     }
4854 }
4855
4856 sub package_from_d_control () {
4857     if (!defined $package) {
4858         my $sourcep = parsecontrol('debian/control','debian/control');
4859         $package = getfield $sourcep, 'Source';
4860     }
4861 }
4862
4863 sub fetchpullargs () {
4864     package_from_d_control();
4865     if (@ARGV==0) {
4866         $isuite = branchsuite();
4867         if (!$isuite) {
4868             my $clogp = parsechangelog();
4869             my $clogsuite = getfield $clogp, 'Distribution';
4870             $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4871         }
4872     } elsif (@ARGV==1) {
4873         ($isuite) = @ARGV;
4874     } else {
4875         badusage __ "incorrect arguments to dgit fetch or dgit pull";
4876     }
4877     notpushing();
4878 }
4879
4880 sub cmd_fetch {
4881     parseopts();
4882     fetchpullargs();
4883     dofetch();
4884 }
4885
4886 sub cmd_pull {
4887     parseopts();
4888     fetchpullargs();
4889     determine_whether_split_brain get_source_format();
4890     if (do_split_brain()) {
4891         my ($format, $fopts) = get_source_format();
4892         madformat($format) and fail f_ <<END, $quilt_mode
4893 dgit pull not yet supported in split view mode (including with view-splitting quilt modes)
4894 END
4895     }
4896     pull();
4897 }
4898
4899 sub cmd_checkout {
4900     parseopts();
4901     package_from_d_control();
4902     @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4903     ($isuite) = @ARGV;
4904     notpushing();
4905
4906     foreach my $canon (qw(0 1)) {
4907         if (!$canon) {
4908             $csuite= $isuite;
4909         } else {
4910             undef $csuite;
4911             canonicalise_suite();
4912         }
4913         if (length git_get_ref lref()) {
4914             # local branch already exists, yay
4915             last;
4916         }
4917         if (!length git_get_ref lrref()) {
4918             if (!$canon) {
4919                 # nope
4920                 next;
4921             }
4922             dofetch();
4923         }
4924         # now lrref exists
4925         runcmd (@git, qw(update-ref), lref(), lrref(), '');
4926         last;
4927     }
4928     local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4929         "dgit checkout $isuite";
4930     runcmd (@git, qw(checkout), lbranch());
4931 }
4932
4933 sub cmd_update_vcs_git () {
4934     my $specsuite;
4935     if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4936         ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4937     } else {
4938         ($specsuite) = (@ARGV);
4939         shift @ARGV;
4940     }
4941     my $dofetch=1;
4942     if (@ARGV) {
4943         if ($ARGV[0] eq '-') {
4944             $dofetch = 0;
4945         } elsif ($ARGV[0] eq '-') {
4946             shift;
4947         }
4948     }
4949
4950     package_from_d_control();
4951     my $ctrl;
4952     if ($specsuite eq '.') {
4953         $ctrl = parsecontrol 'debian/control', 'debian/control';
4954     } else {
4955         $isuite = $specsuite;
4956         get_archive_dsc();
4957         $ctrl = $dsc;
4958     }
4959     my $url = getfield $ctrl, 'Vcs-Git';
4960
4961     my @cmd;
4962     my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4963     if (!defined $orgurl) {
4964         print STDERR f_ "setting up vcs-git: %s\n", $url;
4965         @cmd = (@git, qw(remote add vcs-git), $url);
4966     } elsif ($orgurl eq $url) {
4967         print STDERR f_ "vcs git already configured: %s\n", $url;
4968     } else {
4969         print STDERR f_ "changing vcs-git url to: %s\n", $url;
4970         @cmd = (@git, qw(remote set-url vcs-git), $url);
4971     }
4972     runcmd_ordryrun_local @cmd;
4973     if ($dofetch) {
4974         print f_ "fetching (%s)\n", "@ARGV";
4975         runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4976     }
4977 }
4978
4979 sub prep_push () {
4980     parseopts();
4981     build_or_push_prep_early();
4982     pushing();
4983     build_or_push_prep_modes();
4984     check_not_dirty();
4985     my $specsuite;
4986     if (@ARGV==0) {
4987     } elsif (@ARGV==1) {
4988         ($specsuite) = (@ARGV);
4989     } else {
4990         badusage f_ "incorrect arguments to dgit %s", $subcommand;
4991     }
4992     if ($new_package) {
4993         local ($package) = $existing_package; # this is a hack
4994         canonicalise_suite();
4995     } else {
4996         canonicalise_suite();
4997     }
4998     if (defined $specsuite &&
4999         $specsuite ne $isuite &&
5000         $specsuite ne $csuite) {
5001             fail f_ "dgit %s: changelog specifies %s (%s)".
5002                     " but command line specifies %s",
5003                     $subcommand, $isuite, $csuite, $specsuite;
5004     }
5005 }
5006
5007 sub cmd_push {
5008     prep_push();
5009     dopush();
5010 }
5011
5012 #---------- remote commands' implementation ----------
5013
5014 sub pre_remote_push_build_host {
5015     my ($nrargs) = shift @ARGV;
5016     my (@rargs) = @ARGV[0..$nrargs-1];
5017     @ARGV = @ARGV[$nrargs..$#ARGV];
5018     die unless @rargs;
5019     my ($dir,$vsnwant) = @rargs;
5020     # vsnwant is a comma-separated list; we report which we have
5021     # chosen in our ready response (so other end can tell if they
5022     # offered several)
5023     $debugprefix = ' ';
5024     $we_are_responder = 1;
5025     $us .= " (build host)";
5026
5027     open PI, "<&STDIN" or confess "$!";
5028     open STDIN, "/dev/null" or confess "$!";
5029     open PO, ">&STDOUT" or confess "$!";
5030     autoflush PO 1;
5031     open STDOUT, ">&STDERR" or confess "$!";
5032     autoflush STDOUT 1;
5033
5034     $vsnwant //= 1;
5035     ($protovsn) = grep {
5036         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
5037     } @rpushprotovsn_support;
5038
5039     fail f_ "build host has dgit rpush protocol versions %s".
5040             " but invocation host has %s",
5041             (join ",", @rpushprotovsn_support), $vsnwant
5042         unless defined $protovsn;
5043
5044     changedir $dir;
5045 }
5046 sub cmd_remote_push_build_host {
5047     responder_send_command("dgit-remote-push-ready $protovsn");
5048     &cmd_push;
5049 }
5050
5051 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5052 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5053 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5054 #     a good error message)
5055
5056 sub rpush_handle_protovsn_bothends () {
5057 }
5058
5059 our $i_tmp;
5060
5061 sub i_cleanup {
5062     local ($@, $?);
5063     my $report = i_child_report();
5064     if (defined $report) {
5065         printdebug "($report)\n";
5066     } elsif ($i_child_pid) {
5067         printdebug "(killing build host child $i_child_pid)\n";
5068         kill 15, $i_child_pid;
5069     }
5070     if (defined $i_tmp && !defined $initiator_tempdir) {
5071         changedir "/";
5072         eval { rmtree $i_tmp; };
5073     }
5074 }
5075
5076 END {
5077     return unless forkcheck_mainprocess();
5078     i_cleanup();
5079 }
5080
5081 sub i_method {
5082     my ($base,$selector,@args) = @_;
5083     $selector =~ s/\-/_/g;
5084     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5085 }
5086
5087 sub pre_rpush () {
5088     not_necessarily_a_tree();
5089 }
5090 sub cmd_rpush {
5091     my $host = nextarg;
5092     my $dir;
5093     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5094         $host = $1;
5095         $dir = $'; #';
5096     } else {
5097         $dir = nextarg;
5098     }
5099     $dir =~ s{^-}{./-};
5100     my @rargs = ($dir);
5101     push @rargs, join ",", @rpushprotovsn_support;
5102     my @rdgit;
5103     push @rdgit, @dgit;
5104     push @rdgit, @ropts;
5105     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5106     push @rdgit, @ARGV;
5107     my @cmd = (@ssh, $host, shellquote @rdgit);
5108     debugcmd "+",@cmd;
5109
5110     $we_are_initiator=1;
5111
5112     if (defined $initiator_tempdir) {
5113         rmtree $initiator_tempdir;
5114         mkdir $initiator_tempdir, 0700
5115             or fail f_ "create %s: %s", $initiator_tempdir, $!;
5116         $i_tmp = $initiator_tempdir;
5117     } else {
5118         $i_tmp = tempdir();
5119     }
5120     $i_child_pid = open2(\*RO, \*RI, @cmd);
5121     changedir $i_tmp;
5122     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5123     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5124
5125     for (;;) {
5126         my ($icmd,$iargs) = initiator_expect {
5127             m/^(\S+)(?: (.*))?$/;
5128             ($1,$2);
5129         };
5130         i_method "i_resp", $icmd, $iargs;
5131     }
5132 }
5133
5134 sub i_resp_progress ($) {
5135     my ($rhs) = @_;
5136     my $msg = protocol_read_bytes \*RO, $rhs;
5137     progress $msg;
5138 }
5139
5140 sub i_resp_supplementary_message ($) {
5141     my ($rhs) = @_;
5142     $supplementary_message = protocol_read_bytes \*RO, $rhs;
5143 }
5144
5145 sub i_resp_complete {
5146     my $pid = $i_child_pid;
5147     $i_child_pid = undef; # prevents killing some other process with same pid
5148     printdebug "waiting for build host child $pid...\n";
5149     my $got = waitpid $pid, 0;
5150     confess "$!" unless $got == $pid;
5151     fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5152
5153     i_cleanup();
5154     printdebug __ "all done\n";
5155     finish 0;
5156 }
5157
5158 sub i_resp_file ($) {
5159     my ($keyword) = @_;
5160     my $localname = i_method "i_localname", $keyword;
5161     my $localpath = "$i_tmp/$localname";
5162     stat_exists $localpath and
5163         badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5164     protocol_receive_file \*RO, $localpath;
5165     i_method "i_file", $keyword;
5166 }
5167
5168 our %i_param;
5169
5170 sub i_resp_param ($) {
5171     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5172     $i_param{$1} = $2;
5173 }
5174
5175 sub i_resp_previously ($) {
5176     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5177         or badproto \*RO, __ "bad previously spec";
5178     my $r = system qw(git check-ref-format), $1;
5179     confess "bad previously ref spec ($r)" if $r;
5180     $previously{$1} = $2;
5181 }
5182
5183 our %i_wanted;
5184 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5185
5186 sub i_resp_want ($) {
5187     my ($keyword) = @_;
5188     die "$keyword ?" if $i_wanted{$keyword}++;
5189
5190     defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5191     $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5192     die unless $isuite =~ m/^$suite_re$/;
5193
5194     if (!defined $dsc) {
5195         pushing();
5196         rpush_handle_protovsn_bothends();
5197         push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5198         if ($protovsn >= 6) {
5199             determine_whether_split_brain getfield $dsc, 'Format';
5200             $do_split_brain eq ($i_param{'splitbrain'} // '<unsent>')
5201                 or badproto \*RO,
5202  "split brain mismatch, $do_split_brain != $i_param{'split_brain'}";
5203             printdebug "rpush split brain $do_split_brain\n";
5204         }
5205     }
5206
5207     my @localpaths = i_method "i_want", $keyword;
5208     printdebug "[[  $keyword @localpaths\n";
5209     foreach my $localpath (@localpaths) {
5210         protocol_send_file \*RI, $localpath;
5211     }
5212     print RI "files-end\n" or confess "$!";
5213 }
5214
5215 sub i_localname_parsed_changelog {
5216     return "remote-changelog.822";
5217 }
5218 sub i_file_parsed_changelog {
5219     ($i_clogp, $i_version, $i_dscfn) =
5220         push_parse_changelog "$i_tmp/remote-changelog.822";
5221     die if $i_dscfn =~ m#/|^\W#;
5222 }
5223
5224 sub i_localname_dsc {
5225     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5226     return $i_dscfn;
5227 }
5228 sub i_file_dsc { }
5229
5230 sub i_localname_buildinfo ($) {
5231     my $bi = $i_param{'buildinfo-filename'};
5232     defined $bi or badproto \*RO, "buildinfo before filename";
5233     defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5234     $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5235         or badproto \*RO, "improper buildinfo filename";
5236     return $&;
5237 }
5238 sub i_file_buildinfo {
5239     my $bi = $i_param{'buildinfo-filename'};
5240     my $bd = parsecontrol "$i_tmp/$bi", $bi;
5241     my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5242     if (!forceing [qw(buildinfo-changes-mismatch)]) {
5243         files_compare_inputs($bd, $ch);
5244         (getfield $bd, $_) eq (getfield $ch, $_) or
5245             fail f_ "buildinfo mismatch in field %s", $_
5246             foreach qw(Source Version);
5247         !defined $bd->{$_} or
5248             fail f_ "buildinfo contains forbidden field %s", $_
5249             foreach qw(Changes Changed-by Distribution);
5250     }
5251     push @i_buildinfos, $bi;
5252     delete $i_param{'buildinfo-filename'};
5253 }
5254
5255 sub i_localname_changes {
5256     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5257     $i_changesfn = $i_dscfn;
5258     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5259     return $i_changesfn;
5260 }
5261 sub i_file_changes { }
5262
5263 sub i_want_signed_tag {
5264     printdebug Dumper(\%i_param, $i_dscfn);
5265     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5266         && defined $i_param{'csuite'}
5267         or badproto \*RO, "premature desire for signed-tag";
5268     my $head = $i_param{'head'};
5269     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5270
5271     my $maintview = $i_param{'maint-view'};
5272     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5273
5274     if ($protovsn == 4) {
5275         my $p = $i_param{'tagformat'} // '<undef>';
5276         $p eq 'new'
5277             or badproto \*RO, "tag format mismatch: $p vs. new";
5278     }
5279
5280     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5281     $csuite = $&;
5282     defined $dsc or badproto \*RO, "dsc (before parsed-changelog)";
5283
5284     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5285
5286     return
5287         push_mktags $i_clogp, $i_dscfn,
5288             $i_changesfn, (__ 'remote changes file'),
5289             \@tagwants;
5290 }
5291
5292 sub i_want_signed_dsc_changes {
5293     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5294     sign_changes $i_changesfn;
5295     return ($i_dscfn, $i_changesfn, @i_buildinfos);
5296 }
5297
5298 #---------- building etc. ----------
5299
5300 our $version;
5301 our $sourcechanges;
5302 our $dscfn;
5303
5304 #----- `3.0 (quilt)' handling -----
5305
5306 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5307
5308 sub quiltify_dpkg_commit ($$$;$) {
5309     my ($patchname,$author,$msg, $xinfo) = @_;
5310     $xinfo //= '';
5311
5312     mkpath '.git/dgit'; # we are in playtree
5313     my $descfn = ".git/dgit/quilt-description.tmp";
5314     open O, '>', $descfn or confess "$descfn: $!";
5315     $msg =~ s/\n+/\n\n/;
5316     print O <<END or confess "$!";
5317 From: $author
5318 ${xinfo}Subject: $msg
5319 ---
5320
5321 END
5322     close O or confess "$!";
5323
5324     {
5325         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5326         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5327         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5328         runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5329     }
5330 }
5331
5332 sub quiltify_trees_differ ($$;$$$) {
5333     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5334     # returns true iff the two tree objects differ other than in debian/
5335     # with $finegrained,
5336     # returns bitmask 01 - differ in upstream files except .gitignore
5337     #                 02 - differ in .gitignore
5338     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5339     #  is set for each modified .gitignore filename $fn
5340     # if $unrepres is defined, array ref to which is appeneded
5341     #  a list of unrepresentable changes (removals of upstream files
5342     #  (as messages)
5343     local $/=undef;
5344     my @cmd = (@git, qw(diff-tree -z --no-renames));
5345     push @cmd, qw(--name-only) unless $unrepres;
5346     push @cmd, qw(-r) if $finegrained || $unrepres;
5347     push @cmd, $x, $y;
5348     my $diffs= cmdoutput @cmd;
5349     my $r = 0;
5350     my @lmodes;
5351     foreach my $f (split /\0/, $diffs) {
5352         if ($unrepres && !@lmodes) {
5353             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5354             next;
5355         }
5356         my ($oldmode,$newmode) = @lmodes;
5357         @lmodes = ();
5358
5359         next if $f =~ m#^debian(?:/.*)?$#s;
5360
5361         if ($unrepres) {
5362             eval {
5363                 die __ "not a plain file or symlink\n"
5364                     unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5365                            $oldmode =~ m/^(?:10|12)\d{4}$/;
5366                 if ($oldmode =~ m/[^0]/ &&
5367                     $newmode =~ m/[^0]/) {
5368                     # both old and new files exist
5369                     die __ "mode or type changed\n" if $oldmode ne $newmode;
5370                     die __ "modified symlink\n" unless $newmode =~ m/^10/;
5371                 } elsif ($oldmode =~ m/[^0]/) {
5372                     # deletion
5373                     die __ "deletion of symlink\n"
5374                         unless $oldmode =~ m/^10/;
5375                 } else {
5376                     # creation
5377                     die __ "creation with non-default mode\n"
5378                         unless $newmode =~ m/^100644$/ or
5379                                $newmode =~ m/^120000$/;
5380                 }
5381             };
5382             if ($@) {
5383                 local $/="\n"; chomp $@;
5384                 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5385             }
5386         }
5387
5388         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5389         $r |= $isignore ? 02 : 01;
5390         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5391     }
5392     printdebug "quiltify_trees_differ $x $y => $r\n";
5393     return $r;
5394 }
5395
5396 sub quiltify_tree_sentinelfiles ($) {
5397     # lists the `sentinel' files present in the tree
5398     my ($x) = @_;
5399     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5400         qw(-- debian/rules debian/control);
5401     $r =~ s/\n/,/g;
5402     return $r;
5403 }
5404
5405 sub quiltify_splitting ($$$$$$$) {
5406     my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5407         $editedignores, $cachekey) = @_;
5408     my $gitignore_special = 1;
5409     if ($quilt_mode !~ m/gbp|dpm|baredebian/) {
5410         # treat .gitignore just like any other upstream file
5411         $diffbits = { %$diffbits };
5412         $_ = !!$_ foreach values %$diffbits;
5413         $gitignore_special = 0;
5414     }
5415     # We would like any commits we generate to be reproducible
5416     my @authline = clogp_authline($clogp);
5417     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
5418     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5419     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
5420     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
5421     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5422     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
5423
5424     confess unless do_split_brain();
5425
5426     my $fulldiffhint = sub {
5427         my ($x,$y) = @_;
5428         my $cmd = "git diff $x $y -- :/ ':!debian'";
5429         $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5430         return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5431                   $cmd;
5432     };
5433
5434     if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5435         ($diffbits->{O2H} & 01)) {
5436         my $msg = f_
5437  "--quilt=%s specified, implying patches-unapplied git tree\n".
5438  " but git tree differs from orig in upstream files.",
5439                      $quilt_mode;
5440         $msg .= $fulldiffhint->($unapplied, 'HEAD');
5441         if (!stat_exists "debian/patches" and $quilt_mode !~ m/baredebian/) {
5442             $msg .= __
5443  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5444         }
5445         fail $msg;
5446     }
5447     if ($quilt_mode =~ m/dpm/ &&
5448         ($diffbits->{H2A} & 01)) {
5449         fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5450 --quilt=%s specified, implying patches-applied git tree
5451  but git tree differs from result of applying debian/patches to upstream
5452 END
5453     }
5454     if ($quilt_mode =~ m/baredebian/) {
5455         # We need to construct a merge which has upstream files from
5456         # upstream and debian/ files from HEAD.
5457
5458         read_tree_upstream $quilt_upstream_commitish, 1, $headref;
5459         my $version = getfield $clogp, 'Version';
5460         my $upsversion = upstreamversion $version;
5461         my $merge = make_commit
5462             [ $headref, $quilt_upstream_commitish ],
5463  [ +(f_ <<ENDT, $upsversion), $quilt_upstream_commitish_message, <<ENDU ];
5464 Combine debian/ with upstream source for %s
5465 ENDT
5466 [dgit ($our_version) baredebian-merge $version $quilt_upstream_commitish_used]
5467 ENDU
5468         runcmd @git, qw(reset -q --hard), $merge;
5469     }
5470     if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5471         ($diffbits->{O2A} & 01)) { # some patches
5472         progress __ "dgit view: creating patches-applied version using gbp pq";
5473         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5474         # gbp pq import creates a fresh branch; push back to dgit-view
5475         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5476         runcmd @git, qw(checkout -q dgit-view);
5477     }
5478     if ($quilt_mode =~ m/gbp|dpm/ &&
5479         ($diffbits->{O2A} & 02)) {
5480         fail f_ <<END, $quilt_mode;
5481 --quilt=%s specified, implying that HEAD is for use with a
5482  tool which does not create patches for changes to upstream
5483  .gitignores: but, such patches exist in debian/patches.
5484 END
5485     }
5486     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5487         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5488         progress __
5489             "dgit view: creating patch to represent .gitignore changes";
5490         ensuredir "debian/patches";
5491         my $gipatch = "debian/patches/auto-gitignore";
5492         open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5493         stat GIPATCH or confess "$gipatch: $!";
5494         fail f_ "%s already exists; but want to create it".
5495                 " to record .gitignore changes",
5496                 $gipatch
5497             if (stat _)[7];
5498         print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5499 Subject: Update .gitignore from Debian packaging branch
5500
5501 The Debian packaging git branch contains these updates to the upstream
5502 .gitignore file(s).  This patch is autogenerated, to provide these
5503 updates to users of the official Debian archive view of the package.
5504 END
5505
5506 [dgit ($our_version) update-gitignore]
5507 ---
5508 ENDU
5509         close GIPATCH or die "$gipatch: $!";
5510         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5511             $unapplied, $headref, "--", sort keys %$editedignores;
5512         open SERIES, "+>>", "debian/patches/series" or confess "$!";
5513         defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5514         my $newline;
5515         defined read SERIES, $newline, 1 or confess "$!";
5516         print SERIES "\n" or confess "$!" unless $newline eq "\n";
5517         print SERIES "auto-gitignore\n" or confess "$!";
5518         close SERIES or die  $!;
5519         runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5520         commit_admin +(__ <<END).<<ENDU
5521 Commit patch to update .gitignore
5522 END
5523
5524 [dgit ($our_version) update-gitignore-quilt-fixup]
5525 ENDU
5526     }
5527 }
5528
5529 sub quiltify ($$$$) {
5530     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5531
5532     # Quilt patchification algorithm
5533     #
5534     # We search backwards through the history of the main tree's HEAD
5535     # (T) looking for a start commit S whose tree object is identical
5536     # to to the patch tip tree (ie the tree corresponding to the
5537     # current dpkg-committed patch series).  For these purposes
5538     # `identical' disregards anything in debian/ - this wrinkle is
5539     # necessary because dpkg-source treates debian/ specially.
5540     #
5541     # We can only traverse edges where at most one of the ancestors'
5542     # trees differs (in changes outside in debian/).  And we cannot
5543     # handle edges which change .pc/ or debian/patches.  To avoid
5544     # going down a rathole we avoid traversing edges which introduce
5545     # debian/rules or debian/control.  And we set a limit on the
5546     # number of edges we are willing to look at.
5547     #
5548     # If we succeed, we walk forwards again.  For each traversed edge
5549     # PC (with P parent, C child) (starting with P=S and ending with
5550     # C=T) to we do this:
5551     #  - git checkout C
5552     #  - dpkg-source --commit with a patch name and message derived from C
5553     # After traversing PT, we git commit the changes which
5554     # should be contained within debian/patches.
5555
5556     # The search for the path S..T is breadth-first.  We maintain a
5557     # todo list containing search nodes.  A search node identifies a
5558     # commit, and looks something like this:
5559     #  $p = {
5560     #      Commit => $git_commit_id,
5561     #      Child => $c,                          # or undef if P=T
5562     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
5563     #      Nontrivial => true iff $p..$c has relevant changes
5564     #  };
5565
5566     my @todo;
5567     my @nots;
5568     my $sref_S;
5569     my $max_work=100;
5570     my %considered; # saves being exponential on some weird graphs
5571
5572     my $t_sentinels = quiltify_tree_sentinelfiles $target;
5573
5574     my $not = sub {
5575         my ($search,$whynot) = @_;
5576         printdebug " search NOT $search->{Commit} $whynot\n";
5577         $search->{Whynot} = $whynot;
5578         push @nots, $search;
5579         no warnings qw(exiting);
5580         next;
5581     };
5582
5583     push @todo, {
5584         Commit => $target,
5585     };
5586
5587     while (@todo) {
5588         my $c = shift @todo;
5589         next if $considered{$c->{Commit}}++;
5590
5591         $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5592
5593         printdebug "quiltify investigate $c->{Commit}\n";
5594
5595         # are we done?
5596         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5597             printdebug " search finished hooray!\n";
5598             $sref_S = $c;
5599             last;
5600         }
5601
5602         quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5603         if ($quilt_mode eq 'smash') {
5604             printdebug " search quitting smash\n";
5605             last;
5606         }
5607
5608         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5609         $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5610             if $c_sentinels ne $t_sentinels;
5611
5612         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5613         $commitdata =~ m/\n\n/;
5614         $commitdata =~ $`;
5615         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5616         @parents = map { { Commit => $_, Child => $c } } @parents;
5617
5618         $not->($c, __ "root commit") if !@parents;
5619
5620         foreach my $p (@parents) {
5621             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5622         }
5623         my $ndiffers = grep { $_->{Nontrivial} } @parents;
5624         $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5625             if $ndiffers > 1;
5626
5627         foreach my $p (@parents) {
5628             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5629
5630             my @cmd= (@git, qw(diff-tree -r --name-only),
5631                       $p->{Commit},$c->{Commit},
5632                       qw(-- debian/patches .pc debian/source/format));
5633             my $patchstackchange = cmdoutput @cmd;
5634             if (length $patchstackchange) {
5635                 $patchstackchange =~ s/\n/,/g;
5636                 $not->($p, f_ "changed %s", $patchstackchange);
5637             }
5638
5639             printdebug " search queue P=$p->{Commit} ",
5640                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5641             push @todo, $p;
5642         }
5643     }
5644
5645     if (!$sref_S) {
5646         printdebug "quiltify want to smash\n";
5647
5648         my $abbrev = sub {
5649             my $x = $_[0]{Commit};
5650             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5651             return $x;
5652         };
5653         if ($quilt_mode eq 'linear') {
5654             print STDERR f_
5655                 "\n%s: error: quilt fixup cannot be linear.  Stopped at:\n",
5656                 $us;
5657             my $all_gdr = !!@nots;
5658             foreach my $notp (@nots) {
5659                 my $c = $notp->{Child};
5660                 my $cprange = $abbrev->($notp);
5661                 $cprange .= "..".$abbrev->($c) if $c;
5662                 print STDERR f_ "%s:  %s: %s\n",
5663                     $us, $cprange, $notp->{Whynot};
5664                 $all_gdr &&= $notp->{Child} &&
5665                     (git_cat_file $notp->{Child}{Commit}, 'commit')
5666                     =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5667             }
5668             print STDERR "\n";
5669             $failsuggestion =
5670                 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5671                 if $all_gdr;
5672             print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5673             fail __
5674  "quilt history linearisation failed.  Search \`quilt fixup' in dgit(7).\n";
5675         } elsif ($quilt_mode eq 'smash') {
5676         } elsif ($quilt_mode eq 'auto') {
5677             progress __ "quilt fixup cannot be linear, smashing...";
5678         } else {
5679             confess "$quilt_mode ?";
5680         }
5681
5682         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5683         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5684         my $ncommits = 3;
5685         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5686
5687         quiltify_dpkg_commit "auto-$version-$target-$time",
5688             (getfield $clogp, 'Maintainer'),
5689             (f_ "Automatically generated patch (%s)\n".
5690              "Last (up to) %s git changes, FYI:\n\n",
5691              $clogp->{Version}, $ncommits).
5692              $msg;
5693         return;
5694     }
5695
5696     progress __ "quiltify linearisation planning successful, executing...";
5697
5698     for (my $p = $sref_S;
5699          my $c = $p->{Child};
5700          $p = $p->{Child}) {
5701         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5702         next unless $p->{Nontrivial};
5703
5704         my $cc = $c->{Commit};
5705
5706         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5707         $commitdata =~ m/\n\n/ or die "$c ?";
5708         $commitdata = $`;
5709         my $msg = $'; #';
5710         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5711         my $author = $1;
5712
5713         my $commitdate = cmdoutput
5714             @git, qw(log -n1 --pretty=format:%aD), $cc;
5715
5716         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5717
5718         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5719         $strip_nls->();
5720
5721         my $title = $1;
5722         my $patchname;
5723         my $patchdir;
5724
5725         my $gbp_check_suitable = sub {
5726             $_ = shift;
5727             my ($what) = @_;
5728
5729             eval {
5730                 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5731                 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5732                 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5733                 die __ "is series file\n" if m{$series_filename_re}o;
5734                 die __ "too long\n" if length > 200;
5735             };
5736             return $_ unless $@;
5737             print STDERR f_
5738                 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5739                 $cc, $what, $@;
5740             return undef;
5741         };
5742
5743         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5744                            gbp-pq-name: \s* )
5745                        (\S+) \s* \n //ixm) {
5746             $patchname = $gbp_check_suitable->($1, 'Name');
5747         }
5748         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5749                            gbp-pq-topic: \s* )
5750                        (\S+) \s* \n //ixm) {
5751             $patchdir = $gbp_check_suitable->($1, 'Topic');
5752         }
5753
5754         $strip_nls->();
5755
5756         if (!defined $patchname) {
5757             $patchname = $title;
5758             $patchname =~ s/[.:]$//;
5759             use Text::Iconv;
5760             eval {
5761                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5762                 my $translitname = $converter->convert($patchname);
5763                 die unless defined $translitname;
5764                 $patchname = $translitname;
5765             };
5766             print STDERR
5767                 +(f_ "dgit: patch title transliteration error: %s", $@)
5768                 if $@;
5769             $patchname =~ y/ A-Z/-a-z/;
5770             $patchname =~ y/-a-z0-9_.+=~//cd;
5771             $patchname =~ s/^\W/x-$&/;
5772             $patchname = substr($patchname,0,40);
5773             $patchname .= ".patch";
5774         }
5775         if (!defined $patchdir) {
5776             $patchdir = '';
5777         }
5778         if (length $patchdir) {
5779             $patchname = "$patchdir/$patchname";
5780         }
5781         if ($patchname =~ m{^(.*)/}) {
5782             mkpath "debian/patches/$1";
5783         }
5784
5785         my $index;
5786         for ($index='';
5787              stat "debian/patches/$patchname$index";
5788              $index++) { }
5789         $!==ENOENT or confess "$patchname$index $!";
5790
5791         runcmd @git, qw(checkout -q), $cc;
5792
5793         # We use the tip's changelog so that dpkg-source doesn't
5794         # produce complaining messages from dpkg-parsechangelog.  None
5795         # of the information dpkg-source gets from the changelog is
5796         # actually relevant - it gets put into the original message
5797         # which dpkg-source provides our stunt editor, and then
5798         # overwritten.
5799         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5800
5801         quiltify_dpkg_commit "$patchname$index", $author, $msg,
5802             "Date: $commitdate\n".
5803             "X-Dgit-Generated: $clogp->{Version} $cc\n";
5804
5805         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5806     }
5807 }
5808
5809 sub build_maybe_quilt_fixup () {
5810     my ($format,$fopts) = get_source_format;
5811     return unless madformat_wantfixup $format;
5812     # sigh
5813
5814     check_for_vendor_patches();
5815
5816     my $clogp = parsechangelog();
5817     my $headref = git_rev_parse('HEAD');
5818     my $symref = git_get_symref();
5819     my $upstreamversion = upstreamversion $version;
5820
5821     prep_ud();
5822     changedir $playground;
5823
5824     my $splitbrain_cachekey;
5825
5826     if (do_split_brain()) {
5827         my $cachehit;
5828         ($cachehit, $splitbrain_cachekey) =
5829             quilt_check_splitbrain_cache($headref, $upstreamversion);
5830         if ($cachehit) {
5831             changedir $maindir;
5832             return;
5833         }
5834     }
5835
5836     unpack_playtree_need_cd_work($headref);
5837     if (do_split_brain()) {
5838         runcmd @git, qw(checkout -q -b dgit-view);
5839         # so long as work is not deleted, its current branch will
5840         # remain dgit-view, rather than master, so subsequent calls to
5841         #  unpack_playtree_need_cd_work
5842         # will DTRT, resetting dgit-view.
5843         confess if $made_split_brain;
5844         $made_split_brain = 1;
5845     }
5846     chdir '..';
5847
5848     if ($fopts->{'single-debian-patch'}) {
5849         fail f_
5850  "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5851             $quilt_mode
5852             if quiltmode_splitting();
5853         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5854     } else {
5855         quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5856                               $splitbrain_cachekey);
5857     }
5858
5859     if (do_split_brain()) {
5860         my $dgitview = git_rev_parse 'HEAD';
5861
5862         changedir $maindir;
5863         reflog_cache_insert "refs/$splitbraincache",
5864             $splitbrain_cachekey, $dgitview;
5865
5866         changedir "$playground/work";
5867
5868         my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5869         progress f_ "dgit view: created (%s)", $saved;
5870     }
5871
5872     changedir $maindir;
5873     runcmd_ordryrun_local
5874         @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5875 }
5876
5877 sub build_check_quilt_splitbrain () {
5878     build_maybe_quilt_fixup();
5879 }
5880
5881 sub unpack_playtree_need_cd_work ($) {
5882     my ($headref) = @_;
5883
5884     # prep_ud() must have been called already.
5885     if (!chdir "work") {
5886         # Check in the filesystem because sometimes we run prep_ud
5887         # in between multiple calls to unpack_playtree_need_cd_work.
5888         confess "$!" unless $!==ENOENT;
5889         mkdir "work" or confess "$!";
5890         changedir "work";
5891         mktree_in_ud_here();
5892     }
5893     runcmd @git, qw(reset -q --hard), $headref;
5894 }
5895
5896 sub unpack_playtree_linkorigs ($$) {
5897     my ($upstreamversion, $fn) = @_;
5898     # calls $fn->($leafname);
5899
5900     my $bpd_abs = bpd_abs();
5901
5902     dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5903
5904     opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5905     while ($!=0, defined(my $leaf = readdir QFD)) {
5906         my $f = bpd_abs()."/".$leaf;
5907         {
5908             local ($debuglevel) = $debuglevel-1;
5909             printdebug "QF linkorigs bpd $leaf, $f ?\n";
5910         }
5911         next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5912         printdebug "QF linkorigs $leaf, $f Y\n";
5913         link_ltarget $f, $leaf or die "$leaf $!";
5914         $fn->($leaf);
5915     }
5916     die "$buildproductsdir: $!" if $!;
5917     closedir QFD;
5918 }
5919
5920 sub quilt_fixup_delete_pc () {
5921     runcmd @git, qw(rm -rqf .pc);
5922     commit_admin +(__ <<END).<<ENDU
5923 Commit removal of .pc (quilt series tracking data)
5924 END
5925
5926 [dgit ($our_version) upgrade quilt-remove-pc]
5927 ENDU
5928 }
5929
5930 sub quilt_fixup_singlepatch ($$$) {
5931     my ($clogp, $headref, $upstreamversion) = @_;
5932
5933     progress __ "starting quiltify (single-debian-patch)";
5934
5935     # dpkg-source --commit generates new patches even if
5936     # single-debian-patch is in debian/source/options.  In order to
5937     # get it to generate debian/patches/debian-changes, it is
5938     # necessary to build the source package.
5939
5940     unpack_playtree_linkorigs($upstreamversion, sub { });
5941     unpack_playtree_need_cd_work($headref);
5942
5943     rmtree("debian/patches");
5944
5945     runcmd @dpkgsource, qw(-b .);
5946     changedir "..";
5947     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5948     rename srcfn("$upstreamversion", "/debian/patches"),
5949         "work/debian/patches"
5950         or $!==ENOENT
5951         or confess "install d/patches: $!";
5952
5953     changedir "work";
5954     commit_quilty_patch();
5955 }
5956
5957 sub quilt_need_fake_dsc ($) {
5958     # cwd should be playground
5959     my ($upstreamversion) = @_;
5960
5961     return if stat_exists "fake.dsc";
5962     # ^ OK to test this as a sentinel because if we created it
5963     # we must either have done the rest too, or crashed.
5964
5965     my $fakeversion="$upstreamversion-~~DGITFAKE";
5966
5967     my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5968     print $fakedsc <<END or confess "$!";
5969 Format: 3.0 (quilt)
5970 Source: $package
5971 Version: $fakeversion
5972 Files:
5973 END
5974
5975     my $dscaddfile=sub {
5976         my ($leaf) = @_;
5977
5978         my $md = new Digest::MD5;
5979
5980         my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5981         stat $fh or confess "$!";
5982         my $size = -s _;
5983
5984         $md->addfile($fh);
5985         print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5986     };
5987
5988     unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5989
5990     my @files=qw(debian/source/format debian/rules
5991                  debian/control debian/changelog);
5992     foreach my $maybe (qw(debian/patches debian/source/options
5993                           debian/tests/control)) {
5994         next unless stat_exists "$maindir/$maybe";
5995         push @files, $maybe;
5996     }
5997
5998     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5999     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
6000
6001     $dscaddfile->($debtar);
6002     close $fakedsc or confess "$!";
6003 }
6004
6005 sub quilt_fakedsc2unapplied ($$) {
6006     my ($headref, $upstreamversion) = @_;
6007     # must be run in the playground
6008     # quilt_need_fake_dsc must have been called
6009
6010     quilt_need_fake_dsc($upstreamversion);
6011     runcmd qw(sh -ec),
6012         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
6013
6014     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
6015     rename $fakexdir, "fake" or die "$fakexdir $!";
6016
6017     changedir 'fake';
6018
6019     remove_stray_gits(__ "source package");
6020     mktree_in_ud_here();
6021
6022     rmtree '.pc';
6023
6024     rmtree 'debian'; # git checkout commitish paths does not delete!
6025     runcmd @git, qw(checkout -f), $headref, qw(-- debian);
6026     my $unapplied=git_add_write_tree();
6027     printdebug "fake orig tree object $unapplied\n";
6028     return $unapplied;
6029 }
6030
6031 sub quilt_check_splitbrain_cache ($$) {
6032     my ($headref, $upstreamversion) = @_;
6033     # Called only if we are in (potentially) split brain mode.
6034     # Called in playground.
6035     # Computes the cache key and looks in the cache.
6036     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
6037
6038     quilt_need_fake_dsc($upstreamversion);
6039
6040     my $splitbrain_cachekey;
6041
6042     progress f_
6043  "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
6044                 $quilt_mode;
6045     # we look in the reflog of dgit-intern/quilt-cache
6046     # we look for an entry whose message is the key for the cache lookup
6047     my @cachekey = (qw(dgit), $our_version);
6048     push @cachekey, $upstreamversion;
6049     push @cachekey, $quilt_mode;
6050     push @cachekey, $headref;
6051     push @cachekey, $quilt_upstream_commitish // '-';
6052
6053     push @cachekey, hashfile('fake.dsc');
6054
6055     my $srcshash = Digest::SHA->new(256);
6056     my %sfs = ( %INC, '$0(dgit)' => $0 );
6057     foreach my $sfk (sort keys %sfs) {
6058         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6059         $srcshash->add($sfk,"  ");
6060         $srcshash->add(hashfile($sfs{$sfk}));
6061         $srcshash->add("\n");
6062     }
6063     push @cachekey, $srcshash->hexdigest();
6064     $splitbrain_cachekey = "@cachekey";
6065
6066     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6067
6068     my $cachehit = reflog_cache_lookup
6069         "refs/$splitbraincache", $splitbrain_cachekey;
6070
6071     if ($cachehit) {
6072         unpack_playtree_need_cd_work($headref);
6073         my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6074         if ($cachehit ne $headref) {
6075             progress f_ "dgit view: found cached (%s)", $saved;
6076             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6077             $made_split_brain = 1;
6078             return ($cachehit, $splitbrain_cachekey);
6079         }
6080         progress __ "dgit view: found cached, no changes required";
6081         return ($headref, $splitbrain_cachekey);
6082     }
6083
6084     printdebug "splitbrain cache miss\n";
6085     return (undef, $splitbrain_cachekey);
6086 }
6087
6088 sub baredebian_origtarballs_scan ($$$) {
6089     my ($fakedfi, $upstreamversion, $dir) = @_;
6090     if (!opendir OD, $dir) {
6091         return if $! == ENOENT;
6092         fail "opendir $dir (origs): $!";
6093     }
6094
6095     while ($!=0, defined(my $leaf = readdir OD)) {
6096         {
6097             local ($debuglevel) = $debuglevel-1;
6098             printdebug "BDOS $dir $leaf ?\n";
6099         }
6100         next unless is_orig_file_of_vsn $leaf, $upstreamversion;
6101         next if grep { $_->{Filename} eq $leaf } @$fakedfi;
6102         push @$fakedfi, {
6103             Filename => $leaf,
6104             Path => "$dir/$leaf",
6105                         };
6106     }
6107
6108     die "$dir; $!" if $!;
6109     closedir OD;
6110 }
6111
6112 sub quilt_fixup_multipatch ($$$) {
6113     my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6114
6115     progress f_ "examining quilt state (multiple patches, %s mode)",
6116                 $quilt_mode;
6117
6118     # Our objective is:
6119     #  - honour any existing .pc in case it has any strangeness
6120     #  - determine the git commit corresponding to the tip of
6121     #    the patch stack (if there is one)
6122     #  - if there is such a git commit, convert each subsequent
6123     #    git commit into a quilt patch with dpkg-source --commit
6124     #  - otherwise convert all the differences in the tree into
6125     #    a single git commit
6126     #
6127     # To do this we:
6128
6129     # Our git tree doesn't necessarily contain .pc.  (Some versions of
6130     # dgit would include the .pc in the git tree.)  If there isn't
6131     # one, we need to generate one by unpacking the patches that we
6132     # have.
6133     #
6134     # We first look for a .pc in the git tree.  If there is one, we
6135     # will use it.  (This is not the normal case.)
6136     #
6137     # Otherwise need to regenerate .pc so that dpkg-source --commit
6138     # can work.  We do this as follows:
6139     #     1. Collect all relevant .orig from parent directory
6140     #     2. Generate a debian.tar.gz out of
6141     #         debian/{patches,rules,source/format,source/options}
6142     #     3. Generate a fake .dsc containing just these fields:
6143     #          Format Source Version Files
6144     #     4. Extract the fake .dsc
6145     #        Now the fake .dsc has a .pc directory.
6146     # (In fact we do this in every case, because in future we will
6147     # want to search for a good base commit for generating patches.)
6148     #
6149     # Then we can actually do the dpkg-source --commit
6150     #     1. Make a new working tree with the same object
6151     #        store as our main tree and check out the main
6152     #        tree's HEAD.
6153     #     2. Copy .pc from the fake's extraction, if necessary
6154     #     3. Run dpkg-source --commit
6155     #     4. If the result has changes to debian/, then
6156     #          - git add them them
6157     #          - git add .pc if we had a .pc in-tree
6158     #          - git commit
6159     #     5. If we had a .pc in-tree, delete it, and git commit
6160     #     6. Back in the main tree, fast forward to the new HEAD
6161
6162     # Another situation we may have to cope with is gbp-style
6163     # patches-unapplied trees.
6164     #
6165     # We would want to detect these, so we know to escape into
6166     # quilt_fixup_gbp.  However, this is in general not possible.
6167     # Consider a package with a one patch which the dgit user reverts
6168     # (with git revert or the moral equivalent).
6169     #
6170     # That is indistinguishable in contents from a patches-unapplied
6171     # tree.  And looking at the history to distinguish them is not
6172     # useful because the user might have made a confusing-looking git
6173     # history structure (which ought to produce an error if dgit can't
6174     # cope, not a silent reintroduction of an unwanted patch).
6175     #
6176     # So gbp users will have to pass an option.  But we can usually
6177     # detect their failure to do so: if the tree is not a clean
6178     # patches-applied tree, quilt linearisation fails, but the tree
6179     # _is_ a clean patches-unapplied tree, we can suggest that maybe
6180     # they want --quilt=unapplied.
6181     #
6182     # To help detect this, when we are extracting the fake dsc, we
6183     # first extract it with --skip-patches, and then apply the patches
6184     # afterwards with dpkg-source --before-build.  That lets us save a
6185     # tree object corresponding to .origs.
6186
6187     if ($quilt_mode eq 'linear'
6188         && branch_is_gdr($headref)) {
6189         # This is much faster.  It also makes patches that gdr
6190         # likes better for future updates without laundering.
6191         #
6192         # However, it can fail in some casses where we would
6193         # succeed: if there are existing patches, which correspond
6194         # to a prefix of the branch, but are not in gbp/gdr
6195         # format, gdr will fail (exiting status 7), but we might
6196         # be able to figure out where to start linearising.  That
6197         # will be slower so hopefully there's not much to do.
6198
6199         unpack_playtree_need_cd_work $headref;
6200
6201         my @cmd = (@git_debrebase,
6202                    qw(--noop-ok -funclean-mixed -funclean-ordering
6203                       make-patches --quiet-would-amend));
6204         # We tolerate soe snags that gdr wouldn't, by default.
6205         if (act_local()) {
6206             debugcmd "+",@cmd;
6207             $!=0; $?=-1;
6208             failedcmd @cmd
6209                 if system @cmd
6210                 and not ($? == 7*256 or
6211                          $? == -1 && $!==ENOENT);
6212         } else {
6213             dryrun_report @cmd;
6214         }
6215         $headref = git_rev_parse('HEAD');
6216
6217         chdir '..';
6218     }
6219
6220     my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6221
6222     ensuredir '.pc';
6223
6224     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6225     $!=0; $?=-1;
6226     if (system @bbcmd) {
6227         failedcmd @bbcmd if $? < 0;
6228         fail __ <<END;
6229 failed to apply your git tree's patch stack (from debian/patches/) to
6230  the corresponding upstream tarball(s).  Your source tree and .orig
6231  are probably too inconsistent.  dgit can only fix up certain kinds of
6232  anomaly (depending on the quilt mode).  Please see --quilt= in dgit(1).
6233 END
6234     }
6235
6236     changedir '..';
6237
6238     unpack_playtree_need_cd_work($headref);
6239
6240     my $mustdeletepc=0;
6241     if (stat_exists ".pc") {
6242         -d _ or die;
6243         progress __ "Tree already contains .pc - will use it then delete it.";
6244         $mustdeletepc=1;
6245     } else {
6246         rename '../fake/.pc','.pc' or confess "$!";
6247     }
6248
6249     changedir '../fake';
6250     rmtree '.pc';
6251     my $oldtiptree=git_add_write_tree();
6252     printdebug "fake o+d/p tree object $unapplied\n";
6253     changedir '../work';
6254
6255
6256     # We calculate some guesswork now about what kind of tree this might
6257     # be.  This is mostly for error reporting.
6258
6259     my $tentries = cmdoutput @git, qw(ls-tree --name-only -z), $headref;
6260     my $onlydebian = $tentries eq "debian\0";
6261
6262     my $uheadref = $headref;
6263     my $uhead_whatshort = 'HEAD';
6264
6265     if ($quilt_mode =~ m/baredebian\+tarball/) {
6266         # We need to make a tarball import.  Yuk.
6267         # We want to do this here so that we have a $uheadref value
6268
6269         my @fakedfi;
6270         baredebian_origtarballs_scan \@fakedfi, $upstreamversion, bpd_abs();
6271         baredebian_origtarballs_scan \@fakedfi, $upstreamversion,
6272             "$maindir/.." unless $buildproductsdir eq '..';
6273         changedir '..';
6274
6275         my @tartrees = import_tarball_tartrees $upstreamversion, \@fakedfi;
6276
6277         fail __ "baredebian quilt fixup: could not find any origs"
6278             unless @tartrees;
6279
6280         changedir 'work';
6281         my ($authline, $r1authline, $clogp,) =
6282             import_tarball_commits \@tartrees, $upstreamversion;
6283
6284         if (@tartrees == 1) {
6285             $uheadref = $tartrees[0]{Commit};
6286             # TRANSLATORS: this translation must fit in the ASCII art
6287             # quilt differences display.  The untranslated display
6288             # says %9.9s, so with that display it must be at most 9
6289             # characters.
6290             $uhead_whatshort = __ 'tarball';
6291         } else {
6292             # on .dsc import we do not make a separate commit, but
6293             # here we need to do so
6294             rm_subdir_cached '.';
6295             my $parents;
6296             foreach my $ti (@tartrees) {
6297                 my $c = $ti->{Commit};
6298                 if ($ti->{OrigPart} eq 'orig') {
6299                     runcmd qw(git read-tree), $c;
6300                 } elsif ($ti->{OrigPart} =~ m/orig-/) {
6301                     read_tree_subdir $', $c;
6302                 } else {
6303                     confess "$ti->OrigPart} ?"
6304                 }
6305                 $parents .= "parent $c\n";
6306             }
6307             my $tree = git_write_tree();
6308             my $mbody = f_ 'Combine orig tarballs for %s %s',
6309                 $package, $upstreamversion;
6310             $uheadref = hash_commit_text <<END;
6311 tree $tree
6312 ${parents}author $r1authline
6313 committer $r1authline
6314
6315 $mbody
6316
6317 [dgit import tarballs combine $package $upstreamversion]
6318 END
6319             # TRANSLATORS: this translation must fit in the ASCII art
6320             # quilt differences display.  The untranslated display
6321             # says %9.9s, so with that display it must be at most 9
6322             # characters.  This fragmentt is referring to multiple
6323             # orig tarballs in a source package.
6324             $uhead_whatshort = __ 'tarballs';
6325
6326             runcmd @git, qw(reset -q);
6327         }
6328         $quilt_upstream_commitish = $uheadref;
6329         $quilt_upstream_commitish_used = '*orig*';
6330         $quilt_upstream_commitish_message = '';
6331     }
6332     if ($quilt_mode =~ m/baredebian$/) {
6333         $uheadref = $quilt_upstream_commitish;
6334         # TRANSLATORS: this translation must fit in the ASCII art
6335         # quilt differences display.  The untranslated display
6336         # says %9.9s, so with that display it must be at most 9
6337         # characters.
6338         $uhead_whatshort = __ 'upstream';
6339     }
6340
6341     my %editedignores;
6342     my @unrepres;
6343     my $diffbits = {
6344         # H = user's HEAD
6345         # O = orig, without patches applied
6346         # A = "applied", ie orig with H's debian/patches applied
6347         O2H => quiltify_trees_differ($unapplied,$uheadref,   1,
6348                                      \%editedignores, \@unrepres),
6349         H2A => quiltify_trees_differ($uheadref, $oldtiptree,1),
6350         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6351     };
6352
6353     my @dl;
6354     foreach my $bits (qw(01 02)) {
6355         foreach my $v (qw(O2H O2A H2A)) {
6356             push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6357         }
6358     }
6359     printdebug "differences \@dl @dl.\n";
6360
6361     progress f_
6362 "%s: base trees orig=%.20s o+d/p=%.20s",
6363               $us, $unapplied, $oldtiptree;
6364     # TRANSLATORS: Try to keep this ascii-art layout right.  The 0s in
6365     # %9.00009s will be ignored and are there to make the format the
6366     # same length (9 characters) as the output it generates.  If you
6367     # change the value 9, your translations of "upstream" and
6368     # 'tarball' must fit into the new length, and you should change
6369     # the number of 0s.  Do not reduce it below 4 as HEAD has to fit
6370     # too.
6371     progress f_
6372 "%s: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
6373 "%s: quilt differences: %9.00009s %s o+d/p          %9.00009s %s o+d/p",
6374   $us,                      $dl[0], $dl[1],              $dl[3], $dl[4],
6375   $us,        $uhead_whatshort, $dl[2],   $uhead_whatshort, $dl[5];
6376
6377     if (@unrepres && $quilt_mode !~ m/baredebian/) {
6378         # With baredebian, even if the upstream commitish has this
6379         # problem, we don't want to print this message, as nothing
6380         # is going to try to make a patch out of it anyway.
6381         print STDERR f_ "dgit:  cannot represent change: %s: %s\n",
6382                         $_->[1], $_->[0]
6383             foreach @unrepres;
6384         forceable_fail [qw(unrepresentable)], __ <<END;
6385 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6386 END
6387     }
6388
6389     my @failsuggestion;
6390     if ($onlydebian) {
6391         push @failsuggestion, [ 'onlydebian', __
6392  "This has only a debian/ directory; you probably want --quilt=bare debian." ]
6393             unless $quilt_mode =~ m/baredebian/;
6394     } elsif (!($diffbits->{O2H} & $diffbits->{O2A})) {
6395         push @failsuggestion, [ 'unapplied', __
6396  "This might be a patches-unapplied branch." ];
6397     } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6398         push @failsuggestion, [ 'applied', __
6399  "This might be a patches-applied branch." ];
6400     }
6401     push @failsuggestion, [ 'quilt-mode', __
6402  "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6403
6404     push @failsuggestion, [ 'gitattrs', __
6405  "Warning: Tree has .gitattributes.  See GITATTRIBUTES in dgit(7)." ]
6406         if stat_exists '.gitattributes';
6407
6408     push @failsuggestion, [ 'origs', __
6409  "Maybe orig tarball(s) are not identical to git representation?" ]
6410         unless $onlydebian && $quilt_mode !~ m/baredebian/;
6411                # ^ in that case, we didn't really look properly
6412
6413     if (quiltmode_splitting()) {
6414         quiltify_splitting($clogp, $unapplied, $headref, $oldtiptree,
6415                            $diffbits, \%editedignores,
6416                            $splitbrain_cachekey);
6417         return;
6418     }
6419
6420     progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6421     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6422     runcmd @git, qw(checkout -q), (qw(master dgit-view)[do_split_brain()]);
6423
6424     if (!open P, '>>', ".pc/applied-patches") {
6425         $!==&ENOENT or confess "$!";
6426     } else {
6427         close P;
6428     }
6429
6430     commit_quilty_patch();
6431
6432     if ($mustdeletepc) {
6433         quilt_fixup_delete_pc();
6434     }
6435 }
6436
6437 sub quilt_fixup_editor () {
6438     my $descfn = $ENV{$fakeeditorenv};
6439     my $editing = $ARGV[$#ARGV];
6440     open I1, '<', $descfn or confess "$descfn: $!";
6441     open I2, '<', $editing or confess "$editing: $!";
6442     unlink $editing or confess "$editing: $!";
6443     open O, '>', $editing or confess "$editing: $!";
6444     while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6445     my $copying = 0;
6446     while (<I2>) {
6447         $copying ||= m/^\-\-\- /;
6448         next unless $copying;
6449         print O or confess "$!";
6450     }
6451     I2->error and confess "$!";
6452     close O or die $1;
6453     finish 0;
6454 }
6455
6456 sub maybe_apply_patches_dirtily () {
6457     return unless $quilt_mode =~ m/gbp|unapplied|baredebian/;
6458     print STDERR __ <<END or confess "$!";
6459
6460 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6461 dgit: Have to apply the patches - making the tree dirty.
6462 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6463
6464 END
6465     $patches_applied_dirtily = 01;
6466     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6467     runcmd qw(dpkg-source --before-build .);
6468 }
6469
6470 sub maybe_unapply_patches_again () {
6471     progress __ "dgit: Unapplying patches again to tidy up the tree."
6472         if $patches_applied_dirtily;
6473     runcmd qw(dpkg-source --after-build .)
6474         if $patches_applied_dirtily & 01;
6475     rmtree '.pc'
6476         if $patches_applied_dirtily & 02;
6477     $patches_applied_dirtily = 0;
6478 }
6479
6480 #----- other building -----
6481
6482 sub clean_tree_check_git ($$$) {
6483     my ($honour_ignores, $message, $ignmessage) = @_;
6484     my @cmd = (@git, qw(clean -dn));
6485     push @cmd, qw(-x) unless $honour_ignores;
6486     my $leftovers = cmdoutput @cmd;
6487     if (length $leftovers) {
6488         print STDERR $leftovers, "\n" or confess "$!";
6489         $message .= $ignmessage if $honour_ignores;
6490         fail $message;
6491     }
6492 }
6493
6494 sub clean_tree_check_git_wd ($) {
6495     my ($message) = @_;
6496     return if $cleanmode =~ m{no-check};
6497     return if $patches_applied_dirtily; # yuk
6498     clean_tree_check_git +($cleanmode !~ m{all-check}),
6499         $message, "\n".__ <<END;
6500 If this is just missing .gitignore entries, use a different clean
6501 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6502 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6503 END
6504 }
6505
6506 sub clean_tree_check () {
6507     # This function needs to not care about modified but tracked files.
6508     # That was done by check_not_dirty, and by now we may have run
6509     # the rules clean target which might modify tracked files (!)
6510     if ($cleanmode =~ m{^check}) {
6511         clean_tree_check_git +($cleanmode =~ m{ignores}), __
6512  "tree contains uncommitted files and --clean=check specified", '';
6513     } elsif ($cleanmode =~ m{^dpkg-source}) {
6514         clean_tree_check_git_wd __
6515  "tree contains uncommitted files (NB dgit didn't run rules clean)";
6516     } elsif ($cleanmode =~ m{^git}) {
6517         clean_tree_check_git 1, __
6518  "tree contains uncommited, untracked, unignored files\n".
6519  "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6520     } elsif ($cleanmode eq 'none') {
6521     } else {
6522         confess "$cleanmode ?";
6523     }
6524 }
6525
6526 sub clean_tree () {
6527     # We always clean the tree ourselves, rather than leave it to the
6528     # builder (dpkg-source, or soemthing which calls dpkg-source).
6529     if ($quilt_mode =~ m/baredebian/ and $cleanmode =~ m/git/) {
6530         fail f_ <<END, $quilt_mode, $cleanmode;
6531 quilt mode %s (generally needs untracked upstream files)
6532 contradicts clean mode %s (which would delete them)
6533 END
6534         # This is not 100% true: dgit build-source and push-source
6535         # (for example) could operate just fine with no upstream
6536         # source in the working tree.  But it doesn't seem likely that
6537         # the user wants dgit to proactively delete such things.
6538         # -wn, for example, would produce identical output without
6539         # deleting anything from the working tree.
6540     }
6541     if ($cleanmode =~ m{^dpkg-source}) {
6542         my @cmd = @dpkgbuildpackage;
6543         push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6544         push @cmd, qw(-T clean);
6545         maybe_apply_patches_dirtily();
6546         runcmd_ordryrun_local @cmd;
6547         clean_tree_check_git_wd __
6548  "tree contains uncommitted files (after running rules clean)";
6549     } elsif ($cleanmode =~ m{^git(?!-)}) {
6550         runcmd_ordryrun_local @git, qw(clean -xdf);
6551     } elsif ($cleanmode =~ m{^git-ff}) {
6552         runcmd_ordryrun_local @git, qw(clean -xdff);
6553     } elsif ($cleanmode =~ m{^check}) {
6554         clean_tree_check();
6555     } elsif ($cleanmode eq 'none') {
6556     } else {
6557         confess "$cleanmode ?";
6558     }
6559 }
6560
6561 sub cmd_clean () {
6562     badusage __ "clean takes no additional arguments" if @ARGV;
6563     notpushing();
6564     clean_tree();
6565     maybe_unapply_patches_again();
6566 }
6567
6568 # return values from massage_dbp_args are one or both of these flags
6569 sub WANTSRC_SOURCE  () { 01; } # caller should build source (separately)
6570 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6571
6572 sub build_or_push_prep_early () {
6573     our $build_or_push_prep_early_done //= 0;
6574     return if $build_or_push_prep_early_done++;
6575     badusage f_ "-p is not allowed with dgit %s", $subcommand
6576         if defined $package;
6577     my $clogp = parsechangelog();
6578     $isuite = getfield $clogp, 'Distribution';
6579     $package = getfield $clogp, 'Source';
6580     $version = getfield $clogp, 'Version';
6581     $dscfn = dscfn($version);
6582 }
6583
6584 sub build_or_push_prep_modes () {
6585     my ($format) = get_source_format();
6586     determine_whether_split_brain($format);
6587
6588     fail __ "dgit: --include-dirty is not supported with split view".
6589             " (including with view-splitting quilt modes)"
6590         if do_split_brain() && $includedirty;
6591
6592     if (madformat_wantfixup $format and $quilt_mode =~ m/baredebian$/) {
6593         ($quilt_upstream_commitish, $quilt_upstream_commitish_used,
6594          $quilt_upstream_commitish_message)
6595             = resolve_upstream_version
6596             $quilt_upstream_commitish, upstreamversion $version;
6597         progress f_ "dgit: --quilt=%s, %s", $quilt_mode,
6598             $quilt_upstream_commitish_message;
6599     } elsif (defined $quilt_upstream_commitish) {
6600         fail __
6601  "dgit: --upstream-commitish only makes sense with --quilt=baredebian"
6602     }
6603 }
6604
6605 sub build_prep_early () {
6606     build_or_push_prep_early();
6607     notpushing();
6608     build_or_push_prep_modes();
6609     check_not_dirty();
6610 }
6611
6612 sub build_prep ($) {
6613     my ($wantsrc) = @_;
6614     build_prep_early();
6615     check_bpd_exists();
6616     if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6617         # Clean the tree because we're going to use the contents of
6618         # $maindir.  (We trying to include dirty changes in the source
6619         # package, or we are running the builder in $maindir.)
6620         || $cleanmode =~ m{always}) {
6621         # Or because the user asked us to.
6622         clean_tree();
6623     } else {
6624         # We don't actually need to do anything in $maindir, but we
6625         # should do some kind of cleanliness check because (i) the
6626         # user may have forgotten a `git add', and (ii) if the user
6627         # said -wc we should still do the check.
6628         clean_tree_check();
6629     }
6630     build_check_quilt_splitbrain();
6631     if ($rmchanges) {
6632         my $pat = changespat $version;
6633         foreach my $f (glob "$buildproductsdir/$pat") {
6634             if (act_local()) {
6635                 unlink $f or
6636                     fail f_ "remove old changes file %s: %s", $f, $!;
6637             } else {
6638                 progress f_ "would remove %s", $f;
6639             }
6640         }
6641     }
6642 }
6643
6644 sub changesopts_initial () {
6645     my @opts =@changesopts[1..$#changesopts];
6646 }
6647
6648 sub changesopts_version () {
6649     if (!defined $changes_since_version) {
6650         my @vsns;
6651         unless (eval {
6652             @vsns = archive_query('archive_query');
6653             my @quirk = access_quirk();
6654             if ($quirk[0] eq 'backports') {
6655                 local $isuite = $quirk[2];
6656                 local $csuite;
6657                 canonicalise_suite();
6658                 push @vsns, archive_query('archive_query');
6659             }
6660             1;
6661         }) {
6662             print STDERR $@;
6663             fail __
6664  "archive query failed (queried because --since-version not specified)";
6665         }
6666         if (@vsns) {
6667             @vsns = map { $_->[0] } @vsns;
6668             @vsns = sort { -version_compare($a, $b) } @vsns;
6669             $changes_since_version = $vsns[0];
6670             progress f_ "changelog will contain changes since %s", $vsns[0];
6671         } else {
6672             $changes_since_version = '_';
6673             progress __ "package seems new, not specifying -v<version>";
6674         }
6675     }
6676     if ($changes_since_version ne '_') {
6677         return ("-v$changes_since_version");
6678     } else {
6679         return ();
6680     }
6681 }
6682
6683 sub changesopts () {
6684     return (changesopts_initial(), changesopts_version());
6685 }
6686
6687 sub massage_dbp_args ($;$) {
6688     my ($cmd,$xargs) = @_;
6689     # Since we split the source build out so we can do strange things
6690     # to it, massage the arguments to dpkg-buildpackage so that the
6691     # main build doessn't build source (or add an argument to stop it
6692     # building source by default).
6693     debugcmd '#massaging#', @$cmd if $debuglevel>1;
6694     # -nc has the side effect of specifying -b if nothing else specified
6695     # and some combinations of -S, -b, et al, are errors, rather than
6696     # later simply overriding earlie.  So we need to:
6697     #  - search the command line for these options
6698     #  - pick the last one
6699     #  - perhaps add our own as a default
6700     #  - perhaps adjust it to the corresponding non-source-building version
6701     my $dmode = '-F';
6702     foreach my $l ($cmd, $xargs) {
6703         next unless $l;
6704         @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6705     }
6706     push @$cmd, '-nc';
6707 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6708     my $r = WANTSRC_BUILDER;
6709     printdebug "massage split $dmode.\n";
6710     if ($dmode =~ s/^--build=//) {
6711         $r = 0;
6712         my @d = split /,/, $dmode;
6713         $r |= WANTSRC_SOURCE  if grep { s/^full$/binary/ } @d;
6714         $r |= WANTSRC_SOURCE  if grep { s/^source$// } @d;
6715         $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6716         fail __ "Wanted to build nothing!" unless $r;
6717         $dmode = '--build='. join ',', grep m/./, @d;
6718     } else {
6719         $r =
6720           $dmode =~ m/[S]/     ?  WANTSRC_SOURCE :
6721           $dmode =~ y/gGF/ABb/ ?  WANTSRC_SOURCE | WANTSRC_BUILDER :
6722           $dmode =~ m/[ABb]/   ?                   WANTSRC_BUILDER :
6723           confess "$dmode ?";
6724     }
6725     printdebug "massage done $r $dmode.\n";
6726     push @$cmd, $dmode;
6727 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6728     return $r;
6729 }
6730
6731 sub in_bpd (&) {
6732     my ($fn) = @_;
6733     my $wasdir = must_getcwd();
6734     changedir $buildproductsdir;
6735     $fn->();
6736     changedir $wasdir;
6737 }
6738
6739 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6740 sub postbuild_mergechanges ($) {
6741     my ($msg_if_onlyone) = @_;
6742     # If there is only one .changes file, fail with $msg_if_onlyone,
6743     # or if that is undef, be a no-op.
6744     # Returns the changes file to report to the user.
6745     my $pat = changespat $version;
6746     my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6747     @changesfiles = sort {
6748         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6749             or $a cmp $b
6750     } @changesfiles;
6751     my $result;
6752     if (@changesfiles==1) {
6753         fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6754 only one changes file from build (%s)
6755 END
6756             if defined $msg_if_onlyone;
6757         $result = $changesfiles[0];
6758     } elsif (@changesfiles==2) {
6759         my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6760         foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6761             fail f_ "%s found in binaries changes file %s", $l, $binchanges
6762                 if $l =~ m/\.dsc$/;
6763         }
6764         runcmd_ordryrun_local @mergechanges, @changesfiles;
6765         my $multichanges = changespat $version,'multi';
6766         if (act_local()) {
6767             stat_exists $multichanges or fail f_
6768                 "%s unexpectedly not created by build", $multichanges;
6769             foreach my $cf (glob $pat) {
6770                 next if $cf eq $multichanges;
6771                 rename "$cf", "$cf.inmulti" or fail f_
6772                     "install new changes %s\{,.inmulti}: %s", $cf, $!;
6773             }
6774         }
6775         $result = $multichanges;
6776     } else {
6777         fail f_ "wrong number of different changes files (%s)",
6778                 "@changesfiles";
6779     }
6780     printdone f_ "build successful, results in %s\n", $result
6781         or confess "$!";
6782 }
6783
6784 sub midbuild_checkchanges () {
6785     my $pat = changespat $version;
6786     return if $rmchanges;
6787     my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6788     @unwanted = grep {
6789         $_ ne changespat $version,'source' and
6790         $_ ne changespat $version,'multi'
6791     } @unwanted;
6792     fail +(f_ <<END, $pat, "@unwanted")
6793 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6794 Suggest you delete %s.
6795 END
6796         if @unwanted;
6797 }
6798
6799 sub midbuild_checkchanges_vanilla ($) {
6800     my ($wantsrc) = @_;
6801     midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6802 }
6803
6804 sub postbuild_mergechanges_vanilla ($) {
6805     my ($wantsrc) = @_;
6806     if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6807         in_bpd {
6808             postbuild_mergechanges(undef);
6809         };
6810     } else {
6811         printdone __ "build successful\n";
6812     }
6813 }
6814
6815 sub cmd_build {
6816     build_prep_early();
6817     $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6818 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6819 %s: warning: build-products-dir will be ignored; files will go to ..
6820 END
6821     $buildproductsdir = '..';
6822     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6823     my $wantsrc = massage_dbp_args \@dbp;
6824     build_prep($wantsrc);
6825     if ($wantsrc & WANTSRC_SOURCE) {
6826         build_source();
6827         midbuild_checkchanges_vanilla $wantsrc;
6828     }
6829     if ($wantsrc & WANTSRC_BUILDER) {
6830         push @dbp, changesopts_version();
6831         maybe_apply_patches_dirtily();
6832         runcmd_ordryrun_local @dbp;
6833     }
6834     maybe_unapply_patches_again();
6835     postbuild_mergechanges_vanilla $wantsrc;
6836 }
6837
6838 sub pre_gbp_build {
6839     $quilt_mode //= 'gbp';
6840 }
6841
6842 sub cmd_gbp_build {
6843     build_prep_early();
6844
6845     # gbp can make .origs out of thin air.  In my tests it does this
6846     # even for a 1.0 format package, with no origs present.  So I
6847     # guess it keys off just the version number.  We don't know
6848     # exactly what .origs ought to exist, but let's assume that we
6849     # should run gbp if: the version has an upstream part and the main
6850     # orig is absent.
6851     my $upstreamversion = upstreamversion $version;
6852     my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6853     my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6854
6855     if ($gbp_make_orig) {
6856         clean_tree();
6857         $cleanmode = 'none'; # don't do it again
6858     }
6859
6860     my @dbp = @dpkgbuildpackage;
6861
6862     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6863
6864     if (!length $gbp_build[0]) {
6865         if (length executable_on_path('git-buildpackage')) {
6866             $gbp_build[0] = qw(git-buildpackage);
6867         } else {
6868             $gbp_build[0] = 'gbp buildpackage';
6869         }
6870     }
6871     my @cmd = opts_opt_multi_cmd [], @gbp_build;
6872
6873     push @cmd, (qw(-us -uc --git-no-sign-tags),
6874                 "--git-builder=".(shellquote @dbp));
6875
6876     if ($gbp_make_orig) {
6877         my $priv = dgit_privdir();
6878         my $ok = "$priv/origs-gen-ok";
6879         unlink $ok or $!==&ENOENT or confess "$!";
6880         my @origs_cmd = @cmd;
6881         push @origs_cmd, qw(--git-cleaner=true);
6882         push @origs_cmd, "--git-prebuild=".
6883             "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6884         push @origs_cmd, @ARGV;
6885         if (act_local()) {
6886             debugcmd @origs_cmd;
6887             system @origs_cmd;
6888             do { local $!; stat_exists $ok; }
6889                 or failedcmd @origs_cmd;
6890         } else {
6891             dryrun_report @origs_cmd;
6892         }
6893     }
6894
6895     build_prep($wantsrc);
6896     if ($wantsrc & WANTSRC_SOURCE) {
6897         build_source();
6898         midbuild_checkchanges_vanilla $wantsrc;
6899     } else {
6900         push @cmd, '--git-cleaner=true';
6901     }
6902     maybe_unapply_patches_again();
6903     if ($wantsrc & WANTSRC_BUILDER) {
6904         push @cmd, changesopts();
6905         runcmd_ordryrun_local @cmd, @ARGV;
6906     }
6907     postbuild_mergechanges_vanilla $wantsrc;
6908 }
6909 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6910
6911 sub building_source_in_playtree {
6912     # If $includedirty, we have to build the source package from the
6913     # working tree, not a playtree, so that uncommitted changes are
6914     # included (copying or hardlinking them into the playtree could
6915     # cause trouble).
6916     #
6917     # Note that if we are building a source package in split brain
6918     # mode we do not support including uncommitted changes, because
6919     # that makes quilt fixup too hard.  I.e. ($made_split_brain && (dgit is
6920     # building a source package)) => !$includedirty
6921     return !$includedirty;
6922 }
6923
6924 sub build_source {
6925     $sourcechanges = changespat $version,'source';
6926     if (act_local()) {
6927         unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6928             or fail f_ "remove %s: %s", $sourcechanges, $!;
6929     }
6930 #    confess unless !!$made_split_brain == do_split_brain();
6931
6932     my @cmd = (@dpkgsource, qw(-b --));
6933     my $leafdir;
6934     if (building_source_in_playtree()) {
6935         $leafdir = 'work';
6936         my $headref = git_rev_parse('HEAD');
6937         # If we are in split brain, there is already a playtree with
6938         # the thing we should package into a .dsc (thanks to quilt
6939         # fixup).  If not, make a playtree
6940         prep_ud() unless $made_split_brain;
6941         changedir $playground;
6942         unless ($made_split_brain) {
6943             my $upstreamversion = upstreamversion $version;
6944             unpack_playtree_linkorigs($upstreamversion, sub { });
6945             unpack_playtree_need_cd_work($headref);
6946             changedir '..';
6947         }
6948     } else {
6949         $leafdir = basename $maindir;
6950
6951         if ($buildproductsdir ne '..') {
6952             # Well, we are going to run dpkg-source -b which consumes
6953             # origs from .. and generates output there.  To make this
6954             # work when the bpd is not .. , we would have to (i) link
6955             # origs from bpd to .. , (ii) check for files that
6956             # dpkg-source -b would/might overwrite, and afterwards
6957             # (iii) move all the outputs back to the bpd (iv) except
6958             # for the origs which should be deleted from .. if they
6959             # weren't there beforehand.  And if there is an error and
6960             # we don't run to completion we would necessarily leave a
6961             # mess.  This is too much.  The real way to fix this
6962             # is for dpkg-source to have bpd support.
6963             confess unless $includedirty;
6964             fail __
6965  "--include-dirty not supported with --build-products-dir, sorry";
6966         }
6967
6968         changedir '..';
6969     }
6970     runcmd_ordryrun_local @cmd, $leafdir;
6971
6972     changedir $leafdir;
6973     runcmd_ordryrun_local qw(sh -ec),
6974       'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6975       @dpkggenchanges, qw(-S), changesopts();
6976     changedir '..';
6977
6978     printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6979     $dsc = parsecontrol($dscfn, "source package");
6980
6981     my $mv = sub {
6982         my ($why, $l) = @_;
6983         printdebug " renaming ($why) $l\n";
6984         rename_link_xf 0, "$l", bpd_abs()."/$l"
6985             or fail f_ "put in place new built file (%s): %s", $l, $@;
6986     };
6987     foreach my $l (split /\n/, getfield $dsc, 'Files') {
6988         $l =~ m/\S+$/ or next;
6989         $mv->('Files', $&);
6990     }
6991     $mv->('dsc', $dscfn);
6992     $mv->('changes', $sourcechanges);
6993
6994     changedir $maindir;
6995 }
6996
6997 sub cmd_build_source {
6998     badusage __ "build-source takes no additional arguments" if @ARGV;
6999     build_prep(WANTSRC_SOURCE);
7000     build_source();
7001     maybe_unapply_patches_again();
7002     printdone f_ "source built, results in %s and %s",
7003                  $dscfn, $sourcechanges;
7004 }
7005
7006 sub cmd_push_source {
7007     prep_push();
7008     fail __
7009         "dgit push-source: --include-dirty/--ignore-dirty does not make".
7010         "sense with push-source!"
7011         if $includedirty;
7012     build_check_quilt_splitbrain();
7013     if ($changesfile) {
7014         my $changes = parsecontrol("$buildproductsdir/$changesfile",
7015                                    __ "source changes file");
7016         unless (test_source_only_changes($changes)) {
7017             fail __ "user-specified changes file is not source-only";
7018         }
7019     } else {
7020         # Building a source package is very fast, so just do it
7021         build_source();
7022         confess "er, patches are applied dirtily but shouldn't be.."
7023             if $patches_applied_dirtily;
7024         $changesfile = $sourcechanges;
7025     }
7026     dopush();
7027 }
7028
7029 sub binary_builder {
7030     my ($bbuilder, $pbmc_msg, @args) = @_;
7031     build_prep(WANTSRC_SOURCE);
7032     build_source();
7033     midbuild_checkchanges();
7034     in_bpd {
7035         if (act_local()) {
7036             stat_exists $dscfn or fail f_
7037                 "%s (in build products dir): %s", $dscfn, $!;
7038             stat_exists $sourcechanges or fail f_
7039                 "%s (in build products dir): %s", $sourcechanges, $!;
7040         }
7041         runcmd_ordryrun_local @$bbuilder, @args;
7042     };
7043     maybe_unapply_patches_again();
7044     in_bpd {
7045         postbuild_mergechanges($pbmc_msg);
7046     };
7047 }
7048
7049 sub cmd_sbuild {
7050     build_prep_early();
7051     binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
7052 perhaps you need to pass -A ?  (sbuild's default is to build only
7053 arch-specific binaries; dgit 1.4 used to override that.)
7054 END
7055 }
7056
7057 sub pbuilder ($) {
7058     my ($pbuilder) = @_;
7059     build_prep_early();
7060     # @ARGV is allowed to contain only things that should be passed to
7061     # pbuilder under debbuildopts; just massage those
7062     my $wantsrc = massage_dbp_args \@ARGV;
7063     fail __
7064         "you asked for a builder but your debbuildopts didn't ask for".
7065         " any binaries -- is this really what you meant?"
7066         unless $wantsrc & WANTSRC_BUILDER;
7067     fail __
7068         "we must build a .dsc to pass to the builder but your debbuiltopts".
7069         " forbids the building of a source package; cannot continue"
7070       unless $wantsrc & WANTSRC_SOURCE;
7071     # We do not want to include the verb "build" in @pbuilder because
7072     # the user can customise @pbuilder and they shouldn't be required
7073     # to include "build" in their customised value.  However, if the
7074     # user passes any additional args to pbuilder using the dgit
7075     # option --pbuilder:foo, such args need to come after the "build"
7076     # verb.  opts_opt_multi_cmd does all of that.
7077     binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
7078                    qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
7079                    $dscfn);
7080 }
7081
7082 sub cmd_pbuilder {
7083     pbuilder(\@pbuilder);
7084 }
7085
7086 sub cmd_cowbuilder {
7087     pbuilder(\@cowbuilder);
7088 }
7089
7090 sub cmd_quilt_fixup {
7091     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
7092     build_prep_early();
7093     clean_tree();
7094     build_maybe_quilt_fixup();
7095 }
7096
7097 sub cmd_print_unapplied_treeish {
7098     badusage __ "incorrect arguments to dgit print-unapplied-treeish"
7099         if @ARGV;
7100     my $headref = git_rev_parse('HEAD');
7101     my $clogp = commit_getclogp $headref;
7102     $package = getfield $clogp, 'Source';
7103     $version = getfield $clogp, 'Version';
7104     $isuite = getfield $clogp, 'Distribution';
7105     $csuite = $isuite; # we want this to be offline!
7106     notpushing();
7107
7108     prep_ud();
7109     changedir $playground;
7110     my $uv = upstreamversion $version;
7111     my $u = quilt_fakedsc2unapplied($headref, $uv);
7112     print $u, "\n" or confess "$!";
7113 }
7114
7115 sub import_dsc_result {
7116     my ($dstref, $newhash, $what_log, $what_msg) = @_;
7117     my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
7118     runcmd @cmd;
7119     check_gitattrs($newhash, __ "source tree");
7120
7121     progress f_ "dgit: import-dsc: %s", $what_msg;
7122 }
7123
7124 sub cmd_import_dsc {
7125     my $needsig = 0;
7126
7127     while (@ARGV) {
7128         last unless $ARGV[0] =~ m/^-/;
7129         $_ = shift @ARGV;
7130         last if m/^--?$/;
7131         if (m/^--require-valid-signature$/) {
7132             $needsig = 1;
7133         } else {
7134             badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
7135         }
7136     }
7137
7138     badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
7139         unless @ARGV==2;
7140     my ($dscfn, $dstbranch) = @ARGV;
7141
7142     badusage __ "dry run makes no sense with import-dsc"
7143         unless act_local();
7144
7145     my $force = $dstbranch =~ s/^\+//   ? +1 :
7146                 $dstbranch =~ s/^\.\.// ? -1 :
7147                                            0;
7148     my $info = $force ? " $&" : '';
7149     $info = "$dscfn$info";
7150
7151     my $specbranch = $dstbranch;
7152     $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
7153     $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
7154
7155     my @symcmd = (@git, qw(symbolic-ref -q HEAD));
7156     my $chead = cmdoutput_errok @symcmd;
7157     defined $chead or $?==256 or failedcmd @symcmd;
7158
7159     fail f_ "%s is checked out - will not update it", $dstbranch
7160         if defined $chead and $chead eq $dstbranch;
7161
7162     my $oldhash = git_get_ref $dstbranch;
7163
7164     open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
7165     $dscdata = do { local $/ = undef; <D>; };
7166     D->error and fail f_ "read %s: %s", $dscfn, $!;
7167     close C;
7168
7169     # we don't normally need this so import it here
7170     use Dpkg::Source::Package;
7171     my $dp = new Dpkg::Source::Package filename => $dscfn,
7172         require_valid_signature => $needsig;
7173     {
7174         local $SIG{__WARN__} = sub {
7175             print STDERR $_[0];
7176             return unless $needsig;
7177             fail __ "import-dsc signature check failed";
7178         };
7179         if (!$dp->is_signed()) {
7180             warn f_ "%s: warning: importing unsigned .dsc\n", $us;
7181         } else {
7182             my $r = $dp->check_signature();
7183             confess "->check_signature => $r" if $needsig && $r;
7184         }
7185     }
7186
7187     parse_dscdata();
7188
7189     $package = getfield $dsc, 'Source';
7190
7191     parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
7192         unless forceing [qw(import-dsc-with-dgit-field)];
7193     parse_dsc_field_def_dsc_distro();
7194
7195     $isuite = 'DGIT-IMPORT-DSC';
7196     $idistro //= $dsc_distro;
7197
7198     notpushing();
7199
7200     if (defined $dsc_hash) {
7201         progress __
7202             "dgit: import-dsc of .dsc with Dgit field, using git hash";
7203         resolve_dsc_field_commit undef, undef;
7204     }
7205     if (defined $dsc_hash) {
7206         my @cmd = (qw(sh -ec),
7207                    "echo $dsc_hash | git cat-file --batch-check");
7208         my $objgot = cmdoutput @cmd;
7209         if ($objgot =~ m#^\w+ missing\b#) {
7210             fail f_ <<END, $dsc_hash
7211 .dsc contains Dgit field referring to object %s
7212 Your git tree does not have that object.  Try `git fetch' from a
7213 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
7214 END
7215         }
7216         if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
7217             if ($force > 0) {
7218                 progress __ "Not fast forward, forced update.";
7219             } else {
7220                 fail f_ "Not fast forward to %s", $dsc_hash;
7221             }
7222         }
7223         import_dsc_result $dstbranch, $dsc_hash,
7224             "dgit import-dsc (Dgit): $info",
7225             f_ "updated git ref %s", $dstbranch;
7226         return 0;
7227     }
7228
7229     fail f_ <<END, $dstbranch, $specbranch, $specbranch
7230 Branch %s already exists
7231 Specify ..%s for a pseudo-merge, binding in existing history
7232 Specify  +%s to overwrite, discarding existing history
7233 END
7234         if $oldhash && !$force;
7235
7236     my @dfi = dsc_files_info();
7237     foreach my $fi (@dfi) {
7238         my $f = $fi->{Filename};
7239         # We transfer all the pieces of the dsc to the bpd, not just
7240         # origs.  This is by analogy with dgit fetch, which wants to
7241         # keep them somewhere to avoid downloading them again.
7242         # We make symlinks, though.  If the user wants copies, then
7243         # they can copy the parts of the dsc to the bpd using dcmd,
7244         # or something.
7245         my $here = "$buildproductsdir/$f";
7246         if (lstat $here) {
7247             if (stat $here) {
7248                 next;
7249             }
7250             fail f_ "lstat %s works but stat gives %s !", $here, $!;
7251         }
7252         fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7253         printdebug "not in bpd, $f ...\n";
7254         # $f does not exist in bpd, we need to transfer it
7255         my $there = $dscfn;
7256         $there =~ s{[^/]+$}{$f} or confess "$there ?";
7257         # $there is file we want, relative to user's cwd, or abs
7258         printdebug "not in bpd, $f, test $there ...\n";
7259         stat $there or fail f_
7260             "import %s requires %s, but: %s", $dscfn, $there, $!;
7261         if ($there =~ m#^(?:\./+)?\.\./+#) {
7262             # $there is relative to user's cwd
7263             my $there_from_parent = $';
7264             if ($buildproductsdir !~ m{^/}) {
7265                 # abs2rel, despite its name, can take two relative paths
7266                 $there = File::Spec->abs2rel($there,$buildproductsdir);
7267                 # now $there is relative to bpd, great
7268                 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7269             } else {
7270                 $there = (dirname $maindir)."/$there_from_parent";
7271                 # now $there is absoute
7272                 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7273             }
7274         } elsif ($there =~ m#^/#) {
7275             # $there is absolute already
7276             printdebug "not in bpd, $f, abs, $there ...\n";
7277         } else {
7278             fail f_
7279                 "cannot import %s which seems to be inside working tree!",
7280                 $dscfn;
7281         }
7282         symlink $there, $here or fail f_
7283             "symlink %s to %s: %s", $there, $here, $!;
7284         progress f_ "made symlink %s -> %s", $here, $there;
7285 #       print STDERR Dumper($fi);
7286     }
7287     my @mergeinputs = generate_commits_from_dsc();
7288     die unless @mergeinputs == 1;
7289
7290     my $newhash = $mergeinputs[0]{Commit};
7291
7292     if ($oldhash) {
7293         if ($force > 0) {
7294             progress __
7295                 "Import, forced update - synthetic orphan git history.";
7296         } elsif ($force < 0) {
7297             progress __ "Import, merging.";
7298             my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7299             my $version = getfield $dsc, 'Version';
7300             my $clogp = commit_getclogp $newhash;
7301             my $authline = clogp_authline $clogp;
7302             $newhash = hash_commit_text <<ENDU
7303 tree $tree
7304 parent $newhash
7305 parent $oldhash
7306 author $authline
7307 committer $authline
7308
7309 ENDU
7310                 .(f_ <<END, $package, $version, $dstbranch);
7311 Merge %s (%s) import into %s
7312 END
7313         } else {
7314             die; # caught earlier
7315         }
7316     }
7317
7318     import_dsc_result $dstbranch, $newhash,
7319         "dgit import-dsc: $info",
7320         f_ "results are in git ref %s", $dstbranch;
7321 }
7322
7323 sub pre_archive_api_query () {
7324     not_necessarily_a_tree();
7325 }
7326 sub cmd_archive_api_query {
7327     badusage __ "need only 1 subpath argument" unless @ARGV==1;
7328     my ($subpath) = @ARGV;
7329     local $isuite = 'DGIT-API-QUERY-CMD';
7330     my @cmd = archive_api_query_cmd($subpath);
7331     push @cmd, qw(-f);
7332     debugcmd ">",@cmd;
7333     exec @cmd or fail f_ "exec curl: %s\n", $!;
7334 }
7335
7336 sub repos_server_url () {
7337     $package = '_dgit-repos-server';
7338     local $access_forpush = 1;
7339     local $isuite = 'DGIT-REPOS-SERVER';
7340     my $url = access_giturl();
7341 }
7342
7343 sub pre_clone_dgit_repos_server () {
7344     not_necessarily_a_tree();
7345 }
7346 sub cmd_clone_dgit_repos_server {
7347     badusage __ "need destination argument" unless @ARGV==1;
7348     my ($destdir) = @ARGV;
7349     my $url = repos_server_url();
7350     my @cmd = (@git, qw(clone), $url, $destdir);
7351     debugcmd ">",@cmd;
7352     exec @cmd or fail f_ "exec git clone: %s\n", $!;
7353 }
7354
7355 sub pre_print_dgit_repos_server_source_url () {
7356     not_necessarily_a_tree();
7357 }
7358 sub cmd_print_dgit_repos_server_source_url {
7359     badusage __
7360         "no arguments allowed to dgit print-dgit-repos-server-source-url"
7361         if @ARGV;
7362     my $url = repos_server_url();
7363     print $url, "\n" or confess "$!";
7364 }
7365
7366 sub pre_print_dpkg_source_ignores {
7367     not_necessarily_a_tree();
7368 }
7369 sub cmd_print_dpkg_source_ignores {
7370     badusage __
7371         "no arguments allowed to dgit print-dpkg-source-ignores"
7372         if @ARGV;
7373     print "@dpkg_source_ignores\n" or confess "$!";
7374 }
7375
7376 sub cmd_setup_mergechangelogs {
7377     badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7378         if @ARGV;
7379     local $isuite = 'DGIT-SETUP-TREE';
7380     setup_mergechangelogs(1);
7381 }
7382
7383 sub cmd_setup_useremail {
7384     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7385     local $isuite = 'DGIT-SETUP-TREE';
7386     setup_useremail(1);
7387 }
7388
7389 sub cmd_setup_gitattributes {
7390     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7391     local $isuite = 'DGIT-SETUP-TREE';
7392     setup_gitattrs(1);
7393 }
7394
7395 sub cmd_setup_new_tree {
7396     badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7397     local $isuite = 'DGIT-SETUP-TREE';
7398     setup_new_tree();
7399 }
7400
7401 #---------- argument parsing and main program ----------
7402
7403 sub cmd_version {
7404     print "dgit version $our_version\n" or confess "$!";
7405     finish 0;
7406 }
7407
7408 our (%valopts_long, %valopts_short);
7409 our (%funcopts_long);
7410 our @rvalopts;
7411 our (@modeopt_cfgs);
7412
7413 sub defvalopt ($$$$) {
7414     my ($long,$short,$val_re,$how) = @_;
7415     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7416     $valopts_long{$long} = $oi;
7417     $valopts_short{$short} = $oi;
7418     # $how subref should:
7419     #   do whatever assignemnt or thing it likes with $_[0]
7420     #   if the option should not be passed on to remote, @rvalopts=()
7421     # or $how can be a scalar ref, meaning simply assign the value
7422 }
7423
7424 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7425 defvalopt '--distro',        '-d', '.+',      \$idistro;
7426 defvalopt '',                '-k', '.+',      \$keyid;
7427 defvalopt '--existing-package','', '.*',      \$existing_package;
7428 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
7429 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
7430 defvalopt '--package',   '-p',   $package_re, \$package;
7431 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
7432
7433 defvalopt '', '-C', '.+', sub {
7434     ($changesfile) = (@_);
7435     if ($changesfile =~ s#^(.*)/##) {
7436         $buildproductsdir = $1;
7437     }
7438 };
7439
7440 defvalopt '--initiator-tempdir','','.*', sub {
7441     ($initiator_tempdir) = (@_);
7442     $initiator_tempdir =~ m#^/# or
7443         badusage __ "--initiator-tempdir must be used specify an".
7444                     " absolute, not relative, directory."
7445 };
7446
7447 sub defoptmodes ($@) {
7448     my ($varref, $cfgkey, $default, %optmap) = @_;
7449     my %permit;
7450     while (my ($opt,$val) = each %optmap) {
7451         $funcopts_long{$opt} = sub { $$varref = $val; };
7452         $permit{$val} = $val;
7453     }
7454     push @modeopt_cfgs, {
7455         Var => $varref,
7456         Key => $cfgkey,
7457         Default => $default,
7458         Vals => \%permit
7459     };
7460 }
7461
7462 defoptmodes \$dodep14tag, qw( dep14tag          want
7463                               --dep14tag        want
7464                               --no-dep14tag     no
7465                               --always-dep14tag always );
7466
7467 sub parseopts () {
7468     my $om;
7469
7470     if (defined $ENV{'DGIT_SSH'}) {
7471         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7472     } elsif (defined $ENV{'GIT_SSH'}) {
7473         @ssh = ($ENV{'GIT_SSH'});
7474     }
7475
7476     my $oi;
7477     my $val;
7478     my $valopt = sub {
7479         my ($what) = @_;
7480         @rvalopts = ($_);
7481         if (!defined $val) {
7482             badusage f_ "%s needs a value", $what unless @ARGV;
7483             $val = shift @ARGV;
7484             push @rvalopts, $val;
7485         }
7486         badusage f_ "bad value \`%s' for %s", $val, $what unless
7487             $val =~ m/^$oi->{Re}$(?!\n)/s;
7488         my $how = $oi->{How};
7489         if (ref($how) eq 'SCALAR') {
7490             $$how = $val;
7491         } else {
7492             $how->($val);
7493         }
7494         push @ropts, @rvalopts;
7495     };
7496
7497     while (@ARGV) {
7498         last unless $ARGV[0] =~ m/^-/;
7499         $_ = shift @ARGV;
7500         last if m/^--?$/;
7501         if (m/^--/) {
7502             if (m/^--dry-run$/) {
7503                 push @ropts, $_;
7504                 $dryrun_level=2;
7505             } elsif (m/^--damp-run$/) {
7506                 push @ropts, $_;
7507                 $dryrun_level=1;
7508             } elsif (m/^--no-sign$/) {
7509                 push @ropts, $_;
7510                 $sign=0;
7511             } elsif (m/^--help$/) {
7512                 cmd_help();
7513             } elsif (m/^--version$/) {
7514                 cmd_version();
7515             } elsif (m/^--new$/) {
7516                 push @ropts, $_;
7517                 $new_package=1;
7518             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7519                      ($om = $opts_opt_map{$1}) &&
7520                      length $om->[0]) {
7521                 push @ropts, $_;
7522                 $om->[0] = $2;
7523             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7524                      !$opts_opt_cmdonly{$1} &&
7525                      ($om = $opts_opt_map{$1})) {
7526                 push @ropts, $_;
7527                 push @$om, $2;
7528             } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7529                      !$opts_opt_cmdonly{$1} &&
7530                      ($om = $opts_opt_map{$1})) {
7531                 push @ropts, $_;
7532                 my $cmd = shift @$om;
7533                 @$om = ($cmd, grep { $_ ne $2 } @$om);
7534             } elsif (m/^--($quilt_options_re)$/s) {
7535                 push @ropts, "--quilt=$1";
7536                 $quilt_mode = $1;
7537             } elsif (m/^--(?:ignore|include)-dirty$/s) {
7538                 push @ropts, $_;
7539                 $includedirty = 1;
7540             } elsif (m/^--no-quilt-fixup$/s) {
7541                 push @ropts, $_;
7542                 $quilt_mode = 'nocheck';
7543             } elsif (m/^--no-rm-on-error$/s) {
7544                 push @ropts, $_;
7545                 $rmonerror = 0;
7546             } elsif (m/^--no-chase-dsc-distro$/s) {
7547                 push @ropts, $_;
7548                 $chase_dsc_distro = 0;
7549             } elsif (m/^--overwrite$/s) {
7550                 push @ropts, $_;
7551                 $overwrite_version = '';
7552             } elsif (m/^--split-(?:view|brain)$/s) {
7553                 push @ropts, $_;
7554                 $splitview_mode = 'always';
7555             } elsif (m/^--split-(?:view|brain)=($splitview_modes_re)$/s) {
7556                 push @ropts, $_;
7557                 $splitview_mode = $1;
7558             } elsif (m/^--overwrite=(.+)$/s) {
7559                 push @ropts, $_;
7560                 $overwrite_version = $1;
7561             } elsif (m/^--delayed=(\d+)$/s) {
7562                 push @ropts, $_;
7563                 push @dput, $_;
7564             } elsif (m/^--upstream-commitish=(.+)$/s) {
7565                 push @ropts, $_;
7566                 $quilt_upstream_commitish = $1;
7567             } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7568                      m/^--(dgit-view)-save=(.+)$/s
7569                      ) {
7570                 my ($k,$v) = ($1,$2);
7571                 push @ropts, $_;
7572                 $v =~ s#^(?!refs/)#refs/heads/#;
7573                 $internal_object_save{$k} = $v;
7574             } elsif (m/^--(no-)?rm-old-changes$/s) {
7575                 push @ropts, $_;
7576                 $rmchanges = !$1;
7577             } elsif (m/^--deliberately-($deliberately_re)$/s) {
7578                 push @ropts, $_;
7579                 push @deliberatelies, $&;
7580             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7581                 push @ropts, $&;
7582                 $forceopts{$1} = 1;
7583                 $_='';
7584             } elsif (m/^--force-/) {
7585                 print STDERR
7586                     f_ "%s: warning: ignoring unknown force option %s\n",
7587                        $us, $_;
7588                 $_='';
7589             } elsif (m/^--config-lookup-explode=(.+)$/s) {
7590                 # undocumented, for testing
7591                 push @ropts, $_;
7592                 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7593                 # ^ it's supposed to be an array ref
7594             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7595                 $val = $2 ? $' : undef; #';
7596                 $valopt->($oi->{Long});
7597             } elsif ($funcopts_long{$_}) {
7598                 push @ropts, $_;
7599                 $funcopts_long{$_}();
7600             } else {
7601                 badusage f_ "unknown long option \`%s'", $_;
7602             }
7603         } else {
7604             while (m/^-./s) {
7605                 if (s/^-n/-/) {
7606                     push @ropts, $&;
7607                     $dryrun_level=2;
7608                 } elsif (s/^-L/-/) {
7609                     push @ropts, $&;
7610                     $dryrun_level=1;
7611                 } elsif (s/^-h/-/) {
7612                     cmd_help();
7613                 } elsif (s/^-D/-/) {
7614                     push @ropts, $&;
7615                     $debuglevel++;
7616                     enabledebug();
7617                 } elsif (s/^-N/-/) {
7618                     push @ropts, $&;
7619                     $new_package=1;
7620                 } elsif (m/^-m/) {
7621                     push @ropts, $&;
7622                     push @changesopts, $_;
7623                     $_ = '';
7624                 } elsif (s/^-wn$//s) {
7625                     push @ropts, $&;
7626                     $cleanmode = 'none';
7627                 } elsif (s/^-wg(f?)(a?)$//s) {
7628                     push @ropts, $&;
7629                     $cleanmode = 'git';
7630                     $cleanmode .= '-ff' if $1;
7631                     $cleanmode .= ',always' if $2;
7632                 } elsif (s/^-wd(d?)([na]?)$//s) {
7633                     push @ropts, $&;
7634                     $cleanmode = 'dpkg-source';
7635                     $cleanmode .= '-d' if $1;
7636                     $cleanmode .= ',no-check' if $2 eq 'n';
7637                     $cleanmode .= ',all-check' if $2 eq 'a';
7638                 } elsif (s/^-wc$//s) {
7639                     push @ropts, $&;
7640                     $cleanmode = 'check';
7641                 } elsif (s/^-wci$//s) {
7642                     push @ropts, $&;
7643                     $cleanmode = 'check,ignores';
7644                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7645                     push @git, '-c', $&;
7646                     $gitcfgs{cmdline}{$1} = [ $2 ];
7647                 } elsif (s/^-c([^=]+)$//s) {
7648                     push @git, '-c', $&;
7649                     $gitcfgs{cmdline}{$1} = [ 'true' ];
7650                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7651                     $val = $'; #';
7652                     $val = undef unless length $val;
7653                     $valopt->($oi->{Short});
7654                     $_ = '';
7655                 } else {
7656                     badusage f_ "unknown short option \`%s'", $_;
7657                 }
7658             }
7659         }
7660     }
7661 }
7662
7663 sub check_env_sanity () {
7664     my $blocked = new POSIX::SigSet;
7665     sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7666
7667     eval {
7668         foreach my $name (qw(PIPE CHLD)) {
7669             my $signame = "SIG$name";
7670             my $signum = eval "POSIX::$signame" // die;
7671             die f_ "%s is set to something other than SIG_DFL\n",
7672                 $signame
7673                 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7674             $blocked->ismember($signum) and
7675                 die f_ "%s is blocked\n", $signame;
7676         }
7677     };
7678     return unless $@;
7679     chomp $@;
7680     fail f_ <<END, $@;
7681 On entry to dgit, %s
7682 This is a bug produced by something in your execution environment.
7683 Giving up.
7684 END
7685 }
7686
7687
7688 sub parseopts_late_defaults () {
7689     $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7690         if defined $idistro;
7691     $isuite //= cfg('dgit.default.default-suite');
7692
7693     foreach my $k (keys %opts_opt_map) {
7694         my $om = $opts_opt_map{$k};
7695
7696         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7697         if (defined $v) {
7698             badcfg f_ "cannot set command for %s", $k
7699                 unless length $om->[0];
7700             $om->[0] = $v;
7701         }
7702
7703         foreach my $c (access_cfg_cfgs("opts-$k")) {
7704             my @vl =
7705                 map { $_ ? @$_ : () }
7706                 map { $gitcfgs{$_}{$c} }
7707                 reverse @gitcfgsources;
7708             printdebug "CL $c ", (join " ", map { shellquote } @vl),
7709                 "\n" if $debuglevel >= 4;
7710             next unless @vl;
7711             badcfg f_ "cannot configure options for %s", $k
7712                 if $opts_opt_cmdonly{$k};
7713             my $insertpos = $opts_cfg_insertpos{$k};
7714             @$om = ( @$om[0..$insertpos-1],
7715                      @vl,
7716                      @$om[$insertpos..$#$om] );
7717         }
7718     }
7719
7720     if (!defined $rmchanges) {
7721         local $access_forpush;
7722         $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7723     }
7724
7725     if (!defined $quilt_mode) {
7726         local $access_forpush;
7727         $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7728             // access_cfg('quilt-mode', 'RETURN-UNDEF')
7729             // 'linear';
7730         $quilt_mode =~ m/^($quilt_modes_re)$/
7731             or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7732         $quilt_mode = $1;
7733     }
7734     $quilt_mode =~ s/^(baredebian)\+git$/$1/;
7735
7736     foreach my $moc (@modeopt_cfgs) {
7737         local $access_forpush;
7738         my $vr = $moc->{Var};
7739         next if defined $$vr;
7740         $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7741         my $v = $moc->{Vals}{$$vr};
7742         badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7743             unless defined $v;
7744         $$vr = $v;
7745     }
7746
7747     {
7748         local $access_forpush;
7749         default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7750                                 $cleanmode_re);
7751     }
7752
7753     $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7754     $buildproductsdir //= '..';
7755     $bpd_glob = $buildproductsdir;
7756     $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7757 }
7758
7759 setlocale(LC_MESSAGES, "");
7760 textdomain("dgit");
7761
7762 if ($ENV{$fakeeditorenv}) {
7763     git_slurp_config();
7764     quilt_fixup_editor();
7765 }
7766
7767 parseopts();
7768 check_env_sanity();
7769
7770 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7771 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7772     if $dryrun_level == 1;
7773 if (!@ARGV) {
7774     print STDERR __ $helpmsg or confess "$!";
7775     finish 8;
7776 }
7777 $cmd = $subcommand = shift @ARGV;
7778 $cmd =~ y/-/_/;
7779
7780 my $pre_fn = ${*::}{"pre_$cmd"};
7781 $pre_fn->() if $pre_fn;
7782
7783 if ($invoked_in_git_tree) {
7784     changedir_git_toplevel();
7785     record_maindir();
7786 }
7787 git_slurp_config();
7788
7789 my $fn = ${*::}{"cmd_$cmd"};
7790 $fn or badusage f_ "unknown operation %s", $cmd;
7791 $fn->();
7792
7793 finish 0;