dgit

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