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