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