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