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