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 die "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.
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: $fullrefname=$objid.\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 $forceflag = '';
2510     if (fetch_from_archive()) {
2511         if (is_fast_fwd(lrref(), 'HEAD')) {
2512             # ok
2513         } elsif (deliberately_not_fast_forward) {
2514             $forceflag = '+';
2515         } else {
2516             fail "dgit push: HEAD is not a descendant".
2517                 " of the archive's version.\n".
2518                 "dgit: To overwrite its contents,".
2519                 " use git merge -s ours ".lrref().".\n".
2520                 "dgit: To rewind history, if permitted by the archive,".
2521                 " use --deliberately-not-fast-forward";
2522         }
2523     } else {
2524         $new_package or
2525             fail "package appears to be new in this suite;".
2526                 " if this is intentional, use --new";
2527     }
2528
2529     supplementary_message(<<'END');
2530 Push failed, while preparing your push.
2531 You can retry the push, after fixing the problem, if you like.
2532 END
2533
2534     need_tagformat 'new', "quilt mode $quilt_mode"
2535         if quiltmode_splitbrain;
2536
2537     prep_ud();
2538
2539     access_giturl(); # check that success is vaguely likely
2540     select_tagformat();
2541
2542     my $clogpfn = ".git/dgit/changelog.822.tmp";
2543     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2544
2545     responder_send_file('parsed-changelog', $clogpfn);
2546
2547     my ($clogp, $cversion, $dscfn) =
2548         push_parse_changelog("$clogpfn");
2549
2550     my $dscpath = "$buildproductsdir/$dscfn";
2551     stat_exists $dscpath or
2552         fail "looked for .dsc $dscfn, but $!;".
2553             " maybe you forgot to build";
2554
2555     responder_send_file('dsc', $dscpath);
2556
2557     push_parse_dsc($dscpath, $dscfn, $cversion);
2558
2559     my $format = getfield $dsc, 'Format';
2560     printdebug "format $format\n";
2561
2562     my $actualhead = git_rev_parse('HEAD');
2563     my $dgithead = $actualhead;
2564     my $maintviewhead = undef;
2565
2566     if (madformat($format)) {
2567         # user might have not used dgit build, so maybe do this now:
2568         if (quiltmode_splitbrain()) {
2569             my $upstreamversion = $clogp->{Version};
2570             $upstreamversion =~ s/-[^-]*$//;
2571             changedir $ud;
2572             quilt_make_fake_dsc($upstreamversion);
2573             my ($dgitview, $cachekey) =
2574                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2575             $dgitview or fail
2576  "--quilt=$quilt_mode but no cached dgit view:
2577  perhaps tree changed since dgit build[-source] ?";
2578             $split_brain = 1;
2579             $dgithead = $dgitview;
2580             $maintviewhead = $actualhead;
2581             changedir '../../../..';
2582             prep_ud(); # so _only_subdir() works, below
2583         } else {
2584             commit_quilty_patch();
2585         }
2586     }
2587
2588     check_not_dirty();
2589     changedir $ud;
2590     progress "checking that $dscfn corresponds to HEAD";
2591     runcmd qw(dpkg-source -x --),
2592         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2593     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2594     check_for_vendor_patches() if madformat($dsc->{format});
2595     changedir '../../../..';
2596     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2597     my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2598     debugcmd "+",@diffcmd;
2599     $!=0; $?=-1;
2600     my $r = system @diffcmd;
2601     if ($r) {
2602         if ($r==256) {
2603             fail "$dscfn specifies a different tree to your HEAD commit;".
2604                 " perhaps you forgot to build".
2605                 ($diffopt eq '--exit-code' ? "" :
2606                  " (run with -D to see full diff output)");
2607         } else {
2608             failedcmd @diffcmd;
2609         }
2610     }
2611     if (!$changesfile) {
2612         my $pat = changespat $cversion;
2613         my @cs = glob "$buildproductsdir/$pat";
2614         fail "failed to find unique changes file".
2615             " (looked for $pat in $buildproductsdir);".
2616             " perhaps you need to use dgit -C"
2617             unless @cs==1;
2618         ($changesfile) = @cs;
2619     } else {
2620         $changesfile = "$buildproductsdir/$changesfile";
2621     }
2622
2623     # Checks complete, we're going to try and go ahead:
2624
2625     responder_send_file('changes',$changesfile);
2626     responder_send_command("param head $dgithead");
2627     responder_send_command("param csuite $csuite");
2628     responder_send_command("param tagformat $tagformat");
2629     if (quiltmode_splitbrain) {
2630         die unless ($protovsn//4) >= 4;
2631         responder_send_command("param maint-view $maintviewhead");
2632     }
2633
2634     if (deliberately_not_fast_forward) {
2635         git_for_each_ref(lrfetchrefs, sub {
2636             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2637             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2638             responder_send_command("previously $rrefname=$objid");
2639             $previously{$rrefname} = $objid;
2640         });
2641     }
2642
2643     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2644                                  ".git/dgit/tag");
2645     my @tagobjfns;
2646
2647     supplementary_message(<<'END');
2648 Push failed, while signing the tag.
2649 You can retry the push, after fixing the problem, if you like.
2650 END
2651     # If we manage to sign but fail to record it anywhere, it's fine.
2652     if ($we_are_responder) {
2653         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2654         responder_receive_files('signed-tag', @tagobjfns);
2655     } else {
2656         @tagobjfns = push_mktags($clogp,$dscpath,
2657                               $changesfile,$changesfile,
2658                               \@tagwants);
2659     }
2660     supplementary_message(<<'END');
2661 Push failed, *after* signing the tag.
2662 If you want to try again, you should use a new version number.
2663 END
2664
2665     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2666
2667     foreach my $tw (@tagwants) {
2668         my $tag = $tw->{Tag};
2669         my $tagobjfn = $tw->{TagObjFn};
2670         my $tag_obj_hash =
2671             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2672         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2673         runcmd_ordryrun_local
2674             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2675     }
2676
2677     supplementary_message(<<'END');
2678 Push failed, while updating the remote git repository - see messages above.
2679 If you want to try again, you should use a new version number.
2680 END
2681     if (!check_for_git()) {
2682         create_remote_git_repo();
2683     }
2684
2685     my @pushrefs = $forceflag.$dgithead.":".rrref();
2686     foreach my $tw (@tagwants) {
2687         my $view = $tw->{View};
2688         next unless $view eq 'dgit'
2689             or any { $_ eq $view } access_cfg_tagformats();
2690             # ^ $view is "dgit" or "maint" so this looks for "maint"
2691             # in archive supported tagformats.
2692         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2693     }
2694
2695     runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2696     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2697
2698     supplementary_message(<<'END');
2699 Push failed, after updating the remote git repository.
2700 If you want to try again, you must use a new version number.
2701 END
2702     if ($we_are_responder) {
2703         my $dryrunsuffix = act_local() ? "" : ".tmp";
2704         responder_receive_files('signed-dsc-changes',
2705                                 "$dscpath$dryrunsuffix",
2706                                 "$changesfile$dryrunsuffix");
2707     } else {
2708         if (act_local()) {
2709             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2710         } else {
2711             progress "[new .dsc left in $dscpath.tmp]";
2712         }
2713         sign_changes $changesfile;
2714     }
2715
2716     supplementary_message(<<END);
2717 Push failed, while uploading package(s) to the archive server.
2718 You can retry the upload of exactly these same files with dput of:
2719   $changesfile
2720 If that .changes file is broken, you will need to use a new version
2721 number for your next attempt at the upload.
2722 END
2723     my $host = access_cfg('upload-host','RETURN-UNDEF');
2724     my @hostarg = defined($host) ? ($host,) : ();
2725     runcmd_ordryrun @dput, @hostarg, $changesfile;
2726     printdone "pushed and uploaded $cversion";
2727
2728     supplementary_message('');
2729     responder_send_command("complete");
2730 }
2731
2732 sub cmd_clone {
2733     parseopts();
2734     notpushing();
2735     my $dstdir;
2736     badusage "-p is not allowed with clone; specify as argument instead"
2737         if defined $package;
2738     if (@ARGV==1) {
2739         ($package) = @ARGV;
2740     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2741         ($package,$isuite) = @ARGV;
2742     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2743         ($package,$dstdir) = @ARGV;
2744     } elsif (@ARGV==3) {
2745         ($package,$isuite,$dstdir) = @ARGV;
2746     } else {
2747         badusage "incorrect arguments to dgit clone";
2748     }
2749     $dstdir ||= "$package";
2750
2751     if (stat_exists $dstdir) {
2752         fail "$dstdir already exists";
2753     }
2754
2755     my $cwd_remove;
2756     if ($rmonerror && !$dryrun_level) {
2757         $cwd_remove= getcwd();
2758         unshift @end, sub {
2759             return unless defined $cwd_remove;
2760             if (!chdir "$cwd_remove") {
2761                 return if $!==&ENOENT;
2762                 die "chdir $cwd_remove: $!";
2763             }
2764             if (stat $dstdir) {
2765                 rmtree($dstdir) or die "remove $dstdir: $!\n";
2766             } elsif (!grep { $! == $_ }
2767                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2768             } else {
2769                 print STDERR "check whether to remove $dstdir: $!\n";
2770             }
2771         };
2772     }
2773
2774     clone($dstdir);
2775     $cwd_remove = undef;
2776 }
2777
2778 sub branchsuite () {
2779     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2780     if ($branch =~ m#$lbranch_re#o) {
2781         return $1;
2782     } else {
2783         return undef;
2784     }
2785 }
2786
2787 sub fetchpullargs () {
2788     notpushing();
2789     if (!defined $package) {
2790         my $sourcep = parsecontrol('debian/control','debian/control');
2791         $package = getfield $sourcep, 'Source';
2792     }
2793     if (@ARGV==0) {
2794 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
2795         if (!$isuite) {
2796             my $clogp = parsechangelog();
2797             $isuite = getfield $clogp, 'Distribution';
2798         }
2799         canonicalise_suite();
2800         progress "fetching from suite $csuite";
2801     } elsif (@ARGV==1) {
2802         ($isuite) = @ARGV;
2803         canonicalise_suite();
2804     } else {
2805         badusage "incorrect arguments to dgit fetch or dgit pull";
2806     }
2807 }
2808
2809 sub cmd_fetch {
2810     parseopts();
2811     fetchpullargs();
2812     fetch();
2813 }
2814
2815 sub cmd_pull {
2816     parseopts();
2817     fetchpullargs();
2818     pull();
2819 }
2820
2821 sub cmd_push {
2822     parseopts();
2823     pushing();
2824     badusage "-p is not allowed with dgit push" if defined $package;
2825     check_not_dirty();
2826     my $clogp = parsechangelog();
2827     $package = getfield $clogp, 'Source';
2828     my $specsuite;
2829     if (@ARGV==0) {
2830     } elsif (@ARGV==1) {
2831         ($specsuite) = (@ARGV);
2832     } else {
2833         badusage "incorrect arguments to dgit push";
2834     }
2835     $isuite = getfield $clogp, 'Distribution';
2836     if ($new_package) {
2837         local ($package) = $existing_package; # this is a hack
2838         canonicalise_suite();
2839     } else {
2840         canonicalise_suite();
2841     }
2842     if (defined $specsuite &&
2843         $specsuite ne $isuite &&
2844         $specsuite ne $csuite) {
2845             fail "dgit push: changelog specifies $isuite ($csuite)".
2846                 " but command line specifies $specsuite";
2847     }
2848     dopush();
2849 }
2850
2851 #---------- remote commands' implementation ----------
2852
2853 sub cmd_remote_push_build_host {
2854     my ($nrargs) = shift @ARGV;
2855     my (@rargs) = @ARGV[0..$nrargs-1];
2856     @ARGV = @ARGV[$nrargs..$#ARGV];
2857     die unless @rargs;
2858     my ($dir,$vsnwant) = @rargs;
2859     # vsnwant is a comma-separated list; we report which we have
2860     # chosen in our ready response (so other end can tell if they
2861     # offered several)
2862     $debugprefix = ' ';
2863     $we_are_responder = 1;
2864     $us .= " (build host)";
2865
2866     pushing();
2867
2868     open PI, "<&STDIN" or die $!;
2869     open STDIN, "/dev/null" or die $!;
2870     open PO, ">&STDOUT" or die $!;
2871     autoflush PO 1;
2872     open STDOUT, ">&STDERR" or die $!;
2873     autoflush STDOUT 1;
2874
2875     $vsnwant //= 1;
2876     ($protovsn) = grep {
2877         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2878     } @rpushprotovsn_support;
2879
2880     fail "build host has dgit rpush protocol versions ".
2881         (join ",", @rpushprotovsn_support).
2882         " but invocation host has $vsnwant"
2883         unless defined $protovsn;
2884
2885     responder_send_command("dgit-remote-push-ready $protovsn");
2886     rpush_handle_protovsn_bothends();
2887     changedir $dir;
2888     &cmd_push;
2889 }
2890
2891 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2892 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2893 #     a good error message)
2894
2895 sub rpush_handle_protovsn_bothends () {
2896     if ($protovsn < 4) {
2897         need_tagformat 'old', "rpush negotiated protocol $protovsn";
2898     }
2899     select_tagformat();
2900 }
2901
2902 our $i_tmp;
2903
2904 sub i_cleanup {
2905     local ($@, $?);
2906     my $report = i_child_report();
2907     if (defined $report) {
2908         printdebug "($report)\n";
2909     } elsif ($i_child_pid) {
2910         printdebug "(killing build host child $i_child_pid)\n";
2911         kill 15, $i_child_pid;
2912     }
2913     if (defined $i_tmp && !defined $initiator_tempdir) {
2914         changedir "/";
2915         eval { rmtree $i_tmp; };
2916     }
2917 }
2918
2919 END { i_cleanup(); }
2920
2921 sub i_method {
2922     my ($base,$selector,@args) = @_;
2923     $selector =~ s/\-/_/g;
2924     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2925 }
2926
2927 sub cmd_rpush {
2928     pushing();
2929     my $host = nextarg;
2930     my $dir;
2931     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2932         $host = $1;
2933         $dir = $'; #';
2934     } else {
2935         $dir = nextarg;
2936     }
2937     $dir =~ s{^-}{./-};
2938     my @rargs = ($dir);
2939     push @rargs, join ",", @rpushprotovsn_support;
2940     my @rdgit;
2941     push @rdgit, @dgit;
2942     push @rdgit, @ropts;
2943     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2944     push @rdgit, @ARGV;
2945     my @cmd = (@ssh, $host, shellquote @rdgit);
2946     debugcmd "+",@cmd;
2947
2948     if (defined $initiator_tempdir) {
2949         rmtree $initiator_tempdir;
2950         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2951         $i_tmp = $initiator_tempdir;
2952     } else {
2953         $i_tmp = tempdir();
2954     }
2955     $i_child_pid = open2(\*RO, \*RI, @cmd);
2956     changedir $i_tmp;
2957     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2958     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2959     $supplementary_message = '' unless $protovsn >= 3;
2960
2961     fail "rpush negotiated protocol version $protovsn".
2962         " which does not support quilt mode $quilt_mode"
2963         if quiltmode_splitbrain;
2964
2965     rpush_handle_protovsn_bothends();
2966     for (;;) {
2967         my ($icmd,$iargs) = initiator_expect {
2968             m/^(\S+)(?: (.*))?$/;
2969             ($1,$2);
2970         };
2971         i_method "i_resp", $icmd, $iargs;
2972     }
2973 }
2974
2975 sub i_resp_progress ($) {
2976     my ($rhs) = @_;
2977     my $msg = protocol_read_bytes \*RO, $rhs;
2978     progress $msg;
2979 }
2980
2981 sub i_resp_supplementary_message ($) {
2982     my ($rhs) = @_;
2983     $supplementary_message = protocol_read_bytes \*RO, $rhs;
2984 }
2985
2986 sub i_resp_complete {
2987     my $pid = $i_child_pid;
2988     $i_child_pid = undef; # prevents killing some other process with same pid
2989     printdebug "waiting for build host child $pid...\n";
2990     my $got = waitpid $pid, 0;
2991     die $! unless $got == $pid;
2992     die "build host child failed $?" if $?;
2993
2994     i_cleanup();
2995     printdebug "all done\n";
2996     exit 0;
2997 }
2998
2999 sub i_resp_file ($) {
3000     my ($keyword) = @_;
3001     my $localname = i_method "i_localname", $keyword;
3002     my $localpath = "$i_tmp/$localname";
3003     stat_exists $localpath and
3004         badproto \*RO, "file $keyword ($localpath) twice";
3005     protocol_receive_file \*RO, $localpath;
3006     i_method "i_file", $keyword;
3007 }
3008
3009 our %i_param;
3010
3011 sub i_resp_param ($) {
3012     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3013     $i_param{$1} = $2;
3014 }
3015
3016 sub i_resp_previously ($) {
3017     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3018         or badproto \*RO, "bad previously spec";
3019     my $r = system qw(git check-ref-format), $1;
3020     die "bad previously ref spec ($r)" if $r;
3021     $previously{$1} = $2;
3022 }
3023
3024 our %i_wanted;
3025
3026 sub i_resp_want ($) {
3027     my ($keyword) = @_;
3028     die "$keyword ?" if $i_wanted{$keyword}++;
3029     my @localpaths = i_method "i_want", $keyword;
3030     printdebug "[[  $keyword @localpaths\n";
3031     foreach my $localpath (@localpaths) {
3032         protocol_send_file \*RI, $localpath;
3033     }
3034     print RI "files-end\n" or die $!;
3035 }
3036
3037 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3038
3039 sub i_localname_parsed_changelog {
3040     return "remote-changelog.822";
3041 }
3042 sub i_file_parsed_changelog {
3043     ($i_clogp, $i_version, $i_dscfn) =
3044         push_parse_changelog "$i_tmp/remote-changelog.822";
3045     die if $i_dscfn =~ m#/|^\W#;
3046 }
3047
3048 sub i_localname_dsc {
3049     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3050     return $i_dscfn;
3051 }
3052 sub i_file_dsc { }
3053
3054 sub i_localname_changes {
3055     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3056     $i_changesfn = $i_dscfn;
3057     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3058     return $i_changesfn;
3059 }
3060 sub i_file_changes { }
3061
3062 sub i_want_signed_tag {
3063     printdebug Dumper(\%i_param, $i_dscfn);
3064     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3065         && defined $i_param{'csuite'}
3066         or badproto \*RO, "premature desire for signed-tag";
3067     my $head = $i_param{'head'};
3068     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3069
3070     my $maintview = $i_param{'maint-view'};
3071     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3072
3073     select_tagformat();
3074     if ($protovsn >= 4) {
3075         my $p = $i_param{'tagformat'} // '<undef>';
3076         $p eq $tagformat
3077             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3078     }
3079
3080     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3081     $csuite = $&;
3082     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3083
3084     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3085
3086     return
3087         push_mktags $i_clogp, $i_dscfn,
3088             $i_changesfn, 'remote changes',
3089             \@tagwants;
3090 }
3091
3092 sub i_want_signed_dsc_changes {
3093     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3094     sign_changes $i_changesfn;
3095     return ($i_dscfn, $i_changesfn);
3096 }
3097
3098 #---------- building etc. ----------
3099
3100 our $version;
3101 our $sourcechanges;
3102 our $dscfn;
3103
3104 #----- `3.0 (quilt)' handling -----
3105
3106 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3107
3108 sub quiltify_dpkg_commit ($$$;$) {
3109     my ($patchname,$author,$msg, $xinfo) = @_;
3110     $xinfo //= '';
3111
3112     mkpath '.git/dgit';
3113     my $descfn = ".git/dgit/quilt-description.tmp";
3114     open O, '>', $descfn or die "$descfn: $!";
3115     $msg =~ s/\s+$//g;
3116     $msg =~ s/\n/\n /g;
3117     $msg =~ s/^\s+$/ ./mg;
3118     print O <<END or die $!;
3119 Description: $msg
3120 Author: $author
3121 $xinfo
3122 ---
3123
3124 END
3125     close O or die $!;
3126
3127     {
3128         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3129         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3130         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3131         runcmd @dpkgsource, qw(--commit .), $patchname;
3132     }
3133 }
3134
3135 sub quiltify_trees_differ ($$;$$) {
3136     my ($x,$y,$finegrained,$ignorenamesr) = @_;
3137     # returns true iff the two tree objects differ other than in debian/
3138     # with $finegrained,
3139     # returns bitmask 01 - differ in upstream files except .gitignore
3140     #                 02 - differ in .gitignore
3141     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3142     #  is set for each modified .gitignore filename $fn
3143     local $/=undef;
3144     my @cmd = (@git, qw(diff-tree --name-only -z));
3145     push @cmd, qw(-r) if $finegrained;
3146     push @cmd, $x, $y;
3147     my $diffs= cmdoutput @cmd;
3148     my $r = 0;
3149     foreach my $f (split /\0/, $diffs) {
3150         next if $f =~ m#^debian(?:/.*)?$#s;
3151         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3152         $r |= $isignore ? 02 : 01;
3153         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3154     }
3155     printdebug "quiltify_trees_differ $x $y => $r\n";
3156     return $r;
3157 }
3158
3159 sub quiltify_tree_sentinelfiles ($) {
3160     # lists the `sentinel' files present in the tree
3161     my ($x) = @_;
3162     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3163         qw(-- debian/rules debian/control);
3164     $r =~ s/\n/,/g;
3165     return $r;
3166 }
3167
3168 sub quiltify_splitbrain_needed () {
3169     if (!$split_brain) {
3170         progress "dgit view: changes are required...";
3171         runcmd @git, qw(checkout -q -b dgit-view);
3172         $split_brain = 1;
3173     }
3174 }
3175
3176 sub quiltify_splitbrain ($$$$$$) {
3177     my ($clogp, $unapplied, $headref, $diffbits,
3178         $editedignores, $cachekey) = @_;
3179     if ($quilt_mode !~ m/gbp|dpm/) {
3180         # treat .gitignore just like any other upstream file
3181         $diffbits = { %$diffbits };
3182         $_ = !!$_ foreach values %$diffbits;
3183     }
3184     # We would like any commits we generate to be reproducible
3185     my @authline = clogp_authline($clogp);
3186     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
3187     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3188     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
3189
3190     if ($quilt_mode =~ m/gbp|unapplied/ &&
3191         ($diffbits->{H2O} & 01)) {
3192         my $msg =
3193  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3194  " but git tree differs from orig in upstream files.";
3195         if (!stat_exists "debian/patches") {
3196             $msg .=
3197  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3198         }
3199         fail $msg;
3200     }
3201     if ($quilt_mode =~ m/gbp|unapplied/ &&
3202         ($diffbits->{O2A} & 01)) { # some patches
3203         quiltify_splitbrain_needed();
3204         progress "dgit view: creating patches-applied version using gbp pq";
3205         runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3206         # gbp pq import creates a fresh branch; push back to dgit-view
3207         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3208         runcmd @git, qw(checkout -q dgit-view);
3209     }
3210     if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3211         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3212         quiltify_splitbrain_needed();
3213         progress "dgit view: creating patch to represent .gitignore changes";
3214         ensuredir "debian/patches";
3215         my $gipatch = "debian/patches/auto-gitignore";
3216         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3217         stat GIPATCH or die "$gipatch: $!";
3218         fail "$gipatch already exists; but want to create it".
3219             " to record .gitignore changes" if (stat _)[7];
3220         print GIPATCH <<END or die "$gipatch: $!";
3221 Subject: Update .gitignore from Debian packaging branch
3222
3223 The Debian packaging git branch contains these updates to the upstream
3224 .gitignore file(s).  This patch is autogenerated, to provide these
3225 updates to users of the official Debian archive view of the package.
3226
3227 [dgit version $our_version]
3228 ---
3229 END
3230         close GIPATCH or die "$gipatch: $!";
3231         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3232             $unapplied, $headref, "--", sort keys %$editedignores;
3233         open SERIES, "+>>", "debian/patches/series" or die $!;
3234         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3235         my $newline;
3236         defined read SERIES, $newline, 1 or die $!;
3237         print SERIES "\n" or die $! unless $newline eq "\n";
3238         print SERIES "auto-gitignore\n" or die $!;
3239         close SERIES or die  $!;
3240         runcmd @git, qw(add -- debian/patches/series), $gipatch;
3241         commit_admin "Commit patch to update .gitignore";
3242     }
3243
3244     my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3245
3246     changedir '../../../..';
3247     ensuredir ".git/logs/refs/dgit-intern";
3248     my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3249       or die $!;
3250     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3251         $dgitview;
3252
3253     progress "dgit view: created (commit id $dgitview)";
3254
3255     changedir '.git/dgit/unpack/work';
3256 }
3257
3258 sub quiltify ($$$$) {
3259     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3260
3261     # Quilt patchification algorithm
3262     #
3263     # We search backwards through the history of the main tree's HEAD
3264     # (T) looking for a start commit S whose tree object is identical
3265     # to to the patch tip tree (ie the tree corresponding to the
3266     # current dpkg-committed patch series).  For these purposes
3267     # `identical' disregards anything in debian/ - this wrinkle is
3268     # necessary because dpkg-source treates debian/ specially.
3269     #
3270     # We can only traverse edges where at most one of the ancestors'
3271     # trees differs (in changes outside in debian/).  And we cannot
3272     # handle edges which change .pc/ or debian/patches.  To avoid
3273     # going down a rathole we avoid traversing edges which introduce
3274     # debian/rules or debian/control.  And we set a limit on the
3275     # number of edges we are willing to look at.
3276     #
3277     # If we succeed, we walk forwards again.  For each traversed edge
3278     # PC (with P parent, C child) (starting with P=S and ending with
3279     # C=T) to we do this:
3280     #  - git checkout C
3281     #  - dpkg-source --commit with a patch name and message derived from C
3282     # After traversing PT, we git commit the changes which
3283     # should be contained within debian/patches.
3284
3285     # The search for the path S..T is breadth-first.  We maintain a
3286     # todo list containing search nodes.  A search node identifies a
3287     # commit, and looks something like this:
3288     #  $p = {
3289     #      Commit => $git_commit_id,
3290     #      Child => $c,                          # or undef if P=T
3291     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
3292     #      Nontrivial => true iff $p..$c has relevant changes
3293     #  };
3294
3295     my @todo;
3296     my @nots;
3297     my $sref_S;
3298     my $max_work=100;
3299     my %considered; # saves being exponential on some weird graphs
3300
3301     my $t_sentinels = quiltify_tree_sentinelfiles $target;
3302
3303     my $not = sub {
3304         my ($search,$whynot) = @_;
3305         printdebug " search NOT $search->{Commit} $whynot\n";
3306         $search->{Whynot} = $whynot;
3307         push @nots, $search;
3308         no warnings qw(exiting);
3309         next;
3310     };
3311
3312     push @todo, {
3313         Commit => $target,
3314     };
3315
3316     while (@todo) {
3317         my $c = shift @todo;
3318         next if $considered{$c->{Commit}}++;
3319
3320         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3321
3322         printdebug "quiltify investigate $c->{Commit}\n";
3323
3324         # are we done?
3325         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3326             printdebug " search finished hooray!\n";
3327             $sref_S = $c;
3328             last;
3329         }
3330
3331         if ($quilt_mode eq 'nofix') {
3332             fail "quilt fixup required but quilt mode is \`nofix'\n".
3333                 "HEAD commit $c->{Commit} differs from tree implied by ".
3334                 " debian/patches (tree object $oldtiptree)";
3335         }
3336         if ($quilt_mode eq 'smash') {
3337             printdebug " search quitting smash\n";
3338             last;
3339         }
3340
3341         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3342         $not->($c, "has $c_sentinels not $t_sentinels")
3343             if $c_sentinels ne $t_sentinels;
3344
3345         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3346         $commitdata =~ m/\n\n/;
3347         $commitdata =~ $`;
3348         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3349         @parents = map { { Commit => $_, Child => $c } } @parents;
3350
3351         $not->($c, "root commit") if !@parents;
3352
3353         foreach my $p (@parents) {
3354             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3355         }
3356         my $ndiffers = grep { $_->{Nontrivial} } @parents;
3357         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3358
3359         foreach my $p (@parents) {
3360             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3361
3362             my @cmd= (@git, qw(diff-tree -r --name-only),
3363                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3364             my $patchstackchange = cmdoutput @cmd;
3365             if (length $patchstackchange) {
3366                 $patchstackchange =~ s/\n/,/g;
3367                 $not->($p, "changed $patchstackchange");
3368             }
3369
3370             printdebug " search queue P=$p->{Commit} ",
3371                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3372             push @todo, $p;
3373         }
3374     }
3375
3376     if (!$sref_S) {
3377         printdebug "quiltify want to smash\n";
3378
3379         my $abbrev = sub {
3380             my $x = $_[0]{Commit};
3381             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3382             return $x;
3383         };
3384         my $reportnot = sub {
3385             my ($notp) = @_;
3386             my $s = $abbrev->($notp);
3387             my $c = $notp->{Child};
3388             $s .= "..".$abbrev->($c) if $c;
3389             $s .= ": ".$notp->{Whynot};
3390             return $s;
3391         };
3392         if ($quilt_mode eq 'linear') {
3393             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
3394             foreach my $notp (@nots) {
3395                 print STDERR "$us:  ", $reportnot->($notp), "\n";
3396             }
3397             print STDERR "$us: $_\n" foreach @$failsuggestion;
3398             fail "quilt fixup naive history linearisation failed.\n".
3399  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3400         } elsif ($quilt_mode eq 'smash') {
3401         } elsif ($quilt_mode eq 'auto') {
3402             progress "quilt fixup cannot be linear, smashing...";
3403         } else {
3404             die "$quilt_mode ?";
3405         }
3406
3407         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3408         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3409         my $ncommits = 3;
3410         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3411
3412         quiltify_dpkg_commit "auto-$version-$target-$time",
3413             (getfield $clogp, 'Maintainer'),
3414             "Automatically generated patch ($clogp->{Version})\n".
3415             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3416         return;
3417     }
3418
3419     progress "quiltify linearisation planning successful, executing...";
3420
3421     for (my $p = $sref_S;
3422          my $c = $p->{Child};
3423          $p = $p->{Child}) {
3424         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3425         next unless $p->{Nontrivial};
3426
3427         my $cc = $c->{Commit};
3428
3429         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3430         $commitdata =~ m/\n\n/ or die "$c ?";
3431         $commitdata = $`;
3432         my $msg = $'; #';
3433         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3434         my $author = $1;
3435
3436         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3437
3438         my $title = $1;
3439         my $patchname = $title;
3440         $patchname =~ s/[.:]$//;
3441         $patchname =~ y/ A-Z/-a-z/;
3442         $patchname =~ y/-a-z0-9_.+=~//cd;
3443         $patchname =~ s/^\W/x-$&/;
3444         $patchname = substr($patchname,0,40);
3445         my $index;
3446         for ($index='';
3447              stat "debian/patches/$patchname$index";
3448              $index++) { }
3449         $!==ENOENT or die "$patchname$index $!";
3450
3451         runcmd @git, qw(checkout -q), $cc;
3452
3453         # We use the tip's changelog so that dpkg-source doesn't
3454         # produce complaining messages from dpkg-parsechangelog.  None
3455         # of the information dpkg-source gets from the changelog is
3456         # actually relevant - it gets put into the original message
3457         # which dpkg-source provides our stunt editor, and then
3458         # overwritten.
3459         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3460
3461         quiltify_dpkg_commit "$patchname$index", $author, $msg,
3462             "X-Dgit-Generated: $clogp->{Version} $cc\n";
3463
3464         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3465     }
3466
3467     runcmd @git, qw(checkout -q master);
3468 }
3469
3470 sub build_maybe_quilt_fixup () {
3471     my ($format,$fopts) = get_source_format;
3472     return unless madformat $format;
3473     # sigh
3474
3475     check_for_vendor_patches();
3476
3477     my $clogp = parsechangelog();
3478     my $headref = git_rev_parse('HEAD');
3479
3480     prep_ud();
3481     changedir $ud;
3482
3483     my $upstreamversion=$version;
3484     $upstreamversion =~ s/-[^-]*$//;
3485
3486     if ($fopts->{'single-debian-patch'}) {
3487         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3488     } else {
3489         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3490     }
3491
3492     die 'bug' if $split_brain && !$need_split_build_invocation;
3493
3494     changedir '../../../..';
3495     runcmd_ordryrun_local
3496         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3497 }
3498
3499 sub quilt_fixup_mkwork ($) {
3500     my ($headref) = @_;
3501
3502     mkdir "work" or die $!;
3503     changedir "work";
3504     mktree_in_ud_here();
3505     runcmd @git, qw(reset -q --hard), $headref;
3506 }
3507
3508 sub quilt_fixup_linkorigs ($$) {
3509     my ($upstreamversion, $fn) = @_;
3510     # calls $fn->($leafname);
3511
3512     foreach my $f (<../../../../*>) { #/){
3513         my $b=$f; $b =~ s{.*/}{};
3514         {
3515             local ($debuglevel) = $debuglevel-1;
3516             printdebug "QF linkorigs $b, $f ?\n";
3517         }
3518         next unless is_orig_file $b, srcfn $upstreamversion,'';
3519         printdebug "QF linkorigs $b, $f Y\n";
3520         link_ltarget $f, $b or die "$b $!";
3521         $fn->($b);
3522     }
3523 }
3524
3525 sub quilt_fixup_delete_pc () {
3526     runcmd @git, qw(rm -rqf .pc);
3527     commit_admin "Commit removal of .pc (quilt series tracking data)";
3528 }
3529
3530 sub quilt_fixup_singlepatch ($$$) {
3531     my ($clogp, $headref, $upstreamversion) = @_;
3532
3533     progress "starting quiltify (single-debian-patch)";
3534
3535     # dpkg-source --commit generates new patches even if
3536     # single-debian-patch is in debian/source/options.  In order to
3537     # get it to generate debian/patches/debian-changes, it is
3538     # necessary to build the source package.
3539
3540     quilt_fixup_linkorigs($upstreamversion, sub { });
3541     quilt_fixup_mkwork($headref);
3542
3543     rmtree("debian/patches");
3544
3545     runcmd @dpkgsource, qw(-b .);
3546     chdir "..";
3547     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3548     rename srcfn("$upstreamversion", "/debian/patches"),
3549            "work/debian/patches";
3550
3551     chdir "work";
3552     commit_quilty_patch();
3553 }
3554
3555 sub quilt_make_fake_dsc ($) {
3556     my ($upstreamversion) = @_;
3557
3558     my $fakeversion="$upstreamversion-~~DGITFAKE";
3559
3560     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3561     print $fakedsc <<END or die $!;
3562 Format: 3.0 (quilt)
3563 Source: $package
3564 Version: $fakeversion
3565 Files:
3566 END
3567
3568     my $dscaddfile=sub {
3569         my ($b) = @_;
3570
3571         my $md = new Digest::MD5;
3572
3573         my $fh = new IO::File $b, '<' or die "$b $!";
3574         stat $fh or die $!;
3575         my $size = -s _;
3576
3577         $md->addfile($fh);
3578         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3579     };
3580
3581     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3582
3583     my @files=qw(debian/source/format debian/rules
3584                  debian/control debian/changelog);
3585     foreach my $maybe (qw(debian/patches debian/source/options
3586                           debian/tests/control)) {
3587         next unless stat_exists "../../../$maybe";
3588         push @files, $maybe;
3589     }
3590
3591     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3592     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3593
3594     $dscaddfile->($debtar);
3595     close $fakedsc or die $!;
3596 }
3597
3598 sub quilt_check_splitbrain_cache ($$) {
3599     my ($headref, $upstreamversion) = @_;
3600     # Called only if we are in (potentially) split brain mode.
3601     # Called in $ud.
3602     # Computes the cache key and looks in the cache.
3603     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3604
3605     my $splitbrain_cachekey;
3606
3607     progress
3608  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3609     # we look in the reflog of dgit-intern/quilt-cache
3610     # we look for an entry whose message is the key for the cache lookup
3611     my @cachekey = (qw(dgit), $our_version);
3612     push @cachekey, $upstreamversion;
3613     push @cachekey, $quilt_mode;
3614     push @cachekey, $headref;
3615
3616     push @cachekey, hashfile('fake.dsc');
3617
3618     my $srcshash = Digest::SHA->new(256);
3619     my %sfs = ( %INC, '$0(dgit)' => $0 );
3620     foreach my $sfk (sort keys %sfs) {
3621         next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3622         $srcshash->add($sfk,"  ");
3623         $srcshash->add(hashfile($sfs{$sfk}));
3624         $srcshash->add("\n");
3625     }
3626     push @cachekey, $srcshash->hexdigest();
3627     $splitbrain_cachekey = "@cachekey";
3628
3629     my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3630                $splitbraincache);
3631     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3632     debugcmd "|(probably)",@cmd;
3633     my $child = open GC, "-|";  defined $child or die $!;
3634     if (!$child) {
3635         chdir '../../..' or die $!;
3636         if (!stat ".git/logs/refs/$splitbraincache") {
3637             $! == ENOENT or die $!;
3638             printdebug ">(no reflog)\n";
3639             exit 0;
3640         }
3641         exec @cmd; die $!;
3642     }
3643     while (<GC>) {
3644         chomp;
3645         printdebug ">| ", $_, "\n" if $debuglevel > 1;
3646         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3647
3648         my $cachehit = $1;
3649         quilt_fixup_mkwork($headref);
3650         if ($cachehit ne $headref) {
3651             progress "dgit view: found cached (commit id $cachehit)";
3652             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3653             $split_brain = 1;
3654             return ($cachehit, $splitbrain_cachekey);
3655         }
3656         progress "dgit view: found cached, no changes required";
3657         return ($headref, $splitbrain_cachekey);
3658     }
3659     die $! if GC->error;
3660     failedcmd unless close GC;
3661
3662     printdebug "splitbrain cache miss\n";
3663     return (undef, $splitbrain_cachekey);
3664 }
3665
3666 sub quilt_fixup_multipatch ($$$) {
3667     my ($clogp, $headref, $upstreamversion) = @_;
3668
3669     progress "examining quilt state (multiple patches, $quilt_mode mode)";
3670
3671     # Our objective is:
3672     #  - honour any existing .pc in case it has any strangeness
3673     #  - determine the git commit corresponding to the tip of
3674     #    the patch stack (if there is one)
3675     #  - if there is such a git commit, convert each subsequent
3676     #    git commit into a quilt patch with dpkg-source --commit
3677     #  - otherwise convert all the differences in the tree into
3678     #    a single git commit
3679     #
3680     # To do this we:
3681
3682     # Our git tree doesn't necessarily contain .pc.  (Some versions of
3683     # dgit would include the .pc in the git tree.)  If there isn't
3684     # one, we need to generate one by unpacking the patches that we
3685     # have.
3686     #
3687     # We first look for a .pc in the git tree.  If there is one, we
3688     # will use it.  (This is not the normal case.)
3689     #
3690     # Otherwise need to regenerate .pc so that dpkg-source --commit
3691     # can work.  We do this as follows:
3692     #     1. Collect all relevant .orig from parent directory
3693     #     2. Generate a debian.tar.gz out of
3694     #         debian/{patches,rules,source/format,source/options}
3695     #     3. Generate a fake .dsc containing just these fields:
3696     #          Format Source Version Files
3697     #     4. Extract the fake .dsc
3698     #        Now the fake .dsc has a .pc directory.
3699     # (In fact we do this in every case, because in future we will
3700     # want to search for a good base commit for generating patches.)
3701     #
3702     # Then we can actually do the dpkg-source --commit
3703     #     1. Make a new working tree with the same object
3704     #        store as our main tree and check out the main
3705     #        tree's HEAD.
3706     #     2. Copy .pc from the fake's extraction, if necessary
3707     #     3. Run dpkg-source --commit
3708     #     4. If the result has changes to debian/, then
3709     #          - git-add them them
3710     #          - git-add .pc if we had a .pc in-tree
3711     #          - git-commit
3712     #     5. If we had a .pc in-tree, delete it, and git-commit
3713     #     6. Back in the main tree, fast forward to the new HEAD
3714
3715     # Another situation we may have to cope with is gbp-style
3716     # patches-unapplied trees.
3717     #
3718     # We would want to detect these, so we know to escape into
3719     # quilt_fixup_gbp.  However, this is in general not possible.
3720     # Consider a package with a one patch which the dgit user reverts
3721     # (with git-revert or the moral equivalent).
3722     #
3723     # That is indistinguishable in contents from a patches-unapplied
3724     # tree.  And looking at the history to distinguish them is not
3725     # useful because the user might have made a confusing-looking git
3726     # history structure (which ought to produce an error if dgit can't
3727     # cope, not a silent reintroduction of an unwanted patch).
3728     #
3729     # So gbp users will have to pass an option.  But we can usually
3730     # detect their failure to do so: if the tree is not a clean
3731     # patches-applied tree, quilt linearisation fails, but the tree
3732     # _is_ a clean patches-unapplied tree, we can suggest that maybe
3733     # they want --quilt=unapplied.
3734     #
3735     # To help detect this, when we are extracting the fake dsc, we
3736     # first extract it with --skip-patches, and then apply the patches
3737     # afterwards with dpkg-source --before-build.  That lets us save a
3738     # tree object corresponding to .origs.
3739
3740     my $splitbrain_cachekey;
3741
3742     quilt_make_fake_dsc($upstreamversion);
3743
3744     if (quiltmode_splitbrain()) {
3745         my $cachehit;
3746         ($cachehit, $splitbrain_cachekey) =
3747             quilt_check_splitbrain_cache($headref, $upstreamversion);
3748         return if $cachehit;
3749     }
3750
3751     runcmd qw(sh -ec),
3752         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3753
3754     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3755     rename $fakexdir, "fake" or die "$fakexdir $!";
3756
3757     changedir 'fake';
3758
3759     remove_stray_gits();
3760     mktree_in_ud_here();
3761
3762     rmtree '.pc';
3763
3764     runcmd @git, qw(add -Af .);
3765     my $unapplied=git_write_tree();
3766     printdebug "fake orig tree object $unapplied\n";
3767
3768     ensuredir '.pc';
3769
3770     runcmd qw(sh -ec),
3771         'exec dpkg-source --before-build . >/dev/null';
3772
3773     changedir '..';
3774
3775     quilt_fixup_mkwork($headref);
3776
3777     my $mustdeletepc=0;
3778     if (stat_exists ".pc") {
3779         -d _ or die;
3780         progress "Tree already contains .pc - will use it then delete it.";
3781         $mustdeletepc=1;
3782     } else {
3783         rename '../fake/.pc','.pc' or die $!;
3784     }
3785
3786     changedir '../fake';
3787     rmtree '.pc';
3788     runcmd @git, qw(add -Af .);
3789     my $oldtiptree=git_write_tree();
3790     printdebug "fake o+d/p tree object $unapplied\n";
3791     changedir '../work';
3792
3793
3794     # We calculate some guesswork now about what kind of tree this might
3795     # be.  This is mostly for error reporting.
3796
3797     my %editedignores;
3798     my $diffbits = {
3799         # H = user's HEAD
3800         # O = orig, without patches applied
3801         # A = "applied", ie orig with H's debian/patches applied
3802         H2O => quiltify_trees_differ($headref,  $unapplied, 1,\%editedignores),
3803         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
3804         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3805     };
3806
3807     my @dl;
3808     foreach my $b (qw(01 02)) {
3809         foreach my $v (qw(H2O O2A H2A)) {
3810             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3811         }
3812     }
3813     printdebug "differences \@dl @dl.\n";
3814
3815     progress sprintf
3816 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
3817 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
3818                              $dl[0], $dl[1],              $dl[3], $dl[4],
3819                                  $dl[2],                     $dl[5];
3820
3821     my @failsuggestion;
3822     if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3823         push @failsuggestion, "This might be a patches-unapplied branch.";
3824     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3825         push @failsuggestion, "This might be a patches-applied branch.";
3826     }
3827     push @failsuggestion, "Maybe you need to specify one of".
3828         " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3829
3830     if (quiltmode_splitbrain()) {
3831         quiltify_splitbrain($clogp, $unapplied, $headref,
3832                             $diffbits, \%editedignores,
3833                             $splitbrain_cachekey);
3834         return;
3835     }
3836
3837     progress "starting quiltify (multiple patches, $quilt_mode mode)";
3838     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3839
3840     if (!open P, '>>', ".pc/applied-patches") {
3841         $!==&ENOENT or die $!;
3842     } else {
3843         close P;
3844     }
3845
3846     commit_quilty_patch();
3847
3848     if ($mustdeletepc) {
3849         quilt_fixup_delete_pc();
3850     }
3851 }
3852
3853 sub quilt_fixup_editor () {
3854     my $descfn = $ENV{$fakeeditorenv};
3855     my $editing = $ARGV[$#ARGV];
3856     open I1, '<', $descfn or die "$descfn: $!";
3857     open I2, '<', $editing or die "$editing: $!";
3858     unlink $editing or die "$editing: $!";
3859     open O, '>', $editing or die "$editing: $!";
3860     while (<I1>) { print O or die $!; } I1->error and die $!;
3861     my $copying = 0;
3862     while (<I2>) {
3863         $copying ||= m/^\-\-\- /;
3864         next unless $copying;
3865         print O or die $!;
3866     }
3867     I2->error and die $!;
3868     close O or die $1;
3869     exit 0;
3870 }
3871
3872 sub maybe_apply_patches_dirtily () {
3873     return unless $quilt_mode =~ m/gbp|unapplied/;
3874     print STDERR <<END or die $!;
3875
3876 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3877 dgit: Have to apply the patches - making the tree dirty.
3878 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3879
3880 END
3881     $patches_applied_dirtily = 01;
3882     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3883     runcmd qw(dpkg-source --before-build .);
3884 }
3885
3886 sub maybe_unapply_patches_again () {
3887     progress "dgit: Unapplying patches again to tidy up the tree."
3888         if $patches_applied_dirtily;
3889     runcmd qw(dpkg-source --after-build .)
3890         if $patches_applied_dirtily & 01;
3891     rmtree '.pc'
3892         if $patches_applied_dirtily & 02;
3893     $patches_applied_dirtily = 0;
3894 }
3895
3896 #----- other building -----
3897
3898 our $clean_using_builder;
3899 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3900 #   clean the tree before building (perhaps invoked indirectly by
3901 #   whatever we are using to run the build), rather than separately
3902 #   and explicitly by us.
3903
3904 sub clean_tree () {
3905     return if $clean_using_builder;
3906     if ($cleanmode eq 'dpkg-source') {
3907         maybe_apply_patches_dirtily();
3908         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3909     } elsif ($cleanmode eq 'dpkg-source-d') {
3910         maybe_apply_patches_dirtily();
3911         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3912     } elsif ($cleanmode eq 'git') {
3913         runcmd_ordryrun_local @git, qw(clean -xdf);
3914     } elsif ($cleanmode eq 'git-ff') {
3915         runcmd_ordryrun_local @git, qw(clean -xdff);
3916     } elsif ($cleanmode eq 'check') {
3917         my $leftovers = cmdoutput @git, qw(clean -xdn);
3918         if (length $leftovers) {
3919             print STDERR $leftovers, "\n" or die $!;
3920             fail "tree contains uncommitted files and --clean=check specified";
3921         }
3922     } elsif ($cleanmode eq 'none') {
3923     } else {
3924         die "$cleanmode ?";
3925     }
3926 }
3927
3928 sub cmd_clean () {
3929     badusage "clean takes no additional arguments" if @ARGV;
3930     notpushing();
3931     clean_tree();
3932     maybe_unapply_patches_again();
3933 }
3934
3935 sub build_prep () {
3936     notpushing();
3937     badusage "-p is not allowed when building" if defined $package;
3938     check_not_dirty();
3939     clean_tree();
3940     my $clogp = parsechangelog();
3941     $isuite = getfield $clogp, 'Distribution';
3942     $package = getfield $clogp, 'Source';
3943     $version = getfield $clogp, 'Version';
3944     build_maybe_quilt_fixup();
3945     if ($rmchanges) {
3946         my $pat = changespat $version;
3947         foreach my $f (glob "$buildproductsdir/$pat") {
3948             if (act_local()) {
3949                 unlink $f or fail "remove old changes file $f: $!";
3950             } else {
3951                 progress "would remove $f";
3952             }
3953         }
3954     }
3955 }
3956
3957 sub changesopts_initial () {
3958     my @opts =@changesopts[1..$#changesopts];
3959 }
3960
3961 sub changesopts_version () {
3962     if (!defined $changes_since_version) {
3963         my @vsns = archive_query('archive_query');
3964         my @quirk = access_quirk();
3965         if ($quirk[0] eq 'backports') {
3966             local $isuite = $quirk[2];
3967             local $csuite;
3968             canonicalise_suite();
3969             push @vsns, archive_query('archive_query');
3970         }
3971         if (@vsns) {
3972             @vsns = map { $_->[0] } @vsns;
3973             @vsns = sort { -version_compare($a, $b) } @vsns;
3974             $changes_since_version = $vsns[0];
3975             progress "changelog will contain changes since $vsns[0]";
3976         } else {
3977             $changes_since_version = '_';
3978             progress "package seems new, not specifying -v<version>";
3979         }
3980     }
3981     if ($changes_since_version ne '_') {
3982         return ("-v$changes_since_version");
3983     } else {
3984         return ();
3985     }
3986 }
3987
3988 sub changesopts () {
3989     return (changesopts_initial(), changesopts_version());
3990 }
3991
3992 sub massage_dbp_args ($;$) {
3993     my ($cmd,$xargs) = @_;
3994     # We need to:
3995     #
3996     #  - if we're going to split the source build out so we can
3997     #    do strange things to it, massage the arguments to dpkg-buildpackage
3998     #    so that the main build doessn't build source (or add an argument
3999     #    to stop it building source by default).
4000     #
4001     #  - add -nc to stop dpkg-source cleaning the source tree,
4002     #    unless we're not doing a split build and want dpkg-source
4003     #    as cleanmode, in which case we can do nothing
4004     #
4005     # return values:
4006     #    0 - source will NOT need to be built separately by caller
4007     #   +1 - source will need to be built separately by caller
4008     #   +2 - source will need to be built separately by caller AND
4009     #        dpkg-buildpackage should not in fact be run at all!
4010     debugcmd '#massaging#', @$cmd if $debuglevel>1;
4011 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4012     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4013         $clean_using_builder = 1;
4014         return 0;
4015     }
4016     # -nc has the side effect of specifying -b if nothing else specified
4017     # and some combinations of -S, -b, et al, are errors, rather than
4018     # later simply overriding earlie.  So we need to:
4019     #  - search the command line for these options
4020     #  - pick the last one
4021     #  - perhaps add our own as a default
4022     #  - perhaps adjust it to the corresponding non-source-building version
4023     my $dmode = '-F';
4024     foreach my $l ($cmd, $xargs) {
4025         next unless $l;
4026         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4027     }
4028     push @$cmd, '-nc';
4029 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4030     my $r = 0;
4031     if ($need_split_build_invocation) {
4032         printdebug "massage split $dmode.\n";
4033         $r = $dmode =~ m/[S]/     ? +2 :
4034              $dmode =~ y/gGF/ABb/ ? +1 :
4035              $dmode =~ m/[ABb]/   ?  0 :
4036              die "$dmode ?";
4037     }
4038     printdebug "massage done $r $dmode.\n";
4039     push @$cmd, $dmode;
4040 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4041     return $r;
4042 }
4043
4044 sub cmd_build {
4045     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4046     my $wantsrc = massage_dbp_args \@dbp;
4047     if ($wantsrc > 0) {
4048         build_source();
4049     } else {
4050         build_prep();
4051     }
4052     if ($wantsrc < 2) {
4053         push @dbp, changesopts_version();
4054         maybe_apply_patches_dirtily();
4055         runcmd_ordryrun_local @dbp;
4056     }
4057     maybe_unapply_patches_again();
4058     printdone "build successful\n";
4059 }
4060
4061 sub cmd_gbp_build {
4062     my @dbp = @dpkgbuildpackage;
4063
4064     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4065
4066     my @cmd;
4067     if (length executable_on_path('git-buildpackage')) {
4068         @cmd = qw(git-buildpackage);
4069     } else {
4070         @cmd = qw(gbp buildpackage);
4071     }
4072     push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4073
4074     if ($wantsrc > 0) {
4075         build_source();
4076     } else {
4077         if (!$clean_using_builder) {
4078             push @cmd, '--git-cleaner=true';
4079         }
4080         build_prep();
4081     }
4082     maybe_unapply_patches_again();
4083     if ($wantsrc < 2) {
4084         unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4085             canonicalise_suite();
4086             push @cmd, "--git-debian-branch=".lbranch();
4087         }
4088         push @cmd, changesopts();
4089         runcmd_ordryrun_local @cmd, @ARGV;
4090     }
4091     printdone "build successful\n";
4092 }
4093 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4094
4095 sub build_source {
4096     my $our_cleanmode = $cleanmode;
4097     if ($need_split_build_invocation) {
4098         # Pretend that clean is being done some other way.  This
4099         # forces us not to try to use dpkg-buildpackage to clean and
4100         # build source all in one go; and instead we run dpkg-source
4101         # (and build_prep() will do the clean since $clean_using_builder
4102         # is false).
4103         $our_cleanmode = 'ELSEWHERE';
4104     }
4105     if ($our_cleanmode =~ m/^dpkg-source/) {
4106         # dpkg-source invocation (below) will clean, so build_prep shouldn't
4107         $clean_using_builder = 1;
4108     }
4109     build_prep();
4110     $sourcechanges = changespat $version,'source';
4111     if (act_local()) {
4112         unlink "../$sourcechanges" or $!==ENOENT
4113             or fail "remove $sourcechanges: $!";
4114     }
4115     $dscfn = dscfn($version);
4116     if ($our_cleanmode eq 'dpkg-source') {
4117         maybe_apply_patches_dirtily();
4118         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4119             changesopts();
4120     } elsif ($our_cleanmode eq 'dpkg-source-d') {
4121         maybe_apply_patches_dirtily();
4122         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4123             changesopts();
4124     } else {
4125         my @cmd = (@dpkgsource, qw(-b --));
4126         if ($split_brain) {
4127             changedir $ud;
4128             runcmd_ordryrun_local @cmd, "work";
4129             my @udfiles = <${package}_*>;
4130             changedir "../../..";
4131             foreach my $f (@udfiles) {
4132                 printdebug "source copy, found $f\n";
4133                 next unless
4134                     $f eq $dscfn or
4135                     ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4136                      $f eq srcfn($version, $&));
4137                 printdebug "source copy, found $f - renaming\n";
4138                 rename "$ud/$f", "../$f" or $!==ENOENT
4139                     or fail "put in place new source file ($f): $!";
4140             }
4141         } else {
4142             my $pwd = must_getcwd();
4143             my $leafdir = basename $pwd;
4144             changedir "..";
4145             runcmd_ordryrun_local @cmd, $leafdir;
4146             changedir $pwd;
4147         }
4148         runcmd_ordryrun_local qw(sh -ec),
4149             'exec >$1; shift; exec "$@"','x',
4150             "../$sourcechanges",
4151             @dpkggenchanges, qw(-S), changesopts();
4152     }
4153 }
4154
4155 sub cmd_build_source {
4156     badusage "build-source takes no additional arguments" if @ARGV;
4157     build_source();
4158     maybe_unapply_patches_again();
4159     printdone "source built, results in $dscfn and $sourcechanges";
4160 }
4161
4162 sub cmd_sbuild {
4163     build_source();
4164     my $pat = changespat $version;
4165     if (!$rmchanges) {
4166         my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4167         @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4168         fail "changes files other than source matching $pat".
4169             " already present (@unwanted);".
4170             " building would result in ambiguity about the intended results"
4171             if @unwanted;
4172     }
4173     my $wasdir = must_getcwd();
4174     changedir "..";
4175     if (act_local()) {
4176         stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4177         stat_exists $sourcechanges
4178             or fail "$sourcechanges (in parent directory): $!";
4179     }
4180     runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4181     my @changesfiles = glob $pat;
4182     @changesfiles = sort {
4183         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4184             or $a cmp $b
4185     } @changesfiles;
4186     fail "wrong number of different changes files (@changesfiles)"
4187         unless @changesfiles==2;
4188     my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4189     foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4190         fail "$l found in binaries changes file $binchanges"
4191             if $l =~ m/\.dsc$/;
4192     }
4193     runcmd_ordryrun_local @mergechanges, @changesfiles;
4194     my $multichanges = changespat $version,'multi';
4195     if (act_local()) {
4196         stat_exists $multichanges or fail "$multichanges: $!";
4197         foreach my $cf (glob $pat) {
4198             next if $cf eq $multichanges;
4199             rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4200         }
4201     }
4202     changedir $wasdir;
4203     maybe_unapply_patches_again();
4204     printdone "build successful, results in $multichanges\n" or die $!;
4205 }
4206
4207 sub cmd_quilt_fixup {
4208     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4209     my $clogp = parsechangelog();
4210     $version = getfield $clogp, 'Version';
4211     $package = getfield $clogp, 'Source';
4212     check_not_dirty();
4213     clean_tree();
4214     build_maybe_quilt_fixup();
4215 }
4216
4217 sub cmd_archive_api_query {
4218     badusage "need only 1 subpath argument" unless @ARGV==1;
4219     my ($subpath) = @ARGV;
4220     my @cmd = archive_api_query_cmd($subpath);
4221     debugcmd ">",@cmd;
4222     exec @cmd or fail "exec curl: $!\n";
4223 }
4224
4225 sub cmd_clone_dgit_repos_server {
4226     badusage "need destination argument" unless @ARGV==1;
4227     my ($destdir) = @ARGV;
4228     $package = '_dgit-repos-server';
4229     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4230     debugcmd ">",@cmd;
4231     exec @cmd or fail "exec git clone: $!\n";
4232 }
4233
4234 sub cmd_setup_mergechangelogs {
4235     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4236     setup_mergechangelogs(1);
4237 }
4238
4239 sub cmd_setup_useremail {
4240     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4241     setup_useremail(1);
4242 }
4243
4244 sub cmd_setup_new_tree {
4245     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4246     setup_new_tree();
4247 }
4248
4249 #---------- argument parsing and main program ----------
4250
4251 sub cmd_version {
4252     print "dgit version $our_version\n" or die $!;
4253     exit 0;
4254 }
4255
4256 our (%valopts_long, %valopts_short);
4257 our @rvalopts;
4258
4259 sub defvalopt ($$$$) {
4260     my ($long,$short,$val_re,$how) = @_;
4261     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4262     $valopts_long{$long} = $oi;
4263     $valopts_short{$short} = $oi;
4264     # $how subref should:
4265     #   do whatever assignemnt or thing it likes with $_[0]
4266     #   if the option should not be passed on to remote, @rvalopts=()
4267     # or $how can be a scalar ref, meaning simply assign the value
4268 }
4269
4270 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4271 defvalopt '--distro',        '-d', '.+',      \$idistro;
4272 defvalopt '',                '-k', '.+',      \$keyid;
4273 defvalopt '--existing-package','', '.*',      \$existing_package;
4274 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
4275 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
4276 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
4277
4278 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4279
4280 defvalopt '', '-C', '.+', sub {
4281     ($changesfile) = (@_);
4282     if ($changesfile =~ s#^(.*)/##) {
4283         $buildproductsdir = $1;
4284     }
4285 };
4286
4287 defvalopt '--initiator-tempdir','','.*', sub {
4288     ($initiator_tempdir) = (@_);
4289     $initiator_tempdir =~ m#^/# or
4290         badusage "--initiator-tempdir must be used specify an".
4291         " absolute, not relative, directory."
4292 };
4293
4294 sub parseopts () {
4295     my $om;
4296
4297     if (defined $ENV{'DGIT_SSH'}) {
4298         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4299     } elsif (defined $ENV{'GIT_SSH'}) {
4300         @ssh = ($ENV{'GIT_SSH'});
4301     }
4302
4303     my $oi;
4304     my $val;
4305     my $valopt = sub {
4306         my ($what) = @_;
4307         @rvalopts = ($_);
4308         if (!defined $val) {
4309             badusage "$what needs a value" unless @ARGV;
4310             $val = shift @ARGV;
4311             push @rvalopts, $val;
4312         }
4313         badusage "bad value \`$val' for $what" unless
4314             $val =~ m/^$oi->{Re}$(?!\n)/s;
4315         my $how = $oi->{How};
4316         if (ref($how) eq 'SCALAR') {
4317             $$how = $val;
4318         } else {
4319             $how->($val);
4320         }
4321         push @ropts, @rvalopts;
4322     };
4323
4324     while (@ARGV) {
4325         last unless $ARGV[0] =~ m/^-/;
4326         $_ = shift @ARGV;
4327         last if m/^--?$/;
4328         if (m/^--/) {
4329             if (m/^--dry-run$/) {
4330                 push @ropts, $_;
4331                 $dryrun_level=2;
4332             } elsif (m/^--damp-run$/) {
4333                 push @ropts, $_;
4334                 $dryrun_level=1;
4335             } elsif (m/^--no-sign$/) {
4336                 push @ropts, $_;
4337                 $sign=0;
4338             } elsif (m/^--help$/) {
4339                 cmd_help();
4340             } elsif (m/^--version$/) {
4341                 cmd_version();
4342             } elsif (m/^--new$/) {
4343                 push @ropts, $_;
4344                 $new_package=1;
4345             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4346                      ($om = $opts_opt_map{$1}) &&
4347                      length $om->[0]) {
4348                 push @ropts, $_;
4349                 $om->[0] = $2;
4350             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4351                      !$opts_opt_cmdonly{$1} &&
4352                      ($om = $opts_opt_map{$1})) {
4353                 push @ropts, $_;
4354                 push @$om, $2;
4355             } elsif (m/^--ignore-dirty$/s) {
4356                 push @ropts, $_;
4357                 $ignoredirty = 1;
4358             } elsif (m/^--no-quilt-fixup$/s) {
4359                 push @ropts, $_;
4360                 $quilt_mode = 'nocheck';
4361             } elsif (m/^--no-rm-on-error$/s) {
4362                 push @ropts, $_;
4363                 $rmonerror = 0;
4364             } elsif (m/^--(no-)?rm-old-changes$/s) {
4365                 push @ropts, $_;
4366                 $rmchanges = !$1;
4367             } elsif (m/^--deliberately-($deliberately_re)$/s) {
4368                 push @ropts, $_;
4369                 push @deliberatelies, $&;
4370             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4371                 # undocumented, for testing
4372                 push @ropts, $_;
4373                 $tagformat_want = [ $1, 'command line', 1 ];
4374                 # 1 menas overrides distro configuration
4375             } elsif (m/^--always-split-source-build$/s) {
4376                 # undocumented, for testing
4377                 push @ropts, $_;
4378                 $need_split_build_invocation = 1;
4379             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4380                 $val = $2 ? $' : undef; #';
4381                 $valopt->($oi->{Long});
4382             } else {
4383                 badusage "unknown long option \`$_'";
4384             }
4385         } else {
4386             while (m/^-./s) {
4387                 if (s/^-n/-/) {
4388                     push @ropts, $&;
4389                     $dryrun_level=2;
4390                 } elsif (s/^-L/-/) {
4391                     push @ropts, $&;
4392                     $dryrun_level=1;
4393                 } elsif (s/^-h/-/) {
4394                     cmd_help();
4395                 } elsif (s/^-D/-/) {
4396                     push @ropts, $&;
4397                     $debuglevel++;
4398                     enabledebug();
4399                 } elsif (s/^-N/-/) {
4400                     push @ropts, $&;
4401                     $new_package=1;
4402                 } elsif (m/^-m/) {
4403                     push @ropts, $&;
4404                     push @changesopts, $_;
4405                     $_ = '';
4406                 } elsif (s/^-wn$//s) {
4407                     push @ropts, $&;
4408                     $cleanmode = 'none';
4409                 } elsif (s/^-wg$//s) {
4410                     push @ropts, $&;
4411                     $cleanmode = 'git';
4412                 } elsif (s/^-wgf$//s) {
4413                     push @ropts, $&;
4414                     $cleanmode = 'git-ff';
4415                 } elsif (s/^-wd$//s) {
4416                     push @ropts, $&;
4417                     $cleanmode = 'dpkg-source';
4418                 } elsif (s/^-wdd$//s) {
4419                     push @ropts, $&;
4420                     $cleanmode = 'dpkg-source-d';
4421                 } elsif (s/^-wc$//s) {
4422                     push @ropts, $&;
4423                     $cleanmode = 'check';
4424                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4425                     $val = $'; #';
4426                     $val = undef unless length $val;
4427                     $valopt->($oi->{Short});
4428                     $_ = '';
4429                 } else {
4430                     badusage "unknown short option \`$_'";
4431                 }
4432             }
4433         }
4434     }
4435 }
4436
4437 sub finalise_opts_opts () {
4438     foreach my $k (keys %opts_opt_map) {
4439         my $om = $opts_opt_map{$k};
4440
4441         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4442         if (defined $v) {
4443             badcfg "cannot set command for $k"
4444                 unless length $om->[0];
4445             $om->[0] = $v;
4446         }
4447
4448         foreach my $c (access_cfg_cfgs("opts-$k")) {
4449             my $vl = $gitcfg{$c};
4450             printdebug "CL $c ",
4451                 ($vl ? join " ", map { shellquote } @$vl : ""),
4452                 "\n" if $debuglevel >= 4;
4453             next unless $vl;
4454             badcfg "cannot configure options for $k"
4455                 if $opts_opt_cmdonly{$k};
4456             my $insertpos = $opts_cfg_insertpos{$k};
4457             @$om = ( @$om[0..$insertpos-1],
4458                      @$vl,
4459                      @$om[$insertpos..$#$om] );
4460         }
4461     }
4462 }
4463
4464 if ($ENV{$fakeeditorenv}) {
4465     git_slurp_config();
4466     quilt_fixup_editor();
4467 }
4468
4469 parseopts();
4470 git_slurp_config();
4471
4472 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4473 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4474     if $dryrun_level == 1;
4475 if (!@ARGV) {
4476     print STDERR $helpmsg or die $!;
4477     exit 8;
4478 }
4479 my $cmd = shift @ARGV;
4480 $cmd =~ y/-/_/;
4481
4482 if (!defined $rmchanges) {
4483     local $access_forpush;
4484     $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4485 }
4486
4487 if (!defined $quilt_mode) {
4488     local $access_forpush;
4489     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4490         // access_cfg('quilt-mode', 'RETURN-UNDEF')
4491         // 'linear';
4492     $quilt_mode =~ m/^($quilt_modes_re)$/
4493         or badcfg "unknown quilt-mode \`$quilt_mode'";
4494     $quilt_mode = $1;
4495 }
4496
4497 $need_split_build_invocation ||= quiltmode_splitbrain();
4498
4499 if (!defined $cleanmode) {
4500     local $access_forpush;
4501     $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4502     $cleanmode //= 'dpkg-source';
4503
4504     badcfg "unknown clean-mode \`$cleanmode'" unless
4505         $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4506 }
4507
4508 my $fn = ${*::}{"cmd_$cmd"};
4509 $fn or badusage "unknown operation $cmd";
4510 $fn->();