dgit

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