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