dgit

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