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