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