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