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