dgit

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