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