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