dgit

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