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