dgit

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