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