dgit

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