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 import_tarball_tartrees ($$) {
2275     my ($upstreamv, $dfi) = @_;
2276     # cwd should be the playground
2277
2278     # We unpack and record the orig tarballs first, so that we only
2279     # need disk space for one private copy of the unpacked source.
2280     # But we can't make them into commits until we have the metadata
2281     # from the debian/changelog, so we record the tree objects now and
2282     # make them into commits later.
2283     my @tartrees;
2284     my $orig_f_base = srcfn $upstreamv, '';
2285
2286     foreach my $fi (@$dfi) {
2287         # We actually import, and record as a commit, every tarball
2288         # (unless there is only one file, in which case there seems
2289         # little point.
2290
2291         my $f = $fi->{Filename};
2292         printdebug "import considering $f ";
2293         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2294         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2295         my $compr_ext = $1;
2296
2297         my ($orig_f_part) =
2298             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2299
2300         printdebug "Y ", (join ' ', map { $_//"(none)" }
2301                           $compr_ext, $orig_f_part
2302                          ), "\n";
2303
2304         my $path = $fi->{Path} // $f;
2305         my $input = new IO::File $f, '<' or die "$f $!";
2306         my $compr_pid;
2307         my @compr_cmd;
2308
2309         if (defined $compr_ext) {
2310             my $cname =
2311                 Dpkg::Compression::compression_guess_from_filename $f;
2312             fail "Dpkg::Compression cannot handle file $f in source package"
2313                 if defined $compr_ext && !defined $cname;
2314             my $compr_proc =
2315                 new Dpkg::Compression::Process compression => $cname;
2316             @compr_cmd = $compr_proc->get_uncompress_cmdline();
2317             my $compr_fh = new IO::Handle;
2318             my $compr_pid = open $compr_fh, "-|" // confess "$!";
2319             if (!$compr_pid) {
2320                 open STDIN, "<&", $input or confess "$!";
2321                 exec @compr_cmd;
2322                 die "dgit (child): exec $compr_cmd[0]: $!\n";
2323             }
2324             $input = $compr_fh;
2325         }
2326
2327         rmtree "_unpack-tar";
2328         mkdir "_unpack-tar" or confess "$!";
2329         my @tarcmd = qw(tar -x -f -
2330                         --no-same-owner --no-same-permissions
2331                         --no-acls --no-xattrs --no-selinux);
2332         my $tar_pid = fork // confess "$!";
2333         if (!$tar_pid) {
2334             chdir "_unpack-tar" or confess "$!";
2335             open STDIN, "<&", $input or confess "$!";
2336             exec @tarcmd;
2337             die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2338         }
2339         $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2340         !$? or failedcmd @tarcmd;
2341
2342         close $input or
2343             (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2344              : confess "$!");
2345         # finally, we have the results in "tarball", but maybe
2346         # with the wrong permissions
2347
2348         runcmd qw(chmod -R +rwX _unpack-tar);
2349         changedir "_unpack-tar";
2350         remove_stray_gits($f);
2351         mktree_in_ud_here();
2352
2353         my ($tree) = git_add_write_tree();
2354         my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2355         if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2356             $tree = $1;
2357             printdebug "one subtree $1\n";
2358         } else {
2359             printdebug "multiple subtrees\n";
2360         }
2361         changedir "..";
2362         rmtree "_unpack-tar";
2363
2364         my $ent = [ $f, $tree ];
2365         push @tartrees, {
2366             Orig => !!$orig_f_part,
2367             Sort => (!$orig_f_part         ? 2 :
2368                      $orig_f_part =~ m/-/g ? 1 :
2369                                              0),
2370             F => $f,
2371             Tree => $tree,
2372         };
2373     }
2374
2375     @tartrees = sort {
2376         # put any without "_" first (spec is not clear whether files
2377         # are always in the usual order).  Tarballs without "_" are
2378         # the main orig or the debian tarball.
2379         $a->{Sort} <=> $b->{Sort} or
2380         $a->{F}    cmp $b->{F}
2381     } @tartrees;
2382
2383     @tartrees;
2384 }
2385
2386 sub import_tarball_commits ($$) {
2387     my ($tartrees, $upstreamv) = @_;
2388     # cwd should be a playtree which has a relevant debian/changelog
2389     # fills in $tt->{Commit} for each one
2390
2391     my $any_orig = grep { $_->{Orig} } @$tartrees;
2392
2393     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2394     my $clogp;
2395     my $r1clogp;
2396
2397     printdebug "import clog search...\n";
2398     parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2399         my ($thisstanza, $desc) = @_;
2400         no warnings qw(exiting);
2401
2402         $clogp //= $thisstanza;
2403
2404         printdebug "import clog $thisstanza->{version} $desc...\n";
2405
2406         last if !$any_orig; # we don't need $r1clogp
2407
2408         # We look for the first (most recent) changelog entry whose
2409         # version number is lower than the upstream version of this
2410         # package.  Then the last (least recent) previous changelog
2411         # entry is treated as the one which introduced this upstream
2412         # version and used for the synthetic commits for the upstream
2413         # tarballs.
2414
2415         # One might think that a more sophisticated algorithm would be
2416         # necessary.  But: we do not want to scan the whole changelog
2417         # file.  Stopping when we see an earlier version, which
2418         # necessarily then is an earlier upstream version, is the only
2419         # realistic way to do that.  Then, either the earliest
2420         # changelog entry we have seen so far is indeed the earliest
2421         # upload of this upstream version; or there are only changelog
2422         # entries relating to later upstream versions (which is not
2423         # possible unless the changelog and .dsc disagree about the
2424         # version).  Then it remains to choose between the physically
2425         # last entry in the file, and the one with the lowest version
2426         # number.  If these are not the same, we guess that the
2427         # versions were created in a non-monotonic order rather than
2428         # that the changelog entries have been misordered.
2429
2430         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2431
2432         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2433         $r1clogp = $thisstanza;
2434
2435         printdebug "import clog $r1clogp->{version} becomes r1\n";
2436     };
2437
2438     $clogp or fail __ "package changelog has no entries!";
2439
2440     my $authline = clogp_authline $clogp;
2441     my $changes = getfield $clogp, 'Changes';
2442     $changes =~ s/^\n//; # Changes: \n
2443     my $cversion = getfield $clogp, 'Version';
2444
2445     if (@$tartrees) {
2446         $r1clogp //= $clogp; # maybe there's only one entry;
2447         my $r1authline = clogp_authline $r1clogp;
2448         # Strictly, r1authline might now be wrong if it's going to be
2449         # unused because !$any_orig.  Whatever.
2450
2451         printdebug "import tartrees authline   $authline\n";
2452         printdebug "import tartrees r1authline $r1authline\n";
2453
2454         foreach my $tt (@$tartrees) {
2455             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2456
2457             my $mbody = f_ "Import %s", $tt->{F};
2458             $tt->{Commit} = hash_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2459 tree $tt->{Tree}
2460 author $r1authline
2461 committer $r1authline
2462
2463 $mbody
2464
2465 [dgit import orig $tt->{F}]
2466 END_O
2467 tree $tt->{Tree}
2468 author $authline
2469 committer $authline
2470
2471 $mbody
2472
2473 [dgit import tarball $package $cversion $tt->{F}]
2474 END_T
2475         }
2476     }
2477
2478     return ($authline, $clogp, $changes);
2479 }
2480
2481 sub generate_commits_from_dsc () {
2482     # See big comment in fetch_from_archive, below.
2483     # See also README.dsc-import.
2484     prep_ud();
2485     changedir $playground;
2486
2487     my $bpd_abs = bpd_abs();
2488     my $upstreamv = upstreamversion $dsc->{version};
2489     my @dfi = dsc_files_info();
2490
2491     dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2492         sub { grep { $_->{Filename} eq $_[0] } @dfi };
2493
2494     foreach my $fi (@dfi) {
2495         my $f = $fi->{Filename};
2496         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2497         my $upper_f = "$bpd_abs/$f";
2498
2499         printdebug "considering reusing $f: ";
2500
2501         if (link_ltarget "$upper_f,fetch", $f) {
2502             printdebug "linked (using ...,fetch).\n";
2503         } elsif ((printdebug "($!) "),
2504                  $! != ENOENT) {
2505             fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2506         } elsif (link_ltarget $upper_f, $f) {
2507             printdebug "linked.\n";
2508         } elsif ((printdebug "($!) "),
2509                  $! != ENOENT) {
2510             fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2511         } else {
2512             printdebug "absent.\n";
2513         }
2514
2515         my $refetched;
2516         complete_file_from_dsc('.', $fi, \$refetched)
2517             or next;
2518
2519         printdebug "considering saving $f: ";
2520
2521         if (rename_link_xf 1, $f, $upper_f) {
2522             printdebug "linked.\n";
2523         } elsif ((printdebug "($@) "),
2524                  $! != EEXIST) {
2525             fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2526         } elsif (!$refetched) {
2527             printdebug "no need.\n";
2528         } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2529             printdebug "linked (using ...,fetch).\n";
2530         } elsif ((printdebug "($@) "),
2531                  $! != EEXIST) {
2532             fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2533         } else {
2534             printdebug "cannot.\n";
2535         }
2536     }
2537
2538     my @tartrees;
2539     @tartrees = import_tarball_tartrees($upstreamv, \@dfi)
2540         unless @dfi == 1; # only one file in .dsc
2541
2542     my $dscfn = "$package.dsc";
2543
2544     my $treeimporthow = 'package';
2545
2546     open D, ">", $dscfn or die "$dscfn: $!";
2547     print D $dscdata or die "$dscfn: $!";
2548     close D or die "$dscfn: $!";
2549     my @cmd = qw(dpkg-source);
2550     push @cmd, '--no-check' if $dsc_checked;
2551     if (madformat $dsc->{format}) {
2552         push @cmd, '--skip-patches';
2553         $treeimporthow = 'unpatched';
2554     }
2555     push @cmd, qw(-x --), $dscfn;
2556     runcmd @cmd;
2557
2558     my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2559     if (madformat $dsc->{format}) {
2560         check_for_vendor_patches();
2561     }
2562
2563     my $dappliedtree;
2564     if (madformat $dsc->{format}) {
2565         my @pcmd = qw(dpkg-source --before-build .);
2566         runcmd shell_cmd 'exec >/dev/null', @pcmd;
2567         rmtree '.pc';
2568         $dappliedtree = git_add_write_tree();
2569     }
2570
2571     my ($authline, $clogp, $changes) =
2572         import_tarball_commits(\@tartrees, $upstreamv);
2573
2574     my $cversion = getfield $clogp, 'Version';
2575
2576     printdebug "import main commit\n";
2577
2578     open C, ">../commit.tmp" or confess "$!";
2579     print C <<END or confess "$!";
2580 tree $tree
2581 END
2582     print C <<END or confess "$!" foreach @tartrees;
2583 parent $_->{Commit}
2584 END
2585     print C <<END or confess "$!";
2586 author $authline
2587 committer $authline
2588
2589 $changes
2590
2591 [dgit import $treeimporthow $package $cversion]
2592 END
2593
2594     close C or confess "$!";
2595     my $rawimport_hash = hash_commit qw(../commit.tmp);
2596
2597     if (madformat $dsc->{format}) {
2598         printdebug "import apply patches...\n";
2599
2600         # regularise the state of the working tree so that
2601         # the checkout of $rawimport_hash works nicely.
2602         my $dappliedcommit = hash_commit_text(<<END);
2603 tree $dappliedtree
2604 author $authline
2605 committer $authline
2606
2607 [dgit dummy commit]
2608 END
2609         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2610
2611         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2612
2613         # We need the answers to be reproducible
2614         my @authline = clogp_authline($clogp);
2615         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2616         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2617         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2618         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
2619         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2620         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
2621
2622         my $path = $ENV{PATH} or die;
2623
2624         # we use ../../gbp-pq-output, which (given that we are in
2625         # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2626         # is .git/dgit.
2627
2628         foreach my $use_absurd (qw(0 1)) {
2629             runcmd @git, qw(checkout -q unpa);
2630             runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2631             local $ENV{PATH} = $path;
2632             if ($use_absurd) {
2633                 chomp $@;
2634                 progress "warning: $@";
2635                 $path = "$absurdity:$path";
2636                 progress f_ "%s: trying slow absurd-git-apply...", $us;
2637                 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2638                     or $!==ENOENT
2639                     or confess "$!";
2640             }
2641             eval {
2642                 die "forbid absurd git-apply\n" if $use_absurd
2643                     && forceing [qw(import-gitapply-no-absurd)];
2644                 die "only absurd git-apply!\n" if !$use_absurd
2645                     && forceing [qw(import-gitapply-absurd)];
2646
2647                 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2648                 local $ENV{PATH} = $path                    if $use_absurd;
2649
2650                 my @showcmd = (gbp_pq, qw(import));
2651                 my @realcmd = shell_cmd
2652                     'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2653                 debugcmd "+",@realcmd;
2654                 if (system @realcmd) {
2655                     die f_ "%s failed: %s\n",
2656                         +(shellquote @showcmd),
2657                         failedcmd_waitstatus();
2658                 }
2659
2660                 my $gapplied = git_rev_parse('HEAD');
2661                 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2662                 $gappliedtree eq $dappliedtree or
2663                     fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2664 gbp-pq import and dpkg-source disagree!
2665  gbp-pq import gave commit %s
2666  gbp-pq import gave tree %s
2667  dpkg-source --before-build gave tree %s
2668 END
2669                 $rawimport_hash = $gapplied;
2670             };
2671             last unless $@;
2672         }
2673         if ($@) {
2674             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2675             die $@;
2676         }
2677     }
2678
2679     progress f_ "synthesised git commit from .dsc %s", $cversion;
2680
2681     my $rawimport_mergeinput = {
2682         Commit => $rawimport_hash,
2683         Info => __ "Import of source package",
2684     };
2685     my @output = ($rawimport_mergeinput);
2686
2687     if ($lastpush_mergeinput) {
2688         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2689         my $oversion = getfield $oldclogp, 'Version';
2690         my $vcmp =
2691             version_compare($oversion, $cversion);
2692         if ($vcmp < 0) {
2693             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2694                 { ReverseParents => 1,
2695                   Message => (f_ <<END, $package, $cversion, $csuite) });
2696 Record %s (%s) in archive suite %s
2697 END
2698         } elsif ($vcmp > 0) {
2699             print STDERR f_ <<END, $cversion, $oversion,
2700
2701 Version actually in archive:   %s (older)
2702 Last version pushed with dgit: %s (newer or same)
2703 %s
2704 END
2705                 __ $later_warning_msg or confess "$!";
2706             @output = $lastpush_mergeinput;
2707         } else {
2708             # Same version.  Use what's in the server git branch,
2709             # discarding our own import.  (This could happen if the
2710             # server automatically imports all packages into git.)
2711             @output = $lastpush_mergeinput;
2712         }
2713     }
2714     changedir $maindir;
2715     rmtree $playground;
2716     return @output;
2717 }
2718
2719 sub complete_file_from_dsc ($$;$) {
2720     our ($dstdir, $fi, $refetched) = @_;
2721     # Ensures that we have, in $dstdir, the file $fi, with the correct
2722     # contents.  (Downloading it from alongside $dscurl if necessary.)
2723     # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2724     # and will set $$refetched=1 if it did so (or tried to).
2725
2726     my $f = $fi->{Filename};
2727     my $tf = "$dstdir/$f";
2728     my $downloaded = 0;
2729
2730     my $got;
2731     my $checkhash = sub {
2732         open F, "<", "$tf" or die "$tf: $!";
2733         $fi->{Digester}->reset();
2734         $fi->{Digester}->addfile(*F);
2735         F->error and confess "$!";
2736         $got = $fi->{Digester}->hexdigest();
2737         return $got eq $fi->{Hash};
2738     };
2739
2740     if (stat_exists $tf) {
2741         if ($checkhash->()) {
2742             progress f_ "using existing %s", $f;
2743             return 1;
2744         }
2745         if (!$refetched) {
2746             fail f_ "file %s has hash %s but .dsc demands hash %s".
2747                     " (perhaps you should delete this file?)",
2748                     $f, $got, $fi->{Hash};
2749         }
2750         progress f_ "need to fetch correct version of %s", $f;
2751         unlink $tf or die "$tf $!";
2752         $$refetched = 1;
2753     } else {
2754         printdebug "$tf does not exist, need to fetch\n";
2755     }
2756
2757     my $furl = $dscurl;
2758     $furl =~ s{/[^/]+$}{};
2759     $furl .= "/$f";
2760     die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2761     die "$f ?" if $f =~ m#/#;
2762     runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2763     return 0 if !act_local();
2764
2765     $checkhash->() or
2766         fail f_ "file %s has hash %s but .dsc demands hash %s".
2767                 " (got wrong file from archive!)",
2768                 $f, $got, $fi->{Hash};
2769
2770     return 1;
2771 }
2772
2773 sub ensure_we_have_orig () {
2774     my @dfi = dsc_files_info();
2775     foreach my $fi (@dfi) {
2776         my $f = $fi->{Filename};
2777         next unless is_orig_file_in_dsc($f, \@dfi);
2778         complete_file_from_dsc($buildproductsdir, $fi)
2779             or next;
2780     }
2781 }
2782
2783 #---------- git fetch ----------
2784
2785 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2786 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2787
2788 # We fetch some parts of lrfetchrefs/*.  Ideally we delete these
2789 # locally fetched refs because they have unhelpful names and clutter
2790 # up gitk etc.  So we track whether we have "used up" head ref (ie,
2791 # whether we have made another local ref which refers to this object).
2792 #
2793 # (If we deleted them unconditionally, then we might end up
2794 # re-fetching the same git objects each time dgit fetch was run.)
2795 #
2796 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2797 # in git_fetch_us to fetch the refs in question, and possibly a call
2798 # to lrfetchref_used.
2799
2800 our (%lrfetchrefs_f, %lrfetchrefs_d);
2801 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2802
2803 sub lrfetchref_used ($) {
2804     my ($fullrefname) = @_;
2805     my $objid = $lrfetchrefs_f{$fullrefname};
2806     $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2807 }
2808
2809 sub git_lrfetch_sane {
2810     my ($url, $supplementary, @specs) = @_;
2811     # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2812     # at least as regards @specs.  Also leave the results in
2813     # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2814     # able to clean these up.
2815     #
2816     # With $supplementary==1, @specs must not contain wildcards
2817     # and we add to our previous fetches (non-atomically).
2818
2819     # This is rather miserable:
2820     # When git fetch --prune is passed a fetchspec ending with a *,
2821     # it does a plausible thing.  If there is no * then:
2822     # - it matches subpaths too, even if the supplied refspec
2823     #   starts refs, and behaves completely madly if the source
2824     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2825     # - if there is no matching remote ref, it bombs out the whole
2826     #   fetch.
2827     # We want to fetch a fixed ref, and we don't know in advance
2828     # if it exists, so this is not suitable.
2829     #
2830     # Our workaround is to use git ls-remote.  git ls-remote has its
2831     # own qairks.  Notably, it has the absurd multi-tail-matching
2832     # behaviour: git ls-remote R refs/foo can report refs/foo AND
2833     # refs/refs/foo etc.
2834     #
2835     # Also, we want an idempotent snapshot, but we have to make two
2836     # calls to the remote: one to git ls-remote and to git fetch.  The
2837     # solution is use git ls-remote to obtain a target state, and
2838     # git fetch to try to generate it.  If we don't manage to generate
2839     # the target state, we try again.
2840
2841     printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2842
2843     my $specre = join '|', map {
2844         my $x = $_;
2845         $x =~ s/\W/\\$&/g;
2846         my $wildcard = $x =~ s/\\\*$/.*/;
2847         die if $wildcard && $supplementary;
2848         "(?:refs/$x)";
2849     } @specs;
2850     printdebug "git_lrfetch_sane specre=$specre\n";
2851     my $wanted_rref = sub {
2852         local ($_) = @_;
2853         return m/^(?:$specre)$/;
2854     };
2855
2856     my $fetch_iteration = 0;
2857     FETCH_ITERATION:
2858     for (;;) {
2859         printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2860         if (++$fetch_iteration > 10) {
2861             fail __ "too many iterations trying to get sane fetch!";
2862         }
2863
2864         my @look = map { "refs/$_" } @specs;
2865         my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2866         debugcmd "|",@lcmd;
2867
2868         my %wantr;
2869         open GITLS, "-|", @lcmd or confess "$!";
2870         while (<GITLS>) {
2871             printdebug "=> ", $_;
2872             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2873             my ($objid,$rrefname) = ($1,$2);
2874             if (!$wanted_rref->($rrefname)) {
2875                 print STDERR f_ <<END, "@look", $rrefname;
2876 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2877 END
2878                 next;
2879             }
2880             $wantr{$rrefname} = $objid;
2881         }
2882         $!=0; $?=0;
2883         close GITLS or failedcmd @lcmd;
2884
2885         # OK, now %want is exactly what we want for refs in @specs
2886         my @fspecs = map {
2887             !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2888             "+refs/$_:".lrfetchrefs."/$_";
2889         } @specs;
2890
2891         printdebug "git_lrfetch_sane fspecs @fspecs\n";
2892
2893         my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2894         runcmd_ordryrun_local @fcmd if @fspecs;
2895
2896         if (!$supplementary) {
2897             %lrfetchrefs_f = ();
2898         }
2899         my %objgot;
2900
2901         git_for_each_ref(lrfetchrefs, sub {
2902             my ($objid,$objtype,$lrefname,$reftail) = @_;
2903             $lrfetchrefs_f{$lrefname} = $objid;
2904             $objgot{$objid} = 1;
2905         });
2906
2907         if ($supplementary) {
2908             last;
2909         }
2910
2911         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2912             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2913             if (!exists $wantr{$rrefname}) {
2914                 if ($wanted_rref->($rrefname)) {
2915                     printdebug <<END;
2916 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2917 END
2918                 } else {
2919                     print STDERR f_ <<END, "@fspecs", $lrefname
2920 warning: git fetch %s created %s; this is silly, deleting it.
2921 END
2922                 }
2923                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2924                 delete $lrfetchrefs_f{$lrefname};
2925                 next;
2926             }
2927         }
2928         foreach my $rrefname (sort keys %wantr) {
2929             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2930             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2931             my $want = $wantr{$rrefname};
2932             next if $got eq $want;
2933             if (!defined $objgot{$want}) {
2934                 fail __ <<END unless act_local();
2935 --dry-run specified but we actually wanted the results of git fetch,
2936 so this is not going to work.  Try running dgit fetch first,
2937 or using --damp-run instead of --dry-run.
2938 END
2939                 print STDERR f_ <<END, $lrefname, $want;
2940 warning: git ls-remote suggests we want %s
2941 warning:  and it should refer to %s
2942 warning:  but git fetch didn't fetch that object to any relevant ref.
2943 warning:  This may be due to a race with someone updating the server.
2944 warning:  Will try again...
2945 END
2946                 next FETCH_ITERATION;
2947             }
2948             printdebug <<END;
2949 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2950 END
2951             runcmd_ordryrun_local @git, qw(update-ref -m),
2952                 "dgit fetch git fetch fixup", $lrefname, $want;
2953             $lrfetchrefs_f{$lrefname} = $want;
2954         }
2955         last;
2956     }
2957
2958     if (defined $csuite) {
2959         printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2960         git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2961             my ($objid,$objtype,$lrefname,$reftail) = @_;
2962             next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2963             runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2964         });
2965     }
2966
2967     printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2968         Dumper(\%lrfetchrefs_f);
2969 }
2970
2971 sub git_fetch_us () {
2972     # Want to fetch only what we are going to use, unless
2973     # deliberately-not-ff, in which case we must fetch everything.
2974
2975     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2976         map { "tags/$_" } debiantags('*',access_nomdistro);
2977     push @specs, server_branch($csuite);
2978     push @specs, $rewritemap;
2979     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2980
2981     my $url = access_giturl();
2982     git_lrfetch_sane $url, 0, @specs;
2983
2984     my %here;
2985     my @tagpats = debiantags('*',access_nomdistro);
2986
2987     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2988         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2989         printdebug "currently $fullrefname=$objid\n";
2990         $here{$fullrefname} = $objid;
2991     });
2992     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2993         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2994         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2995         printdebug "offered $lref=$objid\n";
2996         if (!defined $here{$lref}) {
2997             my @upd = (@git, qw(update-ref), $lref, $objid, '');
2998             runcmd_ordryrun_local @upd;
2999             lrfetchref_used $fullrefname;
3000         } elsif ($here{$lref} eq $objid) {
3001             lrfetchref_used $fullrefname;
3002         } else {
3003             print STDERR f_ "Not updating %s from %s to %s.\n",
3004                             $lref, $here{$lref}, $objid;
3005         }
3006     });
3007 }
3008
3009 #---------- dsc and archive handling ----------
3010
3011 sub mergeinfo_getclogp ($) {
3012     # Ensures thit $mi->{Clogp} exists and returns it
3013     my ($mi) = @_;
3014     $mi->{Clogp} = commit_getclogp($mi->{Commit});
3015 }
3016
3017 sub mergeinfo_version ($) {
3018     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
3019 }
3020
3021 sub fetch_from_archive_record_1 ($) {
3022     my ($hash) = @_;
3023     runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
3024     cmdoutput @git, qw(log -n2), $hash;
3025     # ... gives git a chance to complain if our commit is malformed
3026 }
3027
3028 sub fetch_from_archive_record_2 ($) {
3029     my ($hash) = @_;
3030     my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
3031     if (act_local()) {
3032         cmdoutput @upd_cmd;
3033     } else {
3034         dryrun_report @upd_cmd;
3035     }
3036 }
3037
3038 sub parse_dsc_field_def_dsc_distro () {
3039     $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
3040                            dgit.default.distro);
3041 }
3042
3043 sub parse_dsc_field ($$) {
3044     my ($dsc, $what) = @_;
3045     my $f;
3046     foreach my $field (@ourdscfield) {
3047         $f = $dsc->{$field};
3048         last if defined $f;
3049     }
3050
3051     if (!defined $f) {
3052         progress f_ "%s: NO git hash", $what;
3053         parse_dsc_field_def_dsc_distro();
3054     } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3055              = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3056         progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3057         $dsc_hint_tag = [ $dsc_hint_tag ];
3058     } elsif ($f =~ m/^\w+\s*$/) {
3059         $dsc_hash = $&;
3060         parse_dsc_field_def_dsc_distro();
3061         $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3062                           $dsc_distro ];
3063         progress f_ "%s: specified git hash", $what;
3064     } else {
3065         fail f_ "%s: invalid Dgit info", $what;
3066     }
3067 }
3068
3069 sub resolve_dsc_field_commit ($$) {
3070     my ($already_distro, $already_mapref) = @_;
3071
3072     return unless defined $dsc_hash;
3073
3074     my $mapref =
3075         defined $already_mapref &&
3076         ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3077         ? $already_mapref : undef;
3078
3079     my $do_fetch;
3080     $do_fetch = sub {
3081         my ($what, @fetch) = @_;
3082
3083         local $idistro = $dsc_distro;
3084         my $lrf = lrfetchrefs;
3085
3086         if (!$chase_dsc_distro) {
3087             progress f_ "not chasing .dsc distro %s: not fetching %s",
3088                         $dsc_distro, $what;
3089             return 0;
3090         }
3091
3092         progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3093
3094         my $url = access_giturl();
3095         if (!defined $url) {
3096             defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3097 .dsc Dgit metadata is in context of distro %s
3098 for which we have no configured url and .dsc provides no hint
3099 END
3100             my $proto =
3101                 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3102                 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3103             parse_cfg_bool "dsc-url-proto-ok", 'false',
3104                 cfg("dgit.dsc-url-proto-ok.$proto",
3105                     "dgit.default.dsc-url-proto-ok")
3106                 or fail f_ <<END, $dsc_distro, $proto;
3107 .dsc Dgit metadata is in context of distro %s
3108 for which we have no configured url;
3109 .dsc provides hinted url with protocol %s which is unsafe.
3110 (can be overridden by config - consult documentation)
3111 END
3112             $url = $dsc_hint_url;
3113         }
3114
3115         git_lrfetch_sane $url, 1, @fetch;
3116
3117         return $lrf;
3118     };
3119
3120     my $rewrite_enable = do {
3121         local $idistro = $dsc_distro;
3122         access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3123     };
3124
3125     if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3126         if (!defined $mapref) {
3127             my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3128             $mapref = $lrf.'/'.$rewritemap;
3129         }
3130         my $rewritemapdata = git_cat_file $mapref.':map';
3131         if (defined $rewritemapdata
3132             && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3133             progress __
3134                 "server's git history rewrite map contains a relevant entry!";
3135
3136             $dsc_hash = $1;
3137             if (defined $dsc_hash) {
3138                 progress __ "using rewritten git hash in place of .dsc value";
3139             } else {
3140                 progress __ "server data says .dsc hash is to be disregarded";
3141             }
3142         }
3143     }
3144
3145     if (!defined git_cat_file $dsc_hash) {
3146         my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3147         my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3148             defined git_cat_file $dsc_hash
3149             or fail f_ <<END, $dsc_hash;
3150 .dsc Dgit metadata requires commit %s
3151 but we could not obtain that object anywhere.
3152 END
3153         foreach my $t (@tags) {
3154             my $fullrefname = $lrf.'/'.$t;
3155 #           print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3156             next unless $lrfetchrefs_f{$fullrefname};
3157             next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3158             lrfetchref_used $fullrefname;
3159         }
3160     }
3161 }
3162
3163 sub fetch_from_archive () {
3164     check_bpd_exists();
3165     ensure_setup_existing_tree();
3166
3167     # Ensures that lrref() is what is actually in the archive, one way
3168     # or another, according to us - ie this client's
3169     # appropritaely-updated archive view.  Also returns the commit id.
3170     # If there is nothing in the archive, leaves lrref alone and
3171     # returns undef.  git_fetch_us must have already been called.
3172     get_archive_dsc();
3173
3174     if ($dsc) {
3175         parse_dsc_field($dsc, __ 'last upload to archive');
3176         resolve_dsc_field_commit access_basedistro,
3177             lrfetchrefs."/".$rewritemap
3178     } else {
3179         progress __ "no version available from the archive";
3180     }
3181
3182     # If the archive's .dsc has a Dgit field, there are three
3183     # relevant git commitids we need to choose between and/or merge
3184     # together:
3185     #   1. $dsc_hash: the Dgit field from the archive
3186     #   2. $lastpush_hash: the suite branch on the dgit git server
3187     #   3. $lastfetch_hash: our local tracking brach for the suite
3188     #
3189     # These may all be distinct and need not be in any fast forward
3190     # relationship:
3191     #
3192     # If the dsc was pushed to this suite, then the server suite
3193     # branch will have been updated; but it might have been pushed to
3194     # a different suite and copied by the archive.  Conversely a more
3195     # recent version may have been pushed with dgit but not appeared
3196     # in the archive (yet).
3197     #
3198     # $lastfetch_hash may be awkward because archive imports
3199     # (particularly, imports of Dgit-less .dscs) are performed only as
3200     # needed on individual clients, so different clients may perform a
3201     # different subset of them - and these imports are only made
3202     # public during push.  So $lastfetch_hash may represent a set of
3203     # imports different to a subsequent upload by a different dgit
3204     # client.
3205     #
3206     # Our approach is as follows:
3207     #
3208     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3209     # descendant of $dsc_hash, then it was pushed by a dgit user who
3210     # had based their work on $dsc_hash, so we should prefer it.
3211     # Otherwise, $dsc_hash was installed into this suite in the
3212     # archive other than by a dgit push, and (necessarily) after the
3213     # last dgit push into that suite (since a dgit push would have
3214     # been descended from the dgit server git branch); thus, in that
3215     # case, we prefer the archive's version (and produce a
3216     # pseudo-merge to overwrite the dgit server git branch).
3217     #
3218     # (If there is no Dgit field in the archive's .dsc then
3219     # generate_commit_from_dsc uses the version numbers to decide
3220     # whether the suite branch or the archive is newer.  If the suite
3221     # branch is newer it ignores the archive's .dsc; otherwise it
3222     # generates an import of the .dsc, and produces a pseudo-merge to
3223     # overwrite the suite branch with the archive contents.)
3224     #
3225     # The outcome of that part of the algorithm is the `public view',
3226     # and is same for all dgit clients: it does not depend on any
3227     # unpublished history in the local tracking branch.
3228     #
3229     # As between the public view and the local tracking branch: The
3230     # local tracking branch is only updated by dgit fetch, and
3231     # whenever dgit fetch runs it includes the public view in the
3232     # local tracking branch.  Therefore if the public view is not
3233     # descended from the local tracking branch, the local tracking
3234     # branch must contain history which was imported from the archive
3235     # but never pushed; and, its tip is now out of date.  So, we make
3236     # a pseudo-merge to overwrite the old imports and stitch the old
3237     # history in.
3238     #
3239     # Finally: we do not necessarily reify the public view (as
3240     # described above).  This is so that we do not end up stacking two
3241     # pseudo-merges.  So what we actually do is figure out the inputs
3242     # to any public view pseudo-merge and put them in @mergeinputs.
3243
3244     my @mergeinputs;
3245     # $mergeinputs[]{Commit}
3246     # $mergeinputs[]{Info}
3247     # $mergeinputs[0] is the one whose tree we use
3248     # @mergeinputs is in the order we use in the actual commit)
3249     #
3250     # Also:
3251     # $mergeinputs[]{Message} is a commit message to use
3252     # $mergeinputs[]{ReverseParents} if def specifies that parent
3253     #                                list should be in opposite order
3254     # Such an entry has no Commit or Info.  It applies only when found
3255     # in the last entry.  (This ugliness is to support making
3256     # identical imports to previous dgit versions.)
3257
3258     my $lastpush_hash = git_get_ref(lrfetchref());
3259     printdebug "previous reference hash=$lastpush_hash\n";
3260     $lastpush_mergeinput = $lastpush_hash && {
3261         Commit => $lastpush_hash,
3262         Info => (__ "dgit suite branch on dgit git server"),
3263     };
3264
3265     my $lastfetch_hash = git_get_ref(lrref());
3266     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3267     my $lastfetch_mergeinput = $lastfetch_hash && {
3268         Commit => $lastfetch_hash,
3269         Info => (__ "dgit client's archive history view"),
3270     };
3271
3272     my $dsc_mergeinput = $dsc_hash && {
3273         Commit => $dsc_hash,
3274         Info => (__ "Dgit field in .dsc from archive"),
3275     };
3276
3277     my $cwd = getcwd();
3278     my $del_lrfetchrefs = sub {
3279         changedir $cwd;
3280         my $gur;
3281         printdebug "del_lrfetchrefs...\n";
3282         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3283             my $objid = $lrfetchrefs_d{$fullrefname};
3284             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3285             if (!$gur) {
3286                 $gur ||= new IO::Handle;
3287                 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3288             }
3289             printf $gur "delete %s %s\n", $fullrefname, $objid;
3290         }
3291         if ($gur) {
3292             close $gur or failedcmd "git update-ref delete lrfetchrefs";
3293         }
3294     };
3295
3296     if (defined $dsc_hash) {
3297         ensure_we_have_orig();
3298         if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3299             @mergeinputs = $dsc_mergeinput
3300         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3301             print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3302
3303 Git commit in archive is behind the last version allegedly pushed/uploaded.
3304 Commit referred to by archive: %s
3305 Last version pushed with dgit: %s
3306 %s
3307 END
3308                 __ $later_warning_msg or confess "$!";
3309             @mergeinputs = ($lastpush_mergeinput);
3310         } else {
3311             # Archive has .dsc which is not a descendant of the last dgit
3312             # push.  This can happen if the archive moves .dscs about.
3313             # Just follow its lead.
3314             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3315                 progress __ "archive .dsc names newer git commit";
3316                 @mergeinputs = ($dsc_mergeinput);
3317             } else {
3318                 progress __ "archive .dsc names other git commit, fixing up";
3319                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3320             }
3321         }
3322     } elsif ($dsc) {
3323         @mergeinputs = generate_commits_from_dsc();
3324         # We have just done an import.  Now, our import algorithm might
3325         # have been improved.  But even so we do not want to generate
3326         # a new different import of the same package.  So if the
3327         # version numbers are the same, just use our existing version.
3328         # If the version numbers are different, the archive has changed
3329         # (perhaps, rewound).
3330         if ($lastfetch_mergeinput &&
3331             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3332                               (mergeinfo_version $mergeinputs[0]) )) {
3333             @mergeinputs = ($lastfetch_mergeinput);
3334         }
3335     } elsif ($lastpush_hash) {
3336         # only in git, not in the archive yet
3337         @mergeinputs = ($lastpush_mergeinput);
3338         print STDERR f_ <<END,
3339
3340 Package not found in the archive, but has allegedly been pushed using dgit.
3341 %s
3342 END
3343             __ $later_warning_msg or confess "$!";
3344     } else {
3345         printdebug "nothing found!\n";
3346         if (defined $skew_warning_vsn) {
3347             print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3348
3349 Warning: relevant archive skew detected.
3350 Archive allegedly contains %s
3351 But we were not able to obtain any version from the archive or git.
3352
3353 END
3354         }
3355         unshift @end, $del_lrfetchrefs;
3356         return undef;
3357     }
3358
3359     if ($lastfetch_hash &&
3360         !grep {
3361             my $h = $_->{Commit};
3362             $h and is_fast_fwd($lastfetch_hash, $h);
3363             # If true, one of the existing parents of this commit
3364             # is a descendant of the $lastfetch_hash, so we'll
3365             # be ff from that automatically.
3366         } @mergeinputs
3367         ) {
3368         # Otherwise:
3369         push @mergeinputs, $lastfetch_mergeinput;
3370     }
3371
3372     printdebug "fetch mergeinfos:\n";
3373     foreach my $mi (@mergeinputs) {
3374         if ($mi->{Info}) {
3375             printdebug " commit $mi->{Commit} $mi->{Info}\n";
3376         } else {
3377             printdebug sprintf " ReverseParents=%d Message=%s",
3378                 $mi->{ReverseParents}, $mi->{Message};
3379         }
3380     }
3381
3382     my $compat_info= pop @mergeinputs
3383         if $mergeinputs[$#mergeinputs]{Message};
3384
3385     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3386
3387     my $hash;
3388     if (@mergeinputs > 1) {
3389         # here we go, then:
3390         my $tree_commit = $mergeinputs[0]{Commit};
3391
3392         my $tree = get_tree_of_commit $tree_commit;;
3393
3394         # We use the changelog author of the package in question the
3395         # author of this pseudo-merge.  This is (roughly) correct if
3396         # this commit is simply representing aa non-dgit upload.
3397         # (Roughly because it does not record sponsorship - but we
3398         # don't have sponsorship info because that's in the .changes,
3399         # which isn't in the archivw.)
3400         #
3401         # But, it might be that we are representing archive history
3402         # updates (including in-archive copies).  These are not really
3403         # the responsibility of the person who created the .dsc, but
3404         # there is no-one whose name we should better use.  (The
3405         # author of the .dsc-named commit is clearly worse.)
3406
3407         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3408         my $author = clogp_authline $useclogp;
3409         my $cversion = getfield $useclogp, 'Version';
3410
3411         my $mcf = dgit_privdir()."/mergecommit";
3412         open MC, ">", $mcf or die "$mcf $!";
3413         print MC <<END or confess "$!";
3414 tree $tree
3415 END
3416
3417         my @parents = grep { $_->{Commit} } @mergeinputs;
3418         @parents = reverse @parents if $compat_info->{ReverseParents};
3419         print MC <<END or confess "$!" foreach @parents;
3420 parent $_->{Commit}
3421 END
3422
3423         print MC <<END or confess "$!";
3424 author $author
3425 committer $author
3426
3427 END
3428
3429         if (defined $compat_info->{Message}) {
3430             print MC $compat_info->{Message} or confess "$!";
3431         } else {
3432             print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3433 Record %s (%s) in archive suite %s
3434
3435 Record that
3436 END
3437             my $message_add_info = sub {
3438                 my ($mi) = (@_);
3439                 my $mversion = mergeinfo_version $mi;
3440                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
3441                     or confess "$!";
3442             };
3443
3444             $message_add_info->($mergeinputs[0]);
3445             print MC __ <<END or confess "$!";
3446 should be treated as descended from
3447 END
3448             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3449         }
3450
3451         close MC or confess "$!";
3452         $hash = hash_commit $mcf;
3453     } else {
3454         $hash = $mergeinputs[0]{Commit};
3455     }
3456     printdebug "fetch hash=$hash\n";
3457
3458     my $chkff = sub {
3459         my ($lasth, $what) = @_;
3460         return unless $lasth;
3461         confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3462     };
3463
3464     $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3465         if $lastpush_hash;
3466     $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3467
3468     fetch_from_archive_record_1($hash);
3469
3470     if (defined $skew_warning_vsn) {
3471         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3472         my $gotclogp = commit_getclogp($hash);
3473         my $got_vsn = getfield $gotclogp, 'Version';
3474         printdebug "SKEW CHECK GOT $got_vsn\n";
3475         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3476             print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3477
3478 Warning: archive skew detected.  Using the available version:
3479 Archive allegedly contains    %s
3480 We were able to obtain only   %s
3481
3482 END
3483         }
3484     }
3485
3486     if ($lastfetch_hash ne $hash) {
3487         fetch_from_archive_record_2($hash);
3488     }
3489
3490     lrfetchref_used lrfetchref();
3491
3492     check_gitattrs($hash, __ "fetched source tree");
3493
3494     unshift @end, $del_lrfetchrefs;
3495     return $hash;
3496 }
3497
3498 sub set_local_git_config ($$) {
3499     my ($k, $v) = @_;
3500     runcmd @git, qw(config), $k, $v;
3501 }
3502
3503 sub setup_mergechangelogs (;$) {
3504     my ($always) = @_;
3505     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3506
3507     my $driver = 'dpkg-mergechangelogs';
3508     my $cb = "merge.$driver";
3509     confess unless defined $maindir;
3510     my $attrs = "$maindir_gitcommon/info/attributes";
3511     ensuredir "$maindir_gitcommon/info";
3512
3513     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3514     if (!open ATTRS, "<", $attrs) {
3515         $!==ENOENT or die "$attrs: $!";
3516     } else {
3517         while (<ATTRS>) {
3518             chomp;
3519             next if m{^debian/changelog\s};
3520             print NATTRS $_, "\n" or confess "$!";
3521         }
3522         ATTRS->error and confess "$!";
3523         close ATTRS;
3524     }
3525     print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3526     close NATTRS;
3527
3528     set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3529     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3530
3531     rename "$attrs.new", "$attrs" or die "$attrs: $!";
3532 }
3533
3534 sub setup_useremail (;$) {
3535     my ($always) = @_;
3536     return unless $always || access_cfg_bool(1, 'setup-useremail');
3537
3538     my $setup = sub {
3539         my ($k, $envvar) = @_;
3540         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3541         return unless defined $v;
3542         set_local_git_config "user.$k", $v;
3543     };
3544
3545     $setup->('email', 'DEBEMAIL');
3546     $setup->('name', 'DEBFULLNAME');
3547 }
3548
3549 sub ensure_setup_existing_tree () {
3550     my $k = "remote.$remotename.skipdefaultupdate";
3551     my $c = git_get_config $k;
3552     return if defined $c;
3553     set_local_git_config $k, 'true';
3554 }
3555
3556 sub open_main_gitattrs () {
3557     confess 'internal error no maindir' unless defined $maindir;
3558     my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3559         or $!==ENOENT
3560         or die "open $maindir_gitcommon/info/attributes: $!";
3561     return $gai;
3562 }
3563
3564 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3565
3566 sub is_gitattrs_setup () {
3567     # return values:
3568     #  trueish
3569     #     1: gitattributes set up and should be left alone
3570     #  falseish
3571     #     0: there is a dgit-defuse-attrs but it needs fixing
3572     #     undef: there is none
3573     my $gai = open_main_gitattrs();
3574     return 0 unless $gai;
3575     while (<$gai>) {
3576         next unless m{$gitattrs_ourmacro_re};
3577         return 1 if m{\s-working-tree-encoding\s};
3578         printdebug "is_gitattrs_setup: found old macro\n";
3579         return 0;
3580     }
3581     $gai->error and confess "$!";
3582     printdebug "is_gitattrs_setup: found nothing\n";
3583     return undef;
3584 }
3585
3586 sub setup_gitattrs (;$) {
3587     my ($always) = @_;
3588     return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3589
3590     my $already = is_gitattrs_setup();
3591     if ($already) {
3592         progress __ <<END;
3593 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3594  not doing further gitattributes setup
3595 END
3596         return;
3597     }
3598     my $new = "[attr]dgit-defuse-attrs  $negate_harmful_gitattrs";
3599     my $af = "$maindir_gitcommon/info/attributes";
3600     ensuredir "$maindir_gitcommon/info";
3601
3602     open GAO, "> $af.new" or confess "$!";
3603     print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3604 *       dgit-defuse-attrs
3605 $new
3606 END
3607 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3608 ENDT
3609     my $gai = open_main_gitattrs();
3610     if ($gai) {
3611         while (<$gai>) {
3612             if (m{$gitattrs_ourmacro_re}) {
3613                 die unless defined $already;
3614                 $_ = $new;
3615             }
3616             chomp;
3617             print GAO $_, "\n" or confess "$!";
3618         }
3619         $gai->error and confess "$!";
3620     }
3621     close GAO or confess "$!";
3622     rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3623 }
3624
3625 sub setup_new_tree () {
3626     setup_mergechangelogs();
3627     setup_useremail();
3628     setup_gitattrs();
3629 }
3630
3631 sub check_gitattrs ($$) {
3632     my ($treeish, $what) = @_;
3633
3634     return if is_gitattrs_setup;
3635
3636     local $/="\0";
3637     my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3638     debugcmd "|",@cmd;
3639     my $gafl = new IO::File;
3640     open $gafl, "-|", @cmd or confess "$!";
3641     while (<$gafl>) {
3642         chomp or die;
3643         s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3644         next if $1 == 0;
3645         next unless m{(?:^|/)\.gitattributes$};
3646
3647         # oh dear, found one
3648         print STDERR f_ <<END, $what;
3649 dgit: warning: %s contains .gitattributes
3650 dgit: .gitattributes not (fully) defused.  Recommended: dgit setup-new-tree.
3651 END
3652         close $gafl;
3653         return;
3654     }
3655     # tree contains no .gitattributes files
3656     $?=0; $!=0; close $gafl or failedcmd @cmd;
3657 }
3658
3659
3660 sub multisuite_suite_child ($$$) {
3661     my ($tsuite, $mergeinputs, $fn) = @_;
3662     # in child, sets things up, calls $fn->(), and returns undef
3663     # in parent, returns canonical suite name for $tsuite
3664     my $canonsuitefh = IO::File::new_tmpfile;
3665     my $pid = fork // confess "$!";
3666     if (!$pid) {
3667         forkcheck_setup();
3668         $isuite = $tsuite;
3669         $us .= " [$isuite]";
3670         $debugprefix .= " ";
3671         progress f_ "fetching %s...", $tsuite;
3672         canonicalise_suite();
3673         print $canonsuitefh $csuite, "\n" or confess "$!";
3674         close $canonsuitefh or confess "$!";
3675         $fn->();
3676         return undef;
3677     }
3678     waitpid $pid,0 == $pid or confess "$!";
3679     fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3680         if $? && $?!=256*4;
3681     seek $canonsuitefh,0,0 or confess "$!";
3682     local $csuite = <$canonsuitefh>;
3683     confess "$!" unless defined $csuite && chomp $csuite;
3684     if ($? == 256*4) {
3685         printdebug "multisuite $tsuite missing\n";
3686         return $csuite;
3687     }
3688     printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3689     push @$mergeinputs, {
3690         Ref => lrref,
3691         Info => $csuite,
3692     };
3693     return $csuite;
3694 }
3695
3696 sub fork_for_multisuite ($) {
3697     my ($before_fetch_merge) = @_;
3698     # if nothing unusual, just returns ''
3699     #
3700     # if multisuite:
3701     # returns 0 to caller in child, to do first of the specified suites
3702     # in child, $csuite is not yet set
3703     #
3704     # returns 1 to caller in parent, to finish up anything needed after
3705     # in parent, $csuite is set to canonicalised portmanteau
3706
3707     my $org_isuite = $isuite;
3708     my @suites = split /\,/, $isuite;
3709     return '' unless @suites > 1;
3710     printdebug "fork_for_multisuite: @suites\n";
3711
3712     my @mergeinputs;
3713
3714     my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3715                                             sub { });
3716     return 0 unless defined $cbasesuite;
3717
3718     fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3719         unless @mergeinputs;
3720
3721     my @csuites = ($cbasesuite);
3722
3723     $before_fetch_merge->();
3724
3725     foreach my $tsuite (@suites[1..$#suites]) {
3726         $tsuite =~ s/^-/$cbasesuite-/;
3727         my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3728                                                sub {
3729             @end = ();
3730             fetch_one();
3731             finish 0;
3732         });
3733
3734         $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3735         push @csuites, $csubsuite;
3736     }
3737
3738     foreach my $mi (@mergeinputs) {
3739         my $ref = git_get_ref $mi->{Ref};
3740         die "$mi->{Ref} ?" unless length $ref;
3741         $mi->{Commit} = $ref;
3742     }
3743
3744     $csuite = join ",", @csuites;
3745
3746     my $previous = git_get_ref lrref;
3747     if ($previous) {
3748         unshift @mergeinputs, {
3749             Commit => $previous,
3750             Info => (__ "local combined tracking branch"),
3751             Warning => (__
3752  "archive seems to have rewound: local tracking branch is ahead!"),
3753         };
3754     }
3755
3756     foreach my $ix (0..$#mergeinputs) {
3757         $mergeinputs[$ix]{Index} = $ix;
3758     }
3759
3760     @mergeinputs = sort {
3761         -version_compare(mergeinfo_version $a,
3762                          mergeinfo_version $b) # highest version first
3763             or
3764         $a->{Index} <=> $b->{Index}; # earliest in spec first
3765     } @mergeinputs;
3766
3767     my @needed;
3768
3769   NEEDED:
3770     foreach my $mi (@mergeinputs) {
3771         printdebug "multisuite merge check $mi->{Info}\n";
3772         foreach my $previous (@needed) {
3773             next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3774             printdebug "multisuite merge un-needed $previous->{Info}\n";
3775             next NEEDED;
3776         }
3777         push @needed, $mi;
3778         printdebug "multisuite merge this-needed\n";
3779         $mi->{Character} = '+';
3780     }
3781
3782     $needed[0]{Character} = '*';
3783
3784     my $output = $needed[0]{Commit};
3785
3786     if (@needed > 1) {
3787         printdebug "multisuite merge nontrivial\n";
3788         my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3789
3790         my $commit = "tree $tree\n";
3791         my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3792                      "Input branches:\n",
3793                      $csuite;
3794
3795         foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3796             printdebug "multisuite merge include $mi->{Info}\n";
3797             $mi->{Character} //= ' ';
3798             $commit .= "parent $mi->{Commit}\n";
3799             $msg .= sprintf " %s  %-25s %s\n",
3800                 $mi->{Character},
3801                 (mergeinfo_version $mi),
3802                 $mi->{Info};
3803         }
3804         my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3805         $msg .= __ "\nKey\n".
3806             " * marks the highest version branch, which choose to use\n".
3807             " + marks each branch which was not already an ancestor\n\n";
3808         $msg .=
3809             "[dgit multi-suite $csuite]\n";
3810         $commit .=
3811             "author $authline\n".
3812             "committer $authline\n\n";
3813         $output = hash_commit_text $commit.$msg;
3814         printdebug "multisuite merge generated $output\n";
3815     }
3816
3817     fetch_from_archive_record_1($output);
3818     fetch_from_archive_record_2($output);
3819
3820     progress f_ "calculated combined tracking suite %s", $csuite;
3821
3822     return 1;
3823 }
3824
3825 sub clone_set_head () {
3826     open H, "> .git/HEAD" or confess "$!";
3827     print H "ref: ".lref()."\n" or confess "$!";
3828     close H or confess "$!";
3829 }
3830 sub clone_finish ($) {
3831     my ($dstdir) = @_;
3832     runcmd @git, qw(reset --hard), lrref();
3833     runcmd qw(bash -ec), <<'END';
3834         set -o pipefail
3835         git ls-tree -r --name-only -z HEAD | \
3836         xargs -0r touch -h -r . --
3837 END
3838     printdone f_ "ready for work in %s", $dstdir;
3839 }
3840
3841 sub clone ($) {
3842     # in multisuite, returns twice!
3843     # once in parent after first suite fetched,
3844     # and then again in child after everything is finished
3845     my ($dstdir) = @_;
3846     badusage __ "dry run makes no sense with clone" unless act_local();
3847
3848     my $multi_fetched = fork_for_multisuite(sub {
3849         printdebug "multi clone before fetch merge\n";
3850         changedir $dstdir;
3851         record_maindir();
3852     });
3853     if ($multi_fetched) {
3854         printdebug "multi clone after fetch merge\n";
3855         clone_set_head();
3856         clone_finish($dstdir);
3857         return;
3858     }
3859     printdebug "clone main body\n";
3860
3861     mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3862     changedir $dstdir;
3863     check_bpd_exists();
3864
3865     canonicalise_suite();
3866     my $hasgit = check_for_git();
3867
3868     runcmd @git, qw(init -q);
3869     record_maindir();
3870     setup_new_tree();
3871     clone_set_head();
3872     my $giturl = access_giturl(1);
3873     if (defined $giturl) {
3874         runcmd @git, qw(remote add), 'origin', $giturl;
3875     }
3876     if ($hasgit) {
3877         progress __ "fetching existing git history";
3878         git_fetch_us();
3879         runcmd_ordryrun_local @git, qw(fetch origin);
3880     } else {
3881         progress __ "starting new git history";
3882     }
3883     fetch_from_archive() or no_such_package;
3884     my $vcsgiturl = $dsc->{'Vcs-Git'};
3885     if (length $vcsgiturl) {
3886         $vcsgiturl =~ s/\s+-b\s+\S+//g;
3887         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3888     }
3889     clone_finish($dstdir);
3890 }
3891
3892 sub fetch_one () {
3893     canonicalise_suite();
3894     if (check_for_git()) {
3895         git_fetch_us();
3896     }
3897     fetch_from_archive() or no_such_package();
3898
3899     my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3900     if (length $vcsgiturl and
3901         (grep { $csuite eq $_ }
3902          split /\;/,
3903          cfg 'dgit.vcs-git.suites')) {
3904         my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3905         if (defined $current && $current ne $vcsgiturl) {
3906             print STDERR f_ <<END, $csuite;
3907 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3908  Your vcs-git remote url may be out of date.  Use dgit update-vcs-git ?
3909 END
3910         }
3911     }
3912     printdone f_ "fetched into %s", lrref();
3913 }
3914
3915 sub dofetch () {
3916     my $multi_fetched = fork_for_multisuite(sub { });
3917     fetch_one() unless $multi_fetched; # parent
3918     finish 0 if $multi_fetched eq '0'; # child
3919 }
3920
3921 sub pull () {
3922     dofetch();
3923     runcmd_ordryrun_local @git, qw(merge -m),
3924         (f_ "Merge from %s [dgit]", $csuite),
3925         lrref();
3926     printdone f_ "fetched to %s and merged into HEAD", lrref();
3927 }
3928
3929 sub check_not_dirty () {
3930     my @forbid = qw(local-options local-patch-header);
3931     @forbid = map { "debian/source/$_" } @forbid;
3932     foreach my $f (@forbid) {
3933         if (stat_exists $f) {
3934             fail f_ "git tree contains %s", $f;
3935         }
3936     }
3937
3938     my @cmd = (@git, qw(status -uall --ignored --porcelain));
3939     push @cmd, qw(debian/source/format debian/source/options);
3940     push @cmd, @forbid;
3941
3942     my $bad = cmdoutput @cmd;
3943     if (length $bad) {
3944         fail +(__
3945  "you have uncommitted changes to critical files, cannot continue:\n").
3946               $bad;
3947     }
3948
3949     return if $includedirty;
3950
3951     git_check_unmodified();
3952 }
3953
3954 sub commit_admin ($) {
3955     my ($m) = @_;
3956     progress "$m";
3957     runcmd_ordryrun_local @git, qw(commit -m), $m;
3958 }
3959
3960 sub quiltify_nofix_bail ($$) {
3961     my ($headinfo, $xinfo) = @_;
3962     if ($quilt_mode eq 'nofix') {
3963         fail f_
3964             "quilt fixup required but quilt mode is \`nofix'\n".
3965             "HEAD commit%s differs from tree implied by debian/patches%s",
3966             $headinfo, $xinfo;
3967     }
3968 }
3969
3970 sub commit_quilty_patch () {
3971     my $output = cmdoutput @git, qw(status --ignored --porcelain);
3972     my %adds;
3973     foreach my $l (split /\n/, $output) {
3974         next unless $l =~ m/\S/;
3975         if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3976             $adds{$1}++;
3977         }
3978     }
3979     delete $adds{'.pc'}; # if there wasn't one before, don't add it
3980     if (!%adds) {
3981         progress __ "nothing quilty to commit, ok.";
3982         return;
3983     }
3984     quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3985     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3986     runcmd_ordryrun_local @git, qw(add -f), @adds;
3987     commit_admin +(__ <<ENDT).<<END
3988 Commit Debian 3.0 (quilt) metadata
3989
3990 ENDT
3991 [dgit ($our_version) quilt-fixup]
3992 END
3993 }
3994
3995 sub get_source_format () {
3996     my %options;
3997     if (open F, "debian/source/options") {
3998         while (<F>) {
3999             next if m/^\s*\#/;
4000             next unless m/\S/;
4001             s/\s+$//; # ignore missing final newline
4002             if (m/\s*\#\s*/) {
4003                 my ($k, $v) = ($`, $'); #');
4004                 $v =~ s/^"(.*)"$/$1/;
4005                 $options{$k} = $v;
4006             } else {
4007                 $options{$_} = 1;
4008             }
4009         }
4010         F->error and confess "$!";
4011         close F;
4012     } else {
4013         confess "$!" unless $!==&ENOENT;
4014     }
4015
4016     if (!open F, "debian/source/format") {
4017         confess "$!" unless $!==&ENOENT;
4018         return '';
4019     }
4020     $_ = <F>;
4021     F->error and confess "$!";
4022     chomp;
4023     return ($_, \%options);
4024 }
4025
4026 sub madformat_wantfixup ($) {
4027     my ($format) = @_;
4028     return 0 unless $format eq '3.0 (quilt)';
4029     our $quilt_mode_warned;
4030     if ($quilt_mode eq 'nocheck') {
4031         progress f_ "Not doing any fixup of \`%s'".
4032             " due to ----no-quilt-fixup or --quilt=nocheck", $format
4033             unless $quilt_mode_warned++;
4034         return 0;
4035     }
4036     progress f_ "Format \`%s', need to check/update patch stack", $format
4037         unless $quilt_mode_warned++;
4038     return 1;
4039 }
4040
4041 sub maybe_split_brain_save ($$$) {
4042     my ($headref, $dgitview, $msg) = @_;
4043     # => message fragment "$saved" describing disposition of $dgitview
4044     #    (used inside parens, in the English texts)
4045     my $save = $internal_object_save{'dgit-view'};
4046     return f_ "commit id %s", $dgitview unless defined $save;
4047     my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4048                git_update_ref_cmd
4049                "dgit --dgit-view-save $msg HEAD=$headref",
4050                $save, $dgitview);
4051     runcmd @cmd;
4052     return f_ "and left in %s", $save;
4053 }
4054
4055 # An "infopair" is a tuple [ $thing, $what ]
4056 # (often $thing is a commit hash; $what is a description)
4057
4058 sub infopair_cond_equal ($$) {
4059     my ($x,$y) = @_;
4060     $x->[0] eq $y->[0] or fail <<END;
4061 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4062 END
4063 };
4064
4065 sub infopair_lrf_tag_lookup ($$) {
4066     my ($tagnames, $what) = @_;
4067     # $tagname may be an array ref
4068     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4069     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4070     foreach my $tagname (@tagnames) {
4071         my $lrefname = lrfetchrefs."/tags/$tagname";
4072         my $tagobj = $lrfetchrefs_f{$lrefname};
4073         next unless defined $tagobj;
4074         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4075         return [ git_rev_parse($tagobj), $what ];
4076     }
4077     fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4078 Wanted tag %s (%s) on dgit server, but not found
4079 END
4080                       : (f_ <<END, $what, "@tagnames");
4081 Wanted tag %s (one of: %s) on dgit server, but not found
4082 END
4083 }
4084
4085 sub infopair_cond_ff ($$) {
4086     my ($anc,$desc) = @_;
4087     is_fast_fwd($anc->[0], $desc->[0]) or
4088         fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4089 %s (%s) .. %s (%s) is not fast forward
4090 END
4091 };
4092
4093 sub pseudomerge_version_check ($$) {
4094     my ($clogp, $archive_hash) = @_;
4095
4096     my $arch_clogp = commit_getclogp $archive_hash;
4097     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4098                      __ 'version currently in archive' ];
4099     if (defined $overwrite_version) {
4100         if (length $overwrite_version) {
4101             infopair_cond_equal([ $overwrite_version,
4102                                   '--overwrite= version' ],
4103                                 $i_arch_v);
4104         } else {
4105             my $v = $i_arch_v->[0];
4106             progress f_
4107                 "Checking package changelog for archive version %s ...", $v;
4108             my $cd;
4109             eval {
4110                 my @xa = ("-f$v", "-t$v");
4111                 my $vclogp = parsechangelog @xa;
4112                 my $gf = sub {
4113                     my ($fn) = @_;
4114                     [ (getfield $vclogp, $fn),
4115                       (f_ "%s field from dpkg-parsechangelog %s",
4116                           $fn, "@xa") ];
4117                 };
4118                 my $cv = $gf->('Version');
4119                 infopair_cond_equal($i_arch_v, $cv);
4120                 $cd = $gf->('Distribution');
4121             };
4122             if ($@) {
4123                 $@ =~ s/^\n//s;
4124                 $@ =~ s/^dgit: //gm;
4125                 fail "$@".
4126                     f_ "Perhaps debian/changelog does not mention %s ?", $v;
4127             }
4128             fail f_ <<END, $cd->[1], $cd->[0], $v
4129 %s is %s
4130 Your tree seems to based on earlier (not uploaded) %s.
4131 END
4132                 if $cd->[0] =~ m/UNRELEASED/;
4133         }
4134     }
4135
4136     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4137     return $i_arch_v;
4138 }
4139
4140 sub pseudomerge_hash_commit ($$$$ $$) {
4141     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4142         $msg_cmd, $msg_msg) = @_;
4143     progress f_ "Declaring that HEAD includes all changes in %s...",
4144                  $i_arch_v->[0];
4145
4146     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4147     my $authline = clogp_authline $clogp;
4148
4149     chomp $msg_msg;
4150     $msg_cmd .=
4151         !defined $overwrite_version ? ""
4152         : !length  $overwrite_version ? " --overwrite"
4153         : " --overwrite=".$overwrite_version;
4154
4155     # Contributing parent is the first parent - that makes
4156     # git rev-list --first-parent DTRT.
4157     my $pmf = dgit_privdir()."/pseudomerge";
4158     open MC, ">", $pmf or die "$pmf $!";
4159     print MC <<END or confess "$!";
4160 tree $tree
4161 parent $dgitview
4162 parent $archive_hash
4163 author $authline
4164 committer $authline
4165
4166 $msg_msg
4167
4168 [$msg_cmd]
4169 END
4170     close MC or confess "$!";
4171
4172     return hash_commit($pmf);
4173 }
4174
4175 sub splitbrain_pseudomerge ($$$$) {
4176     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4177     # => $merged_dgitview
4178     printdebug "splitbrain_pseudomerge...\n";
4179     #
4180     #     We:      debian/PREVIOUS    HEAD($maintview)
4181     # expect:          o ----------------- o
4182     #                    \                   \
4183     #                     o                   o
4184     #                 a/d/PREVIOUS        $dgitview
4185     #                $archive_hash              \
4186     #  If so,                \                   \
4187     #  we do:                 `------------------ o
4188     #   this:                                   $dgitview'
4189     #
4190
4191     return $dgitview unless defined $archive_hash;
4192     return $dgitview if deliberately_not_fast_forward();
4193
4194     printdebug "splitbrain_pseudomerge...\n";
4195
4196     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4197
4198     if (!defined $overwrite_version) {
4199         progress __ "Checking that HEAD includes all changes in archive...";
4200     }
4201
4202     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4203
4204     if (defined $overwrite_version) {
4205     } elsif (!eval {
4206         my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4207         my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4208                                               __ "maintainer view tag");
4209         my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4210         my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4211         my $i_archive = [ $archive_hash, __ "current archive contents" ];
4212
4213         printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4214
4215         infopair_cond_equal($i_dgit, $i_archive);
4216         infopair_cond_ff($i_dep14, $i_dgit);
4217         infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4218         1;
4219     }) {
4220         $@ =~ s/^\n//; chomp $@;
4221         print STDERR <<END.(__ <<ENDT);
4222 $@
4223 END
4224 | Not fast forward; maybe --overwrite is needed ?  Please see dgit(1).
4225 ENDT
4226         finish -1;
4227     }
4228
4229     my $arch_v = $i_arch_v->[0];
4230     my $r = pseudomerge_hash_commit
4231         $clogp, $dgitview, $archive_hash, $i_arch_v,
4232         "dgit --quilt=$quilt_mode",
4233         (defined $overwrite_version
4234          ? f_ "Declare fast forward from %s\n", $arch_v
4235          : f_ "Make fast forward from %s\n",    $arch_v);
4236
4237     maybe_split_brain_save $maintview, $r, "pseudomerge";
4238
4239     progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4240     return $r;
4241 }
4242
4243 sub plain_overwrite_pseudomerge ($$$) {
4244     my ($clogp, $head, $archive_hash) = @_;
4245
4246     printdebug "plain_overwrite_pseudomerge...";
4247
4248     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4249
4250     return $head if is_fast_fwd $archive_hash, $head;
4251
4252     my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4253
4254     my $r = pseudomerge_hash_commit
4255         $clogp, $head, $archive_hash, $i_arch_v,
4256         "dgit", $m;
4257
4258     runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4259
4260     progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4261     return $r;
4262 }
4263
4264 sub push_parse_changelog ($) {
4265     my ($clogpfn) = @_;
4266
4267     my $clogp = Dpkg::Control::Hash->new();
4268     $clogp->load($clogpfn) or die;
4269
4270     my $clogpackage = getfield $clogp, 'Source';
4271     $package //= $clogpackage;
4272     fail f_ "-p specified %s but changelog specified %s",
4273             $package, $clogpackage
4274         unless $package eq $clogpackage;
4275     my $cversion = getfield $clogp, 'Version';
4276
4277     if (!$we_are_initiator) {
4278         # rpush initiator can't do this because it doesn't have $isuite yet
4279         my $tag = debiantag_new($cversion, access_nomdistro);
4280         runcmd @git, qw(check-ref-format), $tag;
4281     }
4282
4283     my $dscfn = dscfn($cversion);
4284
4285     return ($clogp, $cversion, $dscfn);
4286 }
4287
4288 sub push_parse_dsc ($$$) {
4289     my ($dscfn,$dscfnwhat, $cversion) = @_;
4290     $dsc = parsecontrol($dscfn,$dscfnwhat);
4291     my $dversion = getfield $dsc, 'Version';
4292     my $dscpackage = getfield $dsc, 'Source';
4293     ($dscpackage eq $package && $dversion eq $cversion) or
4294         fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4295                 $dscfn, $dscpackage, $dversion,
4296                         $package,    $cversion;
4297 }
4298
4299 sub push_tagwants ($$$$) {
4300     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4301     my @tagwants;
4302     push @tagwants, {
4303         TagFn => \&debiantag_new,
4304         Objid => $dgithead,
4305         TfSuffix => '',
4306         View => 'dgit',
4307     };
4308     if (defined $maintviewhead) {
4309         push @tagwants, {
4310             TagFn => \&debiantag_maintview,
4311             Objid => $maintviewhead,
4312             TfSuffix => '-maintview',
4313             View => 'maint',
4314         };
4315     } elsif ($dodep14tag ne 'no') {
4316         push @tagwants, {
4317             TagFn => \&debiantag_maintview,
4318             Objid => $dgithead,
4319             TfSuffix => '-dgit',
4320             View => 'dgit',
4321         };
4322     };
4323     foreach my $tw (@tagwants) {
4324         $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4325         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4326     }
4327     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4328     return @tagwants;
4329 }
4330
4331 sub push_mktags ($$ $$ $) {
4332     my ($clogp,$dscfn,
4333         $changesfile,$changesfilewhat,
4334         $tagwants) = @_;
4335
4336     die unless $tagwants->[0]{View} eq 'dgit';
4337
4338     my $declaredistro = access_nomdistro();
4339     my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4340     $dsc->{$ourdscfield[0]} = join " ",
4341         $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4342         $reader_giturl;
4343     $dsc->save("$dscfn.tmp") or confess "$!";
4344
4345     my $changes = parsecontrol($changesfile,$changesfilewhat);
4346     foreach my $field (qw(Source Distribution Version)) {
4347         $changes->{$field} eq $clogp->{$field} or
4348             fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4349                     $field, $changes->{$field}, $clogp->{$field};
4350     }
4351
4352     my $cversion = getfield $clogp, 'Version';
4353     my $clogsuite = getfield $clogp, 'Distribution';
4354
4355     # We make the git tag by hand because (a) that makes it easier
4356     # to control the "tagger" (b) we can do remote signing
4357     my $authline = clogp_authline $clogp;
4358     my $delibs = join(" ", "",@deliberatelies);
4359
4360     my $mktag = sub {
4361         my ($tw) = @_;
4362         my $tfn = $tw->{Tfn};
4363         my $head = $tw->{Objid};
4364         my $tag = $tw->{Tag};
4365
4366         open TO, '>', $tfn->('.tmp') or confess "$!";
4367         print TO <<END or confess "$!";
4368 object $head
4369 type commit
4370 tag $tag
4371 tagger $authline
4372
4373 END
4374         if ($tw->{View} eq 'dgit') {
4375             print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4376 %s release %s for %s (%s) [dgit]
4377 ENDT
4378                 or confess "$!";
4379             print TO <<END or confess "$!";
4380 [dgit distro=$declaredistro$delibs]
4381 END
4382             foreach my $ref (sort keys %previously) {
4383                 print TO <<END or confess "$!";
4384 [dgit previously:$ref=$previously{$ref}]
4385 END
4386             }
4387         } elsif ($tw->{View} eq 'maint') {
4388             print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4389 %s release %s for %s (%s)
4390 (maintainer view tag generated by dgit --quilt=%s)
4391 END
4392                 $quilt_mode
4393                 or confess "$!";
4394         } else {
4395             confess Dumper($tw)."?";
4396         }
4397
4398         close TO or confess "$!";
4399
4400         my $tagobjfn = $tfn->('.tmp');
4401         if ($sign) {
4402             if (!defined $keyid) {
4403                 $keyid = access_cfg('keyid','RETURN-UNDEF');
4404             }
4405             if (!defined $keyid) {
4406                 $keyid = getfield $clogp, 'Maintainer';
4407             }
4408             unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4409             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4410             push @sign_cmd, qw(-u),$keyid if defined $keyid;
4411             push @sign_cmd, $tfn->('.tmp');
4412             runcmd_ordryrun @sign_cmd;
4413             if (act_scary()) {
4414                 $tagobjfn = $tfn->('.signed.tmp');
4415                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4416                     $tfn->('.tmp'), $tfn->('.tmp.asc');
4417             }
4418         }
4419         return $tagobjfn;
4420     };
4421
4422     my @r = map { $mktag->($_); } @$tagwants;
4423     return @r;
4424 }
4425
4426 sub sign_changes ($) {
4427     my ($changesfile) = @_;
4428     if ($sign) {
4429         my @debsign_cmd = @debsign;
4430         push @debsign_cmd, "-k$keyid" if defined $keyid;
4431         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4432         push @debsign_cmd, $changesfile;
4433         runcmd_ordryrun @debsign_cmd;
4434     }
4435 }
4436
4437 sub dopush () {
4438     printdebug "actually entering push\n";
4439
4440     supplementary_message(__ <<'END');
4441 Push failed, while checking state of the archive.
4442 You can retry the push, after fixing the problem, if you like.
4443 END
4444     if (check_for_git()) {
4445         git_fetch_us();
4446     }
4447     my $archive_hash = fetch_from_archive();
4448     if (!$archive_hash) {
4449         $new_package or
4450             fail __ "package appears to be new in this suite;".
4451                     " if this is intentional, use --new";
4452     }
4453
4454     supplementary_message(__ <<'END');
4455 Push failed, while preparing your push.
4456 You can retry the push, after fixing the problem, if you like.
4457 END
4458
4459     prep_ud();
4460
4461     access_giturl(); # check that success is vaguely likely
4462     rpush_handle_protovsn_bothends() if $we_are_initiator;
4463
4464     my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4465     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4466
4467     responder_send_file('parsed-changelog', $clogpfn);
4468
4469     my ($clogp, $cversion, $dscfn) =
4470         push_parse_changelog("$clogpfn");
4471
4472     my $dscpath = "$buildproductsdir/$dscfn";
4473     stat_exists $dscpath or
4474         fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4475                 $dscpath, $!;
4476
4477     responder_send_file('dsc', $dscpath);
4478
4479     push_parse_dsc($dscpath, $dscfn, $cversion);
4480
4481     my $format = getfield $dsc, 'Format';
4482
4483     my $symref = git_get_symref();
4484     my $actualhead = git_rev_parse('HEAD');
4485
4486     if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4487         if (quiltmode_splitting()) {
4488             my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4489             fail f_ <<END, $ffq_prev, $quilt_mode;
4490 Branch is managed by git-debrebase (%s
4491 exists), but quilt mode (%s) implies a split view.
4492 Pass the right --quilt option or adjust your git config.
4493 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4494 END
4495         }
4496         runcmd_ordryrun_local @git_debrebase, 'stitch';
4497         $actualhead = git_rev_parse('HEAD');
4498     }
4499
4500     my $dgithead = $actualhead;
4501     my $maintviewhead = undef;
4502
4503     my $upstreamversion = upstreamversion $clogp->{Version};
4504
4505     if (madformat_wantfixup($format)) {
4506         # user might have not used dgit build, so maybe do this now:
4507         if (do_split_brain()) {
4508             changedir $playground;
4509             my $cachekey;
4510             ($dgithead, $cachekey) =
4511                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4512             $dgithead or fail f_
4513  "--quilt=%s but no cached dgit view:
4514  perhaps HEAD changed since dgit build[-source] ?",
4515                               $quilt_mode;
4516         }
4517         if (!do_split_brain()) {
4518             # In split brain mode, do not attempt to incorporate dirty
4519             # stuff from the user's working tree.  That would be mad.
4520             commit_quilty_patch();
4521         }
4522     }
4523     if (do_split_brain()) {
4524         $made_split_brain = 1;
4525         $dgithead = splitbrain_pseudomerge($clogp,
4526                                            $actualhead, $dgithead,
4527                                            $archive_hash);
4528         $maintviewhead = $actualhead;
4529         changedir $maindir;
4530         prep_ud(); # so _only_subdir() works, below
4531     }
4532
4533     if (defined $overwrite_version && !defined $maintviewhead
4534         && $archive_hash) {
4535         $dgithead = plain_overwrite_pseudomerge($clogp,
4536                                                 $dgithead,
4537                                                 $archive_hash);
4538     }
4539
4540     check_not_dirty();
4541
4542     my $forceflag = '';
4543     if ($archive_hash) {
4544         if (is_fast_fwd($archive_hash, $dgithead)) {
4545             # ok
4546         } elsif (deliberately_not_fast_forward) {
4547             $forceflag = '+';
4548         } else {
4549             fail __ "dgit push: HEAD is not a descendant".
4550                 " of the archive's version.\n".
4551                 "To overwrite the archive's contents,".
4552                 " pass --overwrite[=VERSION].\n".
4553                 "To rewind history, if permitted by the archive,".
4554                 " use --deliberately-not-fast-forward.";
4555         }
4556     }
4557
4558     confess unless !!$made_split_brain == do_split_brain();
4559
4560     changedir $playground;
4561     progress f_ "checking that %s corresponds to HEAD", $dscfn;
4562     runcmd qw(dpkg-source -x --),
4563         $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4564     my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4565     check_for_vendor_patches() if madformat($dsc->{format});
4566     changedir $maindir;
4567     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4568     debugcmd "+",@diffcmd;
4569     $!=0; $?=-1;
4570     my $r = system @diffcmd;
4571     if ($r) {
4572         if ($r==256) {
4573             my $referent = $made_split_brain ? $dgithead : 'HEAD';
4574             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4575
4576             my @mode_changes;
4577             my $raw = cmdoutput @git,
4578                 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4579             my $changed;
4580             foreach (split /\0/, $raw) {
4581                 if (defined $changed) {
4582                     push @mode_changes, "$changed: $_\n" if $changed;
4583                     $changed = undef;
4584                     next;
4585                 } elsif (m/^:0+ 0+ /) {
4586                     $changed = '';
4587                 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4588                     $changed = "Mode change from $1 to $2"
4589                 } else {
4590                     die "$_ ?";
4591                 }
4592             }
4593             if (@mode_changes) {
4594                 fail +(f_ <<ENDT, $dscfn).<<END
4595 HEAD specifies a different tree to %s:
4596 ENDT
4597 $diffs
4598 END
4599                     .(join '', @mode_changes)
4600                     .(f_ <<ENDT, $tree, $referent);
4601 There is a problem with your source tree (see dgit(7) for some hints).
4602 To see a full diff, run git diff %s %s
4603 ENDT
4604             }
4605
4606             fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4607 HEAD specifies a different tree to %s:
4608 ENDT
4609 $diffs
4610 END
4611 Perhaps you forgot to build.  Or perhaps there is a problem with your
4612  source tree (see dgit(7) for some hints).  To see a full diff, run
4613    git diff %s %s
4614 ENDT
4615         } else {
4616             failedcmd @diffcmd;
4617         }
4618     }
4619     if (!$changesfile) {
4620         my $pat = changespat $cversion;
4621         my @cs = glob "$buildproductsdir/$pat";
4622         fail f_ "failed to find unique changes file".
4623                 " (looked for %s in %s);".
4624                 " perhaps you need to use dgit -C",
4625                 $pat, $buildproductsdir
4626             unless @cs==1;
4627         ($changesfile) = @cs;
4628     } else {
4629         $changesfile = "$buildproductsdir/$changesfile";
4630     }
4631
4632     # Check that changes and .dsc agree enough
4633     $changesfile =~ m{[^/]*$};
4634     my $changes = parsecontrol($changesfile,$&);
4635     files_compare_inputs($dsc, $changes)
4636         unless forceing [qw(dsc-changes-mismatch)];
4637
4638     # Check whether this is a source only upload
4639     my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4640     my $sourceonlypolicy = access_cfg 'source-only-uploads';
4641     if ($sourceonlypolicy eq 'ok') {
4642     } elsif ($sourceonlypolicy eq 'always') {
4643         forceable_fail [qw(uploading-binaries)],
4644             __ "uploading binaries, although distro policy is source only"
4645             if $hasdebs;
4646     } elsif ($sourceonlypolicy eq 'never') {
4647         forceable_fail [qw(uploading-source-only)],
4648             __ "source-only upload, although distro policy requires .debs"
4649             if !$hasdebs;
4650     } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4651         forceable_fail [qw(uploading-source-only)],
4652             f_ "source-only upload, even though package is entirely NEW\n".
4653                "(this is contrary to policy in %s)",
4654                access_nomdistro()
4655             if !$hasdebs
4656             && $new_package
4657             && !(archive_query('package_not_wholly_new', $package) // 1);
4658     } else {
4659         badcfg f_ "unknown source-only-uploads policy \`%s'",
4660                   $sourceonlypolicy;
4661     }
4662
4663     # Perhaps adjust .dsc to contain right set of origs
4664     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4665                                   $changesfile)
4666         unless forceing [qw(changes-origs-exactly)];
4667
4668     # Checks complete, we're going to try and go ahead:
4669
4670     responder_send_file('changes',$changesfile);
4671     responder_send_command("param head $dgithead");
4672     responder_send_command("param csuite $csuite");
4673     responder_send_command("param isuite $isuite");
4674     responder_send_command("param tagformat new"); # needed in $protovsn==4
4675     if (defined $maintviewhead) {
4676         responder_send_command("param maint-view $maintviewhead");
4677     }
4678
4679     # Perhaps send buildinfo(s) for signing
4680     my $changes_files = getfield $changes, 'Files';
4681     my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4682     foreach my $bi (@buildinfos) {
4683         responder_send_command("param buildinfo-filename $bi");
4684         responder_send_file('buildinfo', "$buildproductsdir/$bi");
4685     }
4686
4687     if (deliberately_not_fast_forward) {
4688         git_for_each_ref(lrfetchrefs, sub {
4689             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4690             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4691             responder_send_command("previously $rrefname=$objid");
4692             $previously{$rrefname} = $objid;
4693         });
4694     }
4695
4696     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4697                                  dgit_privdir()."/tag");
4698     my @tagobjfns;
4699
4700     supplementary_message(__ <<'END');
4701 Push failed, while signing the tag.
4702 You can retry the push, after fixing the problem, if you like.
4703 END
4704     # If we manage to sign but fail to record it anywhere, it's fine.
4705     if ($we_are_responder) {
4706         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4707         responder_receive_files('signed-tag', @tagobjfns);
4708     } else {
4709         @tagobjfns = push_mktags($clogp,$dscpath,
4710                               $changesfile,$changesfile,
4711                               \@tagwants);
4712     }
4713     supplementary_message(__ <<'END');
4714 Push failed, *after* signing the tag.
4715 If you want to try again, you should use a new version number.
4716 END
4717
4718     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4719
4720     foreach my $tw (@tagwants) {
4721         my $tag = $tw->{Tag};
4722         my $tagobjfn = $tw->{TagObjFn};
4723         my $tag_obj_hash =
4724             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4725         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4726         runcmd_ordryrun_local
4727             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4728     }
4729
4730     supplementary_message(__ <<'END');
4731 Push failed, while updating the remote git repository - see messages above.
4732 If you want to try again, you should use a new version number.
4733 END
4734     if (!check_for_git()) {
4735         create_remote_git_repo();
4736     }
4737
4738     my @pushrefs = $forceflag.$dgithead.":".rrref();
4739     foreach my $tw (@tagwants) {
4740         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4741     }
4742
4743     runcmd_ordryrun @git,
4744         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4745     runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4746
4747     supplementary_message(__ <<'END');
4748 Push failed, while obtaining signatures on the .changes and .dsc.
4749 If it was just that the signature failed, you may try again by using
4750 debsign by hand to sign the changes file (see the command dgit tried,
4751 above), and then dput that changes file to complete the upload.
4752 If you need to change the package, you must use a new version number.
4753 END
4754     if ($we_are_responder) {
4755         my $dryrunsuffix = act_local() ? "" : ".tmp";
4756         my @rfiles = ($dscpath, $changesfile);
4757         push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4758         responder_receive_files('signed-dsc-changes',
4759                                 map { "$_$dryrunsuffix" } @rfiles);
4760     } else {
4761         if (act_local()) {
4762             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4763         } else {
4764             progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4765         }
4766         sign_changes $changesfile;
4767     }
4768
4769     supplementary_message(f_ <<END, $changesfile);
4770 Push failed, while uploading package(s) to the archive server.
4771 You can retry the upload of exactly these same files with dput of:
4772   %s
4773 If that .changes file is broken, you will need to use a new version
4774 number for your next attempt at the upload.
4775 END
4776     my $host = access_cfg('upload-host','RETURN-UNDEF');
4777     my @hostarg = defined($host) ? ($host,) : ();
4778     runcmd_ordryrun @dput, @hostarg, $changesfile;
4779     printdone f_ "pushed and uploaded %s", $cversion;
4780
4781     supplementary_message('');
4782     responder_send_command("complete");
4783 }
4784
4785 sub pre_clone () {
4786     not_necessarily_a_tree();
4787 }
4788 sub cmd_clone {
4789     parseopts();
4790     my $dstdir;
4791     badusage __ "-p is not allowed with clone; specify as argument instead"
4792         if defined $package;
4793     if (@ARGV==1) {
4794         ($package) = @ARGV;
4795     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4796         ($package,$isuite) = @ARGV;
4797     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4798         ($package,$dstdir) = @ARGV;
4799     } elsif (@ARGV==3) {
4800         ($package,$isuite,$dstdir) = @ARGV;
4801     } else {
4802         badusage __ "incorrect arguments to dgit clone";
4803     }
4804     notpushing();
4805
4806     $dstdir ||= "$package";
4807     if (stat_exists $dstdir) {
4808         fail f_ "%s already exists", $dstdir;
4809     }
4810
4811     my $cwd_remove;
4812     if ($rmonerror && !$dryrun_level) {
4813         $cwd_remove= getcwd();
4814         unshift @end, sub {
4815             return unless defined $cwd_remove;
4816             if (!chdir "$cwd_remove") {
4817                 return if $!==&ENOENT;
4818                 confess "chdir $cwd_remove: $!";
4819             }
4820             printdebug "clone rmonerror removing $dstdir\n";
4821             if (stat $dstdir) {
4822                 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4823             } elsif (grep { $! == $_ }
4824                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4825             } else {
4826                 print STDERR f_ "check whether to remove %s: %s\n",
4827                                 $dstdir, $!;
4828             }
4829         };
4830     }
4831
4832     clone($dstdir);
4833     $cwd_remove = undef;
4834 }
4835
4836 sub branchsuite () {
4837     my $branch = git_get_symref();
4838     if (defined $branch && $branch =~ m#$lbranch_re#o) {
4839         return $1;
4840     } else {
4841         return undef;
4842     }
4843 }
4844
4845 sub package_from_d_control () {
4846     if (!defined $package) {
4847         my $sourcep = parsecontrol('debian/control','debian/control');
4848         $package = getfield $sourcep, 'Source';
4849     }
4850 }
4851
4852 sub fetchpullargs () {
4853     package_from_d_control();
4854     if (@ARGV==0) {
4855         $isuite = branchsuite();
4856         if (!$isuite) {
4857             my $clogp = parsechangelog();
4858             my $clogsuite = getfield $clogp, 'Distribution';
4859             $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4860         }
4861     } elsif (@ARGV==1) {
4862         ($isuite) = @ARGV;
4863     } else {
4864         badusage __ "incorrect arguments to dgit fetch or dgit pull";
4865     }
4866     notpushing();
4867 }
4868
4869 sub cmd_fetch {
4870     parseopts();
4871     fetchpullargs();
4872     dofetch();
4873 }
4874
4875 sub cmd_pull {
4876     parseopts();
4877     fetchpullargs();
4878     determine_whether_split_brain();
4879     if (do_split_brain()) {
4880         my ($format, $fopts) = get_source_format();
4881         madformat($format) and fail f_ <<END, $quilt_mode
4882 dgit pull not yet supported in split view mode (including with view-splitting quilt modes)
4883 END
4884     }
4885     pull();
4886 }
4887
4888 sub cmd_checkout {
4889     parseopts();
4890     package_from_d_control();
4891     @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4892     ($isuite) = @ARGV;
4893     notpushing();
4894
4895     foreach my $canon (qw(0 1)) {
4896         if (!$canon) {
4897             $csuite= $isuite;
4898         } else {
4899             undef $csuite;
4900             canonicalise_suite();
4901         }
4902         if (length git_get_ref lref()) {
4903             # local branch already exists, yay
4904             last;
4905         }
4906         if (!length git_get_ref lrref()) {
4907             if (!$canon) {
4908                 # nope
4909                 next;
4910             }
4911             dofetch();
4912         }
4913         # now lrref exists
4914         runcmd (@git, qw(update-ref), lref(), lrref(), '');
4915         last;
4916     }
4917     local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4918         "dgit checkout $isuite";
4919     runcmd (@git, qw(checkout), lbranch());
4920 }
4921
4922 sub cmd_update_vcs_git () {
4923     my $specsuite;
4924     if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4925         ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4926     } else {
4927         ($specsuite) = (@ARGV);
4928         shift @ARGV;
4929     }
4930     my $dofetch=1;
4931     if (@ARGV) {
4932         if ($ARGV[0] eq '-') {
4933             $dofetch = 0;
4934         } elsif ($ARGV[0] eq '-') {
4935             shift;
4936         }
4937     }
4938
4939     package_from_d_control();
4940     my $ctrl;
4941     if ($specsuite eq '.') {
4942         $ctrl = parsecontrol 'debian/control', 'debian/control';
4943     } else {
4944         $isuite = $specsuite;
4945         get_archive_dsc();
4946         $ctrl = $dsc;
4947     }
4948     my $url = getfield $ctrl, 'Vcs-Git';
4949
4950     my @cmd;
4951     my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4952     if (!defined $orgurl) {
4953         print STDERR f_ "setting up vcs-git: %s\n", $url;
4954         @cmd = (@git, qw(remote add vcs-git), $url);
4955     } elsif ($orgurl eq $url) {
4956         print STDERR f_ "vcs git already configured: %s\n", $url;
4957     } else {
4958         print STDERR f_ "changing vcs-git url to: %s\n", $url;
4959         @cmd = (@git, qw(remote set-url vcs-git), $url);
4960     }
4961     runcmd_ordryrun_local @cmd;
4962     if ($dofetch) {
4963         print f_ "fetching (%s)\n", "@ARGV";
4964         runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4965     }
4966 }
4967
4968 sub prep_push () {
4969     parseopts();
4970     build_or_push_prep_early();
4971     pushing();
4972     build_or_push_prep_modes();
4973     check_not_dirty();
4974     my $specsuite;
4975     if (@ARGV==0) {
4976     } elsif (@ARGV==1) {
4977         ($specsuite) = (@ARGV);
4978     } else {
4979         badusage f_ "incorrect arguments to dgit %s", $subcommand;
4980     }
4981     if ($new_package) {
4982         local ($package) = $existing_package; # this is a hack
4983         canonicalise_suite();
4984     } else {
4985         canonicalise_suite();
4986     }
4987     if (defined $specsuite &&
4988         $specsuite ne $isuite &&
4989         $specsuite ne $csuite) {
4990             fail f_ "dgit %s: changelog specifies %s (%s)".
4991                     " but command line specifies %s",
4992                     $subcommand, $isuite, $csuite, $specsuite;
4993     }
4994 }
4995
4996 sub cmd_push {
4997     prep_push();
4998     dopush();
4999 }
5000
5001 #---------- remote commands' implementation ----------
5002
5003 sub pre_remote_push_build_host {
5004     my ($nrargs) = shift @ARGV;
5005     my (@rargs) = @ARGV[0..$nrargs-1];
5006     @ARGV = @ARGV[$nrargs..$#ARGV];
5007     die unless @rargs;
5008     my ($dir,$vsnwant) = @rargs;
5009     # vsnwant is a comma-separated list; we report which we have
5010     # chosen in our ready response (so other end can tell if they
5011     # offered several)
5012     $debugprefix = ' ';
5013     $we_are_responder = 1;
5014     $us .= " (build host)";
5015
5016     open PI, "<&STDIN" or confess "$!";
5017     open STDIN, "/dev/null" or confess "$!";
5018     open PO, ">&STDOUT" or confess "$!";
5019     autoflush PO 1;
5020     open STDOUT, ">&STDERR" or confess "$!";
5021     autoflush STDOUT 1;
5022
5023     $vsnwant //= 1;
5024     ($protovsn) = grep {
5025         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
5026     } @rpushprotovsn_support;
5027
5028     fail f_ "build host has dgit rpush protocol versions %s".
5029             " but invocation host has %s",
5030             (join ",", @rpushprotovsn_support), $vsnwant
5031         unless defined $protovsn;
5032
5033     changedir $dir;
5034 }
5035 sub cmd_remote_push_build_host {
5036     responder_send_command("dgit-remote-push-ready $protovsn");
5037     &cmd_push;
5038 }
5039
5040 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5041 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5042 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5043 #     a good error message)
5044
5045 sub rpush_handle_protovsn_bothends () {
5046 }
5047
5048 our $i_tmp;
5049
5050 sub i_cleanup {
5051     local ($@, $?);
5052     my $report = i_child_report();
5053     if (defined $report) {
5054         printdebug "($report)\n";
5055     } elsif ($i_child_pid) {
5056         printdebug "(killing build host child $i_child_pid)\n";
5057         kill 15, $i_child_pid;
5058     }
5059     if (defined $i_tmp && !defined $initiator_tempdir) {
5060         changedir "/";
5061         eval { rmtree $i_tmp; };
5062     }
5063 }
5064
5065 END {
5066     return unless forkcheck_mainprocess();
5067     i_cleanup();
5068 }
5069
5070 sub i_method {
5071     my ($base,$selector,@args) = @_;
5072     $selector =~ s/\-/_/g;
5073     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5074 }
5075
5076 sub pre_rpush () {
5077     not_necessarily_a_tree();
5078 }
5079 sub cmd_rpush {
5080     my $host = nextarg;
5081     my $dir;
5082     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5083         $host = $1;
5084         $dir = $'; #';
5085     } else {
5086         $dir = nextarg;
5087     }
5088     $dir =~ s{^-}{./-};
5089     my @rargs = ($dir);
5090     push @rargs, join ",", @rpushprotovsn_support;
5091     my @rdgit;
5092     push @rdgit, @dgit;
5093     push @rdgit, @ropts;
5094     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5095     push @rdgit, @ARGV;
5096     my @cmd = (@ssh, $host, shellquote @rdgit);
5097     debugcmd "+",@cmd;
5098
5099     $we_are_initiator=1;
5100
5101     if (defined $initiator_tempdir) {
5102         rmtree $initiator_tempdir;
5103         mkdir $initiator_tempdir, 0700
5104             or fail f_ "create %s: %s", $initiator_tempdir, $!;
5105         $i_tmp = $initiator_tempdir;
5106     } else {
5107         $i_tmp = tempdir();
5108     }
5109     $i_child_pid = open2(\*RO, \*RI, @cmd);
5110     changedir $i_tmp;
5111     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5112     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5113
5114     for (;;) {
5115         my ($icmd,$iargs) = initiator_expect {
5116             m/^(\S+)(?: (.*))?$/;
5117             ($1,$2);
5118         };
5119         i_method "i_resp", $icmd, $iargs;
5120     }
5121 }
5122
5123 sub i_resp_progress ($) {
5124     my ($rhs) = @_;
5125     my $msg = protocol_read_bytes \*RO, $rhs;
5126     progress $msg;
5127 }
5128
5129 sub i_resp_supplementary_message ($) {
5130     my ($rhs) = @_;
5131     $supplementary_message = protocol_read_bytes \*RO, $rhs;
5132 }
5133
5134 sub i_resp_complete {
5135     my $pid = $i_child_pid;
5136     $i_child_pid = undef; # prevents killing some other process with same pid
5137     printdebug "waiting for build host child $pid...\n";
5138     my $got = waitpid $pid, 0;
5139     confess "$!" unless $got == $pid;
5140     fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5141
5142     i_cleanup();
5143     printdebug __ "all done\n";
5144     finish 0;
5145 }
5146
5147 sub i_resp_file ($) {
5148     my ($keyword) = @_;
5149     my $localname = i_method "i_localname", $keyword;
5150     my $localpath = "$i_tmp/$localname";
5151     stat_exists $localpath and
5152         badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5153     protocol_receive_file \*RO, $localpath;
5154     i_method "i_file", $keyword;
5155 }
5156
5157 our %i_param;
5158
5159 sub i_resp_param ($) {
5160     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5161     $i_param{$1} = $2;
5162 }
5163
5164 sub i_resp_previously ($) {
5165     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5166         or badproto \*RO, __ "bad previously spec";
5167     my $r = system qw(git check-ref-format), $1;
5168     confess "bad previously ref spec ($r)" if $r;
5169     $previously{$1} = $2;
5170 }
5171
5172 our %i_wanted;
5173
5174 sub i_resp_want ($) {
5175     my ($keyword) = @_;
5176     die "$keyword ?" if $i_wanted{$keyword}++;
5177
5178     defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5179     $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5180     die unless $isuite =~ m/^$suite_re$/;
5181
5182     pushing();
5183     rpush_handle_protovsn_bothends();
5184
5185     my @localpaths = i_method "i_want", $keyword;
5186     printdebug "[[  $keyword @localpaths\n";
5187     foreach my $localpath (@localpaths) {
5188         protocol_send_file \*RI, $localpath;
5189     }
5190     print RI "files-end\n" or confess "$!";
5191 }
5192
5193 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5194
5195 sub i_localname_parsed_changelog {
5196     return "remote-changelog.822";
5197 }
5198 sub i_file_parsed_changelog {
5199     ($i_clogp, $i_version, $i_dscfn) =
5200         push_parse_changelog "$i_tmp/remote-changelog.822";
5201     die if $i_dscfn =~ m#/|^\W#;
5202 }
5203
5204 sub i_localname_dsc {
5205     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5206     return $i_dscfn;
5207 }
5208 sub i_file_dsc { }
5209
5210 sub i_localname_buildinfo ($) {
5211     my $bi = $i_param{'buildinfo-filename'};
5212     defined $bi or badproto \*RO, "buildinfo before filename";
5213     defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5214     $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5215         or badproto \*RO, "improper buildinfo filename";
5216     return $&;
5217 }
5218 sub i_file_buildinfo {
5219     my $bi = $i_param{'buildinfo-filename'};
5220     my $bd = parsecontrol "$i_tmp/$bi", $bi;
5221     my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5222     if (!forceing [qw(buildinfo-changes-mismatch)]) {
5223         files_compare_inputs($bd, $ch);
5224         (getfield $bd, $_) eq (getfield $ch, $_) or
5225             fail f_ "buildinfo mismatch in field %s", $_
5226             foreach qw(Source Version);
5227         !defined $bd->{$_} or
5228             fail f_ "buildinfo contains forbidden field %s", $_
5229             foreach qw(Changes Changed-by Distribution);
5230     }
5231     push @i_buildinfos, $bi;
5232     delete $i_param{'buildinfo-filename'};
5233 }
5234
5235 sub i_localname_changes {
5236     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5237     $i_changesfn = $i_dscfn;
5238     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5239     return $i_changesfn;
5240 }
5241 sub i_file_changes { }
5242
5243 sub i_want_signed_tag {
5244     printdebug Dumper(\%i_param, $i_dscfn);
5245     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5246         && defined $i_param{'csuite'}
5247         or badproto \*RO, "premature desire for signed-tag";
5248     my $head = $i_param{'head'};
5249     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5250
5251     my $maintview = $i_param{'maint-view'};
5252     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5253
5254     if ($protovsn == 4) {
5255         my $p = $i_param{'tagformat'} // '<undef>';
5256         $p eq 'new'
5257             or badproto \*RO, "tag format mismatch: $p vs. new";
5258     }
5259
5260     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5261     $csuite = $&;
5262     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5263
5264     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5265
5266     return
5267         push_mktags $i_clogp, $i_dscfn,
5268             $i_changesfn, (__ 'remote changes file'),
5269             \@tagwants;
5270 }
5271
5272 sub i_want_signed_dsc_changes {
5273     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5274     sign_changes $i_changesfn;
5275     return ($i_dscfn, $i_changesfn, @i_buildinfos);
5276 }
5277
5278 #---------- building etc. ----------
5279
5280 our $version;
5281 our $sourcechanges;
5282 our $dscfn;
5283
5284 #----- `3.0 (quilt)' handling -----
5285
5286 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5287
5288 sub quiltify_dpkg_commit ($$$;$) {
5289     my ($patchname,$author,$msg, $xinfo) = @_;
5290     $xinfo //= '';
5291
5292     mkpath '.git/dgit'; # we are in playtree
5293     my $descfn = ".git/dgit/quilt-description.tmp";
5294     open O, '>', $descfn or confess "$descfn: $!";
5295     $msg =~ s/\n+/\n\n/;
5296     print O <<END or confess "$!";
5297 From: $author
5298 ${xinfo}Subject: $msg
5299 ---
5300
5301 END
5302     close O or confess "$!";
5303
5304     {
5305         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5306         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5307         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5308         runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5309     }
5310 }
5311
5312 sub quiltify_trees_differ ($$;$$$) {
5313     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5314     # returns true iff the two tree objects differ other than in debian/
5315     # with $finegrained,
5316     # returns bitmask 01 - differ in upstream files except .gitignore
5317     #                 02 - differ in .gitignore
5318     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5319     #  is set for each modified .gitignore filename $fn
5320     # if $unrepres is defined, array ref to which is appeneded
5321     #  a list of unrepresentable changes (removals of upstream files
5322     #  (as messages)
5323     local $/=undef;
5324     my @cmd = (@git, qw(diff-tree -z --no-renames));
5325     push @cmd, qw(--name-only) unless $unrepres;
5326     push @cmd, qw(-r) if $finegrained || $unrepres;
5327     push @cmd, $x, $y;
5328     my $diffs= cmdoutput @cmd;
5329     my $r = 0;
5330     my @lmodes;
5331     foreach my $f (split /\0/, $diffs) {
5332         if ($unrepres && !@lmodes) {
5333             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5334             next;
5335         }
5336         my ($oldmode,$newmode) = @lmodes;
5337         @lmodes = ();
5338
5339         next if $f =~ m#^debian(?:/.*)?$#s;
5340
5341         if ($unrepres) {
5342             eval {
5343                 die __ "not a plain file or symlink\n"
5344                     unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5345                            $oldmode =~ m/^(?:10|12)\d{4}$/;
5346                 if ($oldmode =~ m/[^0]/ &&
5347                     $newmode =~ m/[^0]/) {
5348                     # both old and new files exist
5349                     die __ "mode or type changed\n" if $oldmode ne $newmode;
5350                     die __ "modified symlink\n" unless $newmode =~ m/^10/;
5351                 } elsif ($oldmode =~ m/[^0]/) {
5352                     # deletion
5353                     die __ "deletion of symlink\n"
5354                         unless $oldmode =~ m/^10/;
5355                 } else {
5356                     # creation
5357                     die __ "creation with non-default mode\n"
5358                         unless $newmode =~ m/^100644$/ or
5359                                $newmode =~ m/^120000$/;
5360                 }
5361             };
5362             if ($@) {
5363                 local $/="\n"; chomp $@;
5364                 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5365             }
5366         }
5367
5368         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5369         $r |= $isignore ? 02 : 01;
5370         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5371     }
5372     printdebug "quiltify_trees_differ $x $y => $r\n";
5373     return $r;
5374 }
5375
5376 sub quiltify_tree_sentinelfiles ($) {
5377     # lists the `sentinel' files present in the tree
5378     my ($x) = @_;
5379     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5380         qw(-- debian/rules debian/control);
5381     $r =~ s/\n/,/g;
5382     return $r;
5383 }
5384
5385 sub quiltify_splitting ($$$$$$$) {
5386     my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5387         $editedignores, $cachekey) = @_;
5388     my $gitignore_special = 1;
5389     if ($quilt_mode !~ m/gbp|dpm|baredebian/) {
5390         # treat .gitignore just like any other upstream file
5391         $diffbits = { %$diffbits };
5392         $_ = !!$_ foreach values %$diffbits;
5393         $gitignore_special = 0;
5394     }
5395     # We would like any commits we generate to be reproducible
5396     my @authline = clogp_authline($clogp);
5397     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
5398     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5399     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
5400     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
5401     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5402     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
5403
5404     confess unless do_split_brain();
5405
5406     my $fulldiffhint = sub {
5407         my ($x,$y) = @_;
5408         my $cmd = "git diff $x $y -- :/ ':!debian'";
5409         $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5410         return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5411                   $cmd;
5412     };
5413
5414     if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5415         ($diffbits->{O2H} & 01)) {
5416         my $msg = f_
5417  "--quilt=%s specified, implying patches-unapplied git tree\n".
5418  " but git tree differs from orig in upstream files.",
5419                      $quilt_mode;
5420         $msg .= $fulldiffhint->($unapplied, 'HEAD');
5421         if (!stat_exists "debian/patches" and $quilt_mode !~ m/baredebian/) {
5422             $msg .= __
5423  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5424         }
5425         fail $msg;
5426     }
5427     if ($quilt_mode =~ m/dpm/ &&
5428         ($diffbits->{H2A} & 01)) {
5429         fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5430 --quilt=%s specified, implying patches-applied git tree
5431  but git tree differs from result of applying debian/patches to upstream
5432 END
5433     }
5434     if ($quilt_mode =~ m/baredebian/) {
5435         # We need to construct a merge which has upstream files from
5436         # upstream and debian/ files from HEAD.
5437
5438         read_tree_upstream $quilt_upstream_commitish, 1, $headref;
5439         my $version = getfield $clogp, 'Version';
5440         my $upsversion = upstreamversion $version;
5441         my $merge = make_commit
5442             [ $headref, $quilt_upstream_commitish ],
5443  [ +(f_ <<ENDT, $upsversion), $quilt_upstream_commitish_message, <<ENDU ];
5444 Combine debian/ with upstream source for %s
5445 ENDT
5446 [dgit ($our_version) baredebian-merge $version $quilt_upstream_commitish_used]
5447 ENDU
5448         runcmd @git, qw(reset -q --hard), $merge;
5449     }
5450     if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5451         ($diffbits->{O2A} & 01)) { # some patches
5452         progress __ "dgit view: creating patches-applied version using gbp pq";
5453         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5454         # gbp pq import creates a fresh branch; push back to dgit-view
5455         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5456         runcmd @git, qw(checkout -q dgit-view);
5457     }
5458     if ($quilt_mode =~ m/gbp|dpm/ &&
5459         ($diffbits->{O2A} & 02)) {
5460         fail f_ <<END, $quilt_mode;
5461 --quilt=%s specified, implying that HEAD is for use with a
5462  tool which does not create patches for changes to upstream
5463  .gitignores: but, such patches exist in debian/patches.
5464 END
5465     }
5466     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5467         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5468         progress __
5469             "dgit view: creating patch to represent .gitignore changes";
5470         ensuredir "debian/patches";
5471         my $gipatch = "debian/patches/auto-gitignore";
5472         open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5473         stat GIPATCH or confess "$gipatch: $!";
5474         fail f_ "%s already exists; but want to create it".
5475                 " to record .gitignore changes",
5476                 $gipatch
5477             if (stat _)[7];
5478         print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5479 Subject: Update .gitignore from Debian packaging branch
5480
5481 The Debian packaging git branch contains these updates to the upstream
5482 .gitignore file(s).  This patch is autogenerated, to provide these
5483 updates to users of the official Debian archive view of the package.
5484 END
5485
5486 [dgit ($our_version) update-gitignore]
5487 ---
5488 ENDU
5489         close GIPATCH or die "$gipatch: $!";
5490         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5491             $unapplied, $headref, "--", sort keys %$editedignores;
5492         open SERIES, "+>>", "debian/patches/series" or confess "$!";
5493         defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5494         my $newline;
5495         defined read SERIES, $newline, 1 or confess "$!";
5496         print SERIES "\n" or confess "$!" unless $newline eq "\n";
5497         print SERIES "auto-gitignore\n" or confess "$!";
5498         close SERIES or die  $!;
5499         runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5500         commit_admin +(__ <<END).<<ENDU
5501 Commit patch to update .gitignore
5502 END
5503
5504 [dgit ($our_version) update-gitignore-quilt-fixup]
5505 ENDU
5506     }
5507 }
5508
5509 sub quiltify ($$$$) {
5510     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5511
5512     # Quilt patchification algorithm
5513     #
5514     # We search backwards through the history of the main tree's HEAD
5515     # (T) looking for a start commit S whose tree object is identical
5516     # to to the patch tip tree (ie the tree corresponding to the
5517     # current dpkg-committed patch series).  For these purposes
5518     # `identical' disregards anything in debian/ - this wrinkle is
5519     # necessary because dpkg-source treates debian/ specially.
5520     #
5521     # We can only traverse edges where at most one of the ancestors'
5522     # trees differs (in changes outside in debian/).  And we cannot
5523     # handle edges which change .pc/ or debian/patches.  To avoid
5524     # going down a rathole we avoid traversing edges which introduce
5525     # debian/rules or debian/control.  And we set a limit on the
5526     # number of edges we are willing to look at.
5527     #
5528     # If we succeed, we walk forwards again.  For each traversed edge
5529     # PC (with P parent, C child) (starting with P=S and ending with
5530     # C=T) to we do this:
5531     #  - git checkout C
5532     #  - dpkg-source --commit with a patch name and message derived from C
5533     # After traversing PT, we git commit the changes which
5534     # should be contained within debian/patches.
5535
5536     # The search for the path S..T is breadth-first.  We maintain a
5537     # todo list containing search nodes.  A search node identifies a
5538     # commit, and looks something like this:
5539     #  $p = {
5540     #      Commit => $git_commit_id,
5541     #      Child => $c,                          # or undef if P=T
5542     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
5543     #      Nontrivial => true iff $p..$c has relevant changes
5544     #  };
5545
5546     my @todo;
5547     my @nots;
5548     my $sref_S;
5549     my $max_work=100;
5550     my %considered; # saves being exponential on some weird graphs
5551
5552     my $t_sentinels = quiltify_tree_sentinelfiles $target;
5553
5554     my $not = sub {
5555         my ($search,$whynot) = @_;
5556         printdebug " search NOT $search->{Commit} $whynot\n";
5557         $search->{Whynot} = $whynot;
5558         push @nots, $search;
5559         no warnings qw(exiting);
5560         next;
5561     };
5562
5563     push @todo, {
5564         Commit => $target,
5565     };
5566
5567     while (@todo) {
5568         my $c = shift @todo;
5569         next if $considered{$c->{Commit}}++;
5570
5571         $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5572
5573         printdebug "quiltify investigate $c->{Commit}\n";
5574
5575         # are we done?
5576         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5577             printdebug " search finished hooray!\n";
5578             $sref_S = $c;
5579             last;
5580         }
5581
5582         quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5583         if ($quilt_mode eq 'smash') {
5584             printdebug " search quitting smash\n";
5585             last;
5586         }
5587
5588         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5589         $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5590             if $c_sentinels ne $t_sentinels;
5591
5592         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5593         $commitdata =~ m/\n\n/;
5594         $commitdata =~ $`;
5595         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5596         @parents = map { { Commit => $_, Child => $c } } @parents;
5597
5598         $not->($c, __ "root commit") if !@parents;
5599
5600         foreach my $p (@parents) {
5601             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5602         }
5603         my $ndiffers = grep { $_->{Nontrivial} } @parents;
5604         $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5605             if $ndiffers > 1;
5606
5607         foreach my $p (@parents) {
5608             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5609
5610             my @cmd= (@git, qw(diff-tree -r --name-only),
5611                       $p->{Commit},$c->{Commit},
5612                       qw(-- debian/patches .pc debian/source/format));
5613             my $patchstackchange = cmdoutput @cmd;
5614             if (length $patchstackchange) {
5615                 $patchstackchange =~ s/\n/,/g;
5616                 $not->($p, f_ "changed %s", $patchstackchange);
5617             }
5618
5619             printdebug " search queue P=$p->{Commit} ",
5620                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5621             push @todo, $p;
5622         }
5623     }
5624
5625     if (!$sref_S) {
5626         printdebug "quiltify want to smash\n";
5627
5628         my $abbrev = sub {
5629             my $x = $_[0]{Commit};
5630             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5631             return $x;
5632         };
5633         if ($quilt_mode eq 'linear') {
5634             print STDERR f_
5635                 "\n%s: error: quilt fixup cannot be linear.  Stopped at:\n",
5636                 $us;
5637             my $all_gdr = !!@nots;
5638             foreach my $notp (@nots) {
5639                 my $c = $notp->{Child};
5640                 my $cprange = $abbrev->($notp);
5641                 $cprange .= "..".$abbrev->($c) if $c;
5642                 print STDERR f_ "%s:  %s: %s\n",
5643                     $us, $cprange, $notp->{Whynot};
5644                 $all_gdr &&= $notp->{Child} &&
5645                     (git_cat_file $notp->{Child}{Commit}, 'commit')
5646                     =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5647             }
5648             print STDERR "\n";
5649             $failsuggestion =
5650                 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5651                 if $all_gdr;
5652             print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5653             fail __
5654  "quilt history linearisation failed.  Search \`quilt fixup' in dgit(7).\n";
5655         } elsif ($quilt_mode eq 'smash') {
5656         } elsif ($quilt_mode eq 'auto') {
5657             progress __ "quilt fixup cannot be linear, smashing...";
5658         } else {
5659             confess "$quilt_mode ?";
5660         }
5661
5662         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5663         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5664         my $ncommits = 3;
5665         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5666
5667         quiltify_dpkg_commit "auto-$version-$target-$time",
5668             (getfield $clogp, 'Maintainer'),
5669             (f_ "Automatically generated patch (%s)\n".
5670              "Last (up to) %s git changes, FYI:\n\n",
5671              $clogp->{Version}, $ncommits).
5672              $msg;
5673         return;
5674     }
5675
5676     progress __ "quiltify linearisation planning successful, executing...";
5677
5678     for (my $p = $sref_S;
5679          my $c = $p->{Child};
5680          $p = $p->{Child}) {
5681         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5682         next unless $p->{Nontrivial};
5683
5684         my $cc = $c->{Commit};
5685
5686         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5687         $commitdata =~ m/\n\n/ or die "$c ?";
5688         $commitdata = $`;
5689         my $msg = $'; #';
5690         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5691         my $author = $1;
5692
5693         my $commitdate = cmdoutput
5694             @git, qw(log -n1 --pretty=format:%aD), $cc;
5695
5696         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5697
5698         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5699         $strip_nls->();
5700
5701         my $title = $1;
5702         my $patchname;
5703         my $patchdir;
5704
5705         my $gbp_check_suitable = sub {
5706             $_ = shift;
5707             my ($what) = @_;
5708
5709             eval {
5710                 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5711                 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5712                 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5713                 die __ "is series file\n" if m{$series_filename_re}o;
5714                 die __ "too long\n" if length > 200;
5715             };
5716             return $_ unless $@;
5717             print STDERR f_
5718                 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5719                 $cc, $what, $@;
5720             return undef;
5721         };
5722
5723         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5724                            gbp-pq-name: \s* )
5725                        (\S+) \s* \n //ixm) {
5726             $patchname = $gbp_check_suitable->($1, 'Name');
5727         }
5728         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5729                            gbp-pq-topic: \s* )
5730                        (\S+) \s* \n //ixm) {
5731             $patchdir = $gbp_check_suitable->($1, 'Topic');
5732         }
5733
5734         $strip_nls->();
5735
5736         if (!defined $patchname) {
5737             $patchname = $title;
5738             $patchname =~ s/[.:]$//;
5739             use Text::Iconv;
5740             eval {
5741                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5742                 my $translitname = $converter->convert($patchname);
5743                 die unless defined $translitname;
5744                 $patchname = $translitname;
5745             };
5746             print STDERR
5747                 +(f_ "dgit: patch title transliteration error: %s", $@)
5748                 if $@;
5749             $patchname =~ y/ A-Z/-a-z/;
5750             $patchname =~ y/-a-z0-9_.+=~//cd;
5751             $patchname =~ s/^\W/x-$&/;
5752             $patchname = substr($patchname,0,40);
5753             $patchname .= ".patch";
5754         }
5755         if (!defined $patchdir) {
5756             $patchdir = '';
5757         }
5758         if (length $patchdir) {
5759             $patchname = "$patchdir/$patchname";
5760         }
5761         if ($patchname =~ m{^(.*)/}) {
5762             mkpath "debian/patches/$1";
5763         }
5764
5765         my $index;
5766         for ($index='';
5767              stat "debian/patches/$patchname$index";
5768              $index++) { }
5769         $!==ENOENT or confess "$patchname$index $!";
5770
5771         runcmd @git, qw(checkout -q), $cc;
5772
5773         # We use the tip's changelog so that dpkg-source doesn't
5774         # produce complaining messages from dpkg-parsechangelog.  None
5775         # of the information dpkg-source gets from the changelog is
5776         # actually relevant - it gets put into the original message
5777         # which dpkg-source provides our stunt editor, and then
5778         # overwritten.
5779         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5780
5781         quiltify_dpkg_commit "$patchname$index", $author, $msg,
5782             "Date: $commitdate\n".
5783             "X-Dgit-Generated: $clogp->{Version} $cc\n";
5784
5785         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5786     }
5787 }
5788
5789 sub build_maybe_quilt_fixup () {
5790     my ($format,$fopts) = get_source_format;
5791     return unless madformat_wantfixup $format;
5792     # sigh
5793
5794     check_for_vendor_patches();
5795
5796     my $clogp = parsechangelog();
5797     my $headref = git_rev_parse('HEAD');
5798     my $symref = git_get_symref();
5799     my $upstreamversion = upstreamversion $version;
5800
5801     prep_ud();
5802     changedir $playground;
5803
5804     my $splitbrain_cachekey;
5805
5806     if (do_split_brain()) {
5807         my $cachehit;
5808         ($cachehit, $splitbrain_cachekey) =
5809             quilt_check_splitbrain_cache($headref, $upstreamversion);
5810         if ($cachehit) {
5811             changedir $maindir;
5812             return;
5813         }
5814     }
5815
5816     unpack_playtree_need_cd_work($headref);
5817     if (do_split_brain()) {
5818         runcmd @git, qw(checkout -q -b dgit-view);
5819         # so long as work is not deleted, its current branch will
5820         # remain dgit-view, rather than master, so subsequent calls to
5821         #  unpack_playtree_need_cd_work
5822         # will DTRT, resetting dgit-view.
5823         confess if $made_split_brain;
5824         $made_split_brain = 1;
5825     }
5826     chdir '..';
5827
5828     if ($fopts->{'single-debian-patch'}) {
5829         fail f_
5830  "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5831             $quilt_mode
5832             if quiltmode_splitting();
5833         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5834     } else {
5835         quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5836                               $splitbrain_cachekey);
5837     }
5838
5839     if (do_split_brain()) {
5840         my $dgitview = git_rev_parse 'HEAD';
5841
5842         changedir $maindir;
5843         reflog_cache_insert "refs/$splitbraincache",
5844             $splitbrain_cachekey, $dgitview;
5845
5846         changedir "$playground/work";
5847
5848         my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5849         progress f_ "dgit view: created (%s)", $saved;
5850     }
5851
5852     changedir $maindir;
5853     runcmd_ordryrun_local
5854         @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5855 }
5856
5857 sub build_check_quilt_splitbrain () {
5858     build_maybe_quilt_fixup();
5859 }
5860
5861 sub unpack_playtree_need_cd_work ($) {
5862     my ($headref) = @_;
5863
5864     # prep_ud() must have been called already.
5865     if (!chdir "work") {
5866         # Check in the filesystem because sometimes we run prep_ud
5867         # in between multiple calls to unpack_playtree_need_cd_work.
5868         confess "$!" unless $!==ENOENT;
5869         mkdir "work" or confess "$!";
5870         changedir "work";
5871         mktree_in_ud_here();
5872     }
5873     runcmd @git, qw(reset -q --hard), $headref;
5874 }
5875
5876 sub unpack_playtree_linkorigs ($$) {
5877     my ($upstreamversion, $fn) = @_;
5878     # calls $fn->($leafname);
5879
5880     my $bpd_abs = bpd_abs();
5881
5882     dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5883
5884     opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5885     while ($!=0, defined(my $leaf = readdir QFD)) {
5886         my $f = bpd_abs()."/".$leaf;
5887         {
5888             local ($debuglevel) = $debuglevel-1;
5889             printdebug "QF linkorigs bpd $leaf, $f ?\n";
5890         }
5891         next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5892         printdebug "QF linkorigs $leaf, $f Y\n";
5893         link_ltarget $f, $leaf or die "$leaf $!";
5894         $fn->($leaf);
5895     }
5896     die "$buildproductsdir: $!" if $!;
5897     closedir QFD;
5898 }
5899
5900 sub quilt_fixup_delete_pc () {
5901     runcmd @git, qw(rm -rqf .pc);
5902     commit_admin +(__ <<END).<<ENDU
5903 Commit removal of .pc (quilt series tracking data)
5904 END
5905
5906 [dgit ($our_version) upgrade quilt-remove-pc]
5907 ENDU
5908 }
5909
5910 sub quilt_fixup_singlepatch ($$$) {
5911     my ($clogp, $headref, $upstreamversion) = @_;
5912
5913     progress __ "starting quiltify (single-debian-patch)";
5914
5915     # dpkg-source --commit generates new patches even if
5916     # single-debian-patch is in debian/source/options.  In order to
5917     # get it to generate debian/patches/debian-changes, it is
5918     # necessary to build the source package.
5919
5920     unpack_playtree_linkorigs($upstreamversion, sub { });
5921     unpack_playtree_need_cd_work($headref);
5922
5923     rmtree("debian/patches");
5924
5925     runcmd @dpkgsource, qw(-b .);
5926     changedir "..";
5927     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5928     rename srcfn("$upstreamversion", "/debian/patches"),
5929         "work/debian/patches"
5930         or $!==ENOENT
5931         or confess "install d/patches: $!";
5932
5933     changedir "work";
5934     commit_quilty_patch();
5935 }
5936
5937 sub quilt_need_fake_dsc ($) {
5938     # cwd should be playground
5939     my ($upstreamversion) = @_;
5940
5941     return if stat_exists "fake.dsc";
5942     # ^ OK to test this as a sentinel because if we created it
5943     # we must either have done the rest too, or crashed.
5944
5945     my $fakeversion="$upstreamversion-~~DGITFAKE";
5946
5947     my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5948     print $fakedsc <<END or confess "$!";
5949 Format: 3.0 (quilt)
5950 Source: $package
5951 Version: $fakeversion
5952 Files:
5953 END
5954
5955     my $dscaddfile=sub {
5956         my ($leaf) = @_;
5957
5958         my $md = new Digest::MD5;
5959
5960         my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5961         stat $fh or confess "$!";
5962         my $size = -s _;
5963
5964         $md->addfile($fh);
5965         print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5966     };
5967
5968     unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5969
5970     my @files=qw(debian/source/format debian/rules
5971                  debian/control debian/changelog);
5972     foreach my $maybe (qw(debian/patches debian/source/options
5973                           debian/tests/control)) {
5974         next unless stat_exists "$maindir/$maybe";
5975         push @files, $maybe;
5976     }
5977
5978     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5979     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5980
5981     $dscaddfile->($debtar);
5982     close $fakedsc or confess "$!";
5983 }
5984
5985 sub quilt_fakedsc2unapplied ($$) {
5986     my ($headref, $upstreamversion) = @_;
5987     # must be run in the playground
5988     # quilt_need_fake_dsc must have been called
5989
5990     quilt_need_fake_dsc($upstreamversion);
5991     runcmd qw(sh -ec),
5992         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5993
5994     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5995     rename $fakexdir, "fake" or die "$fakexdir $!";
5996
5997     changedir 'fake';
5998
5999     remove_stray_gits(__ "source package");
6000     mktree_in_ud_here();
6001
6002     rmtree '.pc';
6003
6004     rmtree 'debian'; # git checkout commitish paths does not delete!
6005     runcmd @git, qw(checkout -f), $headref, qw(-- debian);
6006     my $unapplied=git_add_write_tree();
6007     printdebug "fake orig tree object $unapplied\n";
6008     return $unapplied;
6009 }
6010
6011 sub quilt_check_splitbrain_cache ($$) {
6012     my ($headref, $upstreamversion) = @_;
6013     # Called only if we are in (potentially) split brain mode.
6014     # Called in playground.
6015     # Computes the cache key and looks in the cache.
6016     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
6017
6018     quilt_need_fake_dsc($upstreamversion);
6019
6020     my $splitbrain_cachekey;
6021
6022     progress f_
6023  "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
6024                 $quilt_mode;
6025     # we look in the reflog of dgit-intern/quilt-cache
6026     # we look for an entry whose message is the key for the cache lookup
6027     my @cachekey = (qw(dgit), $our_version);
6028     push @cachekey, $upstreamversion;
6029     push @cachekey, $quilt_mode;
6030     push @cachekey, $headref;
6031     push @cachekey, $quilt_upstream_commitish // '-';
6032
6033     push @cachekey, hashfile('fake.dsc');
6034
6035     my $srcshash = Digest::SHA->new(256);
6036     my %sfs = ( %INC, '$0(dgit)' => $0 );
6037     foreach my $sfk (sort keys %sfs) {
6038         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6039         $srcshash->add($sfk,"  ");
6040         $srcshash->add(hashfile($sfs{$sfk}));
6041         $srcshash->add("\n");
6042     }
6043     push @cachekey, $srcshash->hexdigest();
6044     $splitbrain_cachekey = "@cachekey";
6045
6046     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6047
6048     my $cachehit = reflog_cache_lookup
6049         "refs/$splitbraincache", $splitbrain_cachekey;
6050
6051     if ($cachehit) {
6052         unpack_playtree_need_cd_work($headref);
6053         my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6054         if ($cachehit ne $headref) {
6055             progress f_ "dgit view: found cached (%s)", $saved;
6056             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6057             $made_split_brain = 1;
6058             return ($cachehit, $splitbrain_cachekey);
6059         }
6060         progress __ "dgit view: found cached, no changes required";
6061         return ($headref, $splitbrain_cachekey);
6062     }
6063
6064     printdebug "splitbrain cache miss\n";
6065     return (undef, $splitbrain_cachekey);
6066 }
6067
6068 sub quilt_fixup_multipatch ($$$) {
6069     my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6070
6071     progress f_ "examining quilt state (multiple patches, %s mode)",
6072                 $quilt_mode;
6073
6074     # Our objective is:
6075     #  - honour any existing .pc in case it has any strangeness
6076     #  - determine the git commit corresponding to the tip of
6077     #    the patch stack (if there is one)
6078     #  - if there is such a git commit, convert each subsequent
6079     #    git commit into a quilt patch with dpkg-source --commit
6080     #  - otherwise convert all the differences in the tree into
6081     #    a single git commit
6082     #
6083     # To do this we:
6084
6085     # Our git tree doesn't necessarily contain .pc.  (Some versions of
6086     # dgit would include the .pc in the git tree.)  If there isn't
6087     # one, we need to generate one by unpacking the patches that we
6088     # have.
6089     #
6090     # We first look for a .pc in the git tree.  If there is one, we
6091     # will use it.  (This is not the normal case.)
6092     #
6093     # Otherwise need to regenerate .pc so that dpkg-source --commit
6094     # can work.  We do this as follows:
6095     #     1. Collect all relevant .orig from parent directory
6096     #     2. Generate a debian.tar.gz out of
6097     #         debian/{patches,rules,source/format,source/options}
6098     #     3. Generate a fake .dsc containing just these fields:
6099     #          Format Source Version Files
6100     #     4. Extract the fake .dsc
6101     #        Now the fake .dsc has a .pc directory.
6102     # (In fact we do this in every case, because in future we will
6103     # want to search for a good base commit for generating patches.)
6104     #
6105     # Then we can actually do the dpkg-source --commit
6106     #     1. Make a new working tree with the same object
6107     #        store as our main tree and check out the main
6108     #        tree's HEAD.
6109     #     2. Copy .pc from the fake's extraction, if necessary
6110     #     3. Run dpkg-source --commit
6111     #     4. If the result has changes to debian/, then
6112     #          - git add them them
6113     #          - git add .pc if we had a .pc in-tree
6114     #          - git commit
6115     #     5. If we had a .pc in-tree, delete it, and git commit
6116     #     6. Back in the main tree, fast forward to the new HEAD
6117
6118     # Another situation we may have to cope with is gbp-style
6119     # patches-unapplied trees.
6120     #
6121     # We would want to detect these, so we know to escape into
6122     # quilt_fixup_gbp.  However, this is in general not possible.
6123     # Consider a package with a one patch which the dgit user reverts
6124     # (with git revert or the moral equivalent).
6125     #
6126     # That is indistinguishable in contents from a patches-unapplied
6127     # tree.  And looking at the history to distinguish them is not
6128     # useful because the user might have made a confusing-looking git
6129     # history structure (which ought to produce an error if dgit can't
6130     # cope, not a silent reintroduction of an unwanted patch).
6131     #
6132     # So gbp users will have to pass an option.  But we can usually
6133     # detect their failure to do so: if the tree is not a clean
6134     # patches-applied tree, quilt linearisation fails, but the tree
6135     # _is_ a clean patches-unapplied tree, we can suggest that maybe
6136     # they want --quilt=unapplied.
6137     #
6138     # To help detect this, when we are extracting the fake dsc, we
6139     # first extract it with --skip-patches, and then apply the patches
6140     # afterwards with dpkg-source --before-build.  That lets us save a
6141     # tree object corresponding to .origs.
6142
6143     if ($quilt_mode eq 'linear'
6144         && branch_is_gdr($headref)) {
6145         # This is much faster.  It also makes patches that gdr
6146         # likes better for future updates without laundering.
6147         #
6148         # However, it can fail in some casses where we would
6149         # succeed: if there are existing patches, which correspond
6150         # to a prefix of the branch, but are not in gbp/gdr
6151         # format, gdr will fail (exiting status 7), but we might
6152         # be able to figure out where to start linearising.  That
6153         # will be slower so hopefully there's not much to do.
6154
6155         unpack_playtree_need_cd_work $headref;
6156
6157         my @cmd = (@git_debrebase,
6158                    qw(--noop-ok -funclean-mixed -funclean-ordering
6159                       make-patches --quiet-would-amend));
6160         # We tolerate soe snags that gdr wouldn't, by default.
6161         if (act_local()) {
6162             debugcmd "+",@cmd;
6163             $!=0; $?=-1;
6164             failedcmd @cmd
6165                 if system @cmd
6166                 and not ($? == 7*256 or
6167                          $? == -1 && $!==ENOENT);
6168         } else {
6169             dryrun_report @cmd;
6170         }
6171         $headref = git_rev_parse('HEAD');
6172
6173         chdir '..';
6174     }
6175
6176     my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6177
6178     ensuredir '.pc';
6179
6180     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6181     $!=0; $?=-1;
6182     if (system @bbcmd) {
6183         failedcmd @bbcmd if $? < 0;
6184         fail __ <<END;
6185 failed to apply your git tree's patch stack (from debian/patches/) to
6186  the corresponding upstream tarball(s).  Your source tree and .orig
6187  are probably too inconsistent.  dgit can only fix up certain kinds of
6188  anomaly (depending on the quilt mode).  Please see --quilt= in dgit(1).
6189 END
6190     }
6191
6192     changedir '..';
6193
6194     unpack_playtree_need_cd_work($headref);
6195
6196     my $mustdeletepc=0;
6197     if (stat_exists ".pc") {
6198         -d _ or die;
6199         progress __ "Tree already contains .pc - will use it then delete it.";
6200         $mustdeletepc=1;
6201     } else {
6202         rename '../fake/.pc','.pc' or confess "$!";
6203     }
6204
6205     changedir '../fake';
6206     rmtree '.pc';
6207     my $oldtiptree=git_add_write_tree();
6208     printdebug "fake o+d/p tree object $unapplied\n";
6209     changedir '../work';
6210
6211
6212     # We calculate some guesswork now about what kind of tree this might
6213     # be.  This is mostly for error reporting.
6214
6215     my $tentries = cmdoutput @git, qw(ls-tree --name-only -z), $headref;
6216     my $onlydebian = $tentries eq "debian\0";
6217
6218     my $uheadref = $headref;
6219     my $uhead_whatshort = 'HEAD';
6220
6221     if ($quilt_mode =~ m/baredebian/) {
6222         $uheadref = $quilt_upstream_commitish;
6223         # TRANSLATORS: this translation must fit in the ASCII art
6224         # quilt differences display.  The untranslated display
6225         # says %9.9s, so with that display it must be at most 9
6226         # characters.
6227         $uhead_whatshort = __ 'upstream';
6228     }
6229
6230     my %editedignores;
6231     my @unrepres;
6232     my $diffbits = {
6233         # H = user's HEAD
6234         # O = orig, without patches applied
6235         # A = "applied", ie orig with H's debian/patches applied
6236         O2H => quiltify_trees_differ($unapplied,$uheadref,   1,
6237                                      \%editedignores, \@unrepres),
6238         H2A => quiltify_trees_differ($uheadref, $oldtiptree,1),
6239         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6240     };
6241
6242     my @dl;
6243     foreach my $bits (qw(01 02)) {
6244         foreach my $v (qw(O2H O2A H2A)) {
6245             push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6246         }
6247     }
6248     printdebug "differences \@dl @dl.\n";
6249
6250     progress f_
6251 "%s: base trees orig=%.20s o+d/p=%.20s",
6252               $us, $unapplied, $oldtiptree;
6253     # TRANSLATORS: Try to keep this ascii-art layout right.  The 0s in
6254     # %9.00009s will be ignored and are there to make the format the
6255     # same length (9 characters) as the output it generates.  If you
6256     # change the value 9, your translation of "upstream" must fit into
6257     # the new length, and you should change the number of 0s.  Do
6258     # not reduce it below 4 as HEAD has to fit too.
6259     progress f_
6260 "%s: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
6261 "%s: quilt differences: %9.00009s %s o+d/p          %9.00009s %s o+d/p",
6262   $us,                      $dl[0], $dl[1],              $dl[3], $dl[4],
6263   $us,        $uhead_whatshort, $dl[2],   $uhead_whatshort, $dl[5];
6264
6265     if (@unrepres && $quilt_mode !~ m/baredebian/) {
6266         # With baredebian, even if the upstream commitish has this
6267         # problem, we don't want to print this message, as nothing
6268         # is going to try to make a patch out of it anyway.
6269         print STDERR f_ "dgit:  cannot represent change: %s: %s\n",
6270                         $_->[1], $_->[0]
6271             foreach @unrepres;
6272         forceable_fail [qw(unrepresentable)], __ <<END;
6273 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6274 END
6275     }
6276
6277     my @failsuggestion;
6278     if ($onlydebian) {
6279         push @failsuggestion, [ 'onlydebian', __
6280  "This has only a debian/ directory; you probably want --quilt=bare debian." ]
6281             unless $quilt_mode =~ m/baredebian/;
6282     } elsif (!($diffbits->{O2H} & $diffbits->{O2A})) {
6283         push @failsuggestion, [ 'unapplied', __
6284  "This might be a patches-unapplied branch." ];
6285     } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6286         push @failsuggestion, [ 'applied', __
6287  "This might be a patches-applied branch." ];
6288     }
6289     push @failsuggestion, [ 'quilt-mode', __
6290  "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6291
6292     push @failsuggestion, [ 'gitattrs', __
6293  "Warning: Tree has .gitattributes.  See GITATTRIBUTES in dgit(7)." ]
6294         if stat_exists '.gitattributes';
6295
6296     push @failsuggestion, [ 'origs', __
6297  "Maybe orig tarball(s) are not identical to git representation?" ]
6298         unless $onlydebian && $quilt_mode !~ m/baredebian/;
6299                # ^ in that case, we didn't really look properly
6300
6301     if (quiltmode_splitting()) {
6302         quiltify_splitting($clogp, $unapplied, $headref, $oldtiptree,
6303                            $diffbits, \%editedignores,
6304                            $splitbrain_cachekey);
6305         return;
6306     }
6307
6308     progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6309     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6310     runcmd @git, qw(checkout -q), (qw(master dgit-view)[do_split_brain()]);
6311
6312     if (!open P, '>>', ".pc/applied-patches") {
6313         $!==&ENOENT or confess "$!";
6314     } else {
6315         close P;
6316     }
6317
6318     commit_quilty_patch();
6319
6320     if ($mustdeletepc) {
6321         quilt_fixup_delete_pc();
6322     }
6323 }
6324
6325 sub quilt_fixup_editor () {
6326     my $descfn = $ENV{$fakeeditorenv};
6327     my $editing = $ARGV[$#ARGV];
6328     open I1, '<', $descfn or confess "$descfn: $!";
6329     open I2, '<', $editing or confess "$editing: $!";
6330     unlink $editing or confess "$editing: $!";
6331     open O, '>', $editing or confess "$editing: $!";
6332     while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6333     my $copying = 0;
6334     while (<I2>) {
6335         $copying ||= m/^\-\-\- /;
6336         next unless $copying;
6337         print O or confess "$!";
6338     }
6339     I2->error and confess "$!";
6340     close O or die $1;
6341     finish 0;
6342 }
6343
6344 sub maybe_apply_patches_dirtily () {
6345     return unless $quilt_mode =~ m/gbp|unapplied|baredebian/;
6346     print STDERR __ <<END or confess "$!";
6347
6348 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6349 dgit: Have to apply the patches - making the tree dirty.
6350 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6351
6352 END
6353     $patches_applied_dirtily = 01;
6354     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6355     runcmd qw(dpkg-source --before-build .);
6356 }
6357
6358 sub maybe_unapply_patches_again () {
6359     progress __ "dgit: Unapplying patches again to tidy up the tree."
6360         if $patches_applied_dirtily;
6361     runcmd qw(dpkg-source --after-build .)
6362         if $patches_applied_dirtily & 01;
6363     rmtree '.pc'
6364         if $patches_applied_dirtily & 02;
6365     $patches_applied_dirtily = 0;
6366 }
6367
6368 #----- other building -----
6369
6370 sub clean_tree_check_git ($$$) {
6371     my ($honour_ignores, $message, $ignmessage) = @_;
6372     my @cmd = (@git, qw(clean -dn));
6373     push @cmd, qw(-x) unless $honour_ignores;
6374     my $leftovers = cmdoutput @cmd;
6375     if (length $leftovers) {
6376         print STDERR $leftovers, "\n" or confess "$!";
6377         $message .= $ignmessage if $honour_ignores;
6378         fail $message;
6379     }
6380 }
6381
6382 sub clean_tree_check_git_wd ($) {
6383     my ($message) = @_;
6384     return if $cleanmode =~ m{no-check};
6385     return if $patches_applied_dirtily; # yuk
6386     clean_tree_check_git +($cleanmode !~ m{all-check}),
6387         $message, "\n".__ <<END;
6388 If this is just missing .gitignore entries, use a different clean
6389 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6390 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6391 END
6392 }
6393
6394 sub clean_tree_check () {
6395     # This function needs to not care about modified but tracked files.
6396     # That was done by check_not_dirty, and by now we may have run
6397     # the rules clean target which might modify tracked files (!)
6398     if ($cleanmode =~ m{^check}) {
6399         clean_tree_check_git +($cleanmode =~ m{ignores}), __
6400  "tree contains uncommitted files and --clean=check specified", '';
6401     } elsif ($cleanmode =~ m{^dpkg-source}) {
6402         clean_tree_check_git_wd __
6403  "tree contains uncommitted files (NB dgit didn't run rules clean)";
6404     } elsif ($cleanmode =~ m{^git}) {
6405         clean_tree_check_git 1, __
6406  "tree contains uncommited, untracked, unignored files\n".
6407  "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6408     } elsif ($cleanmode eq 'none') {
6409     } else {
6410         confess "$cleanmode ?";
6411     }
6412 }
6413
6414 sub clean_tree () {
6415     # We always clean the tree ourselves, rather than leave it to the
6416     # builder (dpkg-source, or soemthing which calls dpkg-source).
6417     if ($quilt_mode =~ m/baredebian/ and $cleanmode =~ m/git/) {
6418         fail f_ <<END, $quilt_mode, $cleanmode;
6419 quilt mode %s (generally needs untracked upstream files)
6420 contradicts clean mode %s (which would delete them)
6421 END
6422         # This is not 100% true: dgit build-source and push-source
6423         # (for example) could operate just fine with no upstream
6424         # source in the working tree.  But it doesn't seem likely that
6425         # the user wants dgit to proactively delete such things.
6426         # -wn, for example, would produce identical output without
6427         # deleting anything from the working tree.
6428     }
6429     if ($cleanmode =~ m{^dpkg-source}) {
6430         my @cmd = @dpkgbuildpackage;
6431         push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6432         push @cmd, qw(-T clean);
6433         maybe_apply_patches_dirtily();
6434         runcmd_ordryrun_local @cmd;
6435         clean_tree_check_git_wd __
6436  "tree contains uncommitted files (after running rules clean)";
6437     } elsif ($cleanmode =~ m{^git(?!-)}) {
6438         runcmd_ordryrun_local @git, qw(clean -xdf);
6439     } elsif ($cleanmode =~ m{^git-ff}) {
6440         runcmd_ordryrun_local @git, qw(clean -xdff);
6441     } elsif ($cleanmode =~ m{^check}) {
6442         clean_tree_check();
6443     } elsif ($cleanmode eq 'none') {
6444     } else {
6445         confess "$cleanmode ?";
6446     }
6447 }
6448
6449 sub cmd_clean () {
6450     badusage __ "clean takes no additional arguments" if @ARGV;
6451     notpushing();
6452     clean_tree();
6453     maybe_unapply_patches_again();
6454 }
6455
6456 # return values from massage_dbp_args are one or both of these flags
6457 sub WANTSRC_SOURCE  () { 01; } # caller should build source (separately)
6458 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6459
6460 sub build_or_push_prep_early () {
6461     our $build_or_push_prep_early_done //= 0;
6462     return if $build_or_push_prep_early_done++;
6463     badusage f_ "-p is not allowed with dgit %s", $subcommand
6464         if defined $package;
6465     my $clogp = parsechangelog();
6466     $isuite = getfield $clogp, 'Distribution';
6467     $package = getfield $clogp, 'Source';
6468     $version = getfield $clogp, 'Version';
6469     $dscfn = dscfn($version);
6470 }
6471
6472 sub build_or_push_prep_modes () {
6473     my ($format,) = determine_whether_split_brain();
6474
6475     fail __ "dgit: --include-dirty is not supported with split view".
6476             " (including with view-splitting quilt modes)"
6477         if do_split_brain() && $includedirty;
6478
6479     if (madformat_wantfixup $format and $quilt_mode =~ m/baredebian$/) {
6480         ($quilt_upstream_commitish, $quilt_upstream_commitish_used,
6481          $quilt_upstream_commitish_message)
6482             = resolve_upstream_version
6483             $quilt_upstream_commitish, upstreamversion $version;
6484         progress f_ "dgit: --quilt=%s, %s", $quilt_mode,
6485             $quilt_upstream_commitish_message;
6486     } elsif (defined $quilt_upstream_commitish) {
6487         fail __
6488  "dgit: --upstream-commitish only makes sense with --quilt=baredebian"
6489     }
6490 }
6491
6492 sub build_prep_early () {
6493     build_or_push_prep_early();
6494     notpushing();
6495     build_or_push_prep_modes();
6496     check_not_dirty();
6497 }
6498
6499 sub build_prep ($) {
6500     my ($wantsrc) = @_;
6501     build_prep_early();
6502     check_bpd_exists();
6503     if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6504         # Clean the tree because we're going to use the contents of
6505         # $maindir.  (We trying to include dirty changes in the source
6506         # package, or we are running the builder in $maindir.)
6507         || $cleanmode =~ m{always}) {
6508         # Or because the user asked us to.
6509         clean_tree();
6510     } else {
6511         # We don't actually need to do anything in $maindir, but we
6512         # should do some kind of cleanliness check because (i) the
6513         # user may have forgotten a `git add', and (ii) if the user
6514         # said -wc we should still do the check.
6515         clean_tree_check();
6516     }
6517     build_check_quilt_splitbrain();
6518     if ($rmchanges) {
6519         my $pat = changespat $version;
6520         foreach my $f (glob "$buildproductsdir/$pat") {
6521             if (act_local()) {
6522                 unlink $f or
6523                     fail f_ "remove old changes file %s: %s", $f, $!;
6524             } else {
6525                 progress f_ "would remove %s", $f;
6526             }
6527         }
6528     }
6529 }
6530
6531 sub changesopts_initial () {
6532     my @opts =@changesopts[1..$#changesopts];
6533 }
6534
6535 sub changesopts_version () {
6536     if (!defined $changes_since_version) {
6537         my @vsns;
6538         unless (eval {
6539             @vsns = archive_query('archive_query');
6540             my @quirk = access_quirk();
6541             if ($quirk[0] eq 'backports') {
6542                 local $isuite = $quirk[2];
6543                 local $csuite;
6544                 canonicalise_suite();
6545                 push @vsns, archive_query('archive_query');
6546             }
6547             1;
6548         }) {
6549             print STDERR $@;
6550             fail __
6551  "archive query failed (queried because --since-version not specified)";
6552         }
6553         if (@vsns) {
6554             @vsns = map { $_->[0] } @vsns;
6555             @vsns = sort { -version_compare($a, $b) } @vsns;
6556             $changes_since_version = $vsns[0];
6557             progress f_ "changelog will contain changes since %s", $vsns[0];
6558         } else {
6559             $changes_since_version = '_';
6560             progress __ "package seems new, not specifying -v<version>";
6561         }
6562     }
6563     if ($changes_since_version ne '_') {
6564         return ("-v$changes_since_version");
6565     } else {
6566         return ();
6567     }
6568 }
6569
6570 sub changesopts () {
6571     return (changesopts_initial(), changesopts_version());
6572 }
6573
6574 sub massage_dbp_args ($;$) {
6575     my ($cmd,$xargs) = @_;
6576     # Since we split the source build out so we can do strange things
6577     # to it, massage the arguments to dpkg-buildpackage so that the
6578     # main build doessn't build source (or add an argument to stop it
6579     # building source by default).
6580     debugcmd '#massaging#', @$cmd if $debuglevel>1;
6581     # -nc has the side effect of specifying -b if nothing else specified
6582     # and some combinations of -S, -b, et al, are errors, rather than
6583     # later simply overriding earlie.  So we need to:
6584     #  - search the command line for these options
6585     #  - pick the last one
6586     #  - perhaps add our own as a default
6587     #  - perhaps adjust it to the corresponding non-source-building version
6588     my $dmode = '-F';
6589     foreach my $l ($cmd, $xargs) {
6590         next unless $l;
6591         @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6592     }
6593     push @$cmd, '-nc';
6594 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6595     my $r = WANTSRC_BUILDER;
6596     printdebug "massage split $dmode.\n";
6597     if ($dmode =~ s/^--build=//) {
6598         $r = 0;
6599         my @d = split /,/, $dmode;
6600         $r |= WANTSRC_SOURCE  if grep { s/^full$/binary/ } @d;
6601         $r |= WANTSRC_SOURCE  if grep { s/^source$// } @d;
6602         $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6603         fail __ "Wanted to build nothing!" unless $r;
6604         $dmode = '--build='. join ',', grep m/./, @d;
6605     } else {
6606         $r =
6607           $dmode =~ m/[S]/     ?  WANTSRC_SOURCE :
6608           $dmode =~ y/gGF/ABb/ ?  WANTSRC_SOURCE | WANTSRC_BUILDER :
6609           $dmode =~ m/[ABb]/   ?                   WANTSRC_BUILDER :
6610           confess "$dmode ?";
6611     }
6612     printdebug "massage done $r $dmode.\n";
6613     push @$cmd, $dmode;
6614 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6615     return $r;
6616 }
6617
6618 sub in_bpd (&) {
6619     my ($fn) = @_;
6620     my $wasdir = must_getcwd();
6621     changedir $buildproductsdir;
6622     $fn->();
6623     changedir $wasdir;
6624 }
6625
6626 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6627 sub postbuild_mergechanges ($) {
6628     my ($msg_if_onlyone) = @_;
6629     # If there is only one .changes file, fail with $msg_if_onlyone,
6630     # or if that is undef, be a no-op.
6631     # Returns the changes file to report to the user.
6632     my $pat = changespat $version;
6633     my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6634     @changesfiles = sort {
6635         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6636             or $a cmp $b
6637     } @changesfiles;
6638     my $result;
6639     if (@changesfiles==1) {
6640         fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6641 only one changes file from build (%s)
6642 END
6643             if defined $msg_if_onlyone;
6644         $result = $changesfiles[0];
6645     } elsif (@changesfiles==2) {
6646         my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6647         foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6648             fail f_ "%s found in binaries changes file %s", $l, $binchanges
6649                 if $l =~ m/\.dsc$/;
6650         }
6651         runcmd_ordryrun_local @mergechanges, @changesfiles;
6652         my $multichanges = changespat $version,'multi';
6653         if (act_local()) {
6654             stat_exists $multichanges or fail f_
6655                 "%s unexpectedly not created by build", $multichanges;
6656             foreach my $cf (glob $pat) {
6657                 next if $cf eq $multichanges;
6658                 rename "$cf", "$cf.inmulti" or fail f_
6659                     "install new changes %s\{,.inmulti}: %s", $cf, $!;
6660             }
6661         }
6662         $result = $multichanges;
6663     } else {
6664         fail f_ "wrong number of different changes files (%s)",
6665                 "@changesfiles";
6666     }
6667     printdone f_ "build successful, results in %s\n", $result
6668         or confess "$!";
6669 }
6670
6671 sub midbuild_checkchanges () {
6672     my $pat = changespat $version;
6673     return if $rmchanges;
6674     my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6675     @unwanted = grep {
6676         $_ ne changespat $version,'source' and
6677         $_ ne changespat $version,'multi'
6678     } @unwanted;
6679     fail +(f_ <<END, $pat, "@unwanted")
6680 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6681 Suggest you delete %s.
6682 END
6683         if @unwanted;
6684 }
6685
6686 sub midbuild_checkchanges_vanilla ($) {
6687     my ($wantsrc) = @_;
6688     midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6689 }
6690
6691 sub postbuild_mergechanges_vanilla ($) {
6692     my ($wantsrc) = @_;
6693     if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6694         in_bpd {
6695             postbuild_mergechanges(undef);
6696         };
6697     } else {
6698         printdone __ "build successful\n";
6699     }
6700 }
6701
6702 sub cmd_build {
6703     build_prep_early();
6704     $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6705 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6706 %s: warning: build-products-dir will be ignored; files will go to ..
6707 END
6708     $buildproductsdir = '..';
6709     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6710     my $wantsrc = massage_dbp_args \@dbp;
6711     build_prep($wantsrc);
6712     if ($wantsrc & WANTSRC_SOURCE) {
6713         build_source();
6714         midbuild_checkchanges_vanilla $wantsrc;
6715     }
6716     if ($wantsrc & WANTSRC_BUILDER) {
6717         push @dbp, changesopts_version();
6718         maybe_apply_patches_dirtily();
6719         runcmd_ordryrun_local @dbp;
6720     }
6721     maybe_unapply_patches_again();
6722     postbuild_mergechanges_vanilla $wantsrc;
6723 }
6724
6725 sub pre_gbp_build {
6726     $quilt_mode //= 'gbp';
6727 }
6728
6729 sub cmd_gbp_build {
6730     build_prep_early();
6731
6732     # gbp can make .origs out of thin air.  In my tests it does this
6733     # even for a 1.0 format package, with no origs present.  So I
6734     # guess it keys off just the version number.  We don't know
6735     # exactly what .origs ought to exist, but let's assume that we
6736     # should run gbp if: the version has an upstream part and the main
6737     # orig is absent.
6738     my $upstreamversion = upstreamversion $version;
6739     my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6740     my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6741
6742     if ($gbp_make_orig) {
6743         clean_tree();
6744         $cleanmode = 'none'; # don't do it again
6745     }
6746
6747     my @dbp = @dpkgbuildpackage;
6748
6749     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6750
6751     if (!length $gbp_build[0]) {
6752         if (length executable_on_path('git-buildpackage')) {
6753             $gbp_build[0] = qw(git-buildpackage);
6754         } else {
6755             $gbp_build[0] = 'gbp buildpackage';
6756         }
6757     }
6758     my @cmd = opts_opt_multi_cmd [], @gbp_build;
6759
6760     push @cmd, (qw(-us -uc --git-no-sign-tags),
6761                 "--git-builder=".(shellquote @dbp));
6762
6763     if ($gbp_make_orig) {
6764         my $priv = dgit_privdir();
6765         my $ok = "$priv/origs-gen-ok";
6766         unlink $ok or $!==&ENOENT or confess "$!";
6767         my @origs_cmd = @cmd;
6768         push @origs_cmd, qw(--git-cleaner=true);
6769         push @origs_cmd, "--git-prebuild=".
6770             "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6771         push @origs_cmd, @ARGV;
6772         if (act_local()) {
6773             debugcmd @origs_cmd;
6774             system @origs_cmd;
6775             do { local $!; stat_exists $ok; }
6776                 or failedcmd @origs_cmd;
6777         } else {
6778             dryrun_report @origs_cmd;
6779         }
6780     }
6781
6782     build_prep($wantsrc);
6783     if ($wantsrc & WANTSRC_SOURCE) {
6784         build_source();
6785         midbuild_checkchanges_vanilla $wantsrc;
6786     } else {
6787         push @cmd, '--git-cleaner=true';
6788     }
6789     maybe_unapply_patches_again();
6790     if ($wantsrc & WANTSRC_BUILDER) {
6791         push @cmd, changesopts();
6792         runcmd_ordryrun_local @cmd, @ARGV;
6793     }
6794     postbuild_mergechanges_vanilla $wantsrc;
6795 }
6796 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6797
6798 sub building_source_in_playtree {
6799     # If $includedirty, we have to build the source package from the
6800     # working tree, not a playtree, so that uncommitted changes are
6801     # included (copying or hardlinking them into the playtree could
6802     # cause trouble).
6803     #
6804     # Note that if we are building a source package in split brain
6805     # mode we do not support including uncommitted changes, because
6806     # that makes quilt fixup too hard.  I.e. ($made_split_brain && (dgit is
6807     # building a source package)) => !$includedirty
6808     return !$includedirty;
6809 }
6810
6811 sub build_source {
6812     $sourcechanges = changespat $version,'source';
6813     if (act_local()) {
6814         unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6815             or fail f_ "remove %s: %s", $sourcechanges, $!;
6816     }
6817 #    confess unless !!$made_split_brain == do_split_brain();
6818
6819     my @cmd = (@dpkgsource, qw(-b --));
6820     my $leafdir;
6821     if (building_source_in_playtree()) {
6822         $leafdir = 'work';
6823         my $headref = git_rev_parse('HEAD');
6824         # If we are in split brain, there is already a playtree with
6825         # the thing we should package into a .dsc (thanks to quilt
6826         # fixup).  If not, make a playtree
6827         prep_ud() unless $made_split_brain;
6828         changedir $playground;
6829         unless ($made_split_brain) {
6830             my $upstreamversion = upstreamversion $version;
6831             unpack_playtree_linkorigs($upstreamversion, sub { });
6832             unpack_playtree_need_cd_work($headref);
6833             changedir '..';
6834         }
6835     } else {
6836         $leafdir = basename $maindir;
6837
6838         if ($buildproductsdir ne '..') {
6839             # Well, we are going to run dpkg-source -b which consumes
6840             # origs from .. and generates output there.  To make this
6841             # work when the bpd is not .. , we would have to (i) link
6842             # origs from bpd to .. , (ii) check for files that
6843             # dpkg-source -b would/might overwrite, and afterwards
6844             # (iii) move all the outputs back to the bpd (iv) except
6845             # for the origs which should be deleted from .. if they
6846             # weren't there beforehand.  And if there is an error and
6847             # we don't run to completion we would necessarily leave a
6848             # mess.  This is too much.  The real way to fix this
6849             # is for dpkg-source to have bpd support.
6850             confess unless $includedirty;
6851             fail __
6852  "--include-dirty not supported with --build-products-dir, sorry";
6853         }
6854
6855         changedir '..';
6856     }
6857     runcmd_ordryrun_local @cmd, $leafdir;
6858
6859     changedir $leafdir;
6860     runcmd_ordryrun_local qw(sh -ec),
6861       'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6862       @dpkggenchanges, qw(-S), changesopts();
6863     changedir '..';
6864
6865     printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6866     $dsc = parsecontrol($dscfn, "source package");
6867
6868     my $mv = sub {
6869         my ($why, $l) = @_;
6870         printdebug " renaming ($why) $l\n";
6871         rename_link_xf 0, "$l", bpd_abs()."/$l"
6872             or fail f_ "put in place new built file (%s): %s", $l, $@;
6873     };
6874     foreach my $l (split /\n/, getfield $dsc, 'Files') {
6875         $l =~ m/\S+$/ or next;
6876         $mv->('Files', $&);
6877     }
6878     $mv->('dsc', $dscfn);
6879     $mv->('changes', $sourcechanges);
6880
6881     changedir $maindir;
6882 }
6883
6884 sub cmd_build_source {
6885     badusage __ "build-source takes no additional arguments" if @ARGV;
6886     build_prep(WANTSRC_SOURCE);
6887     build_source();
6888     maybe_unapply_patches_again();
6889     printdone f_ "source built, results in %s and %s",
6890                  $dscfn, $sourcechanges;
6891 }
6892
6893 sub cmd_push_source {
6894     prep_push();
6895     fail __
6896         "dgit push-source: --include-dirty/--ignore-dirty does not make".
6897         "sense with push-source!"
6898         if $includedirty;
6899     build_check_quilt_splitbrain();
6900     if ($changesfile) {
6901         my $changes = parsecontrol("$buildproductsdir/$changesfile",
6902                                    __ "source changes file");
6903         unless (test_source_only_changes($changes)) {
6904             fail __ "user-specified changes file is not source-only";
6905         }
6906     } else {
6907         # Building a source package is very fast, so just do it
6908         build_source();
6909         confess "er, patches are applied dirtily but shouldn't be.."
6910             if $patches_applied_dirtily;
6911         $changesfile = $sourcechanges;
6912     }
6913     dopush();
6914 }
6915
6916 sub binary_builder {
6917     my ($bbuilder, $pbmc_msg, @args) = @_;
6918     build_prep(WANTSRC_SOURCE);
6919     build_source();
6920     midbuild_checkchanges();
6921     in_bpd {
6922         if (act_local()) {
6923             stat_exists $dscfn or fail f_
6924                 "%s (in build products dir): %s", $dscfn, $!;
6925             stat_exists $sourcechanges or fail f_
6926                 "%s (in build products dir): %s", $sourcechanges, $!;
6927         }
6928         runcmd_ordryrun_local @$bbuilder, @args;
6929     };
6930     maybe_unapply_patches_again();
6931     in_bpd {
6932         postbuild_mergechanges($pbmc_msg);
6933     };
6934 }
6935
6936 sub cmd_sbuild {
6937     build_prep_early();
6938     binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6939 perhaps you need to pass -A ?  (sbuild's default is to build only
6940 arch-specific binaries; dgit 1.4 used to override that.)
6941 END
6942 }
6943
6944 sub pbuilder ($) {
6945     my ($pbuilder) = @_;
6946     build_prep_early();
6947     # @ARGV is allowed to contain only things that should be passed to
6948     # pbuilder under debbuildopts; just massage those
6949     my $wantsrc = massage_dbp_args \@ARGV;
6950     fail __
6951         "you asked for a builder but your debbuildopts didn't ask for".
6952         " any binaries -- is this really what you meant?"
6953         unless $wantsrc & WANTSRC_BUILDER;
6954     fail __
6955         "we must build a .dsc to pass to the builder but your debbuiltopts".
6956         " forbids the building of a source package; cannot continue"
6957       unless $wantsrc & WANTSRC_SOURCE;
6958     # We do not want to include the verb "build" in @pbuilder because
6959     # the user can customise @pbuilder and they shouldn't be required
6960     # to include "build" in their customised value.  However, if the
6961     # user passes any additional args to pbuilder using the dgit
6962     # option --pbuilder:foo, such args need to come after the "build"
6963     # verb.  opts_opt_multi_cmd does all of that.
6964     binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6965                    qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6966                    $dscfn);
6967 }
6968
6969 sub cmd_pbuilder {
6970     pbuilder(\@pbuilder);
6971 }
6972
6973 sub cmd_cowbuilder {
6974     pbuilder(\@cowbuilder);
6975 }
6976
6977 sub cmd_quilt_fixup {
6978     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6979     build_prep_early();
6980     clean_tree();
6981     build_maybe_quilt_fixup();
6982 }
6983
6984 sub cmd_print_unapplied_treeish {
6985     badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6986         if @ARGV;
6987     my $headref = git_rev_parse('HEAD');
6988     my $clogp = commit_getclogp $headref;
6989     $package = getfield $clogp, 'Source';
6990     $version = getfield $clogp, 'Version';
6991     $isuite = getfield $clogp, 'Distribution';
6992     $csuite = $isuite; # we want this to be offline!
6993     notpushing();
6994
6995     prep_ud();
6996     changedir $playground;
6997     my $uv = upstreamversion $version;
6998     my $u = quilt_fakedsc2unapplied($headref, $uv);
6999     print $u, "\n" or confess "$!";
7000 }
7001
7002 sub import_dsc_result {
7003     my ($dstref, $newhash, $what_log, $what_msg) = @_;
7004     my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
7005     runcmd @cmd;
7006     check_gitattrs($newhash, __ "source tree");
7007
7008     progress f_ "dgit: import-dsc: %s", $what_msg;
7009 }
7010
7011 sub cmd_import_dsc {
7012     my $needsig = 0;
7013
7014     while (@ARGV) {
7015         last unless $ARGV[0] =~ m/^-/;
7016         $_ = shift @ARGV;
7017         last if m/^--?$/;
7018         if (m/^--require-valid-signature$/) {
7019             $needsig = 1;
7020         } else {
7021             badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
7022         }
7023     }
7024
7025     badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
7026         unless @ARGV==2;
7027     my ($dscfn, $dstbranch) = @ARGV;
7028
7029     badusage __ "dry run makes no sense with import-dsc"
7030         unless act_local();
7031
7032     my $force = $dstbranch =~ s/^\+//   ? +1 :
7033                 $dstbranch =~ s/^\.\.// ? -1 :
7034                                            0;
7035     my $info = $force ? " $&" : '';
7036     $info = "$dscfn$info";
7037
7038     my $specbranch = $dstbranch;
7039     $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
7040     $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
7041
7042     my @symcmd = (@git, qw(symbolic-ref -q HEAD));
7043     my $chead = cmdoutput_errok @symcmd;
7044     defined $chead or $?==256 or failedcmd @symcmd;
7045
7046     fail f_ "%s is checked out - will not update it", $dstbranch
7047         if defined $chead and $chead eq $dstbranch;
7048
7049     my $oldhash = git_get_ref $dstbranch;
7050
7051     open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
7052     $dscdata = do { local $/ = undef; <D>; };
7053     D->error and fail f_ "read %s: %s", $dscfn, $!;
7054     close C;
7055
7056     # we don't normally need this so import it here
7057     use Dpkg::Source::Package;
7058     my $dp = new Dpkg::Source::Package filename => $dscfn,
7059         require_valid_signature => $needsig;
7060     {
7061         local $SIG{__WARN__} = sub {
7062             print STDERR $_[0];
7063             return unless $needsig;
7064             fail __ "import-dsc signature check failed";
7065         };
7066         if (!$dp->is_signed()) {
7067             warn f_ "%s: warning: importing unsigned .dsc\n", $us;
7068         } else {
7069             my $r = $dp->check_signature();
7070             confess "->check_signature => $r" if $needsig && $r;
7071         }
7072     }
7073
7074     parse_dscdata();
7075
7076     $package = getfield $dsc, 'Source';
7077
7078     parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
7079         unless forceing [qw(import-dsc-with-dgit-field)];
7080     parse_dsc_field_def_dsc_distro();
7081
7082     $isuite = 'DGIT-IMPORT-DSC';
7083     $idistro //= $dsc_distro;
7084
7085     notpushing();
7086
7087     if (defined $dsc_hash) {
7088         progress __
7089             "dgit: import-dsc of .dsc with Dgit field, using git hash";
7090         resolve_dsc_field_commit undef, undef;
7091     }
7092     if (defined $dsc_hash) {
7093         my @cmd = (qw(sh -ec),
7094                    "echo $dsc_hash | git cat-file --batch-check");
7095         my $objgot = cmdoutput @cmd;
7096         if ($objgot =~ m#^\w+ missing\b#) {
7097             fail f_ <<END, $dsc_hash
7098 .dsc contains Dgit field referring to object %s
7099 Your git tree does not have that object.  Try `git fetch' from a
7100 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
7101 END
7102         }
7103         if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
7104             if ($force > 0) {
7105                 progress __ "Not fast forward, forced update.";
7106             } else {
7107                 fail f_ "Not fast forward to %s", $dsc_hash;
7108             }
7109         }
7110         import_dsc_result $dstbranch, $dsc_hash,
7111             "dgit import-dsc (Dgit): $info",
7112             f_ "updated git ref %s", $dstbranch;
7113         return 0;
7114     }
7115
7116     fail f_ <<END, $dstbranch, $specbranch, $specbranch
7117 Branch %s already exists
7118 Specify ..%s for a pseudo-merge, binding in existing history
7119 Specify  +%s to overwrite, discarding existing history
7120 END
7121         if $oldhash && !$force;
7122
7123     my @dfi = dsc_files_info();
7124     foreach my $fi (@dfi) {
7125         my $f = $fi->{Filename};
7126         # We transfer all the pieces of the dsc to the bpd, not just
7127         # origs.  This is by analogy with dgit fetch, which wants to
7128         # keep them somewhere to avoid downloading them again.
7129         # We make symlinks, though.  If the user wants copies, then
7130         # they can copy the parts of the dsc to the bpd using dcmd,
7131         # or something.
7132         my $here = "$buildproductsdir/$f";
7133         if (lstat $here) {
7134             if (stat $here) {
7135                 next;
7136             }
7137             fail f_ "lstat %s works but stat gives %s !", $here, $!;
7138         }
7139         fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7140         printdebug "not in bpd, $f ...\n";
7141         # $f does not exist in bpd, we need to transfer it
7142         my $there = $dscfn;
7143         $there =~ s{[^/]+$}{$f} or confess "$there ?";
7144         # $there is file we want, relative to user's cwd, or abs
7145         printdebug "not in bpd, $f, test $there ...\n";
7146         stat $there or fail f_
7147             "import %s requires %s, but: %s", $dscfn, $there, $!;
7148         if ($there =~ m#^(?:\./+)?\.\./+#) {
7149             # $there is relative to user's cwd
7150             my $there_from_parent = $';
7151             if ($buildproductsdir !~ m{^/}) {
7152                 # abs2rel, despite its name, can take two relative paths
7153                 $there = File::Spec->abs2rel($there,$buildproductsdir);
7154                 # now $there is relative to bpd, great
7155                 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7156             } else {
7157                 $there = (dirname $maindir)."/$there_from_parent";
7158                 # now $there is absoute
7159                 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7160             }
7161         } elsif ($there =~ m#^/#) {
7162             # $there is absolute already
7163             printdebug "not in bpd, $f, abs, $there ...\n";
7164         } else {
7165             fail f_
7166                 "cannot import %s which seems to be inside working tree!",
7167                 $dscfn;
7168         }
7169         symlink $there, $here or fail f_
7170             "symlink %s to %s: %s", $there, $here, $!;
7171         progress f_ "made symlink %s -> %s", $here, $there;
7172 #       print STDERR Dumper($fi);
7173     }
7174     my @mergeinputs = generate_commits_from_dsc();
7175     die unless @mergeinputs == 1;
7176
7177     my $newhash = $mergeinputs[0]{Commit};
7178
7179     if ($oldhash) {
7180         if ($force > 0) {
7181             progress __
7182                 "Import, forced update - synthetic orphan git history.";
7183         } elsif ($force < 0) {
7184             progress __ "Import, merging.";
7185             my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7186             my $version = getfield $dsc, 'Version';
7187             my $clogp = commit_getclogp $newhash;
7188             my $authline = clogp_authline $clogp;
7189             $newhash = hash_commit_text <<ENDU
7190 tree $tree
7191 parent $newhash
7192 parent $oldhash
7193 author $authline
7194 committer $authline
7195
7196 ENDU
7197                 .(f_ <<END, $package, $version, $dstbranch);
7198 Merge %s (%s) import into %s
7199 END
7200         } else {
7201             die; # caught earlier
7202         }
7203     }
7204
7205     import_dsc_result $dstbranch, $newhash,
7206         "dgit import-dsc: $info",
7207         f_ "results are in git ref %s", $dstbranch;
7208 }
7209
7210 sub pre_archive_api_query () {
7211     not_necessarily_a_tree();
7212 }
7213 sub cmd_archive_api_query {
7214     badusage __ "need only 1 subpath argument" unless @ARGV==1;
7215     my ($subpath) = @ARGV;
7216     local $isuite = 'DGIT-API-QUERY-CMD';
7217     my @cmd = archive_api_query_cmd($subpath);
7218     push @cmd, qw(-f);
7219     debugcmd ">",@cmd;
7220     exec @cmd or fail f_ "exec curl: %s\n", $!;
7221 }
7222
7223 sub repos_server_url () {
7224     $package = '_dgit-repos-server';
7225     local $access_forpush = 1;
7226     local $isuite = 'DGIT-REPOS-SERVER';
7227     my $url = access_giturl();
7228 }
7229
7230 sub pre_clone_dgit_repos_server () {
7231     not_necessarily_a_tree();
7232 }
7233 sub cmd_clone_dgit_repos_server {
7234     badusage __ "need destination argument" unless @ARGV==1;
7235     my ($destdir) = @ARGV;
7236     my $url = repos_server_url();
7237     my @cmd = (@git, qw(clone), $url, $destdir);
7238     debugcmd ">",@cmd;
7239     exec @cmd or fail f_ "exec git clone: %s\n", $!;
7240 }
7241
7242 sub pre_print_dgit_repos_server_source_url () {
7243     not_necessarily_a_tree();
7244 }
7245 sub cmd_print_dgit_repos_server_source_url {
7246     badusage __
7247         "no arguments allowed to dgit print-dgit-repos-server-source-url"
7248         if @ARGV;
7249     my $url = repos_server_url();
7250     print $url, "\n" or confess "$!";
7251 }
7252
7253 sub pre_print_dpkg_source_ignores {
7254     not_necessarily_a_tree();
7255 }
7256 sub cmd_print_dpkg_source_ignores {
7257     badusage __
7258         "no arguments allowed to dgit print-dpkg-source-ignores"
7259         if @ARGV;
7260     print "@dpkg_source_ignores\n" or confess "$!";
7261 }
7262
7263 sub cmd_setup_mergechangelogs {
7264     badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7265         if @ARGV;
7266     local $isuite = 'DGIT-SETUP-TREE';
7267     setup_mergechangelogs(1);
7268 }
7269
7270 sub cmd_setup_useremail {
7271     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7272     local $isuite = 'DGIT-SETUP-TREE';
7273     setup_useremail(1);
7274 }
7275
7276 sub cmd_setup_gitattributes {
7277     badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7278     local $isuite = 'DGIT-SETUP-TREE';
7279     setup_gitattrs(1);
7280 }
7281
7282 sub cmd_setup_new_tree {
7283     badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7284     local $isuite = 'DGIT-SETUP-TREE';
7285     setup_new_tree();
7286 }
7287
7288 #---------- argument parsing and main program ----------
7289
7290 sub cmd_version {
7291     print "dgit version $our_version\n" or confess "$!";
7292     finish 0;
7293 }
7294
7295 our (%valopts_long, %valopts_short);
7296 our (%funcopts_long);
7297 our @rvalopts;
7298 our (@modeopt_cfgs);
7299
7300 sub defvalopt ($$$$) {
7301     my ($long,$short,$val_re,$how) = @_;
7302     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7303     $valopts_long{$long} = $oi;
7304     $valopts_short{$short} = $oi;
7305     # $how subref should:
7306     #   do whatever assignemnt or thing it likes with $_[0]
7307     #   if the option should not be passed on to remote, @rvalopts=()
7308     # or $how can be a scalar ref, meaning simply assign the value
7309 }
7310
7311 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7312 defvalopt '--distro',        '-d', '.+',      \$idistro;
7313 defvalopt '',                '-k', '.+',      \$keyid;
7314 defvalopt '--existing-package','', '.*',      \$existing_package;
7315 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
7316 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
7317 defvalopt '--package',   '-p',   $package_re, \$package;
7318 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
7319
7320 defvalopt '', '-C', '.+', sub {
7321     ($changesfile) = (@_);
7322     if ($changesfile =~ s#^(.*)/##) {
7323         $buildproductsdir = $1;
7324     }
7325 };
7326
7327 defvalopt '--initiator-tempdir','','.*', sub {
7328     ($initiator_tempdir) = (@_);
7329     $initiator_tempdir =~ m#^/# or
7330         badusage __ "--initiator-tempdir must be used specify an".
7331                     " absolute, not relative, directory."
7332 };
7333
7334 sub defoptmodes ($@) {
7335     my ($varref, $cfgkey, $default, %optmap) = @_;
7336     my %permit;
7337     while (my ($opt,$val) = each %optmap) {
7338         $funcopts_long{$opt} = sub { $$varref = $val; };
7339         $permit{$val} = $val;
7340     }
7341     push @modeopt_cfgs, {
7342         Var => $varref,
7343         Key => $cfgkey,
7344         Default => $default,
7345         Vals => \%permit
7346     };
7347 }
7348
7349 defoptmodes \$dodep14tag, qw( dep14tag          want
7350                               --dep14tag        want
7351                               --no-dep14tag     no
7352                               --always-dep14tag always );
7353
7354 sub parseopts () {
7355     my $om;
7356
7357     if (defined $ENV{'DGIT_SSH'}) {
7358         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7359     } elsif (defined $ENV{'GIT_SSH'}) {
7360         @ssh = ($ENV{'GIT_SSH'});
7361     }
7362
7363     my $oi;
7364     my $val;
7365     my $valopt = sub {
7366         my ($what) = @_;
7367         @rvalopts = ($_);
7368         if (!defined $val) {
7369             badusage f_ "%s needs a value", $what unless @ARGV;
7370             $val = shift @ARGV;
7371             push @rvalopts, $val;
7372         }
7373         badusage f_ "bad value \`%s' for %s", $val, $what unless
7374             $val =~ m/^$oi->{Re}$(?!\n)/s;
7375         my $how = $oi->{How};
7376         if (ref($how) eq 'SCALAR') {
7377             $$how = $val;
7378         } else {
7379             $how->($val);
7380         }
7381         push @ropts, @rvalopts;
7382     };
7383
7384     while (@ARGV) {
7385         last unless $ARGV[0] =~ m/^-/;
7386         $_ = shift @ARGV;
7387         last if m/^--?$/;
7388         if (m/^--/) {
7389             if (m/^--dry-run$/) {
7390                 push @ropts, $_;
7391                 $dryrun_level=2;
7392             } elsif (m/^--damp-run$/) {
7393                 push @ropts, $_;
7394                 $dryrun_level=1;
7395             } elsif (m/^--no-sign$/) {
7396                 push @ropts, $_;
7397                 $sign=0;
7398             } elsif (m/^--help$/) {
7399                 cmd_help();
7400             } elsif (m/^--version$/) {
7401                 cmd_version();
7402             } elsif (m/^--new$/) {
7403                 push @ropts, $_;
7404                 $new_package=1;
7405             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7406                      ($om = $opts_opt_map{$1}) &&
7407                      length $om->[0]) {
7408                 push @ropts, $_;
7409                 $om->[0] = $2;
7410             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7411                      !$opts_opt_cmdonly{$1} &&
7412                      ($om = $opts_opt_map{$1})) {
7413                 push @ropts, $_;
7414                 push @$om, $2;
7415             } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7416                      !$opts_opt_cmdonly{$1} &&
7417                      ($om = $opts_opt_map{$1})) {
7418                 push @ropts, $_;
7419                 my $cmd = shift @$om;
7420                 @$om = ($cmd, grep { $_ ne $2 } @$om);
7421             } elsif (m/^--($quilt_options_re)$/s) {
7422                 push @ropts, "--quilt=$1";
7423                 $quilt_mode = $1;
7424             } elsif (m/^--(?:ignore|include)-dirty$/s) {
7425                 push @ropts, $_;
7426                 $includedirty = 1;
7427             } elsif (m/^--no-quilt-fixup$/s) {
7428                 push @ropts, $_;
7429                 $quilt_mode = 'nocheck';
7430             } elsif (m/^--no-rm-on-error$/s) {
7431                 push @ropts, $_;
7432                 $rmonerror = 0;
7433             } elsif (m/^--no-chase-dsc-distro$/s) {
7434                 push @ropts, $_;
7435                 $chase_dsc_distro = 0;
7436             } elsif (m/^--overwrite$/s) {
7437                 push @ropts, $_;
7438                 $overwrite_version = '';
7439             } elsif (m/^--split-(?:view|brain)$/s) {
7440                 push @ropts, $_;
7441                 $splitview_mode = 'always';
7442             } elsif (m/^--split-(?:view|brain)=($splitview_modes_re)$/s) {
7443                 push @ropts, $_;
7444                 $splitview_mode = $1;
7445             } elsif (m/^--overwrite=(.+)$/s) {
7446                 push @ropts, $_;
7447                 $overwrite_version = $1;
7448             } elsif (m/^--delayed=(\d+)$/s) {
7449                 push @ropts, $_;
7450                 push @dput, $_;
7451             } elsif (m/^--upstream-commitish=(.+)$/s) {
7452                 push @ropts, $_;
7453                 $quilt_upstream_commitish = $1;
7454             } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7455                      m/^--(dgit-view)-save=(.+)$/s
7456                      ) {
7457                 my ($k,$v) = ($1,$2);
7458                 push @ropts, $_;
7459                 $v =~ s#^(?!refs/)#refs/heads/#;
7460                 $internal_object_save{$k} = $v;
7461             } elsif (m/^--(no-)?rm-old-changes$/s) {
7462                 push @ropts, $_;
7463                 $rmchanges = !$1;
7464             } elsif (m/^--deliberately-($deliberately_re)$/s) {
7465                 push @ropts, $_;
7466                 push @deliberatelies, $&;
7467             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7468                 push @ropts, $&;
7469                 $forceopts{$1} = 1;
7470                 $_='';
7471             } elsif (m/^--force-/) {
7472                 print STDERR
7473                     f_ "%s: warning: ignoring unknown force option %s\n",
7474                        $us, $_;
7475                 $_='';
7476             } elsif (m/^--config-lookup-explode=(.+)$/s) {
7477                 # undocumented, for testing
7478                 push @ropts, $_;
7479                 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7480                 # ^ it's supposed to be an array ref
7481             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7482                 $val = $2 ? $' : undef; #';
7483                 $valopt->($oi->{Long});
7484             } elsif ($funcopts_long{$_}) {
7485                 push @ropts, $_;
7486                 $funcopts_long{$_}();
7487             } else {
7488                 badusage f_ "unknown long option \`%s'", $_;
7489             }
7490         } else {
7491             while (m/^-./s) {
7492                 if (s/^-n/-/) {
7493                     push @ropts, $&;
7494                     $dryrun_level=2;
7495                 } elsif (s/^-L/-/) {
7496                     push @ropts, $&;
7497                     $dryrun_level=1;
7498                 } elsif (s/^-h/-/) {
7499                     cmd_help();
7500                 } elsif (s/^-D/-/) {
7501                     push @ropts, $&;
7502                     $debuglevel++;
7503                     enabledebug();
7504                 } elsif (s/^-N/-/) {
7505                     push @ropts, $&;
7506                     $new_package=1;
7507                 } elsif (m/^-m/) {
7508                     push @ropts, $&;
7509                     push @changesopts, $_;
7510                     $_ = '';
7511                 } elsif (s/^-wn$//s) {
7512                     push @ropts, $&;
7513                     $cleanmode = 'none';
7514                 } elsif (s/^-wg(f?)(a?)$//s) {
7515                     push @ropts, $&;
7516                     $cleanmode = 'git';
7517                     $cleanmode .= '-ff' if $1;
7518                     $cleanmode .= ',always' if $2;
7519                 } elsif (s/^-wd(d?)([na]?)$//s) {
7520                     push @ropts, $&;
7521                     $cleanmode = 'dpkg-source';
7522                     $cleanmode .= '-d' if $1;
7523                     $cleanmode .= ',no-check' if $2 eq 'n';
7524                     $cleanmode .= ',all-check' if $2 eq 'a';
7525                 } elsif (s/^-wc$//s) {
7526                     push @ropts, $&;
7527                     $cleanmode = 'check';
7528                 } elsif (s/^-wci$//s) {
7529                     push @ropts, $&;
7530                     $cleanmode = 'check,ignores';
7531                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7532                     push @git, '-c', $&;
7533                     $gitcfgs{cmdline}{$1} = [ $2 ];
7534                 } elsif (s/^-c([^=]+)$//s) {
7535                     push @git, '-c', $&;
7536                     $gitcfgs{cmdline}{$1} = [ 'true' ];
7537                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7538                     $val = $'; #';
7539                     $val = undef unless length $val;
7540                     $valopt->($oi->{Short});
7541                     $_ = '';
7542                 } else {
7543                     badusage f_ "unknown short option \`%s'", $_;
7544                 }
7545             }
7546         }
7547     }
7548 }
7549
7550 sub check_env_sanity () {
7551     my $blocked = new POSIX::SigSet;
7552     sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7553
7554     eval {
7555         foreach my $name (qw(PIPE CHLD)) {
7556             my $signame = "SIG$name";
7557             my $signum = eval "POSIX::$signame" // die;
7558             die f_ "%s is set to something other than SIG_DFL\n",
7559                 $signame
7560                 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7561             $blocked->ismember($signum) and
7562                 die f_ "%s is blocked\n", $signame;
7563         }
7564     };
7565     return unless $@;
7566     chomp $@;
7567     fail f_ <<END, $@;
7568 On entry to dgit, %s
7569 This is a bug produced by something in your execution environment.
7570 Giving up.
7571 END
7572 }
7573
7574
7575 sub parseopts_late_defaults () {
7576     $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7577         if defined $idistro;
7578     $isuite //= cfg('dgit.default.default-suite');
7579
7580     foreach my $k (keys %opts_opt_map) {
7581         my $om = $opts_opt_map{$k};
7582
7583         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7584         if (defined $v) {
7585             badcfg f_ "cannot set command for %s", $k
7586                 unless length $om->[0];
7587             $om->[0] = $v;
7588         }
7589
7590         foreach my $c (access_cfg_cfgs("opts-$k")) {
7591             my @vl =
7592                 map { $_ ? @$_ : () }
7593                 map { $gitcfgs{$_}{$c} }
7594                 reverse @gitcfgsources;
7595             printdebug "CL $c ", (join " ", map { shellquote } @vl),
7596                 "\n" if $debuglevel >= 4;
7597             next unless @vl;
7598             badcfg f_ "cannot configure options for %s", $k
7599                 if $opts_opt_cmdonly{$k};
7600             my $insertpos = $opts_cfg_insertpos{$k};
7601             @$om = ( @$om[0..$insertpos-1],
7602                      @vl,
7603                      @$om[$insertpos..$#$om] );
7604         }
7605     }
7606
7607     if (!defined $rmchanges) {
7608         local $access_forpush;
7609         $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7610     }
7611
7612     if (!defined $quilt_mode) {
7613         local $access_forpush;
7614         $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7615             // access_cfg('quilt-mode', 'RETURN-UNDEF')
7616             // 'linear';
7617         $quilt_mode =~ m/^($quilt_modes_re)$/
7618             or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7619         $quilt_mode = $1;
7620     }
7621
7622     foreach my $moc (@modeopt_cfgs) {
7623         local $access_forpush;
7624         my $vr = $moc->{Var};
7625         next if defined $$vr;
7626         $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7627         my $v = $moc->{Vals}{$$vr};
7628         badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7629             unless defined $v;
7630         $$vr = $v;
7631     }
7632
7633     {
7634         local $access_forpush;
7635         default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7636                                 $cleanmode_re);
7637     }
7638
7639     $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7640     $buildproductsdir //= '..';
7641     $bpd_glob = $buildproductsdir;
7642     $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7643 }
7644
7645 setlocale(LC_MESSAGES, "");
7646 textdomain("dgit");
7647
7648 if ($ENV{$fakeeditorenv}) {
7649     git_slurp_config();
7650     quilt_fixup_editor();
7651 }
7652
7653 parseopts();
7654 check_env_sanity();
7655
7656 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7657 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7658     if $dryrun_level == 1;
7659 if (!@ARGV) {
7660     print STDERR __ $helpmsg or confess "$!";
7661     finish 8;
7662 }
7663 $cmd = $subcommand = shift @ARGV;
7664 $cmd =~ y/-/_/;
7665
7666 my $pre_fn = ${*::}{"pre_$cmd"};
7667 $pre_fn->() if $pre_fn;
7668
7669 if ($invoked_in_git_tree) {
7670     changedir_git_toplevel();
7671     record_maindir();
7672 }
7673 git_slurp_config();
7674
7675 my $fn = ${*::}{"cmd_$cmd"};
7676 $fn or badusage f_ "unknown operation %s", $cmd;
7677 $fn->();
7678
7679 finish 0;