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