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