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