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