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