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';
  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 "only one dfi\n"), next if @$dfi == 1;
2294         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2295         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2296         my $compr_ext = $1;
2297
2298         my ($orig_f_part) =
2299             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2300
2301         printdebug "Y ", (join ' ', map { $_//"(none)" }
2302                           $compr_ext, $orig_f_part
2303                          ), "\n";
2304
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             F => $f,
2371             Tree => $tree,
2372         };
2373     }
2374
2375     @tartrees = sort {
2376         # put any without "_" first (spec is not clear whether files
2377         # are always in the usual order).  Tarballs without "_" are
2378         # the main orig or the debian tarball.
2379         $a->{Sort} <=> $b->{Sort} or
2380         $a->{F}    cmp $b->{F}
2381     } @tartrees;
2382
2383     @tartrees;
2384 }
2385
2386 sub generate_commits_from_dsc () {
2387     # See big comment in fetch_from_archive, below.
2388     # See also README.dsc-import.
2389     prep_ud();
2390     changedir $playground;
2391
2392     my $bpd_abs = bpd_abs();
2393     my $upstreamv = upstreamversion $dsc->{version};
2394     my @dfi = dsc_files_info();
2395
2396     dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2397         sub { grep { $_->{Filename} eq $_[0] } @dfi };
2398
2399     foreach my $fi (@dfi) {
2400         my $f = $fi->{Filename};
2401         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2402         my $upper_f = "$bpd_abs/$f";
2403
2404         printdebug "considering reusing $f: ";
2405
2406         if (link_ltarget "$upper_f,fetch", $f) {
2407             printdebug "linked (using ...,fetch).\n";
2408         } elsif ((printdebug "($!) "),
2409                  $! != ENOENT) {
2410             fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2411         } elsif (link_ltarget $upper_f, $f) {
2412             printdebug "linked.\n";
2413         } elsif ((printdebug "($!) "),
2414                  $! != ENOENT) {
2415             fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2416         } else {
2417             printdebug "absent.\n";
2418         }
2419
2420         my $refetched;
2421         complete_file_from_dsc('.', $fi, \$refetched)
2422             or next;
2423
2424         printdebug "considering saving $f: ";
2425
2426         if (rename_link_xf 1, $f, $upper_f) {
2427             printdebug "linked.\n";
2428         } elsif ((printdebug "($@) "),
2429                  $! != EEXIST) {
2430             fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2431         } elsif (!$refetched) {
2432             printdebug "no need.\n";
2433         } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2434             printdebug "linked (using ...,fetch).\n";
2435         } elsif ((printdebug "($@) "),
2436                  $! != EEXIST) {
2437             fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2438         } else {
2439             printdebug "cannot.\n";
2440         }
2441     }
2442
2443     my @tartrees = import_tarball_tartrees($upstreamv, \@dfi);
2444
2445     my $any_orig = grep { $_->{Orig} } @tartrees;
2446
2447     my $dscfn = "$package.dsc";
2448
2449     my $treeimporthow = 'package';
2450
2451     open D, ">", $dscfn or die "$dscfn: $!";
2452     print D $dscdata or die "$dscfn: $!";
2453     close D or die "$dscfn: $!";
2454     my @cmd = qw(dpkg-source);
2455     push @cmd, '--no-check' if $dsc_checked;
2456     if (madformat $dsc->{format}) {
2457         push @cmd, '--skip-patches';
2458         $treeimporthow = 'unpatched';
2459     }
2460     push @cmd, qw(-x --), $dscfn;
2461     runcmd @cmd;
2462
2463     my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2464     if (madformat $dsc->{format}) {
2465         check_for_vendor_patches();
2466     }
2467
2468     my $dappliedtree;
2469     if (madformat $dsc->{format}) {
2470         my @pcmd = qw(dpkg-source --before-build .);
2471         runcmd shell_cmd 'exec >/dev/null', @pcmd;
2472         rmtree '.pc';
2473         $dappliedtree = git_add_write_tree();
2474     }
2475
2476     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2477     my $clogp;
2478     my $r1clogp;
2479
2480     printdebug "import clog search...\n";
2481     parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2482         my ($thisstanza, $desc) = @_;
2483         no warnings qw(exiting);
2484
2485         $clogp //= $thisstanza;
2486
2487         printdebug "import clog $thisstanza->{version} $desc...\n";
2488
2489         last if !$any_orig; # we don't need $r1clogp
2490
2491         # We look for the first (most recent) changelog entry whose
2492         # version number is lower than the upstream version of this
2493         # package.  Then the last (least recent) previous changelog
2494         # entry is treated as the one which introduced this upstream
2495         # version and used for the synthetic commits for the upstream
2496         # tarballs.
2497
2498         # One might think that a more sophisticated algorithm would be
2499         # necessary.  But: we do not want to scan the whole changelog
2500         # file.  Stopping when we see an earlier version, which
2501         # necessarily then is an earlier upstream version, is the only
2502         # realistic way to do that.  Then, either the earliest
2503         # changelog entry we have seen so far is indeed the earliest
2504         # upload of this upstream version; or there are only changelog
2505         # entries relating to later upstream versions (which is not
2506         # possible unless the changelog and .dsc disagree about the
2507         # version).  Then it remains to choose between the physically
2508         # last entry in the file, and the one with the lowest version
2509         # number.  If these are not the same, we guess that the
2510         # versions were created in a non-monotonic order rather than
2511         # that the changelog entries have been misordered.
2512
2513         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2514
2515         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2516         $r1clogp = $thisstanza;
2517
2518         printdebug "import clog $r1clogp->{version} becomes r1\n";
2519     };
2520
2521     $clogp or fail __ "package changelog has no entries!";
2522
2523     my $authline = clogp_authline $clogp;
2524     my $changes = getfield $clogp, 'Changes';
2525     $changes =~ s/^\n//; # Changes: \n
2526     my $cversion = getfield $clogp, 'Version';
2527
2528     if (@tartrees) {
2529         $r1clogp //= $clogp; # maybe there's only one entry;
2530         my $r1authline = clogp_authline $r1clogp;
2531         # Strictly, r1authline might now be wrong if it's going to be
2532         # unused because !$any_orig.  Whatever.
2533
2534         printdebug "import tartrees authline   $authline\n";
2535         printdebug "import tartrees r1authline $r1authline\n";
2536
2537         foreach my $tt (@tartrees) {
2538             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2539
2540             my $mbody = f_ "Import %s", $tt->{F};
2541             $tt->{Commit} = hash_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2542 tree $tt->{Tree}
2543 author $r1authline
2544 committer $r1authline
2545
2546 $mbody
2547
2548 [dgit import orig $tt->{F}]
2549 END_O
2550 tree $tt->{Tree}
2551 author $authline
2552 committer $authline
2553
2554 $mbody
2555
2556 [dgit import tarball $package $cversion $tt->{F}]
2557 END_T
2558         }
2559     }
2560
2561     printdebug "import main commit\n";
2562
2563     open C, ">../commit.tmp" or confess "$!";
2564     print C <<END or confess "$!";
2565 tree $tree
2566 END
2567     print C <<END or confess "$!" foreach @tartrees;
2568 parent $_->{Commit}
2569 END
2570     print C <<END or confess "$!";
2571 author $authline
2572 committer $authline
2573
2574 $changes
2575
2576 [dgit import $treeimporthow $package $cversion]
2577 END
2578
2579     close C or confess "$!";
2580     my $rawimport_hash = hash_commit qw(../commit.tmp);
2581
2582     if (madformat $dsc->{format}) {
2583         printdebug "import apply patches...\n";
2584
2585         # regularise the state of the working tree so that
2586         # the checkout of $rawimport_hash works nicely.
2587         my $dappliedcommit = hash_commit_text(<<END);
2588 tree $dappliedtree
2589 author $authline
2590 committer $authline
2591
2592 [dgit dummy commit]
2593 END
2594         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2595
2596         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2597
2598         # We need the answers to be reproducible
2599         my @authline = clogp_authline($clogp);
2600         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2601         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2602         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2603         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
2604         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2605         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
2606
2607         my $path = $ENV{PATH} or die;
2608
2609         # we use ../../gbp-pq-output, which (given that we are in
2610         # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2611         # is .git/dgit.
2612
2613         foreach my $use_absurd (qw(0 1)) {
2614             runcmd @git, qw(checkout -q unpa);
2615             runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2616             local $ENV{PATH} = $path;
2617             if ($use_absurd) {
2618                 chomp $@;
2619                 progress "warning: $@";
2620                 $path = "$absurdity:$path";
2621                 progress f_ "%s: trying slow absurd-git-apply...", $us;
2622                 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2623                     or $!==ENOENT
2624                     or confess "$!";
2625             }
2626             eval {
2627                 die "forbid absurd git-apply\n" if $use_absurd
2628                     && forceing [qw(import-gitapply-no-absurd)];
2629                 die "only absurd git-apply!\n" if !$use_absurd
2630                     && forceing [qw(import-gitapply-absurd)];
2631
2632                 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2633                 local $ENV{PATH} = $path                    if $use_absurd;
2634
2635                 my @showcmd = (gbp_pq, qw(import));
2636                 my @realcmd = shell_cmd
2637                     'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2638                 debugcmd "+",@realcmd;
2639                 if (system @realcmd) {
2640                     die f_ "%s failed: %s\n",
2641                         +(shellquote @showcmd),
2642                         failedcmd_waitstatus();
2643                 }
2644
2645                 my $gapplied = git_rev_parse('HEAD');
2646                 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2647                 $gappliedtree eq $dappliedtree or
2648                     fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2649 gbp-pq import and dpkg-source disagree!
2650  gbp-pq import gave commit %s
2651  gbp-pq import gave tree %s
2652  dpkg-source --before-build gave tree %s
2653 END
2654                 $rawimport_hash = $gapplied;
2655             };
2656             last unless $@;
2657         }
2658         if ($@) {
2659             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2660             die $@;
2661         }
2662     }
2663
2664     progress f_ "synthesised git commit from .dsc %s", $cversion;
2665
2666     my $rawimport_mergeinput = {
2667         Commit => $rawimport_hash,
2668         Info => __ "Import of source package",
2669     };
2670     my @output = ($rawimport_mergeinput);
2671
2672     if ($lastpush_mergeinput) {
2673         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2674         my $oversion = getfield $oldclogp, 'Version';
2675         my $vcmp =
2676             version_compare($oversion, $cversion);
2677         if ($vcmp < 0) {
2678             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2679                 { ReverseParents => 1,
2680                   Message => (f_ <<END, $package, $cversion, $csuite) });
2681 Record %s (%s) in archive suite %s
2682 END
2683         } elsif ($vcmp > 0) {
2684             print STDERR f_ <<END, $cversion, $oversion,
2685
2686 Version actually in archive:   %s (older)
2687 Last version pushed with dgit: %s (newer or same)
2688 %s
2689 END
2690                 __ $later_warning_msg or confess "$!";
2691             @output = $lastpush_mergeinput;
2692         } else {
2693             # Same version.  Use what's in the server git branch,
2694             # discarding our own import.  (This could happen if the
2695             # server automatically imports all packages into git.)
2696             @output = $lastpush_mergeinput;
2697         }
2698     }
2699     changedir $maindir;
2700     rmtree $playground;
2701     return @output;
2702 }
2703
2704 sub complete_file_from_dsc ($$;$) {
2705     our ($dstdir, $fi, $refetched) = @_;
2706     # Ensures that we have, in $dstdir, the file $fi, with the correct
2707     # contents.  (Downloading it from alongside $dscurl if necessary.)
2708     # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2709     # and will set $$refetched=1 if it did so (or tried to).
2710
2711     my $f = $fi->{Filename};
2712     my $tf = "$dstdir/$f";
2713     my $downloaded = 0;
2714
2715     my $got;
2716     my $checkhash = sub {
2717         open F, "<", "$tf" or die "$tf: $!";
2718         $fi->{Digester}->reset();
2719         $fi->{Digester}->addfile(*F);
2720         F->error and confess "$!";
2721         $got = $fi->{Digester}->hexdigest();
2722         return $got eq $fi->{Hash};
2723     };
2724
2725     if (stat_exists $tf) {
2726         if ($checkhash->()) {
2727             progress f_ "using existing %s", $f;
2728             return 1;
2729         }
2730         if (!$refetched) {
2731             fail f_ "file %s has hash %s but .dsc demands hash %s".
2732                     " (perhaps you should delete this file?)",
2733                     $f, $got, $fi->{Hash};
2734         }
2735         progress f_ "need to fetch correct version of %s", $f;
2736         unlink $tf or die "$tf $!";
2737         $$refetched = 1;
2738     } else {
2739         printdebug "$tf does not exist, need to fetch\n";
2740     }
2741
2742     my $furl = $dscurl;
2743     $furl =~ s{/[^/]+$}{};
2744     $furl .= "/$f";
2745     die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2746     die "$f ?" if $f =~ m#/#;
2747     runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2748     return 0 if !act_local();
2749
2750     $checkhash->() or
2751         fail f_ "file %s has hash %s but .dsc demands hash %s".
2752                 " (got wrong file from archive!)",
2753                 $f, $got, $fi->{Hash};
2754
2755     return 1;
2756 }
2757
2758 sub ensure_we_have_orig () {
2759     my @dfi = dsc_files_info();
2760     foreach my $fi (@dfi) {
2761         my $f = $fi->{Filename};
2762         next unless is_orig_file_in_dsc($f, \@dfi);
2763         complete_file_from_dsc($buildproductsdir, $fi)
2764             or next;
2765     }
2766 }
2767
2768 #---------- git fetch ----------
2769
2770 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2771 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2772
2773 # We fetch some parts of lrfetchrefs/*.  Ideally we delete these
2774 # locally fetched refs because they have unhelpful names and clutter
2775 # up gitk etc.  So we track whether we have "used up" head ref (ie,
2776 # whether we have made another local ref which refers to this object).
2777 #
2778 # (If we deleted them unconditionally, then we might end up
2779 # re-fetching the same git objects each time dgit fetch was run.)
2780 #
2781 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2782 # in git_fetch_us to fetch the refs in question, and possibly a call
2783 # to lrfetchref_used.
2784
2785 our (%lrfetchrefs_f, %lrfetchrefs_d);
2786 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2787
2788 sub lrfetchref_used ($) {
2789     my ($fullrefname) = @_;
2790     my $objid = $lrfetchrefs_f{$fullrefname};
2791     $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2792 }
2793
2794 sub git_lrfetch_sane {
2795     my ($url, $supplementary, @specs) = @_;
2796     # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2797     # at least as regards @specs.  Also leave the results in
2798     # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2799     # able to clean these up.
2800     #
2801     # With $supplementary==1, @specs must not contain wildcards
2802     # and we add to our previous fetches (non-atomically).
2803
2804     # This is rather miserable:
2805     # When git fetch --prune is passed a fetchspec ending with a *,
2806     # it does a plausible thing.  If there is no * then:
2807     # - it matches subpaths too, even if the supplied refspec
2808     #   starts refs, and behaves completely madly if the source
2809     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2810     # - if there is no matching remote ref, it bombs out the whole
2811     #   fetch.
2812     # We want to fetch a fixed ref, and we don't know in advance
2813     # if it exists, so this is not suitable.
2814     #
2815     # Our workaround is to use git ls-remote.  git ls-remote has its
2816     # own qairks.  Notably, it has the absurd multi-tail-matching
2817     # behaviour: git ls-remote R refs/foo can report refs/foo AND
2818     # refs/refs/foo etc.
2819     #
2820     # Also, we want an idempotent snapshot, but we have to make two
2821     # calls to the remote: one to git ls-remote and to git fetch.  The
2822     # solution is use git ls-remote to obtain a target state, and
2823     # git fetch to try to generate it.  If we don't manage to generate
2824     # the target state, we try again.
2825
2826     printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2827
2828     my $specre = join '|', map {
2829         my $x = $_;
2830         $x =~ s/\W/\\$&/g;
2831         my $wildcard = $x =~ s/\\\*$/.*/;
2832         die if $wildcard && $supplementary;
2833         "(?:refs/$x)";
2834     } @specs;
2835     printdebug "git_lrfetch_sane specre=$specre\n";
2836     my $wanted_rref = sub {
2837         local ($_) = @_;
2838         return m/^(?:$specre)$/;
2839     };
2840
2841     my $fetch_iteration = 0;
2842     FETCH_ITERATION:
2843     for (;;) {
2844         printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2845         if (++$fetch_iteration > 10) {
2846             fail __ "too many iterations trying to get sane fetch!";
2847         }
2848
2849         my @look = map { "refs/$_" } @specs;
2850         my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2851         debugcmd "|",@lcmd;
2852
2853         my %wantr;
2854         open GITLS, "-|", @lcmd or confess "$!";
2855         while (<GITLS>) {
2856             printdebug "=> ", $_;
2857             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2858             my ($objid,$rrefname) = ($1,$2);
2859             if (!$wanted_rref->($rrefname)) {
2860                 print STDERR f_ <<END, "@look", $rrefname;
2861 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2862 END
2863                 next;
2864             }
2865             $wantr{$rrefname} = $objid;
2866         }
2867         $!=0; $?=0;
2868         close GITLS or failedcmd @lcmd;
2869
2870         # OK, now %want is exactly what we want for refs in @specs
2871         my @fspecs = map {
2872             !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2873             "+refs/$_:".lrfetchrefs."/$_";
2874         } @specs;
2875
2876         printdebug "git_lrfetch_sane fspecs @fspecs\n";
2877
2878         my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2879         runcmd_ordryrun_local @fcmd if @fspecs;
2880
2881         if (!$supplementary) {
2882             %lrfetchrefs_f = ();
2883         }
2884         my %objgot;
2885
2886         git_for_each_ref(lrfetchrefs, sub {
2887             my ($objid,$objtype,$lrefname,$reftail) = @_;
2888             $lrfetchrefs_f{$lrefname} = $objid;
2889             $objgot{$objid} = 1;
2890         });
2891
2892         if ($supplementary) {
2893             last;
2894         }
2895
2896         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2897             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2898             if (!exists $wantr{$rrefname}) {
2899                 if ($wanted_rref->($rrefname)) {
2900                     printdebug <<END;
2901 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2902 END
2903                 } else {
2904                     print STDERR f_ <<END, "@fspecs", $lrefname
2905 warning: git fetch %s created %s; this is silly, deleting it.
2906 END
2907                 }
2908                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2909                 delete $lrfetchrefs_f{$lrefname};
2910                 next;
2911             }
2912         }
2913         foreach my $rrefname (sort keys %wantr) {
2914             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2915             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2916             my $want = $wantr{$rrefname};
2917             next if $got eq $want;
2918             if (!defined $objgot{$want}) {
2919                 fail __ <<END unless act_local();
2920 --dry-run specified but we actually wanted the results of git fetch,
2921 so this is not going to work.  Try running dgit fetch first,
2922 or using --damp-run instead of --dry-run.
2923 END
2924                 print STDERR f_ <<END, $lrefname, $want;
2925 warning: git ls-remote suggests we want %s
2926 warning:  and it should refer to %s
2927 warning:  but git fetch didn't fetch that object to any relevant ref.
2928 warning:  This may be due to a race with someone updating the server.
2929 warning:  Will try again...
2930 END
2931                 next FETCH_ITERATION;
2932             }
2933             printdebug <<END;
2934 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2935 END
2936             runcmd_ordryrun_local @git, qw(update-ref -m),
2937                 "dgit fetch git fetch fixup", $lrefname, $want;
2938             $lrfetchrefs_f{$lrefname} = $want;
2939         }
2940         last;
2941     }
2942
2943     if (defined $csuite) {
2944         printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2945         git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2946             my ($objid,$objtype,$lrefname,$reftail) = @_;
2947             next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2948             runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2949         });
2950     }
2951
2952     printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2953         Dumper(\%lrfetchrefs_f);
2954 }
2955
2956 sub git_fetch_us () {
2957     # Want to fetch only what we are going to use, unless
2958     # deliberately-not-ff, in which case we must fetch everything.
2959
2960     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2961         map { "tags/$_" } debiantags('*',access_nomdistro);
2962     push @specs, server_branch($csuite);
2963     push @specs, $rewritemap;
2964     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2965
2966     my $url = access_giturl();
2967     git_lrfetch_sane $url, 0, @specs;
2968
2969     my %here;
2970     my @tagpats = debiantags('*',access_nomdistro);
2971
2972     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2973         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2974         printdebug "currently $fullrefname=$objid\n";
2975         $here{$fullrefname} = $objid;
2976     });
2977     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2978         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2979         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2980         printdebug "offered $lref=$objid\n";
2981         if (!defined $here{$lref}) {
2982             my @upd = (@git, qw(update-ref), $lref, $objid, '');
2983             runcmd_ordryrun_local @upd;
2984             lrfetchref_used $fullrefname;
2985         } elsif ($here{$lref} eq $objid) {
2986             lrfetchref_used $fullrefname;
2987         } else {
2988             print STDERR f_ "Not updating %s from %s to %s.\n",
2989                             $lref, $here{$lref}, $objid;
2990         }
2991     });
2992 }
2993
2994 #---------- dsc and archive handling ----------
2995
2996 sub mergeinfo_getclogp ($) {
2997     # Ensures thit $mi->{Clogp} exists and returns it
2998     my ($mi) = @_;
2999     $mi->{Clogp} = commit_getclogp($mi->{Commit});
3000 }
3001
3002 sub mergeinfo_version ($) {
3003     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
3004 }
3005
3006 sub fetch_from_archive_record_1 ($) {
3007     my ($hash) = @_;
3008     runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
3009     cmdoutput @git, qw(log -n2), $hash;
3010     # ... gives git a chance to complain if our commit is malformed
3011 }
3012
3013 sub fetch_from_archive_record_2 ($) {
3014     my ($hash) = @_;
3015     my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
3016     if (act_local()) {
3017         cmdoutput @upd_cmd;
3018     } else {
3019         dryrun_report @upd_cmd;
3020     }
3021 }
3022
3023 sub parse_dsc_field_def_dsc_distro () {
3024     $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
3025                            dgit.default.distro);
3026 }
3027
3028 sub parse_dsc_field ($$) {
3029     my ($dsc, $what) = @_;
3030     my $f;
3031     foreach my $field (@ourdscfield) {
3032         $f = $dsc->{$field};
3033         last if defined $f;
3034     }
3035
3036     if (!defined $f) {
3037         progress f_ "%s: NO git hash", $what;
3038         parse_dsc_field_def_dsc_distro();
3039     } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3040              = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3041         progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3042         $dsc_hint_tag = [ $dsc_hint_tag ];
3043     } elsif ($f =~ m/^\w+\s*$/) {
3044         $dsc_hash = $&;
3045         parse_dsc_field_def_dsc_distro();
3046         $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3047                           $dsc_distro ];
3048         progress f_ "%s: specified git hash", $what;
3049     } else {
3050         fail f_ "%s: invalid Dgit info", $what;
3051     }
3052 }
3053
3054 sub resolve_dsc_field_commit ($$) {
3055     my ($already_distro, $already_mapref) = @_;
3056
3057     return unless defined $dsc_hash;
3058
3059     my $mapref =
3060         defined $already_mapref &&
3061         ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3062         ? $already_mapref : undef;
3063
3064     my $do_fetch;
3065     $do_fetch = sub {
3066         my ($what, @fetch) = @_;
3067
3068         local $idistro = $dsc_distro;
3069         my $lrf = lrfetchrefs;
3070
3071         if (!$chase_dsc_distro) {
3072             progress f_ "not chasing .dsc distro %s: not fetching %s",
3073                         $dsc_distro, $what;
3074             return 0;
3075         }
3076
3077         progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3078
3079         my $url = access_giturl();
3080         if (!defined $url) {
3081             defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3082 .dsc Dgit metadata is in context of distro %s
3083 for which we have no configured url and .dsc provides no hint
3084 END
3085             my $proto =
3086                 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3087                 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3088             parse_cfg_bool "dsc-url-proto-ok", 'false',
3089                 cfg("dgit.dsc-url-proto-ok.$proto",
3090                     "dgit.default.dsc-url-proto-ok")
3091                 or fail f_ <<END, $dsc_distro, $proto;
3092 .dsc Dgit metadata is in context of distro %s
3093 for which we have no configured url;
3094 .dsc provides hinted url with protocol %s which is unsafe.
3095 (can be overridden by config - consult documentation)
3096 END
3097             $url = $dsc_hint_url;
3098         }
3099
3100         git_lrfetch_sane $url, 1, @fetch;
3101
3102         return $lrf;
3103     };
3104
3105     my $rewrite_enable = do {
3106         local $idistro = $dsc_distro;
3107         access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3108     };
3109
3110     if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3111         if (!defined $mapref) {
3112             my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3113             $mapref = $lrf.'/'.$rewritemap;
3114         }
3115         my $rewritemapdata = git_cat_file $mapref.':map';
3116         if (defined $rewritemapdata
3117             && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3118             progress __
3119                 "server's git history rewrite map contains a relevant entry!";
3120
3121             $dsc_hash = $1;
3122             if (defined $dsc_hash) {
3123                 progress __ "using rewritten git hash in place of .dsc value";
3124             } else {
3125                 progress __ "server data says .dsc hash is to be disregarded";
3126             }
3127         }
3128     }
3129
3130     if (!defined git_cat_file $dsc_hash) {
3131         my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3132         my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3133             defined git_cat_file $dsc_hash
3134             or fail f_ <<END, $dsc_hash;
3135 .dsc Dgit metadata requires commit %s
3136 but we could not obtain that object anywhere.
3137 END
3138         foreach my $t (@tags) {
3139             my $fullrefname = $lrf.'/'.$t;
3140 #           print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3141             next unless $lrfetchrefs_f{$fullrefname};
3142             next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3143             lrfetchref_used $fullrefname;
3144         }
3145     }
3146 }
3147
3148 sub fetch_from_archive () {
3149     check_bpd_exists();
3150     ensure_setup_existing_tree();
3151
3152     # Ensures that lrref() is what is actually in the archive, one way
3153     # or another, according to us - ie this client's
3154     # appropritaely-updated archive view.  Also returns the commit id.
3155     # If there is nothing in the archive, leaves lrref alone and
3156     # returns undef.  git_fetch_us must have already been called.
3157     get_archive_dsc();
3158
3159     if ($dsc) {
3160         parse_dsc_field($dsc, __ 'last upload to archive');
3161         resolve_dsc_field_commit access_basedistro,
3162             lrfetchrefs."/".$rewritemap
3163     } else {
3164         progress __ "no version available from the archive";
3165     }
3166
3167     # If the archive's .dsc has a Dgit field, there are three
3168     # relevant git commitids we need to choose between and/or merge
3169     # together:
3170     #   1. $dsc_hash: the Dgit field from the archive
3171     #   2. $lastpush_hash: the suite branch on the dgit git server
3172     #   3. $lastfetch_hash: our local tracking brach for the suite
3173     #
3174     # These may all be distinct and need not be in any fast forward
3175     # relationship:
3176     #
3177     # If the dsc was pushed to this suite, then the server suite
3178     # branch will have been updated; but it might have been pushed to
3179     # a different suite and copied by the archive.  Conversely a more
3180     # recent version may have been pushed with dgit but not appeared
3181     # in the archive (yet).
3182     #
3183     # $lastfetch_hash may be awkward because archive imports
3184     # (particularly, imports of Dgit-less .dscs) are performed only as
3185     # needed on individual clients, so different clients may perform a
3186     # different subset of them - and these imports are only made
3187     # public during push.  So $lastfetch_hash may represent a set of
3188     # imports different to a subsequent upload by a different dgit
3189     # client.
3190     #
3191     # Our approach is as follows:
3192     #
3193     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3194     # descendant of $dsc_hash, then it was pushed by a dgit user who
3195     # had based their work on $dsc_hash, so we should prefer it.
3196     # Otherwise, $dsc_hash was installed into this suite in the
3197     # archive other than by a dgit push, and (necessarily) after the
3198     # last dgit push into that suite (since a dgit push would have
3199     # been descended from the dgit server git branch); thus, in that
3200     # case, we prefer the archive's version (and produce a
3201     # pseudo-merge to overwrite the dgit server git branch).
3202     #
3203     # (If there is no Dgit field in the archive's .dsc then
3204     # generate_commit_from_dsc uses the version numbers to decide
3205     # whether the suite branch or the archive is newer.  If the suite
3206     # branch is newer it ignores the archive's .dsc; otherwise it
3207     # generates an import of the .dsc, and produces a pseudo-merge to
3208     # overwrite the suite branch with the archive contents.)
3209     #
3210     # The outcome of that part of the algorithm is the `public view',
3211     # and is same for all dgit clients: it does not depend on any
3212     # unpublished history in the local tracking branch.
3213     #
3214     # As between the public view and the local tracking branch: The
3215     # local tracking branch is only updated by dgit fetch, and
3216     # whenever dgit fetch runs it includes the public view in the
3217     # local tracking branch.  Therefore if the public view is not
3218     # descended from the local tracking branch, the local tracking
3219     # branch must contain history which was imported from the archive
3220     # but never pushed; and, its tip is now out of date.  So, we make
3221     # a pseudo-merge to overwrite the old imports and stitch the old
3222     # history in.
3223     #
3224     # Finally: we do not necessarily reify the public view (as
3225     # described above).  This is so that we do not end up stacking two
3226     # pseudo-merges.  So what we actually do is figure out the inputs
3227     # to any public view pseudo-merge and put them in @mergeinputs.
3228
3229     my @mergeinputs;
3230     # $mergeinputs[]{Commit}
3231     # $mergeinputs[]{Info}
3232     # $mergeinputs[0] is the one whose tree we use
3233     # @mergeinputs is in the order we use in the actual commit)
3234     #
3235     # Also:
3236     # $mergeinputs[]{Message} is a commit message to use
3237     # $mergeinputs[]{ReverseParents} if def specifies that parent
3238     #                                list should be in opposite order
3239     # Such an entry has no Commit or Info.  It applies only when found
3240     # in the last entry.  (This ugliness is to support making
3241     # identical imports to previous dgit versions.)
3242
3243     my $lastpush_hash = git_get_ref(lrfetchref());
3244     printdebug "previous reference hash=$lastpush_hash\n";
3245     $lastpush_mergeinput = $lastpush_hash && {
3246         Commit => $lastpush_hash,
3247         Info => (__ "dgit suite branch on dgit git server"),
3248     };
3249
3250     my $lastfetch_hash = git_get_ref(lrref());
3251     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3252     my $lastfetch_mergeinput = $lastfetch_hash && {
3253         Commit => $lastfetch_hash,
3254         Info => (__ "dgit client's archive history view"),
3255     };
3256
3257     my $dsc_mergeinput = $dsc_hash && {
3258         Commit => $dsc_hash,
3259         Info => (__ "Dgit field in .dsc from archive"),
3260     };
3261
3262     my $cwd = getcwd();
3263     my $del_lrfetchrefs = sub {
3264         changedir $cwd;
3265         my $gur;
3266         printdebug "del_lrfetchrefs...\n";
3267         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3268             my $objid = $lrfetchrefs_d{$fullrefname};
3269             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3270             if (!$gur) {
3271                 $gur ||= new IO::Handle;
3272                 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3273             }
3274             printf $gur "delete %s %s\n", $fullrefname, $objid;
3275         }
3276         if ($gur) {
3277             close $gur or failedcmd "git update-ref delete lrfetchrefs";
3278         }
3279     };
3280
3281     if (defined $dsc_hash) {
3282         ensure_we_have_orig();
3283         if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3284             @mergeinputs = $dsc_mergeinput
3285         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3286             print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3287
3288 Git commit in archive is behind the last version allegedly pushed/uploaded.
3289 Commit referred to by archive: %s
3290 Last version pushed with dgit: %s
3291 %s
3292 END
3293                 __ $later_warning_msg or confess "$!";
3294             @mergeinputs = ($lastpush_mergeinput);
3295         } else {
3296             # Archive has .dsc which is not a descendant of the last dgit
3297             # push.  This can happen if the archive moves .dscs about.
3298             # Just follow its lead.
3299             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3300                 progress __ "archive .dsc names newer git commit";
3301                 @mergeinputs = ($dsc_mergeinput);
3302             } else {
3303                 progress __ "archive .dsc names other git commit, fixing up";
3304                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3305             }
3306         }
3307     } elsif ($dsc) {
3308         @mergeinputs = generate_commits_from_dsc();
3309         # We have just done an import.  Now, our import algorithm might
3310         # have been improved.  But even so we do not want to generate
3311         # a new different import of the same package.  So if the
3312         # version numbers are the same, just use our existing version.
3313         # If the version numbers are different, the archive has changed
3314         # (perhaps, rewound).
3315         if ($lastfetch_mergeinput &&
3316             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3317                               (mergeinfo_version $mergeinputs[0]) )) {
3318             @mergeinputs = ($lastfetch_mergeinput);
3319         }
3320     } elsif ($lastpush_hash) {
3321         # only in git, not in the archive yet
3322         @mergeinputs = ($lastpush_mergeinput);
3323         print STDERR f_ <<END,
3324
3325 Package not found in the archive, but has allegedly been pushed using dgit.
3326 %s
3327 END
3328             __ $later_warning_msg or confess "$!";
3329     } else {
3330         printdebug "nothing found!\n";
3331         if (defined $skew_warning_vsn) {
3332             print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3333
3334 Warning: relevant archive skew detected.
3335 Archive allegedly contains %s
3336 But we were not able to obtain any version from the archive or git.
3337
3338 END
3339         }
3340         unshift @end, $del_lrfetchrefs;
3341         return undef;
3342     }
3343
3344     if ($lastfetch_hash &&
3345         !grep {
3346             my $h = $_->{Commit};
3347             $h and is_fast_fwd($lastfetch_hash, $h);
3348             # If true, one of the existing parents of this commit
3349             # is a descendant of the $lastfetch_hash, so we'll
3350             # be ff from that automatically.
3351         } @mergeinputs
3352         ) {
3353         # Otherwise:
3354         push @mergeinputs, $lastfetch_mergeinput;
3355     }
3356
3357     printdebug "fetch mergeinfos:\n";
3358     foreach my $mi (@mergeinputs) {
3359         if ($mi->{Info}) {
3360             printdebug " commit $mi->{Commit} $mi->{Info}\n";
3361         } else {
3362             printdebug sprintf " ReverseParents=%d Message=%s",
3363                 $mi->{ReverseParents}, $mi->{Message};
3364         }
3365     }
3366
3367     my $compat_info= pop @mergeinputs
3368         if $mergeinputs[$#mergeinputs]{Message};
3369
3370     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3371
3372     my $hash;
3373     if (@mergeinputs > 1) {
3374         # here we go, then:
3375         my $tree_commit = $mergeinputs[0]{Commit};
3376
3377         my $tree = get_tree_of_commit $tree_commit;;
3378
3379         # We use the changelog author of the package in question the
3380         # author of this pseudo-merge.  This is (roughly) correct if
3381         # this commit is simply representing aa non-dgit upload.
3382         # (Roughly because it does not record sponsorship - but we
3383         # don't have sponsorship info because that's in the .changes,
3384         # which isn't in the archivw.)
3385         #
3386         # But, it might be that we are representing archive history
3387         # updates (including in-archive copies).  These are not really
3388         # the responsibility of the person who created the .dsc, but
3389         # there is no-one whose name we should better use.  (The
3390         # author of the .dsc-named commit is clearly worse.)
3391
3392         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3393         my $author = clogp_authline $useclogp;
3394         my $cversion = getfield $useclogp, 'Version';
3395
3396         my $mcf = dgit_privdir()."/mergecommit";
3397         open MC, ">", $mcf or die "$mcf $!";
3398         print MC <<END or confess "$!";
3399 tree $tree
3400 END
3401
3402         my @parents = grep { $_->{Commit} } @mergeinputs;
3403         @parents = reverse @parents if $compat_info->{ReverseParents};
3404         print MC <<END or confess "$!" foreach @parents;
3405 parent $_->{Commit}
3406 END
3407
3408         print MC <<END or confess "$!";
3409 author $author
3410 committer $author
3411
3412 END
3413
3414         if (defined $compat_info->{Message}) {
3415             print MC $compat_info->{Message} or confess "$!";
3416         } else {
3417             print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3418 Record %s (%s) in archive suite %s
3419
3420 Record that
3421 END
3422             my $message_add_info = sub {
3423                 my ($mi) = (@_);
3424                 my $mversion = mergeinfo_version $mi;
3425                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
3426                     or confess "$!";
3427             };
3428
3429             $message_add_info->($mergeinputs[0]);
3430             print MC __ <<END or confess "$!";
3431 should be treated as descended from
3432 END
3433             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3434         }
3435
3436         close MC or confess "$!";
3437         $hash = hash_commit $mcf;
3438     } else {
3439         $hash = $mergeinputs[0]{Commit};
3440     }
3441     printdebug "fetch hash=$hash\n";
3442
3443     my $chkff = sub {
3444         my ($lasth, $what) = @_;
3445         return unless $lasth;
3446         confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3447     };
3448
3449     $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3450         if $lastpush_hash;
3451     $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3452
3453     fetch_from_archive_record_1($hash);
3454
3455     if (defined $skew_warning_vsn) {
3456         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3457         my $gotclogp = commit_getclogp($hash);
3458         my $got_vsn = getfield $gotclogp, 'Version';
3459         printdebug "SKEW CHECK GOT $got_vsn\n";
3460         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3461             print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3462
3463 Warning: archive skew detected.  Using the available version:
3464 Archive allegedly contains    %s
3465 We were able to obtain only   %s
3466
3467 END
3468         }
3469     }
3470
3471     if ($lastfetch_hash ne $hash) {
3472         fetch_from_archive_record_2($hash);
3473     }
3474
3475     lrfetchref_used lrfetchref();
3476
3477     check_gitattrs($hash, __ "fetched source tree");
3478
3479     unshift @end, $del_lrfetchrefs;
3480     return $hash;
3481 }
3482
3483 sub set_local_git_config ($$) {
3484     my ($k, $v) = @_;
3485     runcmd @git, qw(config), $k, $v;
3486 }
3487
3488 sub setup_mergechangelogs (;$) {
3489     my ($always) = @_;
3490     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3491
3492     my $driver = 'dpkg-mergechangelogs';
3493     my $cb = "merge.$driver";
3494     confess unless defined $maindir;
3495     my $attrs = "$maindir_gitcommon/info/attributes";
3496     ensuredir "$maindir_gitcommon/info";
3497
3498     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3499     if (!open ATTRS, "<", $attrs) {
3500         $!==ENOENT or die "$attrs: $!";
3501     } else {
3502         while (<ATTRS>) {
3503             chomp;
3504             next if m{^debian/changelog\s};
3505             print NATTRS $_, "\n" or confess "$!";
3506         }
3507         ATTRS->error and confess "$!";
3508         close ATTRS;
3509     }
3510     print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3511     close NATTRS;
3512
3513     set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3514     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3515
3516     rename "$attrs.new", "$attrs" or die "$attrs: $!";
3517 }
3518
3519 sub setup_useremail (;$) {
3520     my ($always) = @_;
3521     return unless $always || access_cfg_bool(1, 'setup-useremail');
3522
3523     my $setup = sub {
3524         my ($k, $envvar) = @_;
3525         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3526         return unless defined $v;
3527         set_local_git_config "user.$k", $v;
3528     };
3529
3530     $setup->('email', 'DEBEMAIL');
3531     $setup->('name', 'DEBFULLNAME');
3532 }
3533
3534 sub ensure_setup_existing_tree () {
3535     my $k = "remote.$remotename.skipdefaultupdate";
3536     my $c = git_get_config $k;
3537     return if defined $c;
3538     set_local_git_config $k, 'true';
3539 }
3540
3541 sub open_main_gitattrs () {
3542     confess 'internal error no maindir' unless defined $maindir;
3543     my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3544         or $!==ENOENT
3545         or die "open $maindir_gitcommon/info/attributes: $!";
3546     return $gai;
3547 }
3548
3549 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3550
3551 sub is_gitattrs_setup () {
3552     # return values:
3553     #  trueish
3554     #     1: gitattributes set up and should be left alone
3555     #  falseish
3556     #     0: there is a dgit-defuse-attrs but it needs fixing
3557     #     undef: there is none
3558     my $gai = open_main_gitattrs();
3559     return 0 unless $gai;
3560     while (<$gai>) {
3561         next unless m{$gitattrs_ourmacro_re};
3562         return 1 if m{\s-working-tree-encoding\s};
3563         printdebug "is_gitattrs_setup: found old macro\n";
3564         return 0;
3565     }
3566     $gai->error and confess "$!";
3567     printdebug "is_gitattrs_setup: found nothing\n";
3568     return undef;
3569 }
3570
3571 sub setup_gitattrs (;$) {
3572     my ($always) = @_;
3573     return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3574
3575     my $already = is_gitattrs_setup();
3576     if ($already) {
3577         progress __ <<END;
3578 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3579  not doing further gitattributes setup
3580 END
3581         return;
3582     }
3583     my $new = "[attr]dgit-defuse-attrs  $negate_harmful_gitattrs";
3584     my $af = "$maindir_gitcommon/info/attributes";
3585     ensuredir "$maindir_gitcommon/info";
3586
3587     open GAO, "> $af.new" or confess "$!";
3588     print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3589 *       dgit-defuse-attrs
3590 $new
3591 END
3592 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3593 ENDT
3594     my $gai = open_main_gitattrs();
3595     if ($gai) {
3596         while (<$gai>) {
3597             if (m{$gitattrs_ourmacro_re}) {
3598                 die unless defined $already;
3599                 $_ = $new;
3600             }
3601             chomp;
3602             print GAO $_, "\n" or confess "$!";
3603         }
3604         $gai->error and confess "$!";
3605     }
3606     close GAO or confess "$!";
3607     rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3608 }
3609
3610 sub setup_new_tree () {
3611     setup_mergechangelogs();
3612     setup_useremail();
3613     setup_gitattrs();
3614 }
3615
3616 sub check_gitattrs ($$) {
3617     my ($treeish, $what) = @_;
3618
3619     return if is_gitattrs_setup;
3620
3621     local $/="\0";
3622     my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3623     debugcmd "|",@cmd;
3624     my $gafl = new IO::File;
3625     open $gafl, "-|", @cmd or confess "$!";
3626     while (<$gafl>) {
3627         chomp or die;
3628         s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3629         next if $1 == 0;
3630         next unless m{(?:^|/)\.gitattributes$};
3631
3632         # oh dear, found one
3633         print STDERR f_ <<END, $what;
3634 dgit: warning: %s contains .gitattributes
3635 dgit: .gitattributes not (fully) defused.  Recommended: dgit setup-new-tree.
3636 END
3637         close $gafl;
3638         return;
3639     }
3640     # tree contains no .gitattributes files
3641     $?=0; $!=0; close $gafl or failedcmd @cmd;
3642 }
3643
3644
3645 sub multisuite_suite_child ($$$) {
3646     my ($tsuite, $mergeinputs, $fn) = @_;
3647     # in child, sets things up, calls $fn->(), and returns undef
3648     # in parent, returns canonical suite name for $tsuite
3649     my $canonsuitefh = IO::File::new_tmpfile;
3650     my $pid = fork // confess "$!";
3651     if (!$pid) {
3652         forkcheck_setup();
3653         $isuite = $tsuite;
3654         $us .= " [$isuite]";
3655         $debugprefix .= " ";
3656         progress f_ "fetching %s...", $tsuite;
3657         canonicalise_suite();
3658         print $canonsuitefh $csuite, "\n" or confess "$!";
3659         close $canonsuitefh or confess "$!";
3660         $fn->();
3661         return undef;
3662     }
3663     waitpid $pid,0 == $pid or confess "$!";
3664     fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3665         if $? && $?!=256*4;
3666     seek $canonsuitefh,0,0 or confess "$!";
3667     local $csuite = <$canonsuitefh>;
3668     confess "$!" unless defined $csuite && chomp $csuite;
3669     if ($? == 256*4) {
3670         printdebug "multisuite $tsuite missing\n";
3671         return $csuite;
3672     }
3673     printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3674     push @$mergeinputs, {
3675         Ref => lrref,
3676         Info => $csuite,
3677     };
3678     return $csuite;
3679 }
3680
3681 sub fork_for_multisuite ($) {
3682     my ($before_fetch_merge) = @_;
3683     # if nothing unusual, just returns ''
3684     #
3685     # if multisuite:
3686     # returns 0 to caller in child, to do first of the specified suites
3687     # in child, $csuite is not yet set
3688     #
3689     # returns 1 to caller in parent, to finish up anything needed after
3690     # in parent, $csuite is set to canonicalised portmanteau
3691
3692     my $org_isuite = $isuite;
3693     my @suites = split /\,/, $isuite;
3694     return '' unless @suites > 1;
3695     printdebug "fork_for_multisuite: @suites\n";
3696
3697     my @mergeinputs;
3698
3699     my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3700                                             sub { });
3701     return 0 unless defined $cbasesuite;
3702
3703     fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3704         unless @mergeinputs;
3705
3706     my @csuites = ($cbasesuite);
3707
3708     $before_fetch_merge->();
3709
3710     foreach my $tsuite (@suites[1..$#suites]) {
3711         $tsuite =~ s/^-/$cbasesuite-/;
3712         my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3713                                                sub {
3714             @end = ();
3715             fetch_one();
3716             finish 0;
3717         });
3718
3719         $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3720         push @csuites, $csubsuite;
3721     }
3722
3723     foreach my $mi (@mergeinputs) {
3724         my $ref = git_get_ref $mi->{Ref};
3725         die "$mi->{Ref} ?" unless length $ref;
3726         $mi->{Commit} = $ref;
3727     }
3728
3729     $csuite = join ",", @csuites;
3730
3731     my $previous = git_get_ref lrref;
3732     if ($previous) {
3733         unshift @mergeinputs, {
3734             Commit => $previous,
3735             Info => (__ "local combined tracking branch"),
3736             Warning => (__
3737  "archive seems to have rewound: local tracking branch is ahead!"),
3738         };
3739     }
3740
3741     foreach my $ix (0..$#mergeinputs) {
3742         $mergeinputs[$ix]{Index} = $ix;
3743     }
3744
3745     @mergeinputs = sort {
3746         -version_compare(mergeinfo_version $a,
3747                          mergeinfo_version $b) # highest version first
3748             or
3749         $a->{Index} <=> $b->{Index}; # earliest in spec first
3750     } @mergeinputs;
3751
3752     my @needed;
3753
3754   NEEDED:
3755     foreach my $mi (@mergeinputs) {
3756         printdebug "multisuite merge check $mi->{Info}\n";
3757         foreach my $previous (@needed) {
3758             next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3759             printdebug "multisuite merge un-needed $previous->{Info}\n";
3760             next NEEDED;
3761         }
3762         push @needed, $mi;
3763         printdebug "multisuite merge this-needed\n";
3764         $mi->{Character} = '+';
3765     }
3766
3767     $needed[0]{Character} = '*';
3768
3769     my $output = $needed[0]{Commit};
3770
3771     if (@needed > 1) {
3772         printdebug "multisuite merge nontrivial\n";
3773         my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3774
3775         my $commit = "tree $tree\n";
3776         my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3777                      "Input branches:\n",
3778                      $csuite;
3779
3780         foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3781             printdebug "multisuite merge include $mi->{Info}\n";
3782             $mi->{Character} //= ' ';
3783             $commit .= "parent $mi->{Commit}\n";
3784             $msg .= sprintf " %s  %-25s %s\n",
3785                 $mi->{Character},
3786                 (mergeinfo_version $mi),
3787                 $mi->{Info};
3788         }
3789         my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3790         $msg .= __ "\nKey\n".
3791             " * marks the highest version branch, which choose to use\n".
3792             " + marks each branch which was not already an ancestor\n\n";
3793         $msg .=
3794             "[dgit multi-suite $csuite]\n";
3795         $commit .=
3796             "author $authline\n".
3797             "committer $authline\n\n";
3798         $output = hash_commit_text $commit.$msg;
3799         printdebug "multisuite merge generated $output\n";
3800     }
3801
3802     fetch_from_archive_record_1($output);
3803     fetch_from_archive_record_2($output);
3804
3805     progress f_ "calculated combined tracking suite %s", $csuite;
3806
3807     return 1;
3808 }
3809
3810 sub clone_set_head () {
3811     open H, "> .git/HEAD" or confess "$!";
3812     print H "ref: ".lref()."\n" or confess "$!";
3813     close H or confess "$!";
3814 }
3815 sub clone_finish ($) {
3816     my ($dstdir) = @_;
3817     runcmd @git, qw(reset --hard), lrref();
3818     runcmd qw(bash -ec), <<'END';
3819         set -o pipefail
3820         git ls-tree -r --name-only -z HEAD | \
3821         xargs -0r touch -h -r . --
3822 END
3823     printdone f_ "ready for work in %s", $dstdir;
3824 }
3825
3826 sub clone ($) {
3827     # in multisuite, returns twice!
3828     # once in parent after first suite fetched,
3829     # and then again in child after everything is finished
3830     my ($dstdir) = @_;
3831     badusage __ "dry run makes no sense with clone" unless act_local();
3832
3833     my $multi_fetched = fork_for_multisuite(sub {
3834         printdebug "multi clone before fetch merge\n";
3835         changedir $dstdir;
3836         record_maindir();
3837     });
3838     if ($multi_fetched) {
3839         printdebug "multi clone after fetch merge\n";
3840         clone_set_head();
3841         clone_finish($dstdir);
3842         return;
3843     }
3844     printdebug "clone main body\n";
3845
3846     mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3847     changedir $dstdir;
3848     check_bpd_exists();
3849
3850     canonicalise_suite();
3851     my $hasgit = check_for_git();
3852
3853     runcmd @git, qw(init -q);
3854     record_maindir();
3855     setup_new_tree();
3856     clone_set_head();
3857     my $giturl = access_giturl(1);
3858     if (defined $giturl) {
3859         runcmd @git, qw(remote add), 'origin', $giturl;
3860     }
3861     if ($hasgit) {
3862         progress __ "fetching existing git history";
3863         git_fetch_us();
3864         runcmd_ordryrun_local @git, qw(fetch origin);
3865     } else {
3866         progress __ "starting new git history";
3867     }
3868     fetch_from_archive() or no_such_package;
3869     my $vcsgiturl = $dsc->{'Vcs-Git'};
3870     if (length $vcsgiturl) {
3871         $vcsgiturl =~ s/\s+-b\s+\S+//g;
3872         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3873     }
3874     clone_finish($dstdir);
3875 }
3876
3877 sub fetch_one () {
3878     canonicalise_suite();
3879     if (check_for_git()) {
3880         git_fetch_us();
3881     }
3882     fetch_from_archive() or no_such_package();
3883
3884     my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3885     if (length $vcsgiturl and
3886         (grep { $csuite eq $_ }
3887          split /\;/,
3888          cfg 'dgit.vcs-git.suites')) {
3889         my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3890         if (defined $current && $current ne $vcsgiturl) {
3891             print STDERR f_ <<END, $csuite;
3892 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3893  Your vcs-git remote url may be out of date.  Use dgit update-vcs-git ?
3894 END
3895         }
3896     }
3897     printdone f_ "fetched into %s", lrref();
3898 }
3899
3900 sub dofetch () {
3901     my $multi_fetched = fork_for_multisuite(sub { });
3902     fetch_one() unless $multi_fetched; # parent
3903     finish 0 if $multi_fetched eq '0'; # child
3904 }
3905
3906 sub pull () {
3907     dofetch();
3908     runcmd_ordryrun_local @git, qw(merge -m),
3909         (f_ "Merge from %s [dgit]", $csuite),
3910         lrref();
3911     printdone f_ "fetched to %s and merged into HEAD", lrref();
3912 }
3913
3914 sub check_not_dirty () {
3915     my @forbid = qw(local-options local-patch-header);
3916     @forbid = map { "debian/source/$_" } @forbid;
3917     foreach my $f (@forbid) {
3918         if (stat_exists $f) {
3919             fail f_ "git tree contains %s", $f;
3920         }
3921     }
3922
3923     my @cmd = (@git, qw(status -uall --ignored --porcelain));
3924     push @cmd, qw(debian/source/format debian/source/options);
3925     push @cmd, @forbid;
3926
3927     my $bad = cmdoutput @cmd;
3928     if (length $bad) {
3929         fail +(__
3930  "you have uncommitted changes to critical files, cannot continue:\n").
3931               $bad;
3932     }
3933
3934     return if $includedirty;
3935
3936     git_check_unmodified();
3937 }
3938
3939 sub commit_admin ($) {
3940     my ($m) = @_;
3941     progress "$m";
3942     runcmd_ordryrun_local @git, qw(commit -m), $m;
3943 }
3944
3945 sub quiltify_nofix_bail ($$) {
3946     my ($headinfo, $xinfo) = @_;
3947     if ($quilt_mode eq 'nofix') {
3948         fail f_
3949             "quilt fixup required but quilt mode is \`nofix'\n".
3950             "HEAD commit%s differs from tree implied by debian/patches%s",
3951             $headinfo, $xinfo;
3952     }
3953 }
3954
3955 sub commit_quilty_patch () {
3956     my $output = cmdoutput @git, qw(status --ignored --porcelain);
3957     my %adds;
3958     foreach my $l (split /\n/, $output) {
3959         next unless $l =~ m/\S/;
3960         if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3961             $adds{$1}++;
3962         }
3963     }
3964     delete $adds{'.pc'}; # if there wasn't one before, don't add it
3965     if (!%adds) {
3966         progress __ "nothing quilty to commit, ok.";
3967         return;
3968     }
3969     quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3970     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3971     runcmd_ordryrun_local @git, qw(add -f), @adds;
3972     commit_admin +(__ <<ENDT).<<END
3973 Commit Debian 3.0 (quilt) metadata
3974
3975 ENDT
3976 [dgit ($our_version) quilt-fixup]
3977 END
3978 }
3979
3980 sub get_source_format () {
3981     my %options;
3982     if (open F, "debian/source/options") {
3983         while (<F>) {
3984             next if m/^\s*\#/;
3985             next unless m/\S/;
3986             s/\s+$//; # ignore missing final newline
3987             if (m/\s*\#\s*/) {
3988                 my ($k, $v) = ($`, $'); #');
3989                 $v =~ s/^"(.*)"$/$1/;
3990                 $options{$k} = $v;
3991             } else {
3992                 $options{$_} = 1;
3993             }
3994         }
3995         F->error and confess "$!";
3996         close F;
3997     } else {
3998         confess "$!" unless $!==&ENOENT;
3999     }
4000
4001     if (!open F, "debian/source/format") {
4002         confess "$!" unless $!==&ENOENT;
4003         return '';
4004     }
4005     $_ = <F>;
4006     F->error and confess "$!";
4007     chomp;
4008     return ($_, \%options);
4009 }
4010
4011 sub madformat_wantfixup ($) {
4012     my ($format) = @_;
4013     return 0 unless $format eq '3.0 (quilt)';
4014     our $quilt_mode_warned;
4015     if ($quilt_mode eq 'nocheck') {
4016         progress f_ "Not doing any fixup of \`%s'".
4017             " due to ----no-quilt-fixup or --quilt=nocheck", $format
4018             unless $quilt_mode_warned++;
4019         return 0;
4020     }
4021     progress f_ "Format \`%s', need to check/update patch stack", $format
4022         unless $quilt_mode_warned++;
4023     return 1;
4024 }
4025
4026 sub maybe_split_brain_save ($$$) {
4027     my ($headref, $dgitview, $msg) = @_;
4028     # => message fragment "$saved" describing disposition of $dgitview
4029     #    (used inside parens, in the English texts)
4030     my $save = $internal_object_save{'dgit-view'};
4031     return f_ "commit id %s", $dgitview unless defined $save;
4032     my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4033                git_update_ref_cmd
4034                "dgit --dgit-view-save $msg HEAD=$headref",
4035                $save, $dgitview);
4036     runcmd @cmd;
4037     return f_ "and left in %s", $save;
4038 }
4039
4040 # An "infopair" is a tuple [ $thing, $what ]
4041 # (often $thing is a commit hash; $what is a description)
4042
4043 sub infopair_cond_equal ($$) {
4044     my ($x,$y) = @_;
4045     $x->[0] eq $y->[0] or fail <<END;
4046 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4047 END
4048 };
4049
4050 sub infopair_lrf_tag_lookup ($$) {
4051     my ($tagnames, $what) = @_;
4052     # $tagname may be an array ref
4053     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4054     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4055     foreach my $tagname (@tagnames) {
4056         my $lrefname = lrfetchrefs."/tags/$tagname";
4057         my $tagobj = $lrfetchrefs_f{$lrefname};
4058         next unless defined $tagobj;
4059         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4060         return [ git_rev_parse($tagobj), $what ];
4061     }
4062     fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4063 Wanted tag %s (%s) on dgit server, but not found
4064 END
4065                       : (f_ <<END, $what, "@tagnames");
4066 Wanted tag %s (one of: %s) on dgit server, but not found
4067 END
4068 }
4069
4070 sub infopair_cond_ff ($$) {
4071     my ($anc,$desc) = @_;
4072     is_fast_fwd($anc->[0], $desc->[0]) or
4073         fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4074 %s (%s) .. %s (%s) is not fast forward
4075 END
4076 };
4077
4078 sub pseudomerge_version_check ($$) {
4079     my ($clogp, $archive_hash) = @_;
4080
4081     my $arch_clogp = commit_getclogp $archive_hash;
4082     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4083                      __ 'version currently in archive' ];
4084     if (defined $overwrite_version) {
4085         if (length $overwrite_version) {
4086             infopair_cond_equal([ $overwrite_version,
4087                                   '--overwrite= version' ],
4088                                 $i_arch_v);
4089         } else {
4090             my $v = $i_arch_v->[0];
4091             progress f_
4092                 "Checking package changelog for archive version %s ...", $v;
4093             my $cd;
4094             eval {
4095                 my @xa = ("-f$v", "-t$v");
4096                 my $vclogp = parsechangelog @xa;
4097                 my $gf = sub {
4098                     my ($fn) = @_;
4099                     [ (getfield $vclogp, $fn),
4100                       (f_ "%s field from dpkg-parsechangelog %s",
4101                           $fn, "@xa") ];
4102                 };
4103                 my $cv = $gf->('Version');
4104                 infopair_cond_equal($i_arch_v, $cv);
4105                 $cd = $gf->('Distribution');
4106             };
4107             if ($@) {
4108                 $@ =~ s/^\n//s;
4109                 $@ =~ s/^dgit: //gm;
4110                 fail "$@".
4111                     f_ "Perhaps debian/changelog does not mention %s ?", $v;
4112             }
4113             fail f_ <<END, $cd->[1], $cd->[0], $v
4114 %s is %s
4115 Your tree seems to based on earlier (not uploaded) %s.
4116 END
4117                 if $cd->[0] =~ m/UNRELEASED/;
4118         }
4119     }
4120
4121     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4122     return $i_arch_v;
4123 }
4124
4125 sub pseudomerge_hash_commit ($$$$ $$) {
4126     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4127         $msg_cmd, $msg_msg) = @_;
4128     progress f_ "Declaring that HEAD includes all changes in %s...",
4129                  $i_arch_v->[0];
4130
4131     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4132     my $authline = clogp_authline $clogp;
4133
4134     chomp $msg_msg;
4135     $msg_cmd .=
4136         !defined $overwrite_version ? ""
4137         : !length  $overwrite_version ? " --overwrite"
4138         : " --overwrite=".$overwrite_version;
4139
4140     # Contributing parent is the first parent - that makes
4141     # git rev-list --first-parent DTRT.
4142     my $pmf = dgit_privdir()."/pseudomerge";
4143     open MC, ">", $pmf or die "$pmf $!";
4144     print MC <<END or confess "$!";
4145 tree $tree
4146 parent $dgitview
4147 parent $archive_hash
4148 author $authline
4149 committer $authline
4150
4151 $msg_msg
4152
4153 [$msg_cmd]
4154 END
4155     close MC or confess "$!";
4156
4157     return hash_commit($pmf);
4158 }
4159
4160 sub splitbrain_pseudomerge ($$$$) {
4161     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4162     # => $merged_dgitview
4163     printdebug "splitbrain_pseudomerge...\n";
4164     #
4165     #     We:      debian/PREVIOUS    HEAD($maintview)
4166     # expect:          o ----------------- o
4167     #                    \                   \
4168     #                     o                   o
4169     #                 a/d/PREVIOUS        $dgitview
4170     #                $archive_hash              \
4171     #  If so,                \                   \
4172     #  we do:                 `------------------ o
4173     #   this:                                   $dgitview'
4174     #
4175
4176     return $dgitview unless defined $archive_hash;
4177     return $dgitview if deliberately_not_fast_forward();
4178
4179     printdebug "splitbrain_pseudomerge...\n";
4180
4181     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4182
4183     if (!defined $overwrite_version) {
4184         progress __ "Checking that HEAD includes all changes in archive...";
4185     }
4186
4187     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4188
4189     if (defined $overwrite_version) {
4190     } elsif (!eval {
4191         my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4192         my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4193                                               __ "maintainer view tag");
4194         my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4195         my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4196         my $i_archive = [ $archive_hash, __ "current archive contents" ];
4197
4198         printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4199
4200         infopair_cond_equal($i_dgit, $i_archive);
4201         infopair_cond_ff($i_dep14, $i_dgit);
4202         infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4203         1;
4204     }) {
4205         $@ =~ s/^\n//; chomp $@;
4206         print STDERR <<END.(__ <<ENDT);
4207 $@
4208 END
4209 | Not fast forward; maybe --overwrite is needed ?  Please see dgit(1).
4210 ENDT
4211         finish -1;
4212     }
4213
4214     my $arch_v = $i_arch_v->[0];
4215     my $r = pseudomerge_hash_commit
4216         $clogp, $dgitview, $archive_hash, $i_arch_v,
4217         "dgit --quilt=$quilt_mode",
4218         (defined $overwrite_version
4219          ? f_ "Declare fast forward from %s\n", $arch_v
4220          : f_ "Make fast forward from %s\n",    $arch_v);
4221
4222     maybe_split_brain_save $maintview, $r, "pseudomerge";
4223
4224     progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4225     return $r;
4226 }
4227
4228 sub plain_overwrite_pseudomerge ($$$) {
4229     my ($clogp, $head, $archive_hash) = @_;
4230
4231     printdebug "plain_overwrite_pseudomerge...";
4232
4233     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4234
4235     return $head if is_fast_fwd $archive_hash, $head;
4236
4237     my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4238
4239     my $r = pseudomerge_hash_commit
4240         $clogp, $head, $archive_hash, $i_arch_v,
4241         "dgit", $m;
4242
4243     runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4244
4245     progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4246     return $r;
4247 }
4248
4249 sub push_parse_changelog ($) {
4250     my ($clogpfn) = @_;
4251
4252     my $clogp = Dpkg::Control::Hash->new();
4253     $clogp->load($clogpfn) or die;
4254
4255     my $clogpackage = getfield $clogp, 'Source';
4256     $package //= $clogpackage;
4257     fail f_ "-p specified %s but changelog specified %s",
4258             $package, $clogpackage
4259         unless $package eq $clogpackage;
4260     my $cversion = getfield $clogp, 'Version';
4261
4262     if (!$we_are_initiator) {
4263         # rpush initiator can't do this because it doesn't have $isuite yet
4264         my $tag = debiantag_new($cversion, access_nomdistro);
4265         runcmd @git, qw(check-ref-format), $tag;
4266     }
4267
4268     my $dscfn = dscfn($cversion);
4269
4270     return ($clogp, $cversion, $dscfn);
4271 }
4272
4273 sub push_parse_dsc ($$$) {
4274     my ($dscfn,$dscfnwhat, $cversion) = @_;
4275     $dsc = parsecontrol($dscfn,$dscfnwhat);
4276     my $dversion = getfield $dsc, 'Version';
4277     my $dscpackage = getfield $dsc, 'Source';
4278     ($dscpackage eq $package && $dversion eq $cversion) or
4279         fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4280                 $dscfn, $dscpackage, $dversion,
4281                         $package,    $cversion;
4282 }
4283
4284 sub push_tagwants ($$$$) {
4285     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4286     my @tagwants;
4287     push @tagwants, {
4288         TagFn => \&debiantag_new,
4289         Objid => $dgithead,
4290         TfSuffix => '',
4291         View => 'dgit',
4292     };
4293     if (defined $maintviewhead) {
4294         push @tagwants, {
4295             TagFn => \&debiantag_maintview,
4296             Objid => $maintviewhead,
4297             TfSuffix => '-maintview',
4298             View => 'maint',
4299         };
4300     } elsif ($dodep14tag ne 'no') {
4301         push @tagwants, {
4302             TagFn => \&debiantag_maintview,
4303             Objid => $dgithead,
4304             TfSuffix => '-dgit',
4305             View => 'dgit',
4306         };
4307     };
4308     foreach my $tw (@tagwants) {
4309         $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4310         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4311     }
4312     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4313     return @tagwants;
4314 }
4315
4316 sub push_mktags ($$ $$ $) {
4317     my ($clogp,$dscfn,
4318         $changesfile,$changesfilewhat,
4319         $tagwants) = @_;
4320
4321     die unless $tagwants->[0]{View} eq 'dgit';
4322
4323     my $declaredistro = access_nomdistro();
4324     my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4325     $dsc->{$ourdscfield[0]} = join " ",
4326         $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4327         $reader_giturl;
4328     $dsc->save("$dscfn.tmp") or confess "$!";
4329
4330     my $changes = parsecontrol($changesfile,$changesfilewhat);
4331     foreach my $field (qw(Source Distribution Version)) {
4332         $changes->{$field} eq $clogp->{$field} or
4333             fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4334                     $field, $changes->{$field}, $clogp->{$field};
4335     }
4336
4337     my $cversion = getfield $clogp, 'Version';
4338     my $clogsuite = getfield $clogp, 'Distribution';
4339
4340     # We make the git tag by hand because (a) that makes it easier
4341     # to control the "tagger" (b) we can do remote signing
4342     my $authline = clogp_authline $clogp;
4343     my $delibs = join(" ", "",@deliberatelies);
4344
4345     my $mktag = sub {
4346         my ($tw) = @_;
4347         my $tfn = $tw->{Tfn};
4348         my $head = $tw->{Objid};
4349         my $tag = $tw->{Tag};
4350
4351         open TO, '>', $tfn->('.tmp') or confess "$!";
4352         print TO <<END or confess "$!";
4353 object $head
4354 type commit
4355 tag $tag
4356 tagger $authline
4357
4358 END
4359         if ($tw->{View} eq 'dgit') {
4360             print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4361 %s release %s for %s (%s) [dgit]
4362 ENDT
4363                 or confess "$!";
4364             print TO <<END or confess "$!";
4365 [dgit distro=$declaredistro$delibs]
4366 END
4367             foreach my $ref (sort keys %previously) {
4368                 print TO <<END or confess "$!";
4369 [dgit previously:$ref=$previously{$ref}]
4370 END
4371             }
4372         } elsif ($tw->{View} eq 'maint') {
4373             print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4374 %s release %s for %s (%s)
4375 (maintainer view tag generated by dgit --quilt=%s)
4376 END
4377                 $quilt_mode
4378                 or confess "$!";
4379         } else {
4380             confess Dumper($tw)."?";
4381         }
4382
4383         close TO or confess "$!";
4384
4385         my $tagobjfn = $tfn->('.tmp');
4386         if ($sign) {
4387             if (!defined $keyid) {
4388                 $keyid = access_cfg('keyid','RETURN-UNDEF');
4389             }
4390             if (!defined $keyid) {
4391                 $keyid = getfield $clogp, 'Maintainer';
4392             }
4393             unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4394             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4395             push @sign_cmd, qw(-u),$keyid if defined $keyid;
4396             push @sign_cmd, $tfn->('.tmp');
4397             runcmd_ordryrun @sign_cmd;
4398             if (act_scary()) {
4399                 $tagobjfn = $tfn->('.signed.tmp');
4400                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4401                     $tfn->('.tmp'), $tfn->('.tmp.asc');
4402             }
4403         }
4404         return $tagobjfn;
4405     };
4406
4407     my @r = map { $mktag->($_); } @$tagwants;
4408     return @r;
4409 }
4410
4411 sub sign_changes ($) {
4412     my ($changesfile) = @_;
4413     if ($sign) {
4414         my @debsign_cmd = @debsign;
4415         push @debsign_cmd, "-k$keyid" if defined $keyid;
4416         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4417         push @debsign_cmd, $changesfile;
4418         runcmd_ordryrun @debsign_cmd;
4419     }
4420 }
4421
4422 sub dopush () {
4423     printdebug "actually entering push\n";
4424
4425     supplementary_message(__ <<'END');
4426 Push failed, while checking state of the archive.
4427 You can retry the push, after fixing the problem, if you like.
4428 END
4429     if (check_for_git()) {
4430         git_fetch_us();
4431     }
4432     my $archive_hash = fetch_from_archive();
4433     if (!$archive_hash) {
4434         $new_package or
4435             fail __ "package appears to be new in this suite;".
4436                     " if this is intentional, use --new";
4437     }
4438
4439     supplementary_message(__ <<'END');
4440 Push failed, while preparing your push.
4441 You can retry the push, after fixing the problem, if you like.
4442 END
4443
4444     prep_ud();
4445
4446     access_giturl(); # check that success is vaguely likely
4447     rpush_handle_protovsn_bothends() if $we_are_initiator;
4448
4449     my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4450     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4451
4452     responder_send_file('parsed-changelog', $clogpfn);
4453
4454     my ($clogp, $cversion, $dscfn) =
4455         push_parse_changelog("$clogpfn");
4456
4457     my $dscpath = "$buildproductsdir/$dscfn";
4458     stat_exists $dscpath or
4459         fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4460                 $dscpath, $!;
4461
4462     responder_send_file('dsc', $dscpath);
4463
4464     push_parse_dsc($dscpath, $dscfn, $cversion);
4465
4466     my $format = getfield $dsc, 'Format';
4467
4468     my $symref = git_get_symref();
4469     my $actualhead = git_rev_parse('HEAD');
4470
4471     if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4472         if (quiltmode_splitting()) {
4473             my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4474             fail f_ <<END, $ffq_prev, $quilt_mode;
4475 Branch is managed by git-debrebase (%s
4476 exists), but quilt mode (%s) implies a split view.
4477 Pass the right --quilt option or adjust your git config.
4478 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4479 END
4480         }
4481         runcmd_ordryrun_local @git_debrebase, 'stitch';
4482         $actualhead = git_rev_parse('HEAD');
4483     }
4484
4485     my $dgithead = $actualhead;
4486     my $maintviewhead = undef;
4487
4488     my $upstreamversion = upstreamversion $clogp->{Version};
4489
4490     if (madformat_wantfixup($format)) {
4491         # user might have not used dgit build, so maybe do this now:
4492         if (do_split_brain()) {
4493             changedir $playground;
4494             my $cachekey;
4495             ($dgithead, $cachekey) =
4496                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4497             $dgithead or fail f_
4498  "--quilt=%s but no cached dgit view:
4499  perhaps HEAD changed since dgit build[-source] ?",
4500                               $quilt_mode;
4501         }
4502         if (!do_split_brain()) {
4503             # In split brain mode, do not attempt to incorporate dirty
4504             # stuff from the user's working tree.  That would be mad.
4505             commit_quilty_patch();
4506         }
4507     }
4508     if (do_split_brain()) {
4509         $made_split_brain = 1;
4510         $dgithead = splitbrain_pseudomerge($clogp,
4511                                            $actualhead, $dgithead,
4512                                            $archive_hash);
4513         $maintviewhead = $actualhead;
4514         changedir $maindir;
4515         prep_ud(); # so _only_subdir() works, below
4516     }
4517
4518     if (defined $overwrite_version && !defined $maintviewhead
4519         && $archive_hash) {
4520         $dgithead = plain_overwrite_pseudomerge($clogp,
4521                                                 $dgithead,
4522                                                 $archive_hash);
4523     }
4524
4525     check_not_dirty();
4526
4527     my $forceflag = '';
4528     if ($archive_hash) {
4529         if (is_fast_fwd($archive_hash, $dgithead)) {
4530             # ok
4531         } elsif (deliberately_not_fast_forward) {
4532             $forceflag = '+';
4533         } else {
4534             fail __ "dgit push: HEAD is not a descendant".
4535                 " of the archive's version.\n".
4536                 "To overwrite the archive's contents,".
4537                 " pass --overwrite[=VERSION].\n".
4538                 "To rewind history, if permitted by the archive,".
4539                 " use --deliberately-not-fast-forward.";
4540         }
4541     }
4542
4543     confess unless !!$made_split_brain == do_split_brain();
4544
4545     changedir $playground;
4546     progress f_ "checking that %s corresponds to HEAD", $dscfn;
4547     runcmd qw(dpkg-source -x --),
4548         $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4549     my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4550     check_for_vendor_patches() if madformat($dsc->{format});
4551     changedir $maindir;
4552     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4553     debugcmd "+",@diffcmd;
4554     $!=0; $?=-1;
4555     my $r = system @diffcmd;
4556     if ($r) {
4557         if ($r==256) {
4558             my $referent = $made_split_brain ? $dgithead : 'HEAD';
4559             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4560
4561             my @mode_changes;
4562             my $raw = cmdoutput @git,
4563                 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4564             my $changed;
4565             foreach (split /\0/, $raw) {
4566                 if (defined $changed) {
4567                     push @mode_changes, "$changed: $_\n" if $changed;
4568                     $changed = undef;
4569                     next;
4570                 } elsif (m/^:0+ 0+ /) {
4571                     $changed = '';
4572                 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4573                     $changed = "Mode change from $1 to $2"
4574                 } else {
4575                     die "$_ ?";
4576                 }
4577             }
4578             if (@mode_changes) {
4579                 fail +(f_ <<ENDT, $dscfn).<<END
4580 HEAD specifies a different tree to %s:
4581 ENDT
4582 $diffs
4583 END
4584                     .(join '', @mode_changes)
4585                     .(f_ <<ENDT, $tree, $referent);
4586 There is a problem with your source tree (see dgit(7) for some hints).
4587 To see a full diff, run git diff %s %s
4588 ENDT
4589             }
4590
4591             fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4592 HEAD specifies a different tree to %s:
4593 ENDT
4594 $diffs
4595 END
4596 Perhaps you forgot to build.  Or perhaps there is a problem with your
4597  source tree (see dgit(7) for some hints).  To see a full diff, run
4598    git diff %s %s
4599 ENDT
4600         } else {
4601             failedcmd @diffcmd;
4602         }
4603     }
4604     if (!$changesfile) {
4605         my $pat = changespat $cversion;
4606         my @cs = glob "$buildproductsdir/$pat";
4607         fail f_ "failed to find unique changes file".
4608                 " (looked for %s in %s);".
4609                 " perhaps you need to use dgit -C",
4610                 $pat, $buildproductsdir
4611             unless @cs==1;
4612         ($changesfile) = @cs;
4613     } else {
4614         $changesfile = "$buildproductsdir/$changesfile";
4615     }
4616
4617     # Check that changes and .dsc agree enough
4618     $changesfile =~ m{[^/]*$};
4619     my $changes = parsecontrol($changesfile,$&);
4620     files_compare_inputs($dsc, $changes)
4621         unless forceing [qw(dsc-changes-mismatch)];
4622
4623     # Check whether this is a source only upload
4624     my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4625     my $sourceonlypolicy = access_cfg 'source-only-uploads';
4626     if ($sourceonlypolicy eq 'ok') {
4627     } elsif ($sourceonlypolicy eq 'always') {
4628         forceable_fail [qw(uploading-binaries)],
4629             __ "uploading binaries, although distro policy is source only"
4630             if $hasdebs;
4631     } elsif ($sourceonlypolicy eq 'never') {
4632         forceable_fail [qw(uploading-source-only)],
4633             __ "source-only upload, although distro policy requires .debs"
4634             if !$hasdebs;
4635     } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4636         forceable_fail [qw(uploading-source-only)],
4637             f_ "source-only upload, even though package is entirely NEW\n".
4638                "(this is contrary to policy in %s)",
4639                access_nomdistro()
4640             if !$hasdebs
4641             && $new_package
4642             && !(archive_query('package_not_wholly_new', $package) // 1);
4643     } else {
4644         badcfg f_ "unknown source-only-uploads policy \`%s'",
4645                   $sourceonlypolicy;
4646     }
4647
4648     # Perhaps adjust .dsc to contain right set of origs
4649     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4650                                   $changesfile)
4651         unless forceing [qw(changes-origs-exactly)];
4652
4653     # Checks complete, we're going to try and go ahead:
4654
4655     responder_send_file('changes',$changesfile);
4656     responder_send_command("param head $dgithead");
4657     responder_send_command("param csuite $csuite");
4658     responder_send_command("param isuite $isuite");
4659     responder_send_command("param tagformat new"); # needed in $protovsn==4
4660     if (defined $maintviewhead) {
4661         responder_send_command("param maint-view $maintviewhead");
4662     }
4663
4664     # Perhaps send buildinfo(s) for signing
4665     my $changes_files = getfield $changes, 'Files';
4666     my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4667     foreach my $bi (@buildinfos) {
4668         responder_send_command("param buildinfo-filename $bi");
4669         responder_send_file('buildinfo', "$buildproductsdir/$bi");
4670     }
4671
4672     if (deliberately_not_fast_forward) {
4673         git_for_each_ref(lrfetchrefs, sub {
4674             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4675             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4676             responder_send_command("previously $rrefname=$objid");
4677             $previously{$rrefname} = $objid;
4678         });
4679     }
4680
4681     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4682                                  dgit_privdir()."/tag");
4683     my @tagobjfns;
4684
4685     supplementary_message(__ <<'END');
4686 Push failed, while signing the tag.
4687 You can retry the push, after fixing the problem, if you like.
4688 END
4689     # If we manage to sign but fail to record it anywhere, it's fine.
4690     if ($we_are_responder) {
4691         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4692         responder_receive_files('signed-tag', @tagobjfns);
4693     } else {
4694         @tagobjfns = push_mktags($clogp,$dscpath,
4695                               $changesfile,$changesfile,
4696                               \@tagwants);
4697     }
4698     supplementary_message(__ <<'END');
4699 Push failed, *after* signing the tag.
4700 If you want to try again, you should use a new version number.
4701 END
4702
4703     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4704
4705     foreach my $tw (@tagwants) {
4706         my $tag = $tw->{Tag};
4707         my $tagobjfn = $tw->{TagObjFn};
4708         my $tag_obj_hash =
4709             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4710         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4711         runcmd_ordryrun_local
4712             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4713     }
4714
4715     supplementary_message(__ <<'END');
4716 Push failed, while updating the remote git repository - see messages above.
4717 If you want to try again, you should use a new version number.
4718 END
4719     if (!check_for_git()) {
4720         create_remote_git_repo();
4721     }
4722
4723     my @pushrefs = $forceflag.$dgithead.":".rrref();
4724     foreach my $tw (@tagwants) {
4725         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4726     }
4727
4728     runcmd_ordryrun @git,
4729         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4730     runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4731
4732     supplementary_message(__ <<'END');
4733 Push failed, while obtaining signatures on the .changes and .dsc.
4734 If it was just that the signature failed, you may try again by using
4735 debsign by hand to sign the changes file (see the command dgit tried,
4736 above), and then dput that changes file to complete the upload.
4737 If you need to change the package, you must use a new version number.
4738 END
4739     if ($we_are_responder) {
4740         my $dryrunsuffix = act_local() ? "" : ".tmp";
4741         my @rfiles = ($dscpath, $changesfile);
4742         push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4743         responder_receive_files('signed-dsc-changes',
4744                                 map { "$_$dryrunsuffix" } @rfiles);
4745     } else {
4746         if (act_local()) {
4747             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4748         } else {
4749             progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4750         }
4751         sign_changes $changesfile;
4752     }
4753
4754     supplementary_message(f_ <<END, $changesfile);
4755 Push failed, while uploading package(s) to the archive server.
4756 You can retry the upload of exactly these same files with dput of:
4757   %s
4758 If that .changes file is broken, you will need to use a new version
4759 number for your next attempt at the upload.
4760 END
4761     my $host = access_cfg('upload-host','RETURN-UNDEF');
4762     my @hostarg = defined($host) ? ($host,) : ();
4763     runcmd_ordryrun @dput, @hostarg, $changesfile;
4764     printdone f_ "pushed and uploaded %s", $cversion;
4765
4766     supplementary_message('');
4767     responder_send_command("complete");
4768 }
4769
4770 sub pre_clone () {
4771     not_necessarily_a_tree();
4772 }
4773 sub cmd_clone {
4774     parseopts();
4775     my $dstdir;
4776     badusage __ "-p is not allowed with clone; specify as argument instead"
4777         if defined $package;
4778     if (@ARGV==1) {
4779         ($package) = @ARGV;
4780     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4781         ($package,$isuite) = @ARGV;
4782     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4783         ($package,$dstdir) = @ARGV;
4784     } elsif (@ARGV==3) {
4785         ($package,$isuite,$dstdir) = @ARGV;
4786     } else {
4787         badusage __ "incorrect arguments to dgit clone";
4788     }
4789     notpushing();
4790
4791     $dstdir ||= "$package";
4792     if (stat_exists $dstdir) {
4793         fail f_ "%s already exists", $dstdir;
4794     }
4795
4796     my $cwd_remove;
4797     if ($rmonerror && !$dryrun_level) {
4798         $cwd_remove= getcwd();
4799         unshift @end, sub {
4800             return unless defined $cwd_remove;
4801             if (!chdir "$cwd_remove") {
4802                 return if $!==&ENOENT;
4803                 confess "chdir $cwd_remove: $!";
4804             }
4805             printdebug "clone rmonerror removing $dstdir\n";
4806             if (stat $dstdir) {
4807                 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4808             } elsif (grep { $! == $_ }
4809                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4810             } else {
4811                 print STDERR f_ "check whether to remove %s: %s\n",
4812                                 $dstdir, $!;
4813             }
4814         };
4815     }
4816
4817     clone($dstdir);
4818     $cwd_remove = undef;
4819 }
4820
4821 sub branchsuite () {
4822     my $branch = git_get_symref();
4823     if (defined $branch && $branch =~ m#$lbranch_re#o) {
4824         return $1;
4825     } else {
4826         return undef;
4827     }
4828 }
4829
4830 sub package_from_d_control () {
4831     if (!defined $package) {
4832         my $sourcep = parsecontrol('debian/control','debian/control');
4833         $package = getfield $sourcep, 'Source';
4834     }
4835 }
4836
4837 sub fetchpullargs () {
4838     package_from_d_control();
4839     if (@ARGV==0) {
4840         $isuite = branchsuite();
4841         if (!$isuite) {
4842             my $clogp = parsechangelog();
4843             my $clogsuite = getfield $clogp, 'Distribution';
4844             $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4845         }
4846     } elsif (@ARGV==1) {
4847         ($isuite) = @ARGV;
4848     } else {
4849         badusage __ "incorrect arguments to dgit fetch or dgit pull";
4850     }
4851     notpushing();
4852 }
4853
4854 sub cmd_fetch {
4855     parseopts();
4856     fetchpullargs();
4857     dofetch();
4858 }
4859
4860 sub cmd_pull {
4861     parseopts();
4862     fetchpullargs();
4863     determine_whether_split_brain();
4864     if (do_split_brain()) {
4865         my ($format, $fopts) = get_source_format();
4866         madformat($format) and fail f_ <<END, $quilt_mode
4867 dgit pull not yet supported in split view mode (including with view-splitting quilt modes)
4868 END
4869     }
4870     pull();
4871 }
4872
4873 sub cmd_checkout {
4874     parseopts();
4875     package_from_d_control();
4876     @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4877     ($isuite) = @ARGV;
4878     notpushing();
4879
4880     foreach my $canon (qw(0 1)) {
4881         if (!$canon) {
4882             $csuite= $isuite;
4883         } else {
4884             undef $csuite;
4885             canonicalise_suite();
4886         }
4887         if (length git_get_ref lref()) {
4888             # local branch already exists, yay
4889             last;
4890         }
4891         if (!length git_get_ref lrref()) {
4892             if (!$canon) {
4893                 # nope
4894                 next;
4895             }
4896             dofetch();
4897         }
4898         # now lrref exists
4899         runcmd (@git, qw(update-ref), lref(), lrref(), '');
4900         last;
4901     }
4902     local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4903         "dgit checkout $isuite";
4904     runcmd (@git, qw(checkout), lbranch());
4905 }
4906
4907 sub cmd_update_vcs_git () {
4908     my $specsuite;
4909     if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4910         ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4911     } else {
4912         ($specsuite) = (@ARGV);
4913         shift @ARGV;
4914     }
4915     my $dofetch=1;
4916     if (@ARGV) {
4917         if ($ARGV[0] eq '-') {
4918             $dofetch = 0;
4919         } elsif ($ARGV[0] eq '-') {
4920             shift;
4921         }
4922     }
4923
4924     package_from_d_control();
4925     my $ctrl;
4926     if ($specsuite eq '.') {
4927         $ctrl = parsecontrol 'debian/control', 'debian/control';
4928     } else {
4929         $isuite = $specsuite;
4930         get_archive_dsc();
4931         $ctrl = $dsc;
4932     }
4933     my $url = getfield $ctrl, 'Vcs-Git';
4934
4935     my @cmd;
4936     my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4937     if (!defined $orgurl) {
4938         print STDERR f_ "setting up vcs-git: %s\n", $url;
4939         @cmd = (@git, qw(remote add vcs-git), $url);
4940     } elsif ($orgurl eq $url) {
4941         print STDERR f_ "vcs git already configured: %s\n", $url;
4942     } else {
4943         print STDERR f_ "changing vcs-git url to: %s\n", $url;
4944         @cmd = (@git, qw(remote set-url vcs-git), $url);
4945     }
4946     runcmd_ordryrun_local @cmd;
4947     if ($dofetch) {
4948         print f_ "fetching (%s)\n", "@ARGV";
4949         runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4950     }
4951 }
4952
4953 sub prep_push () {
4954     parseopts();
4955     build_or_push_prep_early();
4956     pushing();
4957     build_or_push_prep_modes();
4958     check_not_dirty();
4959     my $specsuite;
4960     if (@ARGV==0) {
4961     } elsif (@ARGV==1) {
4962         ($specsuite) = (@ARGV);
4963     } else {
4964         badusage f_ "incorrect arguments to dgit %s", $subcommand;
4965     }
4966     if ($new_package) {
4967         local ($package) = $existing_package; # this is a hack
4968         canonicalise_suite();
4969     } else {
4970         canonicalise_suite();
4971     }
4972     if (defined $specsuite &&
4973         $specsuite ne $isuite &&
4974         $specsuite ne $csuite) {
4975             fail f_ "dgit %s: changelog specifies %s (%s)".
4976                     " but command line specifies %s",
4977                     $subcommand, $isuite, $csuite, $specsuite;
4978     }
4979 }
4980
4981 sub cmd_push {
4982     prep_push();
4983     dopush();
4984 }
4985
4986 #---------- remote commands' implementation ----------
4987
4988 sub pre_remote_push_build_host {
4989     my ($nrargs) = shift @ARGV;
4990     my (@rargs) = @ARGV[0..$nrargs-1];
4991     @ARGV = @ARGV[$nrargs..$#ARGV];
4992     die unless @rargs;
4993     my ($dir,$vsnwant) = @rargs;
4994     # vsnwant is a comma-separated list; we report which we have
4995     # chosen in our ready response (so other end can tell if they
4996     # offered several)
4997     $debugprefix = ' ';
4998     $we_are_responder = 1;
4999     $us .= " (build host)";
5000
5001     open PI, "<&STDIN" or confess "$!";
5002     open STDIN, "/dev/null" or confess "$!";
5003     open PO, ">&STDOUT" or confess "$!";
5004     autoflush PO 1;
5005     open STDOUT, ">&STDERR" or confess "$!";
5006     autoflush STDOUT 1;
5007
5008     $vsnwant //= 1;
5009     ($protovsn) = grep {
5010         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
5011     } @rpushprotovsn_support;
5012
5013     fail f_ "build host has dgit rpush protocol versions %s".
5014             " but invocation host has %s",
5015             (join ",", @rpushprotovsn_support), $vsnwant
5016         unless defined $protovsn;
5017
5018     changedir $dir;
5019 }
5020 sub cmd_remote_push_build_host {
5021     responder_send_command("dgit-remote-push-ready $protovsn");
5022     &cmd_push;
5023 }
5024
5025 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5026 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5027 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5028 #     a good error message)
5029
5030 sub rpush_handle_protovsn_bothends () {
5031 }
5032
5033 our $i_tmp;
5034
5035 sub i_cleanup {
5036     local ($@, $?);
5037     my $report = i_child_report();
5038     if (defined $report) {
5039         printdebug "($report)\n";
5040     } elsif ($i_child_pid) {
5041         printdebug "(killing build host child $i_child_pid)\n";
5042         kill 15, $i_child_pid;
5043     }
5044     if (defined $i_tmp && !defined $initiator_tempdir) {
5045         changedir "/";
5046         eval { rmtree $i_tmp; };
5047     }
5048 }
5049
5050 END {
5051     return unless forkcheck_mainprocess();
5052     i_cleanup();
5053 }
5054
5055 sub i_method {
5056     my ($base,$selector,@args) = @_;
5057     $selector =~ s/\-/_/g;
5058     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5059 }
5060
5061 sub pre_rpush () {
5062     not_necessarily_a_tree();
5063 }
5064 sub cmd_rpush {
5065     my $host = nextarg;
5066     my $dir;
5067     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5068         $host = $1;
5069         $dir = $'; #';
5070     } else {
5071         $dir = nextarg;
5072     }
5073     $dir =~ s{^-}{./-};
5074     my @rargs = ($dir);
5075     push @rargs, join ",", @rpushprotovsn_support;
5076     my @rdgit;
5077     push @rdgit, @dgit;
5078     push @rdgit, @ropts;
5079     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5080     push @rdgit, @ARGV;
5081     my @cmd = (@ssh, $host, shellquote @rdgit);
5082     debugcmd "+",@cmd;
5083
5084     $we_are_initiator=1;
5085
5086     if (defined $initiator_tempdir) {
5087         rmtree $initiator_tempdir;
5088         mkdir $initiator_tempdir, 0700
5089             or fail f_ "create %s: %s", $initiator_tempdir, $!;
5090         $i_tmp = $initiator_tempdir;
5091     } else {
5092         $i_tmp = tempdir();
5093     }
5094     $i_child_pid = open2(\*RO, \*RI, @cmd);
5095     changedir $i_tmp;
5096     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5097     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5098
5099     for (;;) {
5100         my ($icmd,$iargs) = initiator_expect {
5101             m/^(\S+)(?: (.*))?$/;
5102             ($1,$2);
5103         };
5104         i_method "i_resp", $icmd, $iargs;
5105     }
5106 }
5107
5108 sub i_resp_progress ($) {
5109     my ($rhs) = @_;
5110     my $msg = protocol_read_bytes \*RO, $rhs;
5111     progress $msg;
5112 }
5113
5114 sub i_resp_supplementary_message ($) {
5115     my ($rhs) = @_;
5116     $supplementary_message = protocol_read_bytes \*RO, $rhs;
5117 }
5118
5119 sub i_resp_complete {
5120     my $pid = $i_child_pid;
5121     $i_child_pid = undef; # prevents killing some other process with same pid
5122     printdebug "waiting for build host child $pid...\n";
5123     my $got = waitpid $pid, 0;
5124     confess "$!" unless $got == $pid;
5125     fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5126
5127     i_cleanup();
5128     printdebug __ "all done\n";
5129     finish 0;
5130 }
5131
5132 sub i_resp_file ($) {
5133     my ($keyword) = @_;
5134     my $localname = i_method "i_localname", $keyword;
5135     my $localpath = "$i_tmp/$localname";
5136     stat_exists $localpath and
5137         badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5138     protocol_receive_file \*RO, $localpath;
5139     i_method "i_file", $keyword;
5140 }
5141
5142 our %i_param;
5143
5144 sub i_resp_param ($) {
5145     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5146     $i_param{$1} = $2;
5147 }
5148
5149 sub i_resp_previously ($) {
5150     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5151         or badproto \*RO, __ "bad previously spec";
5152     my $r = system qw(git check-ref-format), $1;
5153     confess "bad previously ref spec ($r)" if $r;
5154     $previously{$1} = $2;
5155 }
5156
5157 our %i_wanted;
5158
5159 sub i_resp_want ($) {
5160     my ($keyword) = @_;
5161     die "$keyword ?" if $i_wanted{$keyword}++;
5162
5163     defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5164     $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5165     die unless $isuite =~ m/^$suite_re$/;
5166
5167     pushing();
5168     rpush_handle_protovsn_bothends();
5169
5170     my @localpaths = i_method "i_want", $keyword;
5171     printdebug "[[  $keyword @localpaths\n";
5172     foreach my $localpath (@localpaths) {
5173         protocol_send_file \*RI, $localpath;
5174     }
5175     print RI "files-end\n" or confess "$!";
5176 }
5177
5178 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5179
5180 sub i_localname_parsed_changelog {
5181     return "remote-changelog.822";
5182 }
5183 sub i_file_parsed_changelog {
5184     ($i_clogp, $i_version, $i_dscfn) =
5185         push_parse_changelog "$i_tmp/remote-changelog.822";
5186     die if $i_dscfn =~ m#/|^\W#;
5187 }
5188
5189 sub i_localname_dsc {
5190     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5191     return $i_dscfn;
5192 }
5193 sub i_file_dsc { }
5194
5195 sub i_localname_buildinfo ($) {
5196     my $bi = $i_param{'buildinfo-filename'};
5197     defined $bi or badproto \*RO, "buildinfo before filename";
5198     defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5199     $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5200         or badproto \*RO, "improper buildinfo filename";
5201     return $&;
5202 }
5203 sub i_file_buildinfo {
5204     my $bi = $i_param{'buildinfo-filename'};
5205     my $bd = parsecontrol "$i_tmp/$bi", $bi;
5206     my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5207     if (!forceing [qw(buildinfo-changes-mismatch)]) {
5208         files_compare_inputs($bd, $ch);
5209         (getfield $bd, $_) eq (getfield $ch, $_) or
5210             fail f_ "buildinfo mismatch in field %s", $_
5211             foreach qw(Source Version);
5212         !defined $bd->{$_} or
5213             fail f_ "buildinfo contains forbidden field %s", $_
5214             foreach qw(Changes Changed-by Distribution);
5215     }
5216     push @i_buildinfos, $bi;
5217     delete $i_param{'buildinfo-filename'};
5218 }
5219
5220 sub i_localname_changes {
5221     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5222     $i_changesfn = $i_dscfn;
5223     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5224     return $i_changesfn;
5225 }
5226 sub i_file_changes { }
5227
5228 sub i_want_signed_tag {
5229     printdebug Dumper(\%i_param, $i_dscfn);
5230     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5231         && defined $i_param{'csuite'}
5232         or badproto \*RO, "premature desire for signed-tag";
5233     my $head = $i_param{'head'};
5234     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5235
5236     my $maintview = $i_param{'maint-view'};
5237     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5238
5239     if ($protovsn == 4) {
5240         my $p = $i_param{'tagformat'} // '<undef>';
5241         $p eq 'new'
5242             or badproto \*RO, "tag format mismatch: $p vs. new";
5243     }
5244
5245     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5246     $csuite = $&;
5247     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5248
5249     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5250
5251     return
5252         push_mktags $i_clogp, $i_dscfn,
5253             $i_changesfn, (__ 'remote changes file'),
5254             \@tagwants;
5255 }
5256
5257 sub i_want_signed_dsc_changes {
5258     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5259     sign_changes $i_changesfn;
5260     return ($i_dscfn, $i_changesfn, @i_buildinfos);
5261 }
5262
5263 #---------- building etc. ----------
5264
5265 our $version;
5266 our $sourcechanges;
5267 our $dscfn;
5268
5269 #----- `3.0 (quilt)' handling -----
5270
5271 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5272
5273 sub quiltify_dpkg_commit ($$$;$) {
5274     my ($patchname,$author,$msg, $xinfo) = @_;
5275     $xinfo //= '';
5276
5277     mkpath '.git/dgit'; # we are in playtree
5278     my $descfn = ".git/dgit/quilt-description.tmp";
5279     open O, '>', $descfn or confess "$descfn: $!";
5280     $msg =~ s/\n+/\n\n/;
5281     print O <<END or confess "$!";
5282 From: $author
5283 ${xinfo}Subject: $msg
5284 ---
5285
5286 END
5287     close O or confess "$!";
5288
5289     {
5290         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5291         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5292         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5293         runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5294     }
5295 }
5296
5297 sub quiltify_trees_differ ($$;$$$) {
5298     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5299     # returns true iff the two tree objects differ other than in debian/
5300     # with $finegrained,
5301     # returns bitmask 01 - differ in upstream files except .gitignore
5302     #                 02 - differ in .gitignore
5303     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5304     #  is set for each modified .gitignore filename $fn
5305     # if $unrepres is defined, array ref to which is appeneded
5306     #  a list of unrepresentable changes (removals of upstream files
5307     #  (as messages)
5308     local $/=undef;
5309     my @cmd = (@git, qw(diff-tree -z --no-renames));
5310     push @cmd, qw(--name-only) unless $unrepres;
5311     push @cmd, qw(-r) if $finegrained || $unrepres;
5312     push @cmd, $x, $y;
5313     my $diffs= cmdoutput @cmd;
5314     my $r = 0;
5315     my @lmodes;
5316     foreach my $f (split /\0/, $diffs) {
5317         if ($unrepres && !@lmodes) {
5318             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5319             next;
5320         }
5321         my ($oldmode,$newmode) = @lmodes;
5322         @lmodes = ();
5323
5324         next if $f =~ m#^debian(?:/.*)?$#s;
5325
5326         if ($unrepres) {
5327             eval {
5328                 die __ "not a plain file or symlink\n"
5329                     unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5330                            $oldmode =~ m/^(?:10|12)\d{4}$/;
5331                 if ($oldmode =~ m/[^0]/ &&
5332                     $newmode =~ m/[^0]/) {
5333                     # both old and new files exist
5334                     die __ "mode or type changed\n" if $oldmode ne $newmode;
5335                     die __ "modified symlink\n" unless $newmode =~ m/^10/;
5336                 } elsif ($oldmode =~ m/[^0]/) {
5337                     # deletion
5338                     die __ "deletion of symlink\n"
5339                         unless $oldmode =~ m/^10/;
5340                 } else {
5341                     # creation
5342                     die __ "creation with non-default mode\n"
5343                         unless $newmode =~ m/^100644$/ or
5344                                $newmode =~ m/^120000$/;
5345                 }
5346             };
5347             if ($@) {
5348                 local $/="\n"; chomp $@;
5349                 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5350             }
5351         }
5352
5353         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5354         $r |= $isignore ? 02 : 01;
5355         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5356     }
5357     printdebug "quiltify_trees_differ $x $y => $r\n";
5358     return $r;
5359 }
5360
5361 sub quiltify_tree_sentinelfiles ($) {
5362     # lists the `sentinel' files present in the tree
5363     my ($x) = @_;
5364     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5365         qw(-- debian/rules debian/control);
5366     $r =~ s/\n/,/g;
5367     return $r;
5368 }
5369
5370 sub quiltify_splitting ($$$$$$$) {
5371     my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5372         $editedignores, $cachekey) = @_;
5373     my $gitignore_special = 1;
5374     if ($quilt_mode !~ m/gbp|dpm|baredebian/) {
5375         # treat .gitignore just like any other upstream file
5376         $diffbits = { %$diffbits };
5377         $_ = !!$_ foreach values %$diffbits;
5378         $gitignore_special = 0;
5379     }
5380     # We would like any commits we generate to be reproducible
5381     my @authline = clogp_authline($clogp);
5382     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
5383     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5384     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
5385     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
5386     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5387     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
5388
5389     confess unless do_split_brain();
5390
5391     my $fulldiffhint = sub {
5392         my ($x,$y) = @_;
5393         my $cmd = "git diff $x $y -- :/ ':!debian'";
5394         $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5395         return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5396                   $cmd;
5397     };
5398
5399     if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5400         ($diffbits->{O2H} & 01)) {
5401         my $msg = f_
5402  "--quilt=%s specified, implying patches-unapplied git tree\n".
5403  " but git tree differs from orig in upstream files.",
5404                      $quilt_mode;
5405         $msg .= $fulldiffhint->($unapplied, 'HEAD');
5406         if (!stat_exists "debian/patches" and $quilt_mode !~ m/baredebian/) {
5407             $msg .= __
5408  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5409         }
5410         fail $msg;
5411     }
5412     if ($quilt_mode =~ m/dpm/ &&
5413         ($diffbits->{H2A} & 01)) {
5414         fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5415 --quilt=%s specified, implying patches-applied git tree
5416  but git tree differs from result of applying debian/patches to upstream
5417 END
5418     }
5419     if ($quilt_mode =~ m/baredebian/) {
5420         # We need to construct a merge which has upstream files from
5421         # upstream and debian/ files from HEAD.
5422
5423         read_tree_upstream $quilt_upstream_commitish, 1, $headref;
5424         my $version = getfield $clogp, 'Version';
5425         my $upsversion = upstreamversion $version;
5426         my $merge = make_commit
5427             [ $headref, $quilt_upstream_commitish ],
5428  [ +(f_ <<ENDT, $upsversion), $quilt_upstream_commitish_message, <<ENDU ];
5429 Combine debian/ with upstream source for %s
5430 ENDT
5431 [dgit ($our_version) baredebian-merge $version $quilt_upstream_commitish_used]
5432 ENDU
5433         runcmd @git, qw(reset -q --hard), $merge;
5434     }
5435     if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5436         ($diffbits->{O2A} & 01)) { # some patches
5437         progress __ "dgit view: creating patches-applied version using gbp pq";
5438         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5439         # gbp pq import creates a fresh branch; push back to dgit-view
5440         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5441         runcmd @git, qw(checkout -q dgit-view);
5442     }
5443     if ($quilt_mode =~ m/gbp|dpm/ &&
5444         ($diffbits->{O2A} & 02)) {
5445         fail f_ <<END, $quilt_mode;
5446 --quilt=%s specified, implying that HEAD is for use with a
5447  tool which does not create patches for changes to upstream
5448  .gitignores: but, such patches exist in debian/patches.
5449 END
5450     }
5451     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5452         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5453         progress __
5454             "dgit view: creating patch to represent .gitignore changes";
5455         ensuredir "debian/patches";
5456         my $gipatch = "debian/patches/auto-gitignore";
5457         open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5458         stat GIPATCH or confess "$gipatch: $!";
5459         fail f_ "%s already exists; but want to create it".
5460                 " to record .gitignore changes",
5461                 $gipatch
5462             if (stat _)[7];
5463         print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5464 Subject: Update .gitignore from Debian packaging branch
5465
5466 The Debian packaging git branch contains these updates to the upstream
5467 .gitignore file(s).  This patch is autogenerated, to provide these
5468 updates to users of the official Debian archive view of the package.
5469 END
5470
5471 [dgit ($our_version) update-gitignore]
5472 ---
5473 ENDU
5474         close GIPATCH or die "$gipatch: $!";
5475         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5476             $unapplied, $headref, "--", sort keys %$editedignores;
5477         open SERIES, "+>>", "debian/patches/series" or confess "$!";
5478         defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5479         my $newline;
5480         defined read SERIES, $newline, 1 or confess "$!";
5481         print SERIES "\n" or confess "$!" unless $newline eq "\n";
5482         print SERIES "auto-gitignore\n" or confess "$!";
5483         close SERIES or die  $!;
5484         runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5485         commit_admin +(__ <<END).<<ENDU
5486 Commit patch to update .gitignore
5487 END
5488
5489 [dgit ($our_version) update-gitignore-quilt-fixup]
5490 ENDU
5491     }
5492 }
5493
5494 sub quiltify ($$$$) {
5495     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5496
5497     # Quilt patchification algorithm
5498     #
5499     # We search backwards through the history of the main tree's HEAD
5500     # (T) looking for a start commit S whose tree object is identical
5501     # to to the patch tip tree (ie the tree corresponding to the
5502     # current dpkg-committed patch series).  For these purposes
5503     # `identical' disregards anything in debian/ - this wrinkle is
5504     # necessary because dpkg-source treates debian/ specially.
5505     #
5506     # We can only traverse edges where at most one of the ancestors'
5507     # trees differs (in changes outside in debian/).  And we cannot
5508     # handle edges which change .pc/ or debian/patches.  To avoid
5509     # going down a rathole we avoid traversing edges which introduce
5510     # debian/rules or debian/control.  And we set a limit on the
5511     # number of edges we are willing to look at.
5512     #
5513     # If we succeed, we walk forwards again.  For each traversed edge
5514     # PC (with P parent, C child) (starting with P=S and ending with
5515     # C=T) to we do this:
5516     #  - git checkout C
5517     #  - dpkg-source --commit with a patch name and message derived from C
5518     # After traversing PT, we git commit the changes which
5519     # should be contained within debian/patches.
5520
5521     # The search for the path S..T is breadth-first.  We maintain a
5522     # todo list containing search nodes.  A search node identifies a
5523     # commit, and looks something like this:
5524     #  $p = {
5525     #      Commit => $git_commit_id,
5526     #      Child => $c,                          # or undef if P=T
5527     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
5528     #      Nontrivial => true iff $p..$c has relevant changes
5529     #  };
5530
5531     my @todo;
5532     my @nots;
5533     my $sref_S;
5534     my $max_work=100;
5535     my %considered; # saves being exponential on some weird graphs
5536
5537     my $t_sentinels = quiltify_tree_sentinelfiles $target;
5538
5539     my $not = sub {
5540         my ($search,$whynot) = @_;
5541         printdebug " search NOT $search->{Commit} $whynot\n";
5542         $search->{Whynot} = $whynot;
5543         push @nots, $search;
5544         no warnings qw(exiting);
5545         next;
5546     };
5547
5548     push @todo, {
5549         Commit => $target,
5550     };
5551
5552     while (@todo) {
5553         my $c = shift @todo;
5554         next if $considered{$c->{Commit}}++;
5555
5556         $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5557
5558         printdebug "quiltify investigate $c->{Commit}\n";
5559
5560         # are we done?
5561         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5562             printdebug " search finished hooray!\n";
5563             $sref_S = $c;
5564             last;
5565         }
5566
5567         quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5568         if ($quilt_mode eq 'smash') {
5569             printdebug " search quitting smash\n";
5570             last;
5571         }
5572
5573         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5574         $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5575             if $c_sentinels ne $t_sentinels;
5576
5577         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5578         $commitdata =~ m/\n\n/;
5579         $commitdata =~ $`;
5580         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5581         @parents = map { { Commit => $_, Child => $c } } @parents;
5582
5583         $not->($c, __ "root commit") if !@parents;
5584
5585         foreach my $p (@parents) {
5586             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5587         }
5588         my $ndiffers = grep { $_->{Nontrivial} } @parents;
5589         $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5590             if $ndiffers > 1;
5591
5592         foreach my $p (@parents) {
5593             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5594
5595             my @cmd= (@git, qw(diff-tree -r --name-only),
5596                       $p->{Commit},$c->{Commit},
5597                       qw(-- debian/patches .pc debian/source/format));
5598             my $patchstackchange = cmdoutput @cmd;
5599             if (length $patchstackchange) {
5600                 $patchstackchange =~ s/\n/,/g;
5601                 $not->($p, f_ "changed %s", $patchstackchange);
5602             }
5603
5604             printdebug " search queue P=$p->{Commit} ",
5605                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5606             push @todo, $p;
5607         }
5608     }
5609
5610     if (!$sref_S) {
5611         printdebug "quiltify want to smash\n";
5612
5613         my $abbrev = sub {
5614             my $x = $_[0]{Commit};
5615             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5616             return $x;
5617         };
5618         if ($quilt_mode eq 'linear') {
5619             print STDERR f_
5620                 "\n%s: error: quilt fixup cannot be linear.  Stopped at:\n",
5621                 $us;
5622             my $all_gdr = !!@nots;
5623             foreach my $notp (@nots) {
5624                 my $c = $notp->{Child};
5625                 my $cprange = $abbrev->($notp);
5626                 $cprange .= "..".$abbrev->($c) if $c;
5627                 print STDERR f_ "%s:  %s: %s\n",
5628                     $us, $cprange, $notp->{Whynot};
5629                 $all_gdr &&= $notp->{Child} &&
5630                     (git_cat_file $notp->{Child}{Commit}, 'commit')
5631                     =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5632             }
5633             print STDERR "\n";
5634             $failsuggestion =
5635                 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5636                 if $all_gdr;
5637             print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5638             fail __
5639  "quilt history linearisation failed.  Search \`quilt fixup' in dgit(7).\n";
5640         } elsif ($quilt_mode eq 'smash') {
5641         } elsif ($quilt_mode eq 'auto') {
5642             progress __ "quilt fixup cannot be linear, smashing...";
5643         } else {
5644             confess "$quilt_mode ?";
5645         }
5646
5647         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5648         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5649         my $ncommits = 3;
5650         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5651
5652         quiltify_dpkg_commit "auto-$version-$target-$time",
5653             (getfield $clogp, 'Maintainer'),
5654             (f_ "Automatically generated patch (%s)\n".
5655              "Last (up to) %s git changes, FYI:\n\n",
5656              $clogp->{Version}, $ncommits).
5657              $msg;
5658         return;
5659     }
5660
5661     progress __ "quiltify linearisation planning successful, executing...";
5662
5663     for (my $p = $sref_S;
5664          my $c = $p->{Child};
5665          $p = $p->{Child}) {
5666         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5667         next unless $p->{Nontrivial};
5668
5669         my $cc = $c->{Commit};
5670
5671         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5672         $commitdata =~ m/\n\n/ or die "$c ?";
5673         $commitdata = $`;
5674         my $msg = $'; #';
5675         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5676         my $author = $1;
5677
5678         my $commitdate = cmdoutput
5679             @git, qw(log -n1 --pretty=format:%aD), $cc;
5680
5681         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5682
5683         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5684         $strip_nls->();
5685
5686         my $title = $1;
5687         my $patchname;
5688         my $patchdir;
5689
5690         my $gbp_check_suitable = sub {
5691             $_ = shift;
5692             my ($what) = @_;
5693
5694             eval {
5695                 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5696                 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5697                 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5698                 die __ "is series file\n" if m{$series_filename_re}o;
5699                 die __ "too long\n" if length > 200;
5700             };
5701             return $_ unless $@;
5702             print STDERR f_
5703                 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5704                 $cc, $what, $@;
5705             return undef;
5706         };
5707
5708         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5709                            gbp-pq-name: \s* )
5710                        (\S+) \s* \n //ixm) {
5711             $patchname = $gbp_check_suitable->($1, 'Name');
5712         }
5713         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5714                            gbp-pq-topic: \s* )
5715                        (\S+) \s* \n //ixm) {
5716             $patchdir = $gbp_check_suitable->($1, 'Topic');
5717         }
5718
5719         $strip_nls->();
5720
5721         if (!defined $patchname) {
5722             $patchname = $title;
5723             $patchname =~ s/[.:]$//;
5724             use Text::Iconv;
5725             eval {
5726                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5727                 my $translitname = $converter->convert($patchname);
5728                 die unless defined $translitname;
5729                 $patchname = $translitname;
5730             };
5731             print STDERR
5732                 +(f_ "dgit: patch title transliteration error: %s", $@)
5733                 if $@;
5734             $patchname =~ y/ A-Z/-a-z/;
5735             $patchname =~ y/-a-z0-9_.+=~//cd;
5736             $patchname =~ s/^\W/x-$&/;
5737             $patchname = substr($patchname,0,40);
5738             $patchname .= ".patch";
5739         }
5740         if (!defined $patchdir) {
5741             $patchdir = '';
5742         }
5743         if (length $patchdir) {
5744             $patchname = "$patchdir/$patchname";
5745         }
5746         if ($patchname =~ m{^(.*)/}) {
5747             mkpath "debian/patches/$1";
5748         }
5749
5750         my $index;
5751         for ($index='';
5752              stat "debian/patches/$patchname$index";
5753              $index++) { }
5754         $!==ENOENT or confess "$patchname$index $!";
5755
5756         runcmd @git, qw(checkout -q), $cc;
5757
5758         # We use the tip's changelog so that dpkg-source doesn't
5759         # produce complaining messages from dpkg-parsechangelog.  None
5760         # of the information dpkg-source gets from the changelog is
5761         # actually relevant - it gets put into the original message
5762         # which dpkg-source provides our stunt editor, and then
5763         # overwritten.
5764         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5765
5766         quiltify_dpkg_commit "$patchname$index", $author, $msg,
5767             "Date: $commitdate\n".
5768             "X-Dgit-Generated: $clogp->{Version} $cc\n";
5769
5770         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5771     }
5772 }
5773
5774 sub build_maybe_quilt_fixup () {
5775     my ($format,$fopts) = get_source_format;
5776     return unless madformat_wantfixup $format;
5777     # sigh
5778
5779     check_for_vendor_patches();
5780
5781     my $clogp = parsechangelog();
5782     my $headref = git_rev_parse('HEAD');
5783     my $symref = git_get_symref();
5784     my $upstreamversion = upstreamversion $version;
5785
5786     prep_ud();
5787     changedir $playground;
5788
5789     my $splitbrain_cachekey;
5790
5791     if (do_split_brain()) {
5792         my $cachehit;
5793         ($cachehit, $splitbrain_cachekey) =
5794             quilt_check_splitbrain_cache($headref, $upstreamversion);
5795         if ($cachehit) {
5796             changedir $maindir;
5797             return;
5798         }
5799     }
5800
5801     unpack_playtree_need_cd_work($headref);
5802     if (do_split_brain()) {
5803         runcmd @git, qw(checkout -q -b dgit-view);
5804         # so long as work is not deleted, its current branch will
5805         # remain dgit-view, rather than master, so subsequent calls to
5806         #  unpack_playtree_need_cd_work
5807         # will DTRT, resetting dgit-view.
5808         confess if $made_split_brain;
5809         $made_split_brain = 1;
5810     }
5811     chdir '..';
5812
5813     if ($fopts->{'single-debian-patch'}) {
5814         fail f_
5815  "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5816             $quilt_mode
5817             if quiltmode_splitting();
5818         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5819     } else {
5820         quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5821                               $splitbrain_cachekey);
5822     }
5823
5824     if (do_split_brain()) {
5825         my $dgitview = git_rev_parse 'HEAD';
5826
5827         changedir $maindir;
5828         reflog_cache_insert "refs/$splitbraincache",
5829             $splitbrain_cachekey, $dgitview;
5830
5831         changedir "$playground/work";
5832
5833         my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5834         progress f_ "dgit view: created (%s)", $saved;
5835     }
5836
5837     changedir $maindir;
5838     runcmd_ordryrun_local
5839         @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5840 }
5841
5842 sub build_check_quilt_splitbrain () {
5843     build_maybe_quilt_fixup();
5844 }
5845
5846 sub unpack_playtree_need_cd_work ($) {
5847     my ($headref) = @_;
5848
5849     # prep_ud() must have been called already.
5850     if (!chdir "work") {
5851         # Check in the filesystem because sometimes we run prep_ud
5852         # in between multiple calls to unpack_playtree_need_cd_work.
5853         confess "$!" unless $!==ENOENT;
5854         mkdir "work" or confess "$!";
5855         changedir "work";
5856         mktree_in_ud_here();
5857     }
5858     runcmd @git, qw(reset -q --hard), $headref;
5859 }
5860
5861 sub unpack_playtree_linkorigs ($$) {
5862     my ($upstreamversion, $fn) = @_;
5863     # calls $fn->($leafname);
5864
5865     my $bpd_abs = bpd_abs();
5866
5867     dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5868
5869     opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5870     while ($!=0, defined(my $leaf = readdir QFD)) {
5871         my $f = bpd_abs()."/".$leaf;
5872         {
5873             local ($debuglevel) = $debuglevel-1;
5874             printdebug "QF linkorigs bpd $leaf, $f ?\n";
5875         }
5876         next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5877         printdebug "QF linkorigs $leaf, $f Y\n";
5878         link_ltarget $f, $leaf or die "$leaf $!";
5879         $fn->($leaf);
5880     }
5881     die "$buildproductsdir: $!" if $!;
5882     closedir QFD;
5883 }
5884
5885 sub quilt_fixup_delete_pc () {
5886     runcmd @git, qw(rm -rqf .pc);
5887     commit_admin +(__ <<END).<<ENDU
5888 Commit removal of .pc (quilt series tracking data)
5889 END
5890
5891 [dgit ($our_version) upgrade quilt-remove-pc]
5892 ENDU
5893 }
5894
5895 sub quilt_fixup_singlepatch ($$$) {
5896     my ($clogp, $headref, $upstreamversion) = @_;
5897
5898     progress __ "starting quiltify (single-debian-patch)";
5899
5900     # dpkg-source --commit generates new patches even if
5901     # single-debian-patch is in debian/source/options.  In order to
5902     # get it to generate debian/patches/debian-changes, it is
5903     # necessary to build the source package.
5904
5905     unpack_playtree_linkorigs($upstreamversion, sub { });
5906     unpack_playtree_need_cd_work($headref);
5907
5908     rmtree("debian/patches");
5909
5910     runcmd @dpkgsource, qw(-b .);
5911     changedir "..";
5912     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5913     rename srcfn("$upstreamversion", "/debian/patches"),
5914         "work/debian/patches"
5915         or $!==ENOENT
5916         or confess "install d/patches: $!";
5917
5918     changedir "work";
5919     commit_quilty_patch();
5920 }
5921
5922 sub quilt_need_fake_dsc ($) {
5923     # cwd should be playground
5924     my ($upstreamversion) = @_;
5925
5926     return if stat_exists "fake.dsc";
5927     # ^ OK to test this as a sentinel because if we created it
5928     # we must either have done the rest too, or crashed.
5929
5930     my $fakeversion="$upstreamversion-~~DGITFAKE";
5931
5932     my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5933     print $fakedsc <<END or confess "$!";
5934 Format: 3.0 (quilt)
5935 Source: $package
5936 Version: $fakeversion
5937 Files:
5938 END
5939
5940     my $dscaddfile=sub {
5941         my ($leaf) = @_;
5942
5943         my $md = new Digest::MD5;
5944
5945         my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5946         stat $fh or confess "$!";
5947         my $size = -s _;
5948
5949         $md->addfile($fh);
5950         print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5951     };
5952
5953     unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5954
5955     my @files=qw(debian/source/format debian/rules
5956                  debian/control debian/changelog);
5957     foreach my $maybe (qw(debian/patches debian/source/options
5958                           debian/tests/control)) {
5959         next unless stat_exists "$maindir/$maybe";
5960         push @files, $maybe;
5961     }
5962
5963     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5964     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5965
5966     $dscaddfile->($debtar);
5967     close $fakedsc or confess "$!";
5968 }
5969
5970 sub quilt_fakedsc2unapplied ($$) {
5971     my ($headref, $upstreamversion) = @_;
5972     # must be run in the playground
5973     # quilt_need_fake_dsc must have been called
5974
5975     quilt_need_fake_dsc($upstreamversion);
5976     runcmd qw(sh -ec),
5977         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5978
5979     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5980     rename $fakexdir, "fake" or die "$fakexdir $!";
5981
5982     changedir 'fake';
5983
5984     remove_stray_gits(__ "source package");
5985     mktree_in_ud_here();
5986
5987     rmtree '.pc';
5988
5989     rmtree 'debian'; # git checkout commitish paths does not delete!
5990     runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5991     my $unapplied=git_add_write_tree();
5992     printdebug "fake orig tree object $unapplied\n";
5993     return $unapplied;
5994 }
5995
5996 sub quilt_check_splitbrain_cache ($$) {
5997     my ($headref, $upstreamversion) = @_;
5998     # Called only if we are in (potentially) split brain mode.
5999     # Called in playground.
6000     # Computes the cache key and looks in the cache.
6001     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
6002
6003     quilt_need_fake_dsc($upstreamversion);
6004
6005     my $splitbrain_cachekey;
6006
6007     progress f_
6008  "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
6009                 $quilt_mode;
6010     # we look in the reflog of dgit-intern/quilt-cache
6011     # we look for an entry whose message is the key for the cache lookup
6012     my @cachekey = (qw(dgit), $our_version);
6013     push @cachekey, $upstreamversion;
6014     push @cachekey, $quilt_mode;
6015     push @cachekey, $headref;
6016     push @cachekey, $quilt_upstream_commitish // '-';
6017
6018     push @cachekey, hashfile('fake.dsc');
6019
6020     my $srcshash = Digest::SHA->new(256);
6021     my %sfs = ( %INC, '$0(dgit)' => $0 );
6022     foreach my $sfk (sort keys %sfs) {
6023         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6024         $srcshash->add($sfk,"  ");
6025         $srcshash->add(hashfile($sfs{$sfk}));
6026         $srcshash->add("\n");
6027     }
6028     push @cachekey, $srcshash->hexdigest();
6029     $splitbrain_cachekey = "@cachekey";
6030
6031     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6032
6033     my $cachehit = reflog_cache_lookup
6034         "refs/$splitbraincache", $splitbrain_cachekey;
6035
6036     if ($cachehit) {
6037         unpack_playtree_need_cd_work($headref);
6038         my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6039         if ($cachehit ne $headref) {
6040             progress f_ "dgit view: found cached (%s)", $saved;
6041             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6042             $made_split_brain = 1;
6043             return ($cachehit, $splitbrain_cachekey);
6044         }
6045         progress __ "dgit view: found cached, no changes required";
6046         return ($headref, $splitbrain_cachekey);
6047     }
6048
6049     printdebug "splitbrain cache miss\n";
6050     return (undef, $splitbrain_cachekey);
6051 }
6052
6053 sub quilt_fixup_multipatch ($$$) {
6054     my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6055
6056     progress f_ "examining quilt state (multiple patches, %s mode)",
6057                 $quilt_mode;
6058
6059     # Our objective is:
6060     #  - honour any existing .pc in case it has any strangeness
6061     #  - determine the git commit corresponding to the tip of
6062     #    the patch stack (if there is one)
6063     #  - if there is such a git commit, convert each subsequent
6064     #    git commit into a quilt patch with dpkg-source --commit
6065     #  - otherwise convert all the differences in the tree into
6066     #    a single git commit
6067     #
6068     # To do this we:
6069
6070     # Our git tree doesn't necessarily contain .pc.  (Some versions of
6071     # dgit would include the .pc in the git tree.)  If there isn't
6072     # one, we need to generate one by unpacking the patches that we
6073     # have.
6074     #
6075     # We first look for a .pc in the git tree.  If there is one, we
6076     # will use it.  (This is not the normal case.)
6077     #
6078     # Otherwise need to regenerate .pc so that dpkg-source --commit
6079     # can work.  We do this as follows:
6080     #     1. Collect all relevant .orig from parent directory
6081     #     2. Generate a debian.tar.gz out of
6082     #         debian/{patches,rules,source/format,source/options}
6083     #     3. Generate a fake .dsc containing just these fields:
6084     #          Format Source Version Files
6085     #     4. Extract the fake .dsc
6086     #        Now the fake .dsc has a .pc directory.
6087     # (In fact we do this in every case, because in future we will
6088     # want to search for a good base commit for generating patches.)
6089     #
6090     # Then we can actually do the dpkg-source --commit
6091     #     1. Make a new working tree with the same object
6092     #        store as our main tree and check out the main
6093     #        tree's HEAD.
6094     #     2. Copy .pc from the fake's extraction, if necessary
6095     #     3. Run dpkg-source --commit
6096     #     4. If the result has changes to debian/, then
6097     #          - git add them them
6098     #          - git add .pc if we had a .pc in-tree
6099     #          - git commit
6100     #     5. If we had a .pc in-tree, delete it, and git commit
6101     #     6. Back in the main tree, fast forward to the new HEAD
6102
6103     # Another situation we may have to cope with is gbp-style
6104     # patches-unapplied trees.
6105     #
6106     # We would want to detect these, so we know to escape into
6107     # quilt_fixup_gbp.  However, this is in general not possible.
6108     # Consider a package with a one patch which the dgit user reverts
6109     # (with git revert or the moral equivalent).
6110     #
6111     # That is indistinguishable in contents from a patches-unapplied
6112     # tree.  And looking at the history to distinguish them is not
6113     # useful because the user might have made a confusing-looking git
6114     # history structure (which ought to produce an error if dgit can't
6115     # cope, not a silent reintroduction of an unwanted patch).
6116     #
6117     # So gbp users will have to pass an option.  But we can usually
6118     # detect their failure to do so: if the tree is not a clean
6119     # patches-applied tree, quilt linearisation fails, but the tree
6120     # _is_ a clean patches-unapplied tree, we can suggest that maybe
6121     # they want --quilt=unapplied.
6122     #
6123     # To help detect this, when we are extracting the fake dsc, we
6124     # first extract it with --skip-patches, and then apply the patches
6125     # afterwards with dpkg-source --before-build.  That lets us save a
6126     # tree object corresponding to .origs.
6127
6128     if ($quilt_mode eq 'linear'
6129         && branch_is_gdr($headref)) {
6130         # This is much faster.  It also makes patches that gdr
6131         # likes better for future updates without laundering.
6132         #
6133         # However, it can fail in some casses where we would
6134         # succeed: if there are existing patches, which correspond
6135         # to a prefix of the branch, but are not in gbp/gdr
6136         # format, gdr will fail (exiting status 7), but we might
6137         # be able to figure out where to start linearising.  That
6138         # will be slower so hopefully there's not much to do.
6139
6140         unpack_playtree_need_cd_work $headref;
6141
6142         my @cmd = (@git_debrebase,
6143                    qw(--noop-ok -funclean-mixed -funclean-ordering
6144                       make-patches --quiet-would-amend));
6145         # We tolerate soe snags that gdr wouldn't, by default.
6146         if (act_local()) {
6147             debugcmd "+",@cmd;
6148             $!=0; $?=-1;
6149             failedcmd @cmd
6150                 if system @cmd
6151                 and not ($? == 7*256 or
6152                          $? == -1 && $!==ENOENT);
6153         } else {
6154             dryrun_report @cmd;
6155         }
6156         $headref = git_rev_parse('HEAD');
6157
6158         chdir '..';
6159     }
6160
6161     my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6162
6163     ensuredir '.pc';
6164
6165     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6166     $!=0; $?=-1;
6167     if (system @bbcmd) {
6168         failedcmd @bbcmd if $? < 0;
6169         fail __ <<END;
6170 failed to apply your git tree's patch stack (from debian/patches/) to
6171  the corresponding upstream tarball(s).  Your source tree and .orig
6172  are probably too inconsistent.  dgit can only fix up certain kinds of
6173  anomaly (depending on the quilt mode).  Please see --quilt= in dgit(1).
6174 END
6175     }
6176
6177     changedir '..';
6178
6179     unpack_playtree_need_cd_work($headref);
6180
6181     my $mustdeletepc=0;
6182     if (stat_exists ".pc") {
6183         -d _ or die;
6184         progress __ "Tree already contains .pc - will use it then delete it.";
6185         $mustdeletepc=1;
6186     } else {
6187         rename '../fake/.pc','.pc' or confess "$!";
6188     }
6189
6190     changedir '../fake';
6191     rmtree '.pc';
6192     my $oldtiptree=git_add_write_tree();
6193     printdebug "fake o+d/p tree object $unapplied\n";
6194     changedir '../work';
6195
6196
6197     # We calculate some guesswork now about what kind of tree this might
6198     # be.  This is mostly for error reporting.
6199
6200     my $tentries = cmdoutput @git, qw(ls-tree --name-only -z), $headref;
6201     my $onlydebian = $tentries eq "debian\0";
6202
6203     my $uheadref = $headref;
6204     my $uhead_whatshort = 'HEAD';
6205
6206     if ($quilt_mode =~ m/baredebian/) {
6207         $uheadref = $quilt_upstream_commitish;
6208         # TRANSLATORS: this translation must fit in the ASCII art
6209         # quilt differences display.  The untranslated display
6210         # says %9.9s, so with that display it must be at most 9
6211         # characters.
6212         $uhead_whatshort = __ 'upstream';
6213     }
6214
6215     my %editedignores;
6216     my @unrepres;
6217     my $diffbits = {
6218         # H = user's HEAD
6219         # O = orig, without patches applied
6220         # A = "applied", ie orig with H's debian/patches applied
6221         O2H => quiltify_trees_differ($unapplied,$uheadref,   1,
6222                                      \%editedignores, \@unrepres),
6223         H2A => quiltify_trees_differ($uheadref, $oldtiptree,1),
6224         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6225     };
6226
6227     my @dl;
6228     foreach my $bits (qw(01 02)) {
6229         foreach my $v (qw(O2H O2A H2A)) {
6230             push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6231         }
6232     }
6233     printdebug "differences \@dl @dl.\n";
6234
6235     progress f_
6236 "%s: base trees orig=%.20s o+d/p=%.20s",
6237               $us, $unapplied, $oldtiptree;
6238     # TRANSLATORS: Try to keep this ascii-art layout right.  The 0s in
6239     # %9.00009s will be ignored and are there to make the format the
6240     # same length (9 characters) as the output it generates.  If you
6241     # change the value 9, your translation of "upstream" must fit into
6242     # the new length, and you should change the number of 0s.  Do
6243     # not reduce it below 4 as HEAD has to fit too.
6244     progress f_
6245 "%s: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
6246 "%s: quilt differences: %9.00009s %s o+d/p          %9.00009s %s o+d/p",
6247   $us,                      $dl[0], $dl[1],              $dl[3], $dl[4],
6248   $us,        $uhead_whatshort, $dl[2],   $uhead_whatshort, $dl[5];
6249
6250     if (@unrepres && $quilt_mode !~ m/baredebian/) {
6251         # With baredebian, even if the upstream commitish has this
6252         # problem, we don't want to print this message, as nothing
6253         # is going to try to make a patch out of it anyway.
6254         print STDERR f_ "dgit:  cannot represent change: %s: %s\n",
6255                         $_->[1], $_->[0]
6256             foreach @unrepres;
6257         forceable_fail [qw(unrepresentable)], __ <<END;
6258 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6259 END
6260     }
6261
6262     my @failsuggestion;
6263     if ($onlydebian) {
6264         push @failsuggestion, [ 'onlydebian', __
6265  "This has only a debian/ directory; you probably want --quilt=bare debian." ]
6266             unless $quilt_mode =~ m/baredebian/;
6267     } elsif (!($diffbits->{O2H} & $diffbits->{O2A})) {
6268         push @failsuggestion, [ 'unapplied', __
6269  "This might be a patches-unapplied branch." ];
6270     } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6271         push @failsuggestion, [ 'applied', __
6272  "This might be a patches-applied branch." ];
6273     }
6274     push @failsuggestion, [ 'quilt-mode', __
6275  "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6276
6277     push @failsuggestion, [ 'gitattrs', __
6278  "Warning: Tree has .gitattributes.  See GITATTRIBUTES in dgit(7)." ]
6279         if stat_exists '.gitattributes';
6280
6281     push @failsuggestion, [ 'origs', __
6282  "Maybe orig tarball(s) are not identical to git representation?" ]
6283         unless $onlydebian && $quilt_mode !~ m/baredebian/;
6284                # ^ in that case, we didn't really look properly
6285
6286     if (quiltmode_splitting()) {
6287         quiltify_splitting($clogp, $unapplied, $headref, $oldtiptree,
6288                            $diffbits, \%editedignores,
6289                            $splitbrain_cachekey);
6290         return;
6291     }
6292
6293     progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6294     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6295     runcmd @git, qw(checkout -q), (qw(master dgit-view)[do_split_brain()]);
6296
6297     if (!open P, '>>', ".pc/applied-patches") {
6298         $!==&ENOENT or confess "$!";
6299     } else {
6300         close P;
6301     }
6302
6303     commit_quilty_patch();
6304
6305     if ($mustdeletepc) {
6306         quilt_fixup_delete_pc();
6307     }
6308 }
6309
6310 sub quilt_fixup_editor () {
6311     my $descfn = $ENV{$fakeeditorenv};
6312     my $editing = $ARGV[$#ARGV];
6313     open I1, '<', $descfn or confess "$descfn: $!";
6314     open I2, '<', $editing or confess "$editing: $!";
6315     unlink $editing or confess "$editing: $!";
6316     open O, '>', $editing or confess "$editing: $!";
6317     while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6318     my $copying = 0;
6319     while (<I2>) {
6320         $copying ||= m/^\-\-\- /;
6321         next unless $copying;
6322         print O or confess "$!";
6323     }
6324     I2->error and confess "$!";
6325     close O or die $1;
6326     finish 0;
6327 }
6328
6329 sub maybe_apply_patches_dirtily () {
6330     return unless $quilt_mode =~ m/gbp|unapplied|baredebian/;
6331     print STDERR __ <<END or confess "$!";
6332
6333 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6334 dgit: Have to apply the patches - making the tree dirty.
6335 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6336
6337 END
6338     $patches_applied_dirtily = 01;
6339     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6340     runcmd qw(dpkg-source --before-build .);
6341 }
6342
6343 sub maybe_unapply_patches_again () {
6344     progress __ "dgit: Unapplying patches again to tidy up the tree."
6345         if $patches_applied_dirtily;
6346     runcmd qw(dpkg-source --after-build .)
6347         if $patches_applied_dirtily & 01;
6348     rmtree '.pc'
6349         if $patches_applied_dirtily & 02;
6350     $patches_applied_dirtily = 0;
6351 }
6352
6353 #----- other building -----
6354
6355 sub clean_tree_check_git ($$$) {
6356     my ($honour_ignores, $message, $ignmessage) = @_;
6357     my @cmd = (@git, qw(clean -dn));
6358     push @cmd, qw(-x) unless $honour_ignores;
6359     my $leftovers = cmdoutput @cmd;
6360     if (length $leftovers) {
6361         print STDERR $leftovers, "\n" or confess "$!";
6362         $message .= $ignmessage if $honour_ignores;
6363         fail $message;
6364     }
6365 }
6366
6367 sub clean_tree_check_git_wd ($) {
6368     my ($message) = @_;
6369     return if $cleanmode =~ m{no-check};
6370     return if $patches_applied_dirtily; # yuk
6371     clean_tree_check_git +($cleanmode !~ m{all-check}),
6372         $message, "\n".__ <<END;
6373 If this is just missing .gitignore entries, use a different clean
6374 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6375 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6376 END
6377 }
6378
6379 sub clean_tree_check () {
6380     # This function needs to not care about modified but tracked files.
6381     # That was done by check_not_dirty, and by now we may have run
6382     # the rules clean target which might modify tracked files (!)
6383     if ($cleanmode =~ m{^check}) {
6384         clean_tree_check_git +($cleanmode =~ m{ignores}), __
6385  "tree contains uncommitted files and --clean=check specified", '';
6386     } elsif ($cleanmode =~ m{^dpkg-source}) {
6387         clean_tree_check_git_wd __
6388  "tree contains uncommitted files (NB dgit didn't run rules clean)";
6389     } elsif ($cleanmode =~ m{^git}) {
6390         clean_tree_check_git 1, __
6391  "tree contains uncommited, untracked, unignored files\n".
6392  "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6393     } elsif ($cleanmode eq 'none') {
6394     } else {
6395         confess "$cleanmode ?";
6396     }
6397 }
6398
6399 sub clean_tree () {
6400     # We always clean the tree ourselves, rather than leave it to the
6401     # builder (dpkg-source, or soemthing which calls dpkg-source).
6402     if ($quilt_mode =~ m/baredebian/ and $cleanmode =~ m/git/) {
6403         fail f_ <<END, $quilt_mode, $cleanmode;
6404 quilt mode %s (generally needs untracked upstream files)
6405 contradicts clean mode %s (which would delete them)
6406 END
6407         # This is not 100% true: dgit build-source and push-source
6408         # (for example) could operate just fine with no upstream
6409         # source in the working tree.  But it doesn't seem likely that
6410         # the user wants dgit to proactively delete such things.
6411         # -wn, for example, would produce identical output without
6412         # deleting anything from the working tree.
6413     }
6414     if ($cleanmode =~ m{^dpkg-source}) {
6415         my @cmd = @dpkgbuildpackage;
6416         push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6417         push @cmd, qw(-T clean);
6418         maybe_apply_patches_dirtily();
6419         runcmd_ordryrun_local @cmd;
6420         clean_tree_check_git_wd __
6421  "tree contains uncommitted files (after running rules clean)";
6422     } elsif ($cleanmode =~ m{^git(?!-)}) {
6423         runcmd_ordryrun_local @git, qw(clean -xdf);
6424     } elsif ($cleanmode =~ m{^git-ff}) {
6425         runcmd_ordryrun_local @git, qw(clean -xdff);
6426     } elsif ($cleanmode =~ m{^check}) {
6427         clean_tree_check();
6428     } elsif ($cleanmode eq 'none') {
6429     } else {
6430         confess "$cleanmode ?";
6431     }
6432 }
6433
6434 sub cmd_clean () {
6435     badusage __ "clean takes no additional arguments" if @ARGV;
6436     notpushing();
6437     clean_tree();
6438     maybe_unapply_patches_again();
6439 }
6440
6441 # return values from massage_dbp_args are one or both of these flags
6442 sub WANTSRC_SOURCE  () { 01; } # caller should build source (separately)
6443 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6444
6445 sub build_or_push_prep_early () {
6446     our $build_or_push_prep_early_done //= 0;
6447     return if $build_or_push_prep_early_done++;
6448     badusage f_ "-p is not allowed with dgit %s", $subcommand
6449         if defined $package;
6450     my $clogp = parsechangelog();
6451     $isuite = getfield $clogp, 'Distribution';
6452     $package = getfield $clogp, 'Source';
6453     $version = getfield $clogp, 'Version';
6454     $dscfn = dscfn($version);
6455 }
6456
6457 sub build_or_push_prep_modes () {
6458     my ($format,) = determine_whether_split_brain();
6459
6460     fail __ "dgit: --include-dirty is not supported with split view".
6461             " (including with view-splitting quilt modes)"
6462         if do_split_brain() && $includedirty;
6463
6464     if (madformat_wantfixup $format and $quilt_mode =~ m/baredebian$/) {
6465         ($quilt_upstream_commitish, $quilt_upstream_commitish_used,
6466          $quilt_upstream_commitish_message)
6467             = resolve_upstream_version
6468             $quilt_upstream_commitish, upstreamversion $version;
6469         progress f_ "dgit: --quilt=%s, %s", $quilt_mode,
6470             $quilt_upstream_commitish_message;
6471     } elsif (defined $quilt_upstream_commitish) {
6472         fail __
6473  "dgit: --upstream-commitish only makes sense with --quilt=baredebian"
6474     }
6475 }
6476
6477 sub build_prep_early () {
6478     build_or_push_prep_early();
6479     notpushing();
6480     build_or_push_prep_modes();
6481     check_not_dirty();
6482 }
6483
6484 sub build_prep ($) {
6485     my ($wantsrc) = @_;
6486     build_prep_early();
6487     check_bpd_exists();
6488     if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6489         # Clean the tree because we're going to use the contents of
6490         # $maindir.  (We trying to include dirty changes in the source
6491         # package, or we are running the builder in $maindir.)
6492         || $cleanmode =~ m{always}) {
6493         # Or because the user asked us to.
6494         clean_tree();
6495     } else {
6496         # We don't actually need to do anything in $maindir, but we
6497         # should do some kind of cleanliness check because (i) the
6498         # user may have forgotten a `git add', and (ii) if the user
6499         # said -wc we should still do the check.
6500         clean_tree_check();
6501     }
6502     build_check_quilt_splitbrain();
6503     if ($rmchanges) {
6504         my $pat = changespat $version;
6505         foreach my $f (glob "$buildproductsdir/$pat") {
6506             if (act_local()) {
6507                 unlink $f or
6508                     fail f_ "remove old changes file %s: %s", $f, $!;
6509             } else {
6510                 progress f_ "would remove %s", $f;
6511             }
6512         }
6513     }
6514 }
6515
6516 sub changesopts_initial () {
6517     my @opts =@changesopts[1..$#changesopts];
6518 }
6519
6520 sub changesopts_version () {
6521     if (!defined $changes_since_version) {
6522         my @vsns;
6523         unless (eval {
6524             @vsns = archive_query('archive_query');
6525             my @quirk = access_quirk();
6526             if ($quirk[0] eq 'backports') {
6527                 local $isuite = $quirk[2];
6528                 local $csuite;
6529                 canonicalise_suite();
6530                 push @vsns, archive_query('archive_query');
6531             }
6532             1;
6533         }) {
6534             print STDERR $@;
6535             fail __
6536  "archive query failed (queried because --since-version not specified)";
6537         }
6538         if (@vsns) {
6539             @vsns = map { $_->[0] } @vsns;
6540             @vsns = sort { -version_compare($a, $b) } @vsns;
6541             $changes_since_version = $vsns[0];
6542             progress f_ "changelog will contain changes since %s", $vsns[0];
6543         } else {
6544             $changes_since_version = '_';
6545             progress __ "package seems new, not specifying -v<version>";
6546         }
6547     }
6548     if ($changes_since_version ne '_') {
6549         return ("-v$changes_since_version");
6550     } else {
6551         return ();
6552     }
6553 }
6554
6555 sub changesopts () {
6556     return (changesopts_initial(), changesopts_version());
6557 }
6558
6559 sub massage_dbp_args ($;$) {
6560     my ($cmd,$xargs) = @_;
6561     # Since we split the source build out so we can do strange things
6562     # to it, massage the arguments to dpkg-buildpackage so that the
6563     # main build doessn't build source (or add an argument to stop it
6564     # building source by default).
6565     debugcmd '#massaging#', @$cmd if $debuglevel>1;
6566     # -nc has the side effect of specifying -b if nothing else specified
6567     # and some combinations of -S, -b, et al, are errors, rather than
6568     # later simply overriding earlie.  So we need to:
6569     #  - search the command line for these options
6570     #  - pick the last one
6571     #  - perhaps add our own as a default
6572     #  - perhaps adjust it to the corresponding non-source-building version
6573     my $dmode = '-F';
6574     foreach my $l ($cmd, $xargs) {
6575         next unless $l;
6576         @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6577     }
6578     push @$cmd, '-nc';
6579 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6580     my $r = WANTSRC_BUILDER;
6581     printdebug "massage split $dmode.\n";
6582     if ($dmode =~ s/^--build=//) {
6583         $r = 0;
6584         my @d = split /,/, $dmode;
6585         $r |= WANTSRC_SOURCE  if grep { s/^full$/binary/ } @d;
6586         $r |= WANTSRC_SOURCE  if grep { s/^source$// } @d;
6587         $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6588         fail __ "Wanted to build nothing!" unless $r;
6589         $dmode = '--build='. join ',', grep m/./, @d;
6590     } else {
6591         $r =
6592           $dmode =~ m/[S]/     ?  WANTSRC_SOURCE :
6593           $dmode =~ y/gGF/ABb/ ?  WANTSRC_SOURCE | WANTSRC_BUILDER :
6594           $dmode =~ m/[ABb]/   ?                   WANTSRC_BUILDER :
6595           confess "$dmode ?";
6596     }
6597     printdebug "massage done $r $dmode.\n";
6598     push @$cmd, $dmode;
6599 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6600     return $r;
6601 }
6602
6603 sub in_bpd (&) {
6604     my ($fn) = @_;
6605     my $wasdir = must_getcwd();
6606     changedir $buildproductsdir;
6607     $fn->();
6608     changedir $wasdir;
6609 }
6610
6611 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6612 sub postbuild_mergechanges ($) {
6613     my ($msg_if_onlyone) = @_;
6614     # If there is only one .changes file, fail with $msg_if_onlyone,
6615     # or if that is undef, be a no-op.
6616     # Returns the changes file to report to the user.
6617     my $pat = changespat $version;
6618     my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6619     @changesfiles = sort {
6620         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6621             or $a cmp $b
6622     } @changesfiles;
6623     my $result;
6624     if (@changesfiles==1) {
6625         fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6626 only one changes file from build (%s)
6627 END
6628             if defined $msg_if_onlyone;
6629         $result = $changesfiles[0];
6630     } elsif (@changesfiles==2) {
6631         my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6632         foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6633             fail f_ "%s found in binaries changes file %s", $l, $binchanges
6634                 if $l =~ m/\.dsc$/;
6635         }
6636         runcmd_ordryrun_local @mergechanges, @changesfiles;
6637         my $multichanges = changespat $version,'multi';
6638         if (act_local()) {
6639             stat_exists $multichanges or fail f_
6640                 "%s unexpectedly not created by build", $multichanges;
6641             foreach my $cf (glob $pat) {
6642                 next if $cf eq $multichanges;
6643                 rename "$cf", "$cf.inmulti" or fail f_
6644                     "install new changes %s\{,.inmulti}: %s", $cf, $!;
6645             }
6646         }
6647         $result = $multichanges;
6648     } else {
6649         fail f_ "wrong number of different changes files (%s)",
6650                 "@changesfiles";
6651     }
6652     printdone f_ "build successful, results in %s\n", $result
6653         or confess "$!";
6654 }
6655
6656 sub midbuild_checkchanges () {
6657     my $pat = changespat $version;
6658     return if $rmchanges;
6659     my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6660     @unwanted = grep {
6661         $_ ne changespat $version,'source' and
6662         $_ ne changespat $version,'multi'
6663     } @unwanted;
6664     fail +(f_ <<END, $pat, "@unwanted")
6665 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6666 Suggest you delete %s.
6667 END
6668         if @unwanted;
6669 }
6670
6671 sub midbuild_checkchanges_vanilla ($) {
6672     my ($wantsrc) = @_;
6673     midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6674 }
6675
6676 sub postbuild_mergechanges_vanilla ($) {
6677     my ($wantsrc) = @_;
6678     if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6679         in_bpd {
6680             postbuild_mergechanges(undef);
6681         };
6682     } else {
6683         printdone __ "build successful\n";
6684     }
6685 }
6686
6687 sub cmd_build {
6688     build_prep_early();
6689     $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6690 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6691 %s: warning: build-products-dir will be ignored; files will go to ..
6692 END
6693     $buildproductsdir = '..';
6694     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6695     my $wantsrc = massage_dbp_args \@dbp;
6696     build_prep($wantsrc);
6697     if ($wantsrc & WANTSRC_SOURCE) {
6698         build_source();
6699         midbuild_checkchanges_vanilla $wantsrc;
6700     }
6701     if ($wantsrc & WANTSRC_BUILDER) {
6702         push @dbp, changesopts_version();
6703         maybe_apply_patches_dirtily();
6704         runcmd_ordryrun_local @dbp;
6705     }
6706     maybe_unapply_patches_again();
6707     postbuild_mergechanges_vanilla $wantsrc;
6708 }
6709
6710 sub pre_gbp_build {
6711     $quilt_mode //= 'gbp';
6712 }
6713
6714 sub cmd_gbp_build {
6715     build_prep_early();
6716
6717     # gbp can make .origs out of thin air.  In my tests it does this
6718     # even for a 1.0 format package, with no origs present.  So I
6719     # guess it keys off just the version number.  We don't know
6720     # exactly what .origs ought to exist, but let's assume that we
6721     # should run gbp if: the version has an upstream part and the main
6722     # orig is absent.
6723     my $upstreamversion = upstreamversion $version;
6724     my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6725     my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6726
6727     if ($gbp_make_orig) {
6728         clean_tree();
6729         $cleanmode = 'none'; # don't do it again
6730     }
6731
6732     my @dbp = @dpkgbuildpackage;
6733
6734     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6735
6736     if (!length $gbp_build[0]) {
6737         if (length executable_on_path('git-buildpackage')) {
6738             $gbp_build[0] = qw(git-buildpackage);
6739         } else {
6740             $gbp_build[0] = 'gbp buildpackage';
6741         }
6742     }
6743     my @cmd = opts_opt_multi_cmd [], @gbp_build;
6744
6745     push @cmd, (qw(-us -uc --git-no-sign-tags),
6746                 "--git-builder=".(shellquote @dbp));
6747
6748     if ($gbp_make_orig) {
6749         my $priv = dgit_privdir();
6750         my $ok = "$priv/origs-gen-ok";
6751         unlink $ok or $!==&ENOENT or confess "$!";
6752         my @origs_cmd = @cmd;
6753         push @origs_cmd, qw(--git-cleaner=true);
6754         push @origs_cmd, "--git-prebuild=".
6755             "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6756         push @origs_cmd, @ARGV;
6757         if (act_local()) {
6758             debugcmd @origs_cmd;
6759             system @origs_cmd;
6760             do { local $!; stat_exists $ok; }
6761                 or failedcmd @origs_cmd;
6762         } else {
6763             dryrun_report @origs_cmd;
6764         }
6765     }
6766
6767     build_prep($wantsrc);
6768     if ($wantsrc & WANTSRC_SOURCE) {
6769         build_source();
6770         midbuild_checkchanges_vanilla $wantsrc;
6771     } else {
6772         push @cmd, '--git-cleaner=true';
6773     }
6774     maybe_unapply_patches_again();
6775     if ($wantsrc & WANTSRC_BUILDER) {
6776         push @cmd, changesopts();
6777         runcmd_ordryrun_local @cmd, @ARGV;
6778     }
6779     postbuild_mergechanges_vanilla $wantsrc;
6780 }
6781 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6782
6783 sub building_source_in_playtree {
6784     # If $includedirty, we have to build the source package from the
6785     # working tree, not a playtree, so that uncommitted changes are
6786     # included (copying or hardlinking them into the playtree could
6787     # cause trouble).
6788     #
6789     # Note that if we are building a source package in split brain
6790     # mode we do not support including uncommitted changes, because
6791     # that makes quilt fixup too hard.  I.e. ($made_split_brain && (dgit is
6792     # building a source package)) => !$includedirty
6793     return !$includedirty;
6794 }
6795
6796 sub build_source {
6797     $sourcechanges = changespat $version,'source';
6798     if (act_local()) {
6799         unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6800             or fail f_ "remove %s: %s", $sourcechanges, $!;
6801     }
6802 #    confess unless !!$made_split_brain == do_split_brain();
6803
6804     my @cmd = (@dpkgsource, qw(-b --));
6805     my $leafdir;
6806     if (building_source_in_playtree()) {
6807         $leafdir = 'work';
6808         my $headref = git_rev_parse('HEAD');
6809         # If we are in split brain, there is already a playtree with
6810         # the thing we should package into a .dsc (thanks to quilt
6811         # fixup).  If not, make a playtree
6812         prep_ud() unless $made_split_brain;
6813         changedir $playground;
6814         unless ($made_split_brain) {
6815             my $upstreamversion = upstreamversion $version;
6816             unpack_playtree_linkorigs($upstreamversion, sub { });
6817             unpack_playtree_need_cd_work($headref);
6818             changedir '..';
6819         }
6820     } else {
6821         $leafdir = basename $maindir;
6822
6823         if ($buildproductsdir ne '..') {
6824             # Well, we are going to run dpkg-source -b which consumes
6825             # origs from .. and generates output there.  To make this
6826             # work when the bpd is not .. , we would have to (i) link
6827             # origs from bpd to .. , (ii) check for files that
6828             # dpkg-source -b would/might overwrite, and afterwards
6829             # (iii) move all the outputs back to the bpd (iv) except
6830             # for the origs which should be deleted from .. if they
6831             # weren't there beforehand.  And if there is an error and
6832             # we don't run to completion we would necessarily leave a
6833             # mess.  This is too much.  The real way to fix this
6834             # is for dpkg-source to have bpd support.
6835             confess unless $includedirty;
6836             fail __
6837  "--include-dirty not supported with --build-products-dir, sorry";
6838         }
6839
6840         changedir '..';
6841     }
6842     runcmd_ordryrun_local @cmd, $leafdir;
6843
6844     changedir $leafdir;
6845     runcmd_ordryrun_local qw(sh -ec),
6846       'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6847       @dpkggenchanges, qw(-S), changesopts();
6848     changedir '..';
6849
6850     printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6851     $dsc = parsecontrol($dscfn, "source package");
6852
6853     my $mv = sub {
6854         my ($why, $l) = @_;
6855         printdebug " renaming ($why) $l\n";
6856         rename_link_xf 0, "$l", bpd_abs()."/$l"
6857             or fail f_ "put in place new built file (%s): %s", $l, $@;
6858     };
6859     foreach my $l (split /\n/, getfield $dsc, 'Files') {
6860         $l =~ m/\S+$/ or next;
6861         $mv->('Files', $&);
6862     }
6863     $mv->('dsc', $dscfn);
6864     $mv->('changes', $sourcechanges);
6865
6866     changedir $maindir;
6867 }
6868
6869 sub cmd_build_source {
6870     badusage __ "build-source takes no additional arguments" if @ARGV;
6871     build_prep(WANTSRC_SOURCE);
6872     build_source();
6873     maybe_unapply_patches_again();
6874     printdone f_ "source built, results in %s and %s",
6875                  $dscfn, $sourcechanges;
6876 }
6877
6878 sub cmd_push_source {
6879     prep_push();
6880     fail __
6881         "dgit push-source: --include-dirty/--ignore-dirty does not make".
6882         "sense with push-source!"
6883         if $includedirty;
6884     build_check_quilt_splitbrain();
6885     if ($changesfile) {
6886         my $changes = parsecontrol("$buildproductsdir/$changesfile",
6887                                    __ "source changes file");
6888         unless (test_source_only_changes($changes)) {
6889             fail __ "user-specified changes file is not source-only";
6890         }
6891     } else {
6892         # Building a source package is very fast, so just do it
6893         build_source();
6894         confess "er, patches are applied dirtily but shouldn't be.."
6895             if $patches_applied_dirtily;
6896         $changesfile = $sourcechanges;
6897     }
6898     dopush();
6899 }
6900
6901 sub binary_builder {
6902     my ($bbuilder, $pbmc_msg, @args) = @_;
6903     build_prep(WANTSRC_SOURCE);
6904     build_source();
6905     midbuild_checkchanges();
6906     in_bpd {
6907         if (act_local()) {
6908             stat_exists $dscfn or fail f_
6909                 "%s (in build products dir): %s", $dscfn, $!;
6910             stat_exists $sourcechanges or fail f_
6911                 "%s (in build products dir): %s", $sourcechanges, $!;
6912         }
6913         runcmd_ordryrun_local @$bbuilder, @args;
6914     };
6915     maybe_unapply_patches_again();
6916     in_bpd {
6917         postbuild_mergechanges($pbmc_msg);
6918     };
6919 }
6920
6921 sub cmd_sbuild {
6922     build_prep_early();
6923     binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6924 perhaps you need to pass -A ?  (sbuild's default is to build only
6925 arch-specific binaries; dgit 1.4 used to override that.)
6926 END
6927 }
6928
6929 sub pbuilder ($) {
6930     my ($pbuilder) = @_;
6931     build_prep_early();
6932     # @ARGV is allowed to contain only things that should be passed to
6933     # pbuilder under debbuildopts; just massage those
6934     my $wantsrc = massage_dbp_args \@ARGV;
6935     fail __
6936         "you asked for a builder but your debbuildopts didn't ask for".
6937         " any binaries -- is this really what you meant?"
6938         unless $wantsrc & WANTSRC_BUILDER;
6939     fail __
6940         "we must build a .dsc to pass to the builder but your debbuiltopts".
6941         " forbids the building of a source package; cannot continue"
6942       unless $wantsrc & WANTSRC_SOURCE;
6943     # We do not want to include the verb "build" in @pbuilder because
6944     # the user can customise @pbuilder and they shouldn't be required
6945     # to include "build" in their customised value.  However, if the
6946     # user passes any additional args to pbuilder using the dgit
6947     # option --pbuilder:foo, such args need to come after the "build"
6948     # verb.  opts_opt_multi_cmd does all of that.
6949     binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6950                    qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6951                    $dscfn);
6952 }
6953
6954 sub cmd_pbuilder {
6955     pbuilder(\@pbuilder);
6956 }
6957
6958 sub cmd_cowbuilder {
6959     pbuilder(\@cowbuilder);
6960 }
6961
6962 sub cmd_quilt_fixup {
6963     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6964     build_prep_early();
6965     clean_tree();
6966     build_maybe_quilt_fixup();
6967 }
6968
6969 sub cmd_print_unapplied_treeish {
6970     badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6971         if @ARGV;
6972     my $headref = git_rev_parse('HEAD');
6973     my $clogp = commit_getclogp $headref;
6974     $package = getfield $clogp, 'Source';
6975     $version = getfield $clogp, 'Version';
6976     $isuite = getfield $clogp, 'Distribution';
6977     $csuite = $isuite; # we want this to be offline!
6978     notpushing();
6979
6980     prep_ud();
6981     changedir $playground;
6982     my $uv = upstreamversion $version;
6983     my $u = quilt_fakedsc2unapplied($headref, $uv);
6984     print $u, "\n" or confess "$!";
6985 }
6986
6987 sub import_dsc_result {
6988     my ($dstref, $newhash, $what_log, $what_msg) = @_;
6989     my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6990     runcmd @cmd;
6991     check_gitattrs($newhash, __ "source tree");
6992
6993     progress f_ "dgit: import-dsc: %s", $what_msg;
6994 }
6995
6996 sub cmd_import_dsc {
6997     my $needsig = 0;
6998
6999     while (@ARGV) {
7000         last unless $ARGV[0] =~ m/^-/;
7001         $_ = shift @ARGV;
7002         last if m/^--?$/;
7003         if (m/^--require-valid-signature$/) {
7004             $needsig = 1;
7005         } else {
7006             badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
7007         }
7008     }
7009
7010     badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
7011         unless @ARGV==2;
7012     my ($dscfn, $dstbranch) = @ARGV;
7013
7014     badusage __ "dry run makes no sense with import-dsc"
7015         unless act_local();
7016
7017     my $force = $dstbranch =~ s/^\+//   ? +1 :
7018                 $dstbranch =~ s/^\.\.// ? -1 :
7019                                            0;
7020     my $info = $force ? " $&" : '';
7021     $info = "$dscfn$info";
7022
7023     my $specbranch = $dstbranch;
7024     $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
7025     $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
7026
7027     my @symcmd = (@git, qw(symbolic-ref -q HEAD));
7028     my $chead = cmdoutput_errok @symcmd;
7029     defined $chead or $?==256 or failedcmd @symcmd;
7030
7031     fail f_ "%s is checked out - will not update it", $dstbranch
7032         if defined $chead and $chead eq $dstbranch;
7033
7034     my $oldhash = git_get_ref $dstbranch;
7035
7036     open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
7037     $dscdata = do { local $/ = undef; <D>; };
7038     D->error and fail f_ "read %s: %s", $dscfn, $!;
7039     close C;
7040
7041     # we don't normally need this so import it here
7042     use Dpkg::Source::Package;
7043     my $dp = new Dpkg::Source::Package filename => $dscfn,
7044         require_valid_signature => $needsig;
7045     {
7046         local $SIG{__WARN__} = sub {
7047             print STDERR $_[0];
7048             return unless $needsig;
7049             fail __ "import-dsc signature check failed";
7050         };
7051         if (!$dp->is_signed()) {
7052             warn f_ "%s: warning: importing unsigned .dsc\n", $us;
7053         } else {
7054             my $r = $dp->check_signature();
7055             confess "->check_signature => $r" if $needsig && $r;
7056         }
7057     }
7058
7059     parse_dscdata();
7060
7061     $package = getfield $dsc, 'Source';
7062
7063     parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
7064         unless forceing [qw(import-dsc-with-dgit-field)];
7065     parse_dsc_field_def_dsc_distro();
7066
7067     $isuite = 'DGIT-IMPORT-DSC';
7068     $idistro //= $dsc_distro;
7069
7070     notpushing();
7071
7072     if (defined $dsc_hash) {
7073         progress __
7074             "dgit: import-dsc of .dsc with Dgit field, using git hash";
7075         resolve_dsc_field_commit undef, undef;
7076     }
7077     if (defined $dsc_hash) {
7078         my @cmd = (qw(sh -ec),
7079                    "echo $dsc_hash | git cat-file --batch-check");
7080         my $objgot = cmdoutput @cmd;
7081         if ($objgot =~ m#^\w+ missing\b#) {
7082             fail f_ <<END, $dsc_hash
7083 .dsc contains Dgit field referring to object %s
7084 Your git tree does not have that object.  Try `git fetch' from a
7085 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
7086 END
7087         }
7088         if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
7089             if ($force > 0) {
7090                 progress __ "Not fast forward, forced update.";
7091             } else {
7092                 fail f_ "Not fast forward to %s", $dsc_hash;
7093             }
7094         }
7095         import_dsc_result $dstbranch, $dsc_hash,
7096             "dgit import-dsc (Dgit): $info",
7097             f_ "updated git ref %s", $dstbranch;
7098         return 0;
7099     }
7100
7101     fail f_ <<END, $dstbranch, $specbranch, $specbranch
7102 Branch %s already exists
7103 Specify ..%s for a pseudo-merge, binding in existing history
7104 Specify  +%s to overwrite, discarding existing history
7105 END
7106         if $oldhash && !$force;
7107
7108     my @dfi = dsc_files_info();
7109     foreach my $fi (@dfi) {
7110         my $f = $fi->{Filename};
7111         # We transfer all the pieces of the dsc to the bpd, not just
7112         # origs.  This is by analogy with dgit fetch, which wants to
7113         # keep them somewhere to avoid downloading them again.
7114         # We make symlinks, though.  If the user wants copies, then
7115         # they can copy the parts of the dsc to the bpd using dcmd,
7116         # or something.
7117         my $here = "$buildproductsdir/$f";
7118         if (lstat $here) {
7119             if (stat $here) {
7120                 next;
7121             }
7122             fail f_ "lstat %s works but stat gives %s !", $here, $!;
7123         }
7124         fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7125         printdebug "not in bpd, $f ...\n";
7126         # $f does not exist in bpd, we need to transfer it
7127         my $there = $dscfn;
7128         $there =~ s{[^/]+$}{$f} or confess "$there ?";
7129         # $there is file we want, relative to user's cwd, or abs
7130         printdebug "not in bpd, $f, test $there ...\n";
7131         stat $there or fail f_
7132             "import %s requires %s, but: %s", $dscfn, $there, $!;
7133         if ($there =~ m#^(?:\./+)?\.\./+#) {
7134             # $there is relative to user's cwd
7135             my $there_from_parent = $';
7136             if ($buildproductsdir !~ m{^/}) {
7137                 # abs2rel, despite its name, can take two relative paths
7138                 $there = File::Spec->abs2rel($there,$buildproductsdir);
7139                 # now $there is relative to bpd, great
7140                 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7141             } else {
7142                 $there = (dirname $maindir)."/$there_from_parent";
7143                 # now $there is absoute
7144                 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7145             }
7146         } elsif ($there =~ m#^/#) {
7147             # $there is absolute already
7148             printdebug "not in bpd, $f, abs, $there ...\n";
7149         } else {
7150             fail f_
7151                 "cannot import %s which seems to be inside working tree!",
7152                 $dscfn;
7153         }
7154         symlink $there, $here or fail f_
7155             "symlink %s to %s: %s", $there, $here, $!;
7156         progress f_ "made symlink %s -> %s", $here, $there;
7157 #       print STDERR Dumper($fi);
7158     }
7159     my @mergeinputs = generate_commits_from_dsc();
7160     die unless @mergeinputs == 1;
7161
7162     my $newhash = $mergeinputs[0]{Commit};
7163
7164     if ($oldhash) {
7165         if ($force > 0) {
7166             progress __
7167                 "Import, forced update - synthetic orphan git history.";
7168         } elsif ($force < 0) {
7169             progress __ "Import, merging.";
7170             my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7171             my $version = getfield $dsc, 'Version';
7172             my $clogp = commit_getclogp $newhash;
7173             my $authline = clogp_authline $clogp;
7174             $newhash = hash_commit_text <<ENDU
7175 tree $tree
7176 parent $newhash
7177 parent $oldhash
7178 author $authline
7179 committer $authline
7180
7181 ENDU
7182                 .(f_ <<END, $package, $version, $dstbranch);
7183 Merge %s (%s) import into %s
7184 END
7185         } else {
7186             die; # caught earlier
7187         }
7188     }
7189
7190     import_dsc_result $dstbranch, $newhash,
7191         "dgit import-dsc: $info",
7192         f_ "results are in git ref %s", $dstbranch;
7193 }
7194
7195 sub pre_archive_api_query () {
7196     not_necessarily_a_tree();
7197 }
7198 sub cmd_archive_api_query {
7199     badusage __ "need only 1 subpath argument" unless @ARGV==1;
7200     my ($subpath) = @ARGV;
7201     local $isuite = 'DGIT-API-QUERY-CMD';
7202     my @cmd = archive_api_query_cmd($subpath);
7203     push @cmd, qw(-f);
7204     debugcmd ">",@cmd;
7205     exec @cmd or fail f_ "exec curl: %s\n", $!;
7206 }
7207
7208 sub repos_server_url () {
7209     $package = '_dgit-repos-server';
7210     local $access_forpush = 1;
7211     local $isuite = 'DGIT-REPOS-SERVER';
7212     my $url = access_giturl();
7213 }
7214
7215 sub pre_clone_dgit_repos_server () {
7216     not_necessarily_a_tree();
7217 }
7218 sub cmd_clone_dgit_repos_server {
7219     badusage __ "need destination argument" unless @ARGV==1;
7220     my ($destdir) = @ARGV;
7221     my $url = repos_server_url();
7222     my @cmd = (@git, qw(clone), $url, $destdir);
7223     debugcmd ">",@cmd;
7224     exec @cmd or fail f_ "exec git clone: %s\n", $!;
7225 }
7226
7227 sub pre_print_dgit_repos_server_source_url () {
7228     not_necessarily_a_tree();
7229 }
7230 sub cmd_print_dgit_repos_server_source_url {
7231     badusage __
7232         "no arguments allowed to dgit print-dgit-repos-server-source-url"
7233         if @ARGV;
7234     my $url = repos_server_url();
7235     print $url, "\n" or confess "$!";
7236 }
7237
7238 sub pre_print_dpkg_source_ignores {
7239     not_necessarily_a_tree();
7240 }
7241 sub cmd_print_dpkg_source_ignores {
7242     badusage __
7243         "no arguments allowed to dgit print-dpkg-source-ignores"
7244         if @ARGV;
7245     print "@dpkg_source_ignores\n" or confess "$!";
7246 }
7247
7248 sub cmd_setup_mergechangelogs {
7249     badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7250         if @ARGV;
7251     local $isuite = 'DGIT-SETUP-TREE';
7252     setup_mergechangelogs(1);
7253 }
7254
7255 sub cmd_setup_useremail {
7256     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7257     local $isuite = 'DGIT-SETUP-TREE';
7258     setup_useremail(1);
7259 }
7260
7261 sub cmd_setup_gitattributes {
7262     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7263     local $isuite = 'DGIT-SETUP-TREE';
7264     setup_gitattrs(1);
7265 }
7266
7267 sub cmd_setup_new_tree {
7268     badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7269     local $isuite = 'DGIT-SETUP-TREE';
7270     setup_new_tree();
7271 }
7272
7273 #---------- argument parsing and main program ----------
7274
7275 sub cmd_version {
7276     print "dgit version $our_version\n" or confess "$!";
7277     finish 0;
7278 }
7279
7280 our (%valopts_long, %valopts_short);
7281 our (%funcopts_long);
7282 our @rvalopts;
7283 our (@modeopt_cfgs);
7284
7285 sub defvalopt ($$$$) {
7286     my ($long,$short,$val_re,$how) = @_;
7287     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7288     $valopts_long{$long} = $oi;
7289     $valopts_short{$short} = $oi;
7290     # $how subref should:
7291     #   do whatever assignemnt or thing it likes with $_[0]
7292     #   if the option should not be passed on to remote, @rvalopts=()
7293     # or $how can be a scalar ref, meaning simply assign the value
7294 }
7295
7296 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7297 defvalopt '--distro',        '-d', '.+',      \$idistro;
7298 defvalopt '',                '-k', '.+',      \$keyid;
7299 defvalopt '--existing-package','', '.*',      \$existing_package;
7300 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
7301 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
7302 defvalopt '--package',   '-p',   $package_re, \$package;
7303 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
7304
7305 defvalopt '', '-C', '.+', sub {
7306     ($changesfile) = (@_);
7307     if ($changesfile =~ s#^(.*)/##) {
7308         $buildproductsdir = $1;
7309     }
7310 };
7311
7312 defvalopt '--initiator-tempdir','','.*', sub {
7313     ($initiator_tempdir) = (@_);
7314     $initiator_tempdir =~ m#^/# or
7315         badusage __ "--initiator-tempdir must be used specify an".
7316                     " absolute, not relative, directory."
7317 };
7318
7319 sub defoptmodes ($@) {
7320     my ($varref, $cfgkey, $default, %optmap) = @_;
7321     my %permit;
7322     while (my ($opt,$val) = each %optmap) {
7323         $funcopts_long{$opt} = sub { $$varref = $val; };
7324         $permit{$val} = $val;
7325     }
7326     push @modeopt_cfgs, {
7327         Var => $varref,
7328         Key => $cfgkey,
7329         Default => $default,
7330         Vals => \%permit
7331     };
7332 }
7333
7334 defoptmodes \$dodep14tag, qw( dep14tag          want
7335                               --dep14tag        want
7336                               --no-dep14tag     no
7337                               --always-dep14tag always );
7338
7339 sub parseopts () {
7340     my $om;
7341
7342     if (defined $ENV{'DGIT_SSH'}) {
7343         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7344     } elsif (defined $ENV{'GIT_SSH'}) {
7345         @ssh = ($ENV{'GIT_SSH'});
7346     }
7347
7348     my $oi;
7349     my $val;
7350     my $valopt = sub {
7351         my ($what) = @_;
7352         @rvalopts = ($_);
7353         if (!defined $val) {
7354             badusage f_ "%s needs a value", $what unless @ARGV;
7355             $val = shift @ARGV;
7356             push @rvalopts, $val;
7357         }
7358         badusage f_ "bad value \`%s' for %s", $val, $what unless
7359             $val =~ m/^$oi->{Re}$(?!\n)/s;
7360         my $how = $oi->{How};
7361         if (ref($how) eq 'SCALAR') {
7362             $$how = $val;
7363         } else {
7364             $how->($val);
7365         }
7366         push @ropts, @rvalopts;
7367     };
7368
7369     while (@ARGV) {
7370         last unless $ARGV[0] =~ m/^-/;
7371         $_ = shift @ARGV;
7372         last if m/^--?$/;
7373         if (m/^--/) {
7374             if (m/^--dry-run$/) {
7375                 push @ropts, $_;
7376                 $dryrun_level=2;
7377             } elsif (m/^--damp-run$/) {
7378                 push @ropts, $_;
7379                 $dryrun_level=1;
7380             } elsif (m/^--no-sign$/) {
7381                 push @ropts, $_;
7382                 $sign=0;
7383             } elsif (m/^--help$/) {
7384                 cmd_help();
7385             } elsif (m/^--version$/) {
7386                 cmd_version();
7387             } elsif (m/^--new$/) {
7388                 push @ropts, $_;
7389                 $new_package=1;
7390             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7391                      ($om = $opts_opt_map{$1}) &&
7392                      length $om->[0]) {
7393                 push @ropts, $_;
7394                 $om->[0] = $2;
7395             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7396                      !$opts_opt_cmdonly{$1} &&
7397                      ($om = $opts_opt_map{$1})) {
7398                 push @ropts, $_;
7399                 push @$om, $2;
7400             } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7401                      !$opts_opt_cmdonly{$1} &&
7402                      ($om = $opts_opt_map{$1})) {
7403                 push @ropts, $_;
7404                 my $cmd = shift @$om;
7405                 @$om = ($cmd, grep { $_ ne $2 } @$om);
7406             } elsif (m/^--($quilt_options_re)$/s) {
7407                 push @ropts, "--quilt=$1";
7408                 $quilt_mode = $1;
7409             } elsif (m/^--(?:ignore|include)-dirty$/s) {
7410                 push @ropts, $_;
7411                 $includedirty = 1;
7412             } elsif (m/^--no-quilt-fixup$/s) {
7413                 push @ropts, $_;
7414                 $quilt_mode = 'nocheck';
7415             } elsif (m/^--no-rm-on-error$/s) {
7416                 push @ropts, $_;
7417                 $rmonerror = 0;
7418             } elsif (m/^--no-chase-dsc-distro$/s) {
7419                 push @ropts, $_;
7420                 $chase_dsc_distro = 0;
7421             } elsif (m/^--overwrite$/s) {
7422                 push @ropts, $_;
7423                 $overwrite_version = '';
7424             } elsif (m/^--split-(?:view|brain)$/s) {
7425                 push @ropts, $_;
7426                 $splitview_mode = 'always';
7427             } elsif (m/^--split-(?:view|brain)=($splitview_modes_re)$/s) {
7428                 push @ropts, $_;
7429                 $splitview_mode = $1;
7430             } elsif (m/^--overwrite=(.+)$/s) {
7431                 push @ropts, $_;
7432                 $overwrite_version = $1;
7433             } elsif (m/^--delayed=(\d+)$/s) {
7434                 push @ropts, $_;
7435                 push @dput, $_;
7436             } elsif (m/^--upstream-commitish=(.+)$/s) {
7437                 push @ropts, $_;
7438                 $quilt_upstream_commitish = $1;
7439             } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7440                      m/^--(dgit-view)-save=(.+)$/s
7441                      ) {
7442                 my ($k,$v) = ($1,$2);
7443                 push @ropts, $_;
7444                 $v =~ s#^(?!refs/)#refs/heads/#;
7445                 $internal_object_save{$k} = $v;
7446             } elsif (m/^--(no-)?rm-old-changes$/s) {
7447                 push @ropts, $_;
7448                 $rmchanges = !$1;
7449             } elsif (m/^--deliberately-($deliberately_re)$/s) {
7450                 push @ropts, $_;
7451                 push @deliberatelies, $&;
7452             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7453                 push @ropts, $&;
7454                 $forceopts{$1} = 1;
7455                 $_='';
7456             } elsif (m/^--force-/) {
7457                 print STDERR
7458                     f_ "%s: warning: ignoring unknown force option %s\n",
7459                        $us, $_;
7460                 $_='';
7461             } elsif (m/^--config-lookup-explode=(.+)$/s) {
7462                 # undocumented, for testing
7463                 push @ropts, $_;
7464                 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7465                 # ^ it's supposed to be an array ref
7466             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7467                 $val = $2 ? $' : undef; #';
7468                 $valopt->($oi->{Long});
7469             } elsif ($funcopts_long{$_}) {
7470                 push @ropts, $_;
7471                 $funcopts_long{$_}();
7472             } else {
7473                 badusage f_ "unknown long option \`%s'", $_;
7474             }
7475         } else {
7476             while (m/^-./s) {
7477                 if (s/^-n/-/) {
7478                     push @ropts, $&;
7479                     $dryrun_level=2;
7480                 } elsif (s/^-L/-/) {
7481                     push @ropts, $&;
7482                     $dryrun_level=1;
7483                 } elsif (s/^-h/-/) {
7484                     cmd_help();
7485                 } elsif (s/^-D/-/) {
7486                     push @ropts, $&;
7487                     $debuglevel++;
7488                     enabledebug();
7489                 } elsif (s/^-N/-/) {
7490                     push @ropts, $&;
7491                     $new_package=1;
7492                 } elsif (m/^-m/) {
7493                     push @ropts, $&;
7494                     push @changesopts, $_;
7495                     $_ = '';
7496                 } elsif (s/^-wn$//s) {
7497                     push @ropts, $&;
7498                     $cleanmode = 'none';
7499                 } elsif (s/^-wg(f?)(a?)$//s) {
7500                     push @ropts, $&;
7501                     $cleanmode = 'git';
7502                     $cleanmode .= '-ff' if $1;
7503                     $cleanmode .= ',always' if $2;
7504                 } elsif (s/^-wd(d?)([na]?)$//s) {
7505                     push @ropts, $&;
7506                     $cleanmode = 'dpkg-source';
7507                     $cleanmode .= '-d' if $1;
7508                     $cleanmode .= ',no-check' if $2 eq 'n';
7509                     $cleanmode .= ',all-check' if $2 eq 'a';
7510                 } elsif (s/^-wc$//s) {
7511                     push @ropts, $&;
7512                     $cleanmode = 'check';
7513                 } elsif (s/^-wci$//s) {
7514                     push @ropts, $&;
7515                     $cleanmode = 'check,ignores';
7516                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7517                     push @git, '-c', $&;
7518                     $gitcfgs{cmdline}{$1} = [ $2 ];
7519                 } elsif (s/^-c([^=]+)$//s) {
7520                     push @git, '-c', $&;
7521                     $gitcfgs{cmdline}{$1} = [ 'true' ];
7522                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7523                     $val = $'; #';
7524                     $val = undef unless length $val;
7525                     $valopt->($oi->{Short});
7526                     $_ = '';
7527                 } else {
7528                     badusage f_ "unknown short option \`%s'", $_;
7529                 }
7530             }
7531         }
7532     }
7533 }
7534
7535 sub check_env_sanity () {
7536     my $blocked = new POSIX::SigSet;
7537     sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7538
7539     eval {
7540         foreach my $name (qw(PIPE CHLD)) {
7541             my $signame = "SIG$name";
7542             my $signum = eval "POSIX::$signame" // die;
7543             die f_ "%s is set to something other than SIG_DFL\n",
7544                 $signame
7545                 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7546             $blocked->ismember($signum) and
7547                 die f_ "%s is blocked\n", $signame;
7548         }
7549     };
7550     return unless $@;
7551     chomp $@;
7552     fail f_ <<END, $@;
7553 On entry to dgit, %s
7554 This is a bug produced by something in your execution environment.
7555 Giving up.
7556 END
7557 }
7558
7559
7560 sub parseopts_late_defaults () {
7561     $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7562         if defined $idistro;
7563     $isuite //= cfg('dgit.default.default-suite');
7564
7565     foreach my $k (keys %opts_opt_map) {
7566         my $om = $opts_opt_map{$k};
7567
7568         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7569         if (defined $v) {
7570             badcfg f_ "cannot set command for %s", $k
7571                 unless length $om->[0];
7572             $om->[0] = $v;
7573         }
7574
7575         foreach my $c (access_cfg_cfgs("opts-$k")) {
7576             my @vl =
7577                 map { $_ ? @$_ : () }
7578                 map { $gitcfgs{$_}{$c} }
7579                 reverse @gitcfgsources;
7580             printdebug "CL $c ", (join " ", map { shellquote } @vl),
7581                 "\n" if $debuglevel >= 4;
7582             next unless @vl;
7583             badcfg f_ "cannot configure options for %s", $k
7584                 if $opts_opt_cmdonly{$k};
7585             my $insertpos = $opts_cfg_insertpos{$k};
7586             @$om = ( @$om[0..$insertpos-1],
7587                      @vl,
7588                      @$om[$insertpos..$#$om] );
7589         }
7590     }
7591
7592     if (!defined $rmchanges) {
7593         local $access_forpush;
7594         $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7595     }
7596
7597     if (!defined $quilt_mode) {
7598         local $access_forpush;
7599         $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7600             // access_cfg('quilt-mode', 'RETURN-UNDEF')
7601             // 'linear';
7602         $quilt_mode =~ m/^($quilt_modes_re)$/
7603             or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7604         $quilt_mode = $1;
7605     }
7606
7607     foreach my $moc (@modeopt_cfgs) {
7608         local $access_forpush;
7609         my $vr = $moc->{Var};
7610         next if defined $$vr;
7611         $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7612         my $v = $moc->{Vals}{$$vr};
7613         badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7614             unless defined $v;
7615         $$vr = $v;
7616     }
7617
7618     {
7619         local $access_forpush;
7620         default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7621                                 $cleanmode_re);
7622     }
7623
7624     $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7625     $buildproductsdir //= '..';
7626     $bpd_glob = $buildproductsdir;
7627     $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7628 }
7629
7630 setlocale(LC_MESSAGES, "");
7631 textdomain("dgit");
7632
7633 if ($ENV{$fakeeditorenv}) {
7634     git_slurp_config();
7635     quilt_fixup_editor();
7636 }
7637
7638 parseopts();
7639 check_env_sanity();
7640
7641 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7642 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7643     if $dryrun_level == 1;
7644 if (!@ARGV) {
7645     print STDERR __ $helpmsg or confess "$!";
7646     finish 8;
7647 }
7648 $cmd = $subcommand = shift @ARGV;
7649 $cmd =~ y/-/_/;
7650
7651 my $pre_fn = ${*::}{"pre_$cmd"};
7652 $pre_fn->() if $pre_fn;
7653
7654 if ($invoked_in_git_tree) {
7655     changedir_git_toplevel();
7656     record_maindir();
7657 }
7658 git_slurp_config();
7659
7660 my $fn = ${*::}{"cmd_$cmd"};
7661 $fn or badusage f_ "unknown operation %s", $cmd;
7662 $fn->();
7663
7664 finish 0;