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