dgit

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