dgit

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