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