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