dgit

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