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