dgit

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