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 $branch = git_get_symref();
4448     if (defined $branch && $branch =~ m#$lbranch_re#o) {
4449         return $1;
4450     } else {
4451         return undef;
4452     }
4453 }
4454
4455 sub fetchpullargs () {
4456     if (!defined $package) {
4457         my $sourcep = parsecontrol('debian/control','debian/control');
4458         $package = getfield $sourcep, 'Source';
4459     }
4460     if (@ARGV==0) {
4461         $isuite = branchsuite();
4462         if (!$isuite) {
4463             my $clogp = parsechangelog();
4464             my $clogsuite = getfield $clogp, 'Distribution';
4465             $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4466         }
4467     } elsif (@ARGV==1) {
4468         ($isuite) = @ARGV;
4469     } else {
4470         badusage "incorrect arguments to dgit fetch or dgit pull";
4471     }
4472     notpushing();
4473 }
4474
4475 sub cmd_fetch {
4476     parseopts();
4477     fetchpullargs();
4478     my $multi_fetched = fork_for_multisuite(sub { });
4479     exit 0 if $multi_fetched;
4480     fetch();
4481 }
4482
4483 sub cmd_pull {
4484     parseopts();
4485     fetchpullargs();
4486     if (quiltmode_splitbrain()) {
4487         my ($format, $fopts) = get_source_format();
4488         madformat($format) and fail <<END
4489 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4490 END
4491     }
4492     pull();
4493 }
4494
4495 sub prep_push () {
4496     parseopts();
4497     build_or_push_prep_early();
4498     pushing();
4499     check_not_dirty();
4500     my $specsuite;
4501     if (@ARGV==0) {
4502     } elsif (@ARGV==1) {
4503         ($specsuite) = (@ARGV);
4504     } else {
4505         badusage "incorrect arguments to dgit $subcommand";
4506     }
4507     if ($new_package) {
4508         local ($package) = $existing_package; # this is a hack
4509         canonicalise_suite();
4510     } else {
4511         canonicalise_suite();
4512     }
4513     if (defined $specsuite &&
4514         $specsuite ne $isuite &&
4515         $specsuite ne $csuite) {
4516             fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4517                 " but command line specifies $specsuite";
4518     }
4519 }
4520
4521 sub cmd_push {
4522     prep_push();
4523     dopush();
4524 }
4525
4526 #---------- remote commands' implementation ----------
4527
4528 sub pre_remote_push_build_host {
4529     my ($nrargs) = shift @ARGV;
4530     my (@rargs) = @ARGV[0..$nrargs-1];
4531     @ARGV = @ARGV[$nrargs..$#ARGV];
4532     die unless @rargs;
4533     my ($dir,$vsnwant) = @rargs;
4534     # vsnwant is a comma-separated list; we report which we have
4535     # chosen in our ready response (so other end can tell if they
4536     # offered several)
4537     $debugprefix = ' ';
4538     $we_are_responder = 1;
4539     $us .= " (build host)";
4540
4541     open PI, "<&STDIN" or die $!;
4542     open STDIN, "/dev/null" or die $!;
4543     open PO, ">&STDOUT" or die $!;
4544     autoflush PO 1;
4545     open STDOUT, ">&STDERR" or die $!;
4546     autoflush STDOUT 1;
4547
4548     $vsnwant //= 1;
4549     ($protovsn) = grep {
4550         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4551     } @rpushprotovsn_support;
4552
4553     fail "build host has dgit rpush protocol versions ".
4554         (join ",", @rpushprotovsn_support).
4555         " but invocation host has $vsnwant"
4556         unless defined $protovsn;
4557
4558     changedir $dir;
4559 }
4560 sub cmd_remote_push_build_host {
4561     responder_send_command("dgit-remote-push-ready $protovsn");
4562     &cmd_push;
4563 }
4564
4565 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4566 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4567 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4568 #     a good error message)
4569
4570 sub rpush_handle_protovsn_bothends () {
4571     if ($protovsn < 4) {
4572         need_tagformat 'old', "rpush negotiated protocol $protovsn";
4573     }
4574     select_tagformat();
4575 }
4576
4577 our $i_tmp;
4578
4579 sub i_cleanup {
4580     local ($@, $?);
4581     my $report = i_child_report();
4582     if (defined $report) {
4583         printdebug "($report)\n";
4584     } elsif ($i_child_pid) {
4585         printdebug "(killing build host child $i_child_pid)\n";
4586         kill 15, $i_child_pid;
4587     }
4588     if (defined $i_tmp && !defined $initiator_tempdir) {
4589         changedir "/";
4590         eval { rmtree $i_tmp; };
4591     }
4592 }
4593
4594 END {
4595     return unless forkcheck_mainprocess();
4596     i_cleanup();
4597 }
4598
4599 sub i_method {
4600     my ($base,$selector,@args) = @_;
4601     $selector =~ s/\-/_/g;
4602     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4603 }
4604
4605 sub pre_rpush () {
4606     not_necessarily_a_tree();
4607 }
4608 sub cmd_rpush {
4609     my $host = nextarg;
4610     my $dir;
4611     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4612         $host = $1;
4613         $dir = $'; #';
4614     } else {
4615         $dir = nextarg;
4616     }
4617     $dir =~ s{^-}{./-};
4618     my @rargs = ($dir);
4619     push @rargs, join ",", @rpushprotovsn_support;
4620     my @rdgit;
4621     push @rdgit, @dgit;
4622     push @rdgit, @ropts;
4623     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4624     push @rdgit, @ARGV;
4625     my @cmd = (@ssh, $host, shellquote @rdgit);
4626     debugcmd "+",@cmd;
4627
4628     $we_are_initiator=1;
4629
4630     if (defined $initiator_tempdir) {
4631         rmtree $initiator_tempdir;
4632         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4633         $i_tmp = $initiator_tempdir;
4634     } else {
4635         $i_tmp = tempdir();
4636     }
4637     $i_child_pid = open2(\*RO, \*RI, @cmd);
4638     changedir $i_tmp;
4639     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4640     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4641     $supplementary_message = '' unless $protovsn >= 3;
4642
4643     for (;;) {
4644         my ($icmd,$iargs) = initiator_expect {
4645             m/^(\S+)(?: (.*))?$/;
4646             ($1,$2);
4647         };
4648         i_method "i_resp", $icmd, $iargs;
4649     }
4650 }
4651
4652 sub i_resp_progress ($) {
4653     my ($rhs) = @_;
4654     my $msg = protocol_read_bytes \*RO, $rhs;
4655     progress $msg;
4656 }
4657
4658 sub i_resp_supplementary_message ($) {
4659     my ($rhs) = @_;
4660     $supplementary_message = protocol_read_bytes \*RO, $rhs;
4661 }
4662
4663 sub i_resp_complete {
4664     my $pid = $i_child_pid;
4665     $i_child_pid = undef; # prevents killing some other process with same pid
4666     printdebug "waiting for build host child $pid...\n";
4667     my $got = waitpid $pid, 0;
4668     die $! unless $got == $pid;
4669     die "build host child failed $?" if $?;
4670
4671     i_cleanup();
4672     printdebug "all done\n";
4673     exit 0;
4674 }
4675
4676 sub i_resp_file ($) {
4677     my ($keyword) = @_;
4678     my $localname = i_method "i_localname", $keyword;
4679     my $localpath = "$i_tmp/$localname";
4680     stat_exists $localpath and
4681         badproto \*RO, "file $keyword ($localpath) twice";
4682     protocol_receive_file \*RO, $localpath;
4683     i_method "i_file", $keyword;
4684 }
4685
4686 our %i_param;
4687
4688 sub i_resp_param ($) {
4689     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4690     $i_param{$1} = $2;
4691 }
4692
4693 sub i_resp_previously ($) {
4694     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4695         or badproto \*RO, "bad previously spec";
4696     my $r = system qw(git check-ref-format), $1;
4697     die "bad previously ref spec ($r)" if $r;
4698     $previously{$1} = $2;
4699 }
4700
4701 our %i_wanted;
4702
4703 sub i_resp_want ($) {
4704     my ($keyword) = @_;
4705     die "$keyword ?" if $i_wanted{$keyword}++;
4706
4707     defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4708     $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4709     die unless $isuite =~ m/^$suite_re$/;
4710
4711     pushing();
4712     rpush_handle_protovsn_bothends();
4713
4714     fail "rpush negotiated protocol version $protovsn".
4715         " which does not support quilt mode $quilt_mode"
4716         if quiltmode_splitbrain;
4717
4718     my @localpaths = i_method "i_want", $keyword;
4719     printdebug "[[  $keyword @localpaths\n";
4720     foreach my $localpath (@localpaths) {
4721         protocol_send_file \*RI, $localpath;
4722     }
4723     print RI "files-end\n" or die $!;
4724 }
4725
4726 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
4727
4728 sub i_localname_parsed_changelog {
4729     return "remote-changelog.822";
4730 }
4731 sub i_file_parsed_changelog {
4732     ($i_clogp, $i_version, $i_dscfn) =
4733         push_parse_changelog "$i_tmp/remote-changelog.822";
4734     die if $i_dscfn =~ m#/|^\W#;
4735 }
4736
4737 sub i_localname_dsc {
4738     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4739     return $i_dscfn;
4740 }
4741 sub i_file_dsc { }
4742
4743 sub i_localname_buildinfo ($) {
4744     my $bi = $i_param{'buildinfo-filename'};
4745     defined $bi or badproto \*RO, "buildinfo before filename";
4746     defined $i_changesfn or badproto \*RO, "buildinfo before changes";
4747     $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
4748         or badproto \*RO, "improper buildinfo filename";
4749     return $&;
4750 }
4751 sub i_file_buildinfo {
4752     my $bi = $i_param{'buildinfo-filename'};
4753     my $bd = parsecontrol "$i_tmp/$bi", $bi;
4754     my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
4755     if (!forceing [qw(buildinfo-changes-mismatch)]) {
4756         files_compare_inputs($bd, $ch);
4757         (getfield $bd, $_) eq (getfield $ch, $_) or
4758             fail "buildinfo mismatch $_"
4759             foreach qw(Source Version);
4760         !defined $bd->{$_} or
4761             fail "buildinfo contains $_"
4762             foreach qw(Changes Changed-by Distribution);
4763     }
4764     push @i_buildinfos, $bi;
4765     delete $i_param{'buildinfo-filename'};
4766 }
4767
4768 sub i_localname_changes {
4769     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4770     $i_changesfn = $i_dscfn;
4771     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4772     return $i_changesfn;
4773 }
4774 sub i_file_changes { }
4775
4776 sub i_want_signed_tag {
4777     printdebug Dumper(\%i_param, $i_dscfn);
4778     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4779         && defined $i_param{'csuite'}
4780         or badproto \*RO, "premature desire for signed-tag";
4781     my $head = $i_param{'head'};
4782     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4783
4784     my $maintview = $i_param{'maint-view'};
4785     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4786
4787     select_tagformat();
4788     if ($protovsn >= 4) {
4789         my $p = $i_param{'tagformat'} // '<undef>';
4790         $p eq $tagformat
4791             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4792     }
4793
4794     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4795     $csuite = $&;
4796     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4797
4798     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4799
4800     return
4801         push_mktags $i_clogp, $i_dscfn,
4802             $i_changesfn, 'remote changes',
4803             \@tagwants;
4804 }
4805
4806 sub i_want_signed_dsc_changes {
4807     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4808     sign_changes $i_changesfn;
4809     return ($i_dscfn, $i_changesfn, @i_buildinfos);
4810 }
4811
4812 #---------- building etc. ----------
4813
4814 our $version;
4815 our $sourcechanges;
4816 our $dscfn;
4817
4818 #----- `3.0 (quilt)' handling -----
4819
4820 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4821
4822 sub quiltify_dpkg_commit ($$$;$) {
4823     my ($patchname,$author,$msg, $xinfo) = @_;
4824     $xinfo //= '';
4825
4826     mkpath '.git/dgit'; # we are in playtree
4827     my $descfn = ".git/dgit/quilt-description.tmp";
4828     open O, '>', $descfn or die "$descfn: $!";
4829     $msg =~ s/\n+/\n\n/;
4830     print O <<END or die $!;
4831 From: $author
4832 ${xinfo}Subject: $msg
4833 ---
4834
4835 END
4836     close O or die $!;
4837
4838     {
4839         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4840         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4841         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4842         runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4843     }
4844 }
4845
4846 sub quiltify_trees_differ ($$;$$$) {
4847     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4848     # returns true iff the two tree objects differ other than in debian/
4849     # with $finegrained,
4850     # returns bitmask 01 - differ in upstream files except .gitignore
4851     #                 02 - differ in .gitignore
4852     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4853     #  is set for each modified .gitignore filename $fn
4854     # if $unrepres is defined, array ref to which is appeneded
4855     #  a list of unrepresentable changes (removals of upstream files
4856     #  (as messages)
4857     local $/=undef;
4858     my @cmd = (@git, qw(diff-tree -z --no-renames));
4859     push @cmd, qw(--name-only) unless $unrepres;
4860     push @cmd, qw(-r) if $finegrained || $unrepres;
4861     push @cmd, $x, $y;
4862     my $diffs= cmdoutput @cmd;
4863     my $r = 0;
4864     my @lmodes;
4865     foreach my $f (split /\0/, $diffs) {
4866         if ($unrepres && !@lmodes) {
4867             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4868             next;
4869         }
4870         my ($oldmode,$newmode) = @lmodes;
4871         @lmodes = ();
4872
4873         next if $f =~ m#^debian(?:/.*)?$#s;
4874
4875         if ($unrepres) {
4876             eval {
4877                 die "not a plain file or symlink\n"
4878                     unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
4879                            $oldmode =~ m/^(?:10|12)\d{4}$/;
4880                 if ($oldmode =~ m/[^0]/ &&
4881                     $newmode =~ m/[^0]/) {
4882                     # both old and new files exist
4883                     die "mode or type changed\n" if $oldmode ne $newmode;
4884                     die "modified symlink\n" unless $newmode =~ m/^10/;
4885                 } elsif ($oldmode =~ m/[^0]/) {
4886                     # deletion
4887                     die "deletion of symlink\n"
4888                         unless $oldmode =~ m/^10/;
4889                 } else {
4890                     # creation
4891                     die "creation with non-default mode\n"
4892                         unless $newmode =~ m/^100644$/ or
4893                                $newmode =~ m/^120000$/;
4894                 }
4895             };
4896             if ($@) {
4897                 local $/="\n"; chomp $@;
4898                 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4899             }
4900         }
4901
4902         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4903         $r |= $isignore ? 02 : 01;
4904         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4905     }
4906     printdebug "quiltify_trees_differ $x $y => $r\n";
4907     return $r;
4908 }
4909
4910 sub quiltify_tree_sentinelfiles ($) {
4911     # lists the `sentinel' files present in the tree
4912     my ($x) = @_;
4913     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4914         qw(-- debian/rules debian/control);
4915     $r =~ s/\n/,/g;
4916     return $r;
4917 }
4918
4919 sub quiltify_splitbrain_needed () {
4920     if (!$split_brain) {
4921         progress "dgit view: changes are required...";
4922         runcmd @git, qw(checkout -q -b dgit-view);
4923         $split_brain = 1;
4924     }
4925 }
4926
4927 sub quiltify_splitbrain ($$$$$$) {
4928     my ($clogp, $unapplied, $headref, $diffbits,
4929         $editedignores, $cachekey) = @_;
4930     if ($quilt_mode !~ m/gbp|dpm/) {
4931         # treat .gitignore just like any other upstream file
4932         $diffbits = { %$diffbits };
4933         $_ = !!$_ foreach values %$diffbits;
4934     }
4935     # We would like any commits we generate to be reproducible
4936     my @authline = clogp_authline($clogp);
4937     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
4938     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4939     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
4940     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
4941     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4942     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
4943
4944     if ($quilt_mode =~ m/gbp|unapplied/ &&
4945         ($diffbits->{O2H} & 01)) {
4946         my $msg =
4947  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4948  " but git tree differs from orig in upstream files.";
4949         if (!stat_exists "debian/patches") {
4950             $msg .=
4951  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4952         }
4953         fail $msg;
4954     }
4955     if ($quilt_mode =~ m/dpm/ &&
4956         ($diffbits->{H2A} & 01)) {
4957         fail <<END;
4958 --quilt=$quilt_mode specified, implying patches-applied git tree
4959  but git tree differs from result of applying debian/patches to upstream
4960 END
4961     }
4962     if ($quilt_mode =~ m/gbp|unapplied/ &&
4963         ($diffbits->{O2A} & 01)) { # some patches
4964         quiltify_splitbrain_needed();
4965         progress "dgit view: creating patches-applied version using gbp pq";
4966         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4967         # gbp pq import creates a fresh branch; push back to dgit-view
4968         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4969         runcmd @git, qw(checkout -q dgit-view);
4970     }
4971     if ($quilt_mode =~ m/gbp|dpm/ &&
4972         ($diffbits->{O2A} & 02)) {
4973         fail <<END
4974 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4975  tool which does not create patches for changes to upstream
4976  .gitignores: but, such patches exist in debian/patches.
4977 END
4978     }
4979     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4980         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4981         quiltify_splitbrain_needed();
4982         progress "dgit view: creating patch to represent .gitignore changes";
4983         ensuredir "debian/patches";
4984         my $gipatch = "debian/patches/auto-gitignore";
4985         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4986         stat GIPATCH or die "$gipatch: $!";
4987         fail "$gipatch already exists; but want to create it".
4988             " to record .gitignore changes" if (stat _)[7];
4989         print GIPATCH <<END or die "$gipatch: $!";
4990 Subject: Update .gitignore from Debian packaging branch
4991
4992 The Debian packaging git branch contains these updates to the upstream
4993 .gitignore file(s).  This patch is autogenerated, to provide these
4994 updates to users of the official Debian archive view of the package.
4995
4996 [dgit ($our_version) update-gitignore]
4997 ---
4998 END
4999         close GIPATCH or die "$gipatch: $!";
5000         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5001             $unapplied, $headref, "--", sort keys %$editedignores;
5002         open SERIES, "+>>", "debian/patches/series" or die $!;
5003         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5004         my $newline;
5005         defined read SERIES, $newline, 1 or die $!;
5006         print SERIES "\n" or die $! unless $newline eq "\n";
5007         print SERIES "auto-gitignore\n" or die $!;
5008         close SERIES or die  $!;
5009         runcmd @git, qw(add -- debian/patches/series), $gipatch;
5010         commit_admin <<END
5011 Commit patch to update .gitignore
5012
5013 [dgit ($our_version) update-gitignore-quilt-fixup]
5014 END
5015     }
5016
5017     my $dgitview = git_rev_parse 'HEAD';
5018
5019     changedir $maindir;
5020     # When we no longer need to support squeeze, use --create-reflog
5021     # instead of this:
5022     ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
5023     my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>'
5024       or die $!;
5025
5026     my $oldcache = git_get_ref "refs/$splitbraincache";
5027     if ($oldcache eq $dgitview) {
5028         my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5029         # git update-ref doesn't always update, in this case.  *sigh*
5030         my $dummy = make_commit_text <<END;
5031 tree $tree
5032 parent $dgitview
5033 author Dgit <dgit\@example.com> 1000000000 +0000
5034 committer Dgit <dgit\@example.com> 1000000000 +0000
5035
5036 Dummy commit - do not use
5037 END
5038         runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5039             "refs/$splitbraincache", $dummy;
5040     }
5041     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5042         $dgitview;
5043
5044     changedir "$playground/work";
5045
5046     my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5047     progress "dgit view: created ($saved)";
5048 }
5049
5050 sub quiltify ($$$$) {
5051     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5052
5053     # Quilt patchification algorithm
5054     #
5055     # We search backwards through the history of the main tree's HEAD
5056     # (T) looking for a start commit S whose tree object is identical
5057     # to to the patch tip tree (ie the tree corresponding to the
5058     # current dpkg-committed patch series).  For these purposes
5059     # `identical' disregards anything in debian/ - this wrinkle is
5060     # necessary because dpkg-source treates debian/ specially.
5061     #
5062     # We can only traverse edges where at most one of the ancestors'
5063     # trees differs (in changes outside in debian/).  And we cannot
5064     # handle edges which change .pc/ or debian/patches.  To avoid
5065     # going down a rathole we avoid traversing edges which introduce
5066     # debian/rules or debian/control.  And we set a limit on the
5067     # number of edges we are willing to look at.
5068     #
5069     # If we succeed, we walk forwards again.  For each traversed edge
5070     # PC (with P parent, C child) (starting with P=S and ending with
5071     # C=T) to we do this:
5072     #  - git checkout C
5073     #  - dpkg-source --commit with a patch name and message derived from C
5074     # After traversing PT, we git commit the changes which
5075     # should be contained within debian/patches.
5076
5077     # The search for the path S..T is breadth-first.  We maintain a
5078     # todo list containing search nodes.  A search node identifies a
5079     # commit, and looks something like this:
5080     #  $p = {
5081     #      Commit => $git_commit_id,
5082     #      Child => $c,                          # or undef if P=T
5083     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
5084     #      Nontrivial => true iff $p..$c has relevant changes
5085     #  };
5086
5087     my @todo;
5088     my @nots;
5089     my $sref_S;
5090     my $max_work=100;
5091     my %considered; # saves being exponential on some weird graphs
5092
5093     my $t_sentinels = quiltify_tree_sentinelfiles $target;
5094
5095     my $not = sub {
5096         my ($search,$whynot) = @_;
5097         printdebug " search NOT $search->{Commit} $whynot\n";
5098         $search->{Whynot} = $whynot;
5099         push @nots, $search;
5100         no warnings qw(exiting);
5101         next;
5102     };
5103
5104     push @todo, {
5105         Commit => $target,
5106     };
5107
5108     while (@todo) {
5109         my $c = shift @todo;
5110         next if $considered{$c->{Commit}}++;
5111
5112         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5113
5114         printdebug "quiltify investigate $c->{Commit}\n";
5115
5116         # are we done?
5117         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5118             printdebug " search finished hooray!\n";
5119             $sref_S = $c;
5120             last;
5121         }
5122
5123         if ($quilt_mode eq 'nofix') {
5124             fail "quilt fixup required but quilt mode is \`nofix'\n".
5125                 "HEAD commit $c->{Commit} differs from tree implied by ".
5126                 " debian/patches (tree object $oldtiptree)";
5127         }
5128         if ($quilt_mode eq 'smash') {
5129             printdebug " search quitting smash\n";
5130             last;
5131         }
5132
5133         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5134         $not->($c, "has $c_sentinels not $t_sentinels")
5135             if $c_sentinels ne $t_sentinels;
5136
5137         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5138         $commitdata =~ m/\n\n/;
5139         $commitdata =~ $`;
5140         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5141         @parents = map { { Commit => $_, Child => $c } } @parents;
5142
5143         $not->($c, "root commit") if !@parents;
5144
5145         foreach my $p (@parents) {
5146             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5147         }
5148         my $ndiffers = grep { $_->{Nontrivial} } @parents;
5149         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5150
5151         foreach my $p (@parents) {
5152             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5153
5154             my @cmd= (@git, qw(diff-tree -r --name-only),
5155                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5156             my $patchstackchange = cmdoutput @cmd;
5157             if (length $patchstackchange) {
5158                 $patchstackchange =~ s/\n/,/g;
5159                 $not->($p, "changed $patchstackchange");
5160             }
5161
5162             printdebug " search queue P=$p->{Commit} ",
5163                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5164             push @todo, $p;
5165         }
5166     }
5167
5168     if (!$sref_S) {
5169         printdebug "quiltify want to smash\n";
5170
5171         my $abbrev = sub {
5172             my $x = $_[0]{Commit};
5173             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5174             return $x;
5175         };
5176         my $reportnot = sub {
5177             my ($notp) = @_;
5178             my $s = $abbrev->($notp);
5179             my $c = $notp->{Child};
5180             $s .= "..".$abbrev->($c) if $c;
5181             $s .= ": ".$notp->{Whynot};
5182             return $s;
5183         };
5184         if ($quilt_mode eq 'linear') {
5185             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
5186             foreach my $notp (@nots) {
5187                 print STDERR "$us:  ", $reportnot->($notp), "\n";
5188             }
5189             print STDERR "$us: $_\n" foreach @$failsuggestion;
5190             fail "quilt fixup naive history linearisation failed.\n".
5191  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5192         } elsif ($quilt_mode eq 'smash') {
5193         } elsif ($quilt_mode eq 'auto') {
5194             progress "quilt fixup cannot be linear, smashing...";
5195         } else {
5196             die "$quilt_mode ?";
5197         }
5198
5199         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5200         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5201         my $ncommits = 3;
5202         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5203
5204         quiltify_dpkg_commit "auto-$version-$target-$time",
5205             (getfield $clogp, 'Maintainer'),
5206             "Automatically generated patch ($clogp->{Version})\n".
5207             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5208         return;
5209     }
5210
5211     progress "quiltify linearisation planning successful, executing...";
5212
5213     for (my $p = $sref_S;
5214          my $c = $p->{Child};
5215          $p = $p->{Child}) {
5216         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5217         next unless $p->{Nontrivial};
5218
5219         my $cc = $c->{Commit};
5220
5221         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5222         $commitdata =~ m/\n\n/ or die "$c ?";
5223         $commitdata = $`;
5224         my $msg = $'; #';
5225         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5226         my $author = $1;
5227
5228         my $commitdate = cmdoutput
5229             @git, qw(log -n1 --pretty=format:%aD), $cc;
5230
5231         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5232
5233         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5234         $strip_nls->();
5235
5236         my $title = $1;
5237         my $patchname;
5238         my $patchdir;
5239
5240         my $gbp_check_suitable = sub {
5241             $_ = shift;
5242             my ($what) = @_;
5243
5244             eval {
5245                 die "contains unexpected slashes\n" if m{//} || m{/$};
5246                 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5247                 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5248                 die "is series file\n" if m{$series_filename_re}o;
5249                 die "too long" if length > 200;
5250             };
5251             return $_ unless $@;
5252             print STDERR "quiltifying commit $cc:".
5253                 " ignoring/dropping Gbp-Pq $what: $@";
5254             return undef;
5255         };
5256
5257         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5258                            gbp-pq-name: \s* )
5259                        (\S+) \s* \n //ixm) {
5260             $patchname = $gbp_check_suitable->($1, 'Name');
5261         }
5262         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5263                            gbp-pq-topic: \s* )
5264                        (\S+) \s* \n //ixm) {
5265             $patchdir = $gbp_check_suitable->($1, 'Topic');
5266         }
5267
5268         $strip_nls->();
5269
5270         if (!defined $patchname) {
5271             $patchname = $title;
5272             $patchname =~ s/[.:]$//;
5273             use Text::Iconv;
5274             eval {
5275                 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5276                 my $translitname = $converter->convert($patchname);
5277                 die unless defined $translitname;
5278                 $patchname = $translitname;
5279             };
5280             print STDERR
5281                 "dgit: patch title transliteration error: $@"
5282                 if $@;
5283             $patchname =~ y/ A-Z/-a-z/;
5284             $patchname =~ y/-a-z0-9_.+=~//cd;
5285             $patchname =~ s/^\W/x-$&/;
5286             $patchname = substr($patchname,0,40);
5287             $patchname .= ".patch";
5288         }
5289         if (!defined $patchdir) {
5290             $patchdir = '';
5291         }
5292         if (length $patchdir) {
5293             $patchname = "$patchdir/$patchname";
5294         }
5295         if ($patchname =~ m{^(.*)/}) {
5296             mkpath "debian/patches/$1";
5297         }
5298
5299         my $index;
5300         for ($index='';
5301              stat "debian/patches/$patchname$index";
5302              $index++) { }
5303         $!==ENOENT or die "$patchname$index $!";
5304
5305         runcmd @git, qw(checkout -q), $cc;
5306
5307         # We use the tip's changelog so that dpkg-source doesn't
5308         # produce complaining messages from dpkg-parsechangelog.  None
5309         # of the information dpkg-source gets from the changelog is
5310         # actually relevant - it gets put into the original message
5311         # which dpkg-source provides our stunt editor, and then
5312         # overwritten.
5313         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5314
5315         quiltify_dpkg_commit "$patchname$index", $author, $msg,
5316             "Date: $commitdate\n".
5317             "X-Dgit-Generated: $clogp->{Version} $cc\n";
5318
5319         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5320     }
5321
5322     runcmd @git, qw(checkout -q master);
5323 }
5324
5325 sub build_maybe_quilt_fixup () {
5326     my ($format,$fopts) = get_source_format;
5327     return unless madformat_wantfixup $format;
5328     # sigh
5329
5330     check_for_vendor_patches();
5331
5332     if (quiltmode_splitbrain) {
5333         fail <<END unless access_cfg_tagformats_can_splitbrain;
5334 quilt mode $quilt_mode requires split view so server needs to support
5335  both "new" and "maint" tag formats, but config says it doesn't.
5336 END
5337     }
5338
5339     my $clogp = parsechangelog();
5340     my $headref = git_rev_parse('HEAD');
5341
5342     prep_ud();
5343     changedir $playground;
5344
5345     my $upstreamversion = upstreamversion $version;
5346
5347     if ($fopts->{'single-debian-patch'}) {
5348         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5349     } else {
5350         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5351     }
5352
5353     die 'bug' if $split_brain && !$need_split_build_invocation;
5354
5355     changedir $maindir;
5356     runcmd_ordryrun_local
5357         @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5358 }
5359
5360 sub quilt_fixup_mkwork ($) {
5361     my ($headref) = @_;
5362
5363     mkdir "work" or die $!;
5364     changedir "work";
5365     mktree_in_ud_here();
5366     runcmd @git, qw(reset -q --hard), $headref;
5367 }
5368
5369 sub quilt_fixup_linkorigs ($$) {
5370     my ($upstreamversion, $fn) = @_;
5371     # calls $fn->($leafname);
5372
5373     foreach my $f (<$maindir/../*>) { #/){
5374         my $b=$f; $b =~ s{.*/}{};
5375         {
5376             local ($debuglevel) = $debuglevel-1;
5377             printdebug "QF linkorigs $b, $f ?\n";
5378         }
5379         next unless is_orig_file_of_vsn $b, $upstreamversion;
5380         printdebug "QF linkorigs $b, $f Y\n";
5381         link_ltarget $f, $b or die "$b $!";
5382         $fn->($b);
5383     }
5384 }
5385
5386 sub quilt_fixup_delete_pc () {
5387     runcmd @git, qw(rm -rqf .pc);
5388     commit_admin <<END
5389 Commit removal of .pc (quilt series tracking data)
5390
5391 [dgit ($our_version) upgrade quilt-remove-pc]
5392 END
5393 }
5394
5395 sub quilt_fixup_singlepatch ($$$) {
5396     my ($clogp, $headref, $upstreamversion) = @_;
5397
5398     progress "starting quiltify (single-debian-patch)";
5399
5400     # dpkg-source --commit generates new patches even if
5401     # single-debian-patch is in debian/source/options.  In order to
5402     # get it to generate debian/patches/debian-changes, it is
5403     # necessary to build the source package.
5404
5405     quilt_fixup_linkorigs($upstreamversion, sub { });
5406     quilt_fixup_mkwork($headref);
5407
5408     rmtree("debian/patches");
5409
5410     runcmd @dpkgsource, qw(-b .);
5411     changedir "..";
5412     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5413     rename srcfn("$upstreamversion", "/debian/patches"),
5414            "work/debian/patches";
5415
5416     changedir "work";
5417     commit_quilty_patch();
5418 }
5419
5420 sub quilt_make_fake_dsc ($) {
5421     my ($upstreamversion) = @_;
5422
5423     my $fakeversion="$upstreamversion-~~DGITFAKE";
5424
5425     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5426     print $fakedsc <<END or die $!;
5427 Format: 3.0 (quilt)
5428 Source: $package
5429 Version: $fakeversion
5430 Files:
5431 END
5432
5433     my $dscaddfile=sub {
5434         my ($b) = @_;
5435
5436         my $md = new Digest::MD5;
5437
5438         my $fh = new IO::File $b, '<' or die "$b $!";
5439         stat $fh or die $!;
5440         my $size = -s _;
5441
5442         $md->addfile($fh);
5443         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5444     };
5445
5446     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5447
5448     my @files=qw(debian/source/format debian/rules
5449                  debian/control debian/changelog);
5450     foreach my $maybe (qw(debian/patches debian/source/options
5451                           debian/tests/control)) {
5452         next unless stat_exists "$maindir/$maybe";
5453         push @files, $maybe;
5454     }
5455
5456     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5457     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5458
5459     $dscaddfile->($debtar);
5460     close $fakedsc or die $!;
5461 }
5462
5463 sub quilt_check_splitbrain_cache ($$) {
5464     my ($headref, $upstreamversion) = @_;
5465     # Called only if we are in (potentially) split brain mode.
5466     # Called in playground.
5467     # Computes the cache key and looks in the cache.
5468     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5469
5470     my $splitbrain_cachekey;
5471
5472     progress
5473  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5474     # we look in the reflog of dgit-intern/quilt-cache
5475     # we look for an entry whose message is the key for the cache lookup
5476     my @cachekey = (qw(dgit), $our_version);
5477     push @cachekey, $upstreamversion;
5478     push @cachekey, $quilt_mode;
5479     push @cachekey, $headref;
5480
5481     push @cachekey, hashfile('fake.dsc');
5482
5483     my $srcshash = Digest::SHA->new(256);
5484     my %sfs = ( %INC, '$0(dgit)' => $0 );
5485     foreach my $sfk (sort keys %sfs) {
5486         next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5487         $srcshash->add($sfk,"  ");
5488         $srcshash->add(hashfile($sfs{$sfk}));
5489         $srcshash->add("\n");
5490     }
5491     push @cachekey, $srcshash->hexdigest();
5492     $splitbrain_cachekey = "@cachekey";
5493
5494     my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5495                $splitbraincache);
5496     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5497     debugcmd "|(probably)",@cmd;
5498     my $child = open GC, "-|";  defined $child or die $!;
5499     if (!$child) {
5500         chdir $maindir or die $!;
5501         if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
5502             $! == ENOENT or die $!;
5503             printdebug ">(no reflog)\n";
5504             exit 0;
5505         }
5506         exec @cmd; die $!;
5507     }
5508     while (<GC>) {
5509         chomp;
5510         printdebug ">| ", $_, "\n" if $debuglevel > 1;
5511         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5512
5513         my $cachehit = $1;
5514         quilt_fixup_mkwork($headref);
5515         my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5516         if ($cachehit ne $headref) {
5517             progress "dgit view: found cached ($saved)";
5518             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5519             $split_brain = 1;
5520             return ($cachehit, $splitbrain_cachekey);
5521         }
5522         progress "dgit view: found cached, no changes required";
5523         return ($headref, $splitbrain_cachekey);
5524     }
5525     die $! if GC->error;
5526     failedcmd unless close GC;
5527
5528     printdebug "splitbrain cache miss\n";
5529     return (undef, $splitbrain_cachekey);
5530 }
5531
5532 sub quilt_fixup_multipatch ($$$) {
5533     my ($clogp, $headref, $upstreamversion) = @_;
5534
5535     progress "examining quilt state (multiple patches, $quilt_mode mode)";
5536
5537     # Our objective is:
5538     #  - honour any existing .pc in case it has any strangeness
5539     #  - determine the git commit corresponding to the tip of
5540     #    the patch stack (if there is one)
5541     #  - if there is such a git commit, convert each subsequent
5542     #    git commit into a quilt patch with dpkg-source --commit
5543     #  - otherwise convert all the differences in the tree into
5544     #    a single git commit
5545     #
5546     # To do this we:
5547
5548     # Our git tree doesn't necessarily contain .pc.  (Some versions of
5549     # dgit would include the .pc in the git tree.)  If there isn't
5550     # one, we need to generate one by unpacking the patches that we
5551     # have.
5552     #
5553     # We first look for a .pc in the git tree.  If there is one, we
5554     # will use it.  (This is not the normal case.)
5555     #
5556     # Otherwise need to regenerate .pc so that dpkg-source --commit
5557     # can work.  We do this as follows:
5558     #     1. Collect all relevant .orig from parent directory
5559     #     2. Generate a debian.tar.gz out of
5560     #         debian/{patches,rules,source/format,source/options}
5561     #     3. Generate a fake .dsc containing just these fields:
5562     #          Format Source Version Files
5563     #     4. Extract the fake .dsc
5564     #        Now the fake .dsc has a .pc directory.
5565     # (In fact we do this in every case, because in future we will
5566     # want to search for a good base commit for generating patches.)
5567     #
5568     # Then we can actually do the dpkg-source --commit
5569     #     1. Make a new working tree with the same object
5570     #        store as our main tree and check out the main
5571     #        tree's HEAD.
5572     #     2. Copy .pc from the fake's extraction, if necessary
5573     #     3. Run dpkg-source --commit
5574     #     4. If the result has changes to debian/, then
5575     #          - git add them them
5576     #          - git add .pc if we had a .pc in-tree
5577     #          - git commit
5578     #     5. If we had a .pc in-tree, delete it, and git commit
5579     #     6. Back in the main tree, fast forward to the new HEAD
5580
5581     # Another situation we may have to cope with is gbp-style
5582     # patches-unapplied trees.
5583     #
5584     # We would want to detect these, so we know to escape into
5585     # quilt_fixup_gbp.  However, this is in general not possible.
5586     # Consider a package with a one patch which the dgit user reverts
5587     # (with git revert or the moral equivalent).
5588     #
5589     # That is indistinguishable in contents from a patches-unapplied
5590     # tree.  And looking at the history to distinguish them is not
5591     # useful because the user might have made a confusing-looking git
5592     # history structure (which ought to produce an error if dgit can't
5593     # cope, not a silent reintroduction of an unwanted patch).
5594     #
5595     # So gbp users will have to pass an option.  But we can usually
5596     # detect their failure to do so: if the tree is not a clean
5597     # patches-applied tree, quilt linearisation fails, but the tree
5598     # _is_ a clean patches-unapplied tree, we can suggest that maybe
5599     # they want --quilt=unapplied.
5600     #
5601     # To help detect this, when we are extracting the fake dsc, we
5602     # first extract it with --skip-patches, and then apply the patches
5603     # afterwards with dpkg-source --before-build.  That lets us save a
5604     # tree object corresponding to .origs.
5605
5606     my $splitbrain_cachekey;
5607
5608     quilt_make_fake_dsc($upstreamversion);
5609
5610     if (quiltmode_splitbrain()) {
5611         my $cachehit;
5612         ($cachehit, $splitbrain_cachekey) =
5613             quilt_check_splitbrain_cache($headref, $upstreamversion);
5614         return if $cachehit;
5615     }
5616
5617     runcmd qw(sh -ec),
5618         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5619
5620     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5621     rename $fakexdir, "fake" or die "$fakexdir $!";
5622
5623     changedir 'fake';
5624
5625     remove_stray_gits("source package");
5626     mktree_in_ud_here();
5627
5628     rmtree '.pc';
5629
5630     runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5631     my $unapplied=git_add_write_tree();
5632     printdebug "fake orig tree object $unapplied\n";
5633
5634     ensuredir '.pc';
5635
5636     my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5637     $!=0; $?=-1;
5638     if (system @bbcmd) {
5639         failedcmd @bbcmd if $? < 0;
5640         fail <<END;
5641 failed to apply your git tree's patch stack (from debian/patches/) to
5642  the corresponding upstream tarball(s).  Your source tree and .orig
5643  are probably too inconsistent.  dgit can only fix up certain kinds of
5644  anomaly (depending on the quilt mode).  See --quilt= in dgit(1).
5645 END
5646     }
5647
5648     changedir '..';
5649
5650     quilt_fixup_mkwork($headref);
5651
5652     my $mustdeletepc=0;
5653     if (stat_exists ".pc") {
5654         -d _ or die;
5655         progress "Tree already contains .pc - will use it then delete it.";
5656         $mustdeletepc=1;
5657     } else {
5658         rename '../fake/.pc','.pc' or die $!;
5659     }
5660
5661     changedir '../fake';
5662     rmtree '.pc';
5663     my $oldtiptree=git_add_write_tree();
5664     printdebug "fake o+d/p tree object $unapplied\n";
5665     changedir '../work';
5666
5667
5668     # We calculate some guesswork now about what kind of tree this might
5669     # be.  This is mostly for error reporting.
5670
5671     my %editedignores;
5672     my @unrepres;
5673     my $diffbits = {
5674         # H = user's HEAD
5675         # O = orig, without patches applied
5676         # A = "applied", ie orig with H's debian/patches applied
5677         O2H => quiltify_trees_differ($unapplied,$headref,   1,
5678                                      \%editedignores, \@unrepres),
5679         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
5680         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5681     };
5682
5683     my @dl;
5684     foreach my $b (qw(01 02)) {
5685         foreach my $v (qw(O2H O2A H2A)) {
5686             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5687         }
5688     }
5689     printdebug "differences \@dl @dl.\n";
5690
5691     progress sprintf
5692 "$us: base trees orig=%.20s o+d/p=%.20s",
5693               $unapplied, $oldtiptree;
5694     progress sprintf
5695 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
5696 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
5697                              $dl[0], $dl[1],              $dl[3], $dl[4],
5698                                  $dl[2],                     $dl[5];
5699
5700     if (@unrepres) {
5701         print STDERR "dgit:  cannot represent change: $_->[1]: $_->[0]\n"
5702             foreach @unrepres;
5703         forceable_fail [qw(unrepresentable)], <<END;
5704 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5705 END
5706     }
5707
5708     my @failsuggestion;
5709     if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5710         push @failsuggestion, "This might be a patches-unapplied branch.";
5711     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5712         push @failsuggestion, "This might be a patches-applied branch.";
5713     }
5714     push @failsuggestion, "Maybe you need to specify one of".
5715         " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5716
5717     if (quiltmode_splitbrain()) {
5718         quiltify_splitbrain($clogp, $unapplied, $headref,
5719                             $diffbits, \%editedignores,
5720                             $splitbrain_cachekey);
5721         return;
5722     }
5723
5724     progress "starting quiltify (multiple patches, $quilt_mode mode)";
5725     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5726
5727     if (!open P, '>>', ".pc/applied-patches") {
5728         $!==&ENOENT or die $!;
5729     } else {
5730         close P;
5731     }
5732
5733     commit_quilty_patch();
5734
5735     if ($mustdeletepc) {
5736         quilt_fixup_delete_pc();
5737     }
5738 }
5739
5740 sub quilt_fixup_editor () {
5741     my $descfn = $ENV{$fakeeditorenv};
5742     my $editing = $ARGV[$#ARGV];
5743     open I1, '<', $descfn or die "$descfn: $!";
5744     open I2, '<', $editing or die "$editing: $!";
5745     unlink $editing or die "$editing: $!";
5746     open O, '>', $editing or die "$editing: $!";
5747     while (<I1>) { print O or die $!; } I1->error and die $!;
5748     my $copying = 0;
5749     while (<I2>) {
5750         $copying ||= m/^\-\-\- /;
5751         next unless $copying;
5752         print O or die $!;
5753     }
5754     I2->error and die $!;
5755     close O or die $1;
5756     exit 0;
5757 }
5758
5759 sub maybe_apply_patches_dirtily () {
5760     return unless $quilt_mode =~ m/gbp|unapplied/;
5761     print STDERR <<END or die $!;
5762
5763 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5764 dgit: Have to apply the patches - making the tree dirty.
5765 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5766
5767 END
5768     $patches_applied_dirtily = 01;
5769     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5770     runcmd qw(dpkg-source --before-build .);
5771 }
5772
5773 sub maybe_unapply_patches_again () {
5774     progress "dgit: Unapplying patches again to tidy up the tree."
5775         if $patches_applied_dirtily;
5776     runcmd qw(dpkg-source --after-build .)
5777         if $patches_applied_dirtily & 01;
5778     rmtree '.pc'
5779         if $patches_applied_dirtily & 02;
5780     $patches_applied_dirtily = 0;
5781 }
5782
5783 #----- other building -----
5784
5785 our $clean_using_builder;
5786 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5787 #   clean the tree before building (perhaps invoked indirectly by
5788 #   whatever we are using to run the build), rather than separately
5789 #   and explicitly by us.
5790
5791 sub clean_tree () {
5792     return if $clean_using_builder;
5793     if ($cleanmode eq 'dpkg-source') {
5794         maybe_apply_patches_dirtily();
5795         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5796     } elsif ($cleanmode eq 'dpkg-source-d') {
5797         maybe_apply_patches_dirtily();
5798         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5799     } elsif ($cleanmode eq 'git') {
5800         runcmd_ordryrun_local @git, qw(clean -xdf);
5801     } elsif ($cleanmode eq 'git-ff') {
5802         runcmd_ordryrun_local @git, qw(clean -xdff);
5803     } elsif ($cleanmode eq 'check') {
5804         my $leftovers = cmdoutput @git, qw(clean -xdn);
5805         if (length $leftovers) {
5806             print STDERR $leftovers, "\n" or die $!;
5807             fail "tree contains uncommitted files and --clean=check specified";
5808         }
5809     } elsif ($cleanmode eq 'none') {
5810     } else {
5811         die "$cleanmode ?";
5812     }
5813 }
5814
5815 sub cmd_clean () {
5816     badusage "clean takes no additional arguments" if @ARGV;
5817     notpushing();
5818     clean_tree();
5819     maybe_unapply_patches_again();
5820 }
5821
5822 sub build_or_push_prep_early () {
5823     our $build_or_push_prep_early_done //= 0;
5824     return if $build_or_push_prep_early_done++;
5825     badusage "-p is not allowed with dgit $subcommand" if defined $package;
5826     my $clogp = parsechangelog();
5827     $isuite = getfield $clogp, 'Distribution';
5828     $package = getfield $clogp, 'Source';
5829     $version = getfield $clogp, 'Version';
5830 }
5831
5832 sub build_prep_early () {
5833     build_or_push_prep_early();
5834     notpushing();
5835     check_not_dirty();
5836 }
5837
5838 sub build_prep () {
5839     build_prep_early();
5840     clean_tree();
5841     build_maybe_quilt_fixup();
5842     if ($rmchanges) {
5843         my $pat = changespat $version;
5844         foreach my $f (glob "$buildproductsdir/$pat") {
5845             if (act_local()) {
5846                 unlink $f or fail "remove old changes file $f: $!";
5847             } else {
5848                 progress "would remove $f";
5849             }
5850         }
5851     }
5852 }
5853
5854 sub changesopts_initial () {
5855     my @opts =@changesopts[1..$#changesopts];
5856 }
5857
5858 sub changesopts_version () {
5859     if (!defined $changes_since_version) {
5860         my @vsns = archive_query('archive_query');
5861         my @quirk = access_quirk();
5862         if ($quirk[0] eq 'backports') {
5863             local $isuite = $quirk[2];
5864             local $csuite;
5865             canonicalise_suite();
5866             push @vsns, archive_query('archive_query');
5867         }
5868         if (@vsns) {
5869             @vsns = map { $_->[0] } @vsns;
5870             @vsns = sort { -version_compare($a, $b) } @vsns;
5871             $changes_since_version = $vsns[0];
5872             progress "changelog will contain changes since $vsns[0]";
5873         } else {
5874             $changes_since_version = '_';
5875             progress "package seems new, not specifying -v<version>";
5876         }
5877     }
5878     if ($changes_since_version ne '_') {
5879         return ("-v$changes_since_version");
5880     } else {
5881         return ();
5882     }
5883 }
5884
5885 sub changesopts () {
5886     return (changesopts_initial(), changesopts_version());
5887 }
5888
5889 sub massage_dbp_args ($;$) {
5890     my ($cmd,$xargs) = @_;
5891     # We need to:
5892     #
5893     #  - if we're going to split the source build out so we can
5894     #    do strange things to it, massage the arguments to dpkg-buildpackage
5895     #    so that the main build doessn't build source (or add an argument
5896     #    to stop it building source by default).
5897     #
5898     #  - add -nc to stop dpkg-source cleaning the source tree,
5899     #    unless we're not doing a split build and want dpkg-source
5900     #    as cleanmode, in which case we can do nothing
5901     #
5902     # return values:
5903     #    0 - source will NOT need to be built separately by caller
5904     #   +1 - source will need to be built separately by caller
5905     #   +2 - source will need to be built separately by caller AND
5906     #        dpkg-buildpackage should not in fact be run at all!
5907     debugcmd '#massaging#', @$cmd if $debuglevel>1;
5908 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5909     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5910         $clean_using_builder = 1;
5911         return 0;
5912     }
5913     # -nc has the side effect of specifying -b if nothing else specified
5914     # and some combinations of -S, -b, et al, are errors, rather than
5915     # later simply overriding earlie.  So we need to:
5916     #  - search the command line for these options
5917     #  - pick the last one
5918     #  - perhaps add our own as a default
5919     #  - perhaps adjust it to the corresponding non-source-building version
5920     my $dmode = '-F';
5921     foreach my $l ($cmd, $xargs) {
5922         next unless $l;
5923         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5924     }
5925     push @$cmd, '-nc';
5926 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5927     my $r = 0;
5928     if ($need_split_build_invocation) {
5929         printdebug "massage split $dmode.\n";
5930         $r = $dmode =~ m/[S]/     ? +2 :
5931              $dmode =~ y/gGF/ABb/ ? +1 :
5932              $dmode =~ m/[ABb]/   ?  0 :
5933              die "$dmode ?";
5934     }
5935     printdebug "massage done $r $dmode.\n";
5936     push @$cmd, $dmode;
5937 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5938     return $r;
5939 }
5940
5941 sub in_parent (&) {
5942     my ($fn) = @_;
5943     my $wasdir = must_getcwd();
5944     changedir "..";
5945     $fn->();
5946     changedir $wasdir;
5947 }
5948
5949 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5950     my ($msg_if_onlyone) = @_;
5951     # If there is only one .changes file, fail with $msg_if_onlyone,
5952     # or if that is undef, be a no-op.
5953     # Returns the changes file to report to the user.
5954     my $pat = changespat $version;
5955     my @changesfiles = glob $pat;
5956     @changesfiles = sort {
5957         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5958             or $a cmp $b
5959     } @changesfiles;
5960     my $result;
5961     if (@changesfiles==1) {
5962         fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5963 only one changes file from build (@changesfiles)
5964 END
5965         $result = $changesfiles[0];
5966     } elsif (@changesfiles==2) {
5967         my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5968         foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5969             fail "$l found in binaries changes file $binchanges"
5970                 if $l =~ m/\.dsc$/;
5971         }
5972         runcmd_ordryrun_local @mergechanges, @changesfiles;
5973         my $multichanges = changespat $version,'multi';
5974         if (act_local()) {
5975             stat_exists $multichanges or fail "$multichanges: $!";
5976             foreach my $cf (glob $pat) {
5977                 next if $cf eq $multichanges;
5978                 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5979             }
5980         }
5981         $result = $multichanges;
5982     } else {
5983         fail "wrong number of different changes files (@changesfiles)";
5984     }
5985     printdone "build successful, results in $result\n" or die $!;
5986 }
5987
5988 sub midbuild_checkchanges () {
5989     my $pat = changespat $version;
5990     return if $rmchanges;
5991     my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5992     @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5993     fail <<END
5994 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5995 Suggest you delete @unwanted.
5996 END
5997         if @unwanted;
5998 }
5999
6000 sub midbuild_checkchanges_vanilla ($) {
6001     my ($wantsrc) = @_;
6002     midbuild_checkchanges() if $wantsrc == 1;
6003 }
6004
6005 sub postbuild_mergechanges_vanilla ($) {
6006     my ($wantsrc) = @_;
6007     if ($wantsrc == 1) {
6008         in_parent {
6009             postbuild_mergechanges(undef);
6010         };
6011     } else {
6012         printdone "build successful\n";
6013     }
6014 }
6015
6016 sub cmd_build {
6017     build_prep_early();
6018     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6019     my $wantsrc = massage_dbp_args \@dbp;
6020     if ($wantsrc > 0) {
6021         build_source();
6022         midbuild_checkchanges_vanilla $wantsrc;
6023     } else {
6024         build_prep();
6025     }
6026     if ($wantsrc < 2) {
6027         push @dbp, changesopts_version();
6028         maybe_apply_patches_dirtily();
6029         runcmd_ordryrun_local @dbp;
6030     }
6031     maybe_unapply_patches_again();
6032     postbuild_mergechanges_vanilla $wantsrc;
6033 }
6034
6035 sub pre_gbp_build {
6036     $quilt_mode //= 'gbp';
6037 }
6038
6039 sub cmd_gbp_build {
6040     build_prep_early();
6041
6042     # gbp can make .origs out of thin air.  In my tests it does this
6043     # even for a 1.0 format package, with no origs present.  So I
6044     # guess it keys off just the version number.  We don't know
6045     # exactly what .origs ought to exist, but let's assume that we
6046     # should run gbp if: the version has an upstream part and the main
6047     # orig is absent.
6048     my $upstreamversion = upstreamversion $version;
6049     my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6050     my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
6051
6052     if ($gbp_make_orig) {
6053         clean_tree();
6054         $cleanmode = 'none'; # don't do it again
6055         $need_split_build_invocation = 1;
6056     }
6057
6058     my @dbp = @dpkgbuildpackage;
6059
6060     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6061
6062     if (!length $gbp_build[0]) {
6063         if (length executable_on_path('git-buildpackage')) {
6064             $gbp_build[0] = qw(git-buildpackage);
6065         } else {
6066             $gbp_build[0] = 'gbp buildpackage';
6067         }
6068     }
6069     my @cmd = opts_opt_multi_cmd @gbp_build;
6070
6071     push @cmd, (qw(-us -uc --git-no-sign-tags),
6072                 "--git-builder=".(shellquote @dbp));
6073
6074     if ($gbp_make_orig) {
6075         my $priv = dgit_privdir();
6076         my $ok = "$priv/origs-gen-ok";
6077         unlink $ok or $!==&ENOENT or die $!;
6078         my @origs_cmd = @cmd;
6079         push @origs_cmd, qw(--git-cleaner=true);
6080         push @origs_cmd, "--git-prebuild=".
6081             "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6082         push @origs_cmd, @ARGV;
6083         if (act_local()) {
6084             debugcmd @origs_cmd;
6085             system @origs_cmd;
6086             do { local $!; stat_exists $ok; }
6087                 or failedcmd @origs_cmd;
6088         } else {
6089             dryrun_report @origs_cmd;
6090         }
6091     }
6092
6093     if ($wantsrc > 0) {
6094         build_source();
6095         midbuild_checkchanges_vanilla $wantsrc;
6096     } else {
6097         if (!$clean_using_builder) {
6098             push @cmd, '--git-cleaner=true';
6099         }
6100         build_prep();
6101     }
6102     maybe_unapply_patches_again();
6103     if ($wantsrc < 2) {
6104         push @cmd, changesopts();
6105         runcmd_ordryrun_local @cmd, @ARGV;
6106     }
6107     postbuild_mergechanges_vanilla $wantsrc;
6108 }
6109 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6110
6111 sub build_source {
6112     build_prep_early();
6113     my $our_cleanmode = $cleanmode;
6114     if ($need_split_build_invocation) {
6115         # Pretend that clean is being done some other way.  This
6116         # forces us not to try to use dpkg-buildpackage to clean and
6117         # build source all in one go; and instead we run dpkg-source
6118         # (and build_prep() will do the clean since $clean_using_builder
6119         # is false).
6120         $our_cleanmode = 'ELSEWHERE';
6121     }
6122     if ($our_cleanmode =~ m/^dpkg-source/) {
6123         # dpkg-source invocation (below) will clean, so build_prep shouldn't
6124         $clean_using_builder = 1;
6125     }
6126     build_prep();
6127     $sourcechanges = changespat $version,'source';
6128     if (act_local()) {
6129         unlink "../$sourcechanges" or $!==ENOENT
6130             or fail "remove $sourcechanges: $!";
6131     }
6132     $dscfn = dscfn($version);
6133     if ($our_cleanmode eq 'dpkg-source') {
6134         maybe_apply_patches_dirtily();
6135         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
6136             changesopts();
6137     } elsif ($our_cleanmode eq 'dpkg-source-d') {
6138         maybe_apply_patches_dirtily();
6139         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
6140             changesopts();
6141     } else {
6142         my @cmd = (@dpkgsource, qw(-b --));
6143         if ($split_brain) {
6144             changedir $playground;
6145             runcmd_ordryrun_local @cmd, "work";
6146             my @udfiles = <${package}_*>;
6147             changedir $maindir;
6148             foreach my $f (@udfiles) {
6149                 printdebug "source copy, found $f\n";
6150                 next unless
6151                     $f eq $dscfn or
6152                     ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
6153                      $f eq srcfn($version, $&));
6154                 printdebug "source copy, found $f - renaming\n";
6155                 rename "$playground/$f", "../$f" or $!==ENOENT
6156                     or fail "put in place new source file ($f): $!";
6157             }
6158         } else {
6159             my $pwd = must_getcwd();
6160             my $leafdir = basename $pwd;
6161             changedir "..";
6162             runcmd_ordryrun_local @cmd, $leafdir;
6163             changedir $pwd;
6164         }
6165         runcmd_ordryrun_local qw(sh -ec),
6166             'exec >$1; shift; exec "$@"','x',
6167             "../$sourcechanges",
6168             @dpkggenchanges, qw(-S), changesopts();
6169     }
6170 }
6171
6172 sub cmd_build_source {
6173     build_prep_early();
6174     badusage "build-source takes no additional arguments" if @ARGV;
6175     build_source();
6176     maybe_unapply_patches_again();
6177     printdone "source built, results in $dscfn and $sourcechanges";
6178 }
6179
6180 sub cmd_sbuild {
6181     build_source();
6182     midbuild_checkchanges();
6183     in_parent {
6184         if (act_local()) {
6185             stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
6186             stat_exists $sourcechanges
6187                 or fail "$sourcechanges (in parent directory): $!";
6188         }
6189         runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
6190     };
6191     maybe_unapply_patches_again();
6192     in_parent {
6193         postbuild_mergechanges(<<END);
6194 perhaps you need to pass -A ?  (sbuild's default is to build only
6195 arch-specific binaries; dgit 1.4 used to override that.)
6196 END
6197     };
6198 }
6199
6200 sub cmd_quilt_fixup {
6201     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6202     build_prep_early();
6203     clean_tree();
6204     build_maybe_quilt_fixup();
6205 }
6206
6207 sub import_dsc_result {
6208     my ($dstref, $newhash, $what_log, $what_msg) = @_;
6209     my @cmd = (@git, qw(update-ref -m), $what_log, $dstref, $newhash);
6210     runcmd @cmd;
6211     check_gitattrs($newhash, "source tree");
6212
6213     progress "dgit: import-dsc: $what_msg";
6214 }
6215
6216 sub cmd_import_dsc {
6217     my $needsig = 0;
6218
6219     while (@ARGV) {
6220         last unless $ARGV[0] =~ m/^-/;
6221         $_ = shift @ARGV;
6222         last if m/^--?$/;
6223         if (m/^--require-valid-signature$/) {
6224             $needsig = 1;
6225         } else {
6226             badusage "unknown dgit import-dsc sub-option \`$_'";
6227         }
6228     }
6229
6230     badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6231     my ($dscfn, $dstbranch) = @ARGV;
6232
6233     badusage "dry run makes no sense with import-dsc" unless act_local();
6234
6235     my $force = $dstbranch =~ s/^\+//   ? +1 :
6236                 $dstbranch =~ s/^\.\.// ? -1 :
6237                                            0;
6238     my $info = $force ? " $&" : '';
6239     $info = "$dscfn$info";
6240
6241     my $specbranch = $dstbranch;
6242     $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6243     $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6244
6245     my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6246     my $chead = cmdoutput_errok @symcmd;
6247     defined $chead or $?==256 or failedcmd @symcmd;
6248
6249     fail "$dstbranch is checked out - will not update it"
6250         if defined $chead and $chead eq $dstbranch;
6251
6252     my $oldhash = git_get_ref $dstbranch;
6253
6254     open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6255     $dscdata = do { local $/ = undef; <D>; };
6256     D->error and fail "read $dscfn: $!";
6257     close C;
6258
6259     # we don't normally need this so import it here
6260     use Dpkg::Source::Package;
6261     my $dp = new Dpkg::Source::Package filename => $dscfn,
6262         require_valid_signature => $needsig;
6263     {
6264         local $SIG{__WARN__} = sub {
6265             print STDERR $_[0];
6266             return unless $needsig;
6267             fail "import-dsc signature check failed";
6268         };
6269         if (!$dp->is_signed()) {
6270             warn "$us: warning: importing unsigned .dsc\n";
6271         } else {
6272             my $r = $dp->check_signature();
6273             die "->check_signature => $r" if $needsig && $r;
6274         }
6275     }
6276
6277     parse_dscdata();
6278
6279     $package = getfield $dsc, 'Source';
6280
6281     parse_dsc_field($dsc, "Dgit metadata in .dsc")
6282         unless forceing [qw(import-dsc-with-dgit-field)];
6283     parse_dsc_field_def_dsc_distro();
6284
6285     $isuite = 'DGIT-IMPORT-DSC';
6286     $idistro //= $dsc_distro;
6287
6288     notpushing();
6289
6290     if (defined $dsc_hash) {
6291         progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6292         resolve_dsc_field_commit undef, undef;
6293     }
6294     if (defined $dsc_hash) {
6295         my @cmd = (qw(sh -ec),
6296                    "echo $dsc_hash | git cat-file --batch-check");
6297         my $objgot = cmdoutput @cmd;
6298         if ($objgot =~ m#^\w+ missing\b#) {
6299             fail <<END
6300 .dsc contains Dgit field referring to object $dsc_hash
6301 Your git tree does not have that object.  Try `git fetch' from a
6302 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6303 END
6304         }
6305         if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6306             if ($force > 0) {
6307                 progress "Not fast forward, forced update.";
6308             } else {
6309                 fail "Not fast forward to $dsc_hash";
6310             }
6311         }
6312         import_dsc_result $dstbranch, $dsc_hash,
6313             "dgit import-dsc (Dgit): $info",
6314             "updated git ref $dstbranch";
6315         return 0;
6316     }
6317
6318     fail <<END
6319 Branch $dstbranch already exists
6320 Specify ..$specbranch for a pseudo-merge, binding in existing history
6321 Specify  +$specbranch to overwrite, discarding existing history
6322 END
6323         if $oldhash && !$force;
6324
6325     my @dfi = dsc_files_info();
6326     foreach my $fi (@dfi) {
6327         my $f = $fi->{Filename};
6328         my $here = "../$f";
6329         if (lstat $here) {
6330             next if stat $here;
6331             fail "lstat $here works but stat gives $! !";
6332         }
6333         fail "stat $here: $!" unless $! == ENOENT;
6334         my $there = $dscfn;
6335         if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6336             $there = $';
6337         } elsif ($dscfn =~ m#^/#) {
6338             $there = $dscfn;
6339         } else {
6340             fail "cannot import $dscfn which seems to be inside working tree!";
6341         }
6342         $there =~ s#/+[^/]+$## or
6343             fail "import $dscfn requires ../$f, but it does not exist";
6344         $there .= "/$f";
6345         my $test = $there =~ m{^/} ? $there : "../$there";
6346         stat $test or fail "import $dscfn requires $test, but: $!";
6347         symlink $there, $here or fail "symlink $there to $here: $!";
6348         progress "made symlink $here -> $there";
6349 #       print STDERR Dumper($fi);
6350     }
6351     my @mergeinputs = generate_commits_from_dsc();
6352     die unless @mergeinputs == 1;
6353
6354     my $newhash = $mergeinputs[0]{Commit};
6355
6356     if ($oldhash) {
6357         if ($force > 0) {
6358             progress "Import, forced update - synthetic orphan git history.";
6359         } elsif ($force < 0) {
6360             progress "Import, merging.";
6361             my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6362             my $version = getfield $dsc, 'Version';
6363             my $clogp = commit_getclogp $newhash;
6364             my $authline = clogp_authline $clogp;
6365             $newhash = make_commit_text <<END;
6366 tree $tree
6367 parent $newhash
6368 parent $oldhash
6369 author $authline
6370 committer $authline
6371
6372 Merge $package ($version) import into $dstbranch
6373 END
6374         } else {
6375             die; # caught earlier
6376         }
6377     }
6378
6379     import_dsc_result $dstbranch, $newhash,
6380         "dgit import-dsc: $info",
6381         "results are in in git ref $dstbranch";
6382 }
6383
6384 sub pre_archive_api_query () {
6385     not_necessarily_a_tree();
6386 }
6387 sub cmd_archive_api_query {
6388     badusage "need only 1 subpath argument" unless @ARGV==1;
6389     my ($subpath) = @ARGV;
6390     my @cmd = archive_api_query_cmd($subpath);
6391     push @cmd, qw(-f);
6392     debugcmd ">",@cmd;
6393     exec @cmd or fail "exec curl: $!\n";
6394 }
6395
6396 sub repos_server_url () {
6397     $package = '_dgit-repos-server';
6398     local $access_forpush = 1;
6399     local $isuite = 'DGIT-REPOS-SERVER';
6400     my $url = access_giturl();
6401 }
6402
6403 sub pre_clone_dgit_repos_server () {
6404     not_necessarily_a_tree();
6405 }
6406 sub cmd_clone_dgit_repos_server {
6407     badusage "need destination argument" unless @ARGV==1;
6408     my ($destdir) = @ARGV;
6409     my $url = repos_server_url();
6410     my @cmd = (@git, qw(clone), $url, $destdir);
6411     debugcmd ">",@cmd;
6412     exec @cmd or fail "exec git clone: $!\n";
6413 }
6414
6415 sub pre_print_dgit_repos_server_source_url () {
6416     not_necessarily_a_tree();
6417 }
6418 sub cmd_print_dgit_repos_server_source_url {
6419     badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6420         if @ARGV;
6421     my $url = repos_server_url();
6422     print $url, "\n" or die $!;
6423 }
6424
6425 sub pre_print_dpkg_source_ignores {
6426     not_necessarily_a_tree();
6427 }
6428 sub cmd_print_dpkg_source_ignores {
6429     badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6430         if @ARGV;
6431     print "@dpkg_source_ignores\n" or die $!;
6432 }
6433
6434 sub cmd_setup_mergechangelogs {
6435     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6436     local $isuite = 'DGIT-SETUP-TREE';
6437     setup_mergechangelogs(1);
6438 }
6439
6440 sub cmd_setup_useremail {
6441     badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6442     local $isuite = 'DGIT-SETUP-TREE';
6443     setup_useremail(1);
6444 }
6445
6446 sub cmd_setup_gitattributes {
6447     badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6448     local $isuite = 'DGIT-SETUP-TREE';
6449     setup_gitattrs(1);
6450 }
6451
6452 sub cmd_setup_new_tree {
6453     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6454     local $isuite = 'DGIT-SETUP-TREE';
6455     setup_new_tree();
6456 }
6457
6458 #---------- argument parsing and main program ----------
6459
6460 sub cmd_version {
6461     print "dgit version $our_version\n" or die $!;
6462     exit 0;
6463 }
6464
6465 our (%valopts_long, %valopts_short);
6466 our (%funcopts_long);
6467 our @rvalopts;
6468 our (@modeopt_cfgs);
6469
6470 sub defvalopt ($$$$) {
6471     my ($long,$short,$val_re,$how) = @_;
6472     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6473     $valopts_long{$long} = $oi;
6474     $valopts_short{$short} = $oi;
6475     # $how subref should:
6476     #   do whatever assignemnt or thing it likes with $_[0]
6477     #   if the option should not be passed on to remote, @rvalopts=()
6478     # or $how can be a scalar ref, meaning simply assign the value
6479 }
6480
6481 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6482 defvalopt '--distro',        '-d', '.+',      \$idistro;
6483 defvalopt '',                '-k', '.+',      \$keyid;
6484 defvalopt '--existing-package','', '.*',      \$existing_package;
6485 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
6486 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
6487 defvalopt '--package',   '-p',   $package_re, \$package;
6488 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
6489
6490 defvalopt '', '-C', '.+', sub {
6491     ($changesfile) = (@_);
6492     if ($changesfile =~ s#^(.*)/##) {
6493         $buildproductsdir = $1;
6494     }
6495 };
6496
6497 defvalopt '--initiator-tempdir','','.*', sub {
6498     ($initiator_tempdir) = (@_);
6499     $initiator_tempdir =~ m#^/# or
6500         badusage "--initiator-tempdir must be used specify an".
6501         " absolute, not relative, directory."
6502 };
6503
6504 sub defoptmodes ($@) {
6505     my ($varref, $cfgkey, $default, %optmap) = @_;
6506     my %permit;
6507     while (my ($opt,$val) = each %optmap) {
6508         $funcopts_long{$opt} = sub { $$varref = $val; };
6509         $permit{$val} = $val;
6510     }
6511     push @modeopt_cfgs, {
6512         Var => $varref,
6513         Key => $cfgkey,
6514         Default => $default,
6515         Vals => \%permit
6516     };
6517 }
6518
6519 defoptmodes \$dodep14tag, qw( dep14tag          want
6520                               --dep14tag        want
6521                               --no-dep14tag     no
6522                               --always-dep14tag always );
6523
6524 sub parseopts () {
6525     my $om;
6526
6527     if (defined $ENV{'DGIT_SSH'}) {
6528         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6529     } elsif (defined $ENV{'GIT_SSH'}) {
6530         @ssh = ($ENV{'GIT_SSH'});
6531     }
6532
6533     my $oi;
6534     my $val;
6535     my $valopt = sub {
6536         my ($what) = @_;
6537         @rvalopts = ($_);
6538         if (!defined $val) {
6539             badusage "$what needs a value" unless @ARGV;
6540             $val = shift @ARGV;
6541             push @rvalopts, $val;
6542         }
6543         badusage "bad value \`$val' for $what" unless
6544             $val =~ m/^$oi->{Re}$(?!\n)/s;
6545         my $how = $oi->{How};
6546         if (ref($how) eq 'SCALAR') {
6547             $$how = $val;
6548         } else {
6549             $how->($val);
6550         }
6551         push @ropts, @rvalopts;
6552     };
6553
6554     while (@ARGV) {
6555         last unless $ARGV[0] =~ m/^-/;
6556         $_ = shift @ARGV;
6557         last if m/^--?$/;
6558         if (m/^--/) {
6559             if (m/^--dry-run$/) {
6560                 push @ropts, $_;
6561                 $dryrun_level=2;
6562             } elsif (m/^--damp-run$/) {
6563                 push @ropts, $_;
6564                 $dryrun_level=1;
6565             } elsif (m/^--no-sign$/) {
6566                 push @ropts, $_;
6567                 $sign=0;
6568             } elsif (m/^--help$/) {
6569                 cmd_help();
6570             } elsif (m/^--version$/) {
6571                 cmd_version();
6572             } elsif (m/^--new$/) {
6573                 push @ropts, $_;
6574                 $new_package=1;
6575             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6576                      ($om = $opts_opt_map{$1}) &&
6577                      length $om->[0]) {
6578                 push @ropts, $_;
6579                 $om->[0] = $2;
6580             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6581                      !$opts_opt_cmdonly{$1} &&
6582                      ($om = $opts_opt_map{$1})) {
6583                 push @ropts, $_;
6584                 push @$om, $2;
6585             } elsif (m/^--(gbp|dpm)$/s) {
6586                 push @ropts, "--quilt=$1";
6587                 $quilt_mode = $1;
6588             } elsif (m/^--ignore-dirty$/s) {
6589                 push @ropts, $_;
6590                 $ignoredirty = 1;
6591             } elsif (m/^--no-quilt-fixup$/s) {
6592                 push @ropts, $_;
6593                 $quilt_mode = 'nocheck';
6594             } elsif (m/^--no-rm-on-error$/s) {
6595                 push @ropts, $_;
6596                 $rmonerror = 0;
6597             } elsif (m/^--no-chase-dsc-distro$/s) {
6598                 push @ropts, $_;
6599                 $chase_dsc_distro = 0;
6600             } elsif (m/^--overwrite$/s) {
6601                 push @ropts, $_;
6602                 $overwrite_version = '';
6603             } elsif (m/^--overwrite=(.+)$/s) {
6604                 push @ropts, $_;
6605                 $overwrite_version = $1;
6606             } elsif (m/^--delayed=(\d+)$/s) {
6607                 push @ropts, $_;
6608                 push @dput, $_;
6609             } elsif (m/^--dgit-view-save=(.+)$/s) {
6610                 push @ropts, $_;
6611                 $split_brain_save = $1;
6612                 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6613             } elsif (m/^--(no-)?rm-old-changes$/s) {
6614                 push @ropts, $_;
6615                 $rmchanges = !$1;
6616             } elsif (m/^--deliberately-($deliberately_re)$/s) {
6617                 push @ropts, $_;
6618                 push @deliberatelies, $&;
6619             } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6620                 push @ropts, $&;
6621                 $forceopts{$1} = 1;
6622                 $_='';
6623             } elsif (m/^--force-/) {
6624                 print STDERR
6625                     "$us: warning: ignoring unknown force option $_\n";
6626                 $_='';
6627             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6628                 # undocumented, for testing
6629                 push @ropts, $_;
6630                 $tagformat_want = [ $1, 'command line', 1 ];
6631                 # 1 menas overrides distro configuration
6632             } elsif (m/^--always-split-source-build$/s) {
6633                 # undocumented, for testing
6634                 push @ropts, $_;
6635                 $need_split_build_invocation = 1;
6636             } elsif (m/^--config-lookup-explode=(.+)$/s) {
6637                 # undocumented, for testing
6638                 push @ropts, $_;
6639                 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6640                 # ^ it's supposed to be an array ref
6641             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6642                 $val = $2 ? $' : undef; #';
6643                 $valopt->($oi->{Long});
6644             } elsif ($funcopts_long{$_}) {
6645                 push @ropts, $_;
6646                 $funcopts_long{$_}();
6647             } else {
6648                 badusage "unknown long option \`$_'";
6649             }
6650         } else {
6651             while (m/^-./s) {
6652                 if (s/^-n/-/) {
6653                     push @ropts, $&;
6654                     $dryrun_level=2;
6655                 } elsif (s/^-L/-/) {
6656                     push @ropts, $&;
6657                     $dryrun_level=1;
6658                 } elsif (s/^-h/-/) {
6659                     cmd_help();
6660                 } elsif (s/^-D/-/) {
6661                     push @ropts, $&;
6662                     $debuglevel++;
6663                     enabledebug();
6664                 } elsif (s/^-N/-/) {
6665                     push @ropts, $&;
6666                     $new_package=1;
6667                 } elsif (m/^-m/) {
6668                     push @ropts, $&;
6669                     push @changesopts, $_;
6670                     $_ = '';
6671                 } elsif (s/^-wn$//s) {
6672                     push @ropts, $&;
6673                     $cleanmode = 'none';
6674                 } elsif (s/^-wg$//s) {
6675                     push @ropts, $&;
6676                     $cleanmode = 'git';
6677                 } elsif (s/^-wgf$//s) {
6678                     push @ropts, $&;
6679                     $cleanmode = 'git-ff';
6680                 } elsif (s/^-wd$//s) {
6681                     push @ropts, $&;
6682                     $cleanmode = 'dpkg-source';
6683                 } elsif (s/^-wdd$//s) {
6684                     push @ropts, $&;
6685                     $cleanmode = 'dpkg-source-d';
6686                 } elsif (s/^-wc$//s) {
6687                     push @ropts, $&;
6688                     $cleanmode = 'check';
6689                 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6690                     push @git, '-c', $&;
6691                     $gitcfgs{cmdline}{$1} = [ $2 ];
6692                 } elsif (s/^-c([^=]+)$//s) {
6693                     push @git, '-c', $&;
6694                     $gitcfgs{cmdline}{$1} = [ 'true' ];
6695                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6696                     $val = $'; #';
6697                     $val = undef unless length $val;
6698                     $valopt->($oi->{Short});
6699                     $_ = '';
6700                 } else {
6701                     badusage "unknown short option \`$_'";
6702                 }
6703             }
6704         }
6705     }
6706 }
6707
6708 sub check_env_sanity () {
6709     my $blocked = new POSIX::SigSet;
6710     sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6711
6712     eval {
6713         foreach my $name (qw(PIPE CHLD)) {
6714             my $signame = "SIG$name";
6715             my $signum = eval "POSIX::$signame" // die;
6716             ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6717                 die "$signame is set to something other than SIG_DFL\n";
6718             $blocked->ismember($signum) and
6719                 die "$signame is blocked\n";
6720         }
6721     };
6722     return unless $@;
6723     chomp $@;
6724     fail <<END;
6725 On entry to dgit, $@
6726 This is a bug produced by something in in your execution environment.
6727 Giving up.
6728 END
6729 }
6730
6731
6732 sub parseopts_late_defaults () {
6733     $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
6734         if defined $idistro;
6735     $isuite //= cfg('dgit.default.default-suite');
6736
6737     foreach my $k (keys %opts_opt_map) {
6738         my $om = $opts_opt_map{$k};
6739
6740         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6741         if (defined $v) {
6742             badcfg "cannot set command for $k"
6743                 unless length $om->[0];
6744             $om->[0] = $v;
6745         }
6746
6747         foreach my $c (access_cfg_cfgs("opts-$k")) {
6748             my @vl =
6749                 map { $_ ? @$_ : () }
6750                 map { $gitcfgs{$_}{$c} }
6751                 reverse @gitcfgsources;
6752             printdebug "CL $c ", (join " ", map { shellquote } @vl),
6753                 "\n" if $debuglevel >= 4;
6754             next unless @vl;
6755             badcfg "cannot configure options for $k"
6756                 if $opts_opt_cmdonly{$k};
6757             my $insertpos = $opts_cfg_insertpos{$k};
6758             @$om = ( @$om[0..$insertpos-1],
6759                      @vl,
6760                      @$om[$insertpos..$#$om] );
6761         }
6762     }
6763
6764     if (!defined $rmchanges) {
6765         local $access_forpush;
6766         $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6767     }
6768
6769     if (!defined $quilt_mode) {
6770         local $access_forpush;
6771         $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6772             // access_cfg('quilt-mode', 'RETURN-UNDEF')
6773             // 'linear';
6774         $quilt_mode =~ m/^($quilt_modes_re)$/
6775             or badcfg "unknown quilt-mode \`$quilt_mode'";
6776         $quilt_mode = $1;
6777     }
6778
6779     foreach my $moc (@modeopt_cfgs) {
6780         local $access_forpush;
6781         my $vr = $moc->{Var};
6782         next if defined $$vr;
6783         $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
6784         my $v = $moc->{Vals}{$$vr};
6785         badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
6786         $$vr = $v;
6787     }
6788
6789     $need_split_build_invocation ||= quiltmode_splitbrain();
6790
6791     if (!defined $cleanmode) {
6792         local $access_forpush;
6793         $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6794         $cleanmode //= 'dpkg-source';
6795
6796         badcfg "unknown clean-mode \`$cleanmode'" unless
6797             $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6798     }
6799 }
6800
6801 if ($ENV{$fakeeditorenv}) {
6802     git_slurp_config();
6803     quilt_fixup_editor();
6804 }
6805
6806 parseopts();
6807 check_env_sanity();
6808
6809 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6810 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6811     if $dryrun_level == 1;
6812 if (!@ARGV) {
6813     print STDERR $helpmsg or die $!;
6814     exit 8;
6815 }
6816 $cmd = $subcommand = shift @ARGV;
6817 $cmd =~ y/-/_/;
6818
6819 my $pre_fn = ${*::}{"pre_$cmd"};
6820 $pre_fn->() if $pre_fn;
6821
6822 record_maindir if $invoked_in_git_tree;
6823 git_slurp_config();
6824
6825 my $fn = ${*::}{"cmd_$cmd"};
6826 $fn or badusage "unknown operation $cmd";
6827 $fn->();