dgit

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