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