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; $?=0;
 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 failedcmd @cmd;
 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 ($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 $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 failedcmd @gitscmd;
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 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; $?=0; 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         commit_quilty_patch();
2003     }
2004
2005     die 'xxx fast forward (should not depend on quilt mode, but will always be needed if we did $split_brain)' if $split_brain;
2006
2007     check_not_dirty();
2008     changedir $ud;
2009     progress "checking that $dscfn corresponds to HEAD";
2010     runcmd qw(dpkg-source -x --),
2011         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2012     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2013     check_for_vendor_patches() if madformat($dsc->{format});
2014     changedir '../../../..';
2015     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2016     my @diffcmd = (@git, qw(diff), $diffopt, $tree);
2017     debugcmd "+",@diffcmd;
2018     $!=0; $?=0;
2019     my $r = system @diffcmd;
2020     if ($r) {
2021         if ($r==256) {
2022             fail "$dscfn specifies a different tree to your HEAD commit;".
2023                 " perhaps you forgot to build".
2024                 ($diffopt eq '--exit-code' ? "" :
2025                  " (run with -D to see full diff output)");
2026         } else {
2027             failedcmd @diffcmd;
2028         }
2029     }
2030     if (!$changesfile) {
2031         my $pat = changespat $cversion;
2032         my @cs = glob "$buildproductsdir/$pat";
2033         fail "failed to find unique changes file".
2034             " (looked for $pat in $buildproductsdir);".
2035             " perhaps you need to use dgit -C"
2036             unless @cs==1;
2037         ($changesfile) = @cs;
2038     } else {
2039         $changesfile = "$buildproductsdir/$changesfile";
2040     }
2041
2042     responder_send_file('changes',$changesfile);
2043     responder_send_command("param head $head");
2044     responder_send_command("param csuite $csuite");
2045
2046     if (deliberately_not_fast_forward) {
2047         git_for_each_ref(lrfetchrefs, sub {
2048             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2049             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2050             responder_send_command("previously $rrefname=$objid");
2051             $previously{$rrefname} = $objid;
2052         });
2053     }
2054
2055     my $tfn = sub { ".git/dgit/tag$_[0]"; };
2056     my $tagobjfn;
2057
2058     supplementary_message(<<'END');
2059 Push failed, while signing the tag.
2060 You can retry the push, after fixing the problem, if you like.
2061 END
2062     # If we manage to sign but fail to record it anywhere, it's fine.
2063     if ($we_are_responder) {
2064         $tagobjfn = $tfn->('.signed.tmp');
2065         responder_receive_files('signed-tag', $tagobjfn);
2066     } else {
2067         $tagobjfn =
2068             push_mktag($head,$clogp,$tag,
2069                        $dscpath,
2070                        $changesfile,$changesfile,
2071                        $tfn);
2072     }
2073     supplementary_message(<<'END');
2074 Push failed, *after* signing the tag.
2075 If you want to try again, you should use a new version number.
2076 END
2077
2078     my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2079     runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2080     runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2081
2082     supplementary_message(<<'END');
2083 Push failed, while updating the remote git repository - see messages above.
2084 If you want to try again, you should use a new version number.
2085 END
2086     if (!check_for_git()) {
2087         create_remote_git_repo();
2088     }
2089     runcmd_ordryrun @git, qw(push),access_giturl(),
2090         $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2091     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2092
2093     supplementary_message(<<'END');
2094 Push failed, after updating the remote git repository.
2095 If you want to try again, you must use a new version number.
2096 END
2097     if ($we_are_responder) {
2098         my $dryrunsuffix = act_local() ? "" : ".tmp";
2099         responder_receive_files('signed-dsc-changes',
2100                                 "$dscpath$dryrunsuffix",
2101                                 "$changesfile$dryrunsuffix");
2102     } else {
2103         if (act_local()) {
2104             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2105         } else {
2106             progress "[new .dsc left in $dscpath.tmp]";
2107         }
2108         sign_changes $changesfile;
2109     }
2110
2111     supplementary_message(<<END);
2112 Push failed, while uploading package(s) to the archive server.
2113 You can retry the upload of exactly these same files with dput of:
2114   $changesfile
2115 If that .changes file is broken, you will need to use a new version
2116 number for your next attempt at the upload.
2117 END
2118     my $host = access_cfg('upload-host','RETURN-UNDEF');
2119     my @hostarg = defined($host) ? ($host,) : ();
2120     runcmd_ordryrun @dput, @hostarg, $changesfile;
2121     printdone "pushed and uploaded $cversion";
2122
2123     supplementary_message('');
2124     responder_send_command("complete");
2125 }
2126
2127 sub cmd_clone {
2128     parseopts();
2129     notpushing();
2130     my $dstdir;
2131     badusage "-p is not allowed with clone; specify as argument instead"
2132         if defined $package;
2133     if (@ARGV==1) {
2134         ($package) = @ARGV;
2135     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2136         ($package,$isuite) = @ARGV;
2137     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2138         ($package,$dstdir) = @ARGV;
2139     } elsif (@ARGV==3) {
2140         ($package,$isuite,$dstdir) = @ARGV;
2141     } else {
2142         badusage "incorrect arguments to dgit clone";
2143     }
2144     $dstdir ||= "$package";
2145
2146     if (stat_exists $dstdir) {
2147         fail "$dstdir already exists";
2148     }
2149
2150     my $cwd_remove;
2151     if ($rmonerror && !$dryrun_level) {
2152         $cwd_remove= getcwd();
2153         unshift @end, sub {
2154             return unless defined $cwd_remove;
2155             if (!chdir "$cwd_remove") {
2156                 return if $!==&ENOENT;
2157                 die "chdir $cwd_remove: $!";
2158             }
2159             if (stat $dstdir) {
2160                 rmtree($dstdir) or die "remove $dstdir: $!\n";
2161             } elsif (!grep { $! == $_ }
2162                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2163             } else {
2164                 print STDERR "check whether to remove $dstdir: $!\n";
2165             }
2166         };
2167     }
2168
2169     clone($dstdir);
2170     $cwd_remove = undef;
2171 }
2172
2173 sub branchsuite () {
2174     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2175     if ($branch =~ m#$lbranch_re#o) {
2176         return $1;
2177     } else {
2178         return undef;
2179     }
2180 }
2181
2182 sub fetchpullargs () {
2183     notpushing();
2184     if (!defined $package) {
2185         my $sourcep = parsecontrol('debian/control','debian/control');
2186         $package = getfield $sourcep, 'Source';
2187     }
2188     if (@ARGV==0) {
2189 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
2190         if (!$isuite) {
2191             my $clogp = parsechangelog();
2192             $isuite = getfield $clogp, 'Distribution';
2193         }
2194         canonicalise_suite();
2195         progress "fetching from suite $csuite";
2196     } elsif (@ARGV==1) {
2197         ($isuite) = @ARGV;
2198         canonicalise_suite();
2199     } else {
2200         badusage "incorrect arguments to dgit fetch or dgit pull";
2201     }
2202 }
2203
2204 sub cmd_fetch {
2205     parseopts();
2206     fetchpullargs();
2207     fetch();
2208 }
2209
2210 sub cmd_pull {
2211     parseopts();
2212     fetchpullargs();
2213     pull();
2214 }
2215
2216 sub cmd_push {
2217     parseopts();
2218     pushing();
2219     badusage "-p is not allowed with dgit push" if defined $package;
2220     check_not_dirty();
2221     my $clogp = parsechangelog();
2222     $package = getfield $clogp, 'Source';
2223     my $specsuite;
2224     if (@ARGV==0) {
2225     } elsif (@ARGV==1) {
2226         ($specsuite) = (@ARGV);
2227     } else {
2228         badusage "incorrect arguments to dgit push";
2229     }
2230     $isuite = getfield $clogp, 'Distribution';
2231     if ($new_package) {
2232         local ($package) = $existing_package; # this is a hack
2233         canonicalise_suite();
2234     } else {
2235         canonicalise_suite();
2236     }
2237     if (defined $specsuite &&
2238         $specsuite ne $isuite &&
2239         $specsuite ne $csuite) {
2240             fail "dgit push: changelog specifies $isuite ($csuite)".
2241                 " but command line specifies $specsuite";
2242     }
2243     supplementary_message(<<'END');
2244 Push failed, while checking state of the archive.
2245 You can retry the push, after fixing the problem, if you like.
2246 END
2247     if (check_for_git()) {
2248         git_fetch_us();
2249     }
2250     my $forceflag = '';
2251     if (fetch_from_archive()) {
2252         if (is_fast_fwd(lrref(), 'HEAD')) {
2253             # ok
2254         } elsif (deliberately_not_fast_forward) {
2255             $forceflag = '+';
2256         } else {
2257             fail "dgit push: HEAD is not a descendant".
2258                 " of the archive's version.\n".
2259                 "dgit: To overwrite its contents,".
2260                 " use git merge -s ours ".lrref().".\n".
2261                 "dgit: To rewind history, if permitted by the archive,".
2262                 " use --deliberately-not-fast-forward";
2263         }
2264     } else {
2265         $new_package or
2266             fail "package appears to be new in this suite;".
2267                 " if this is intentional, use --new";
2268     }
2269     dopush($forceflag);
2270 }
2271
2272 #---------- remote commands' implementation ----------
2273
2274 sub cmd_remote_push_build_host {
2275     my ($nrargs) = shift @ARGV;
2276     my (@rargs) = @ARGV[0..$nrargs-1];
2277     @ARGV = @ARGV[$nrargs..$#ARGV];
2278     die unless @rargs;
2279     my ($dir,$vsnwant) = @rargs;
2280     # vsnwant is a comma-separated list; we report which we have
2281     # chosen in our ready response (so other end can tell if they
2282     # offered several)
2283     $debugprefix = ' ';
2284     $we_are_responder = 1;
2285     $us .= " (build host)";
2286
2287     pushing();
2288
2289     open PI, "<&STDIN" or die $!;
2290     open STDIN, "/dev/null" or die $!;
2291     open PO, ">&STDOUT" or die $!;
2292     autoflush PO 1;
2293     open STDOUT, ">&STDERR" or die $!;
2294     autoflush STDOUT 1;
2295
2296     $vsnwant //= 1;
2297     ($protovsn) = grep {
2298         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2299     } @rpushprotovsn_support;
2300
2301     fail "build host has dgit rpush protocol versions ".
2302         (join ",", @rpushprotovsn_support).
2303         " but invocation host has $vsnwant"
2304         unless defined $protovsn;
2305
2306     responder_send_command("dgit-remote-push-ready $protovsn");
2307
2308     changedir $dir;
2309     &cmd_push;
2310 }
2311
2312 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2313 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2314 #     a good error message)
2315
2316 our $i_tmp;
2317
2318 sub i_cleanup {
2319     local ($@, $?);
2320     my $report = i_child_report();
2321     if (defined $report) {
2322         printdebug "($report)\n";
2323     } elsif ($i_child_pid) {
2324         printdebug "(killing build host child $i_child_pid)\n";
2325         kill 15, $i_child_pid;
2326     }
2327     if (defined $i_tmp && !defined $initiator_tempdir) {
2328         changedir "/";
2329         eval { rmtree $i_tmp; };
2330     }
2331 }
2332
2333 END { i_cleanup(); }
2334
2335 sub i_method {
2336     my ($base,$selector,@args) = @_;
2337     $selector =~ s/\-/_/g;
2338     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2339 }
2340
2341 sub cmd_rpush {
2342     pushing();
2343     my $host = nextarg;
2344     my $dir;
2345     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2346         $host = $1;
2347         $dir = $'; #';
2348     } else {
2349         $dir = nextarg;
2350     }
2351     $dir =~ s{^-}{./-};
2352     my @rargs = ($dir);
2353     push @rargs, join ",", @rpushprotovsn_support;
2354     my @rdgit;
2355     push @rdgit, @dgit;
2356     push @rdgit, @ropts;
2357     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2358     push @rdgit, @ARGV;
2359     my @cmd = (@ssh, $host, shellquote @rdgit);
2360     debugcmd "+",@cmd;
2361
2362     if (defined $initiator_tempdir) {
2363         rmtree $initiator_tempdir;
2364         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2365         $i_tmp = $initiator_tempdir;
2366     } else {
2367         $i_tmp = tempdir();
2368     }
2369     $i_child_pid = open2(\*RO, \*RI, @cmd);
2370     changedir $i_tmp;
2371     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2372     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2373     $supplementary_message = '' unless $protovsn >= 3;
2374     for (;;) {
2375         my ($icmd,$iargs) = initiator_expect {
2376             m/^(\S+)(?: (.*))?$/;
2377             ($1,$2);
2378         };
2379         i_method "i_resp", $icmd, $iargs;
2380     }
2381 }
2382
2383 sub i_resp_progress ($) {
2384     my ($rhs) = @_;
2385     my $msg = protocol_read_bytes \*RO, $rhs;
2386     progress $msg;
2387 }
2388
2389 sub i_resp_supplementary_message ($) {
2390     my ($rhs) = @_;
2391     $supplementary_message = protocol_read_bytes \*RO, $rhs;
2392 }
2393
2394 sub i_resp_complete {
2395     my $pid = $i_child_pid;
2396     $i_child_pid = undef; # prevents killing some other process with same pid
2397     printdebug "waiting for build host child $pid...\n";
2398     my $got = waitpid $pid, 0;
2399     die $! unless $got == $pid;
2400     die "build host child failed $?" if $?;
2401
2402     i_cleanup();
2403     printdebug "all done\n";
2404     exit 0;
2405 }
2406
2407 sub i_resp_file ($) {
2408     my ($keyword) = @_;
2409     my $localname = i_method "i_localname", $keyword;
2410     my $localpath = "$i_tmp/$localname";
2411     stat_exists $localpath and
2412         badproto \*RO, "file $keyword ($localpath) twice";
2413     protocol_receive_file \*RO, $localpath;
2414     i_method "i_file", $keyword;
2415 }
2416
2417 our %i_param;
2418
2419 sub i_resp_param ($) {
2420     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2421     $i_param{$1} = $2;
2422 }
2423
2424 sub i_resp_previously ($) {
2425     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2426         or badproto \*RO, "bad previously spec";
2427     my $r = system qw(git check-ref-format), $1;
2428     die "bad previously ref spec ($r)" if $r;
2429     $previously{$1} = $2;
2430 }
2431
2432 our %i_wanted;
2433
2434 sub i_resp_want ($) {
2435     my ($keyword) = @_;
2436     die "$keyword ?" if $i_wanted{$keyword}++;
2437     my @localpaths = i_method "i_want", $keyword;
2438     printdebug "[[  $keyword @localpaths\n";
2439     foreach my $localpath (@localpaths) {
2440         protocol_send_file \*RI, $localpath;
2441     }
2442     print RI "files-end\n" or die $!;
2443 }
2444
2445 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2446
2447 sub i_localname_parsed_changelog {
2448     return "remote-changelog.822";
2449 }
2450 sub i_file_parsed_changelog {
2451     ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2452         push_parse_changelog "$i_tmp/remote-changelog.822";
2453     die if $i_dscfn =~ m#/|^\W#;
2454 }
2455
2456 sub i_localname_dsc {
2457     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2458     return $i_dscfn;
2459 }
2460 sub i_file_dsc { }
2461
2462 sub i_localname_changes {
2463     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2464     $i_changesfn = $i_dscfn;
2465     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2466     return $i_changesfn;
2467 }
2468 sub i_file_changes { }
2469
2470 sub i_want_signed_tag {
2471     printdebug Dumper(\%i_param, $i_dscfn);
2472     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2473         && defined $i_param{'csuite'}
2474         or badproto \*RO, "premature desire for signed-tag";
2475     my $head = $i_param{'head'};
2476     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2477
2478     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2479     $csuite = $&;
2480     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2481
2482     my $tagobjfn =
2483         push_mktag $head, $i_clogp, $i_tag,
2484             $i_dscfn,
2485             $i_changesfn, 'remote changes',
2486             sub { "tag$_[0]"; };
2487
2488     return $tagobjfn;
2489 }
2490
2491 sub i_want_signed_dsc_changes {
2492     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2493     sign_changes $i_changesfn;
2494     return ($i_dscfn, $i_changesfn);
2495 }
2496
2497 #---------- building etc. ----------
2498
2499 our $version;
2500 our $sourcechanges;
2501 our $dscfn;
2502
2503 #----- `3.0 (quilt)' handling -----
2504
2505 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2506
2507 sub quiltify_dpkg_commit ($$$;$) {
2508     my ($patchname,$author,$msg, $xinfo) = @_;
2509     $xinfo //= '';
2510
2511     mkpath '.git/dgit';
2512     my $descfn = ".git/dgit/quilt-description.tmp";
2513     open O, '>', $descfn or die "$descfn: $!";
2514     $msg =~ s/\s+$//g;
2515     $msg =~ s/\n/\n /g;
2516     $msg =~ s/^\s+$/ ./mg;
2517     print O <<END or die $!;
2518 Description: $msg
2519 Author: $author
2520 $xinfo
2521 ---
2522
2523 END
2524     close O or die $!;
2525
2526     {
2527         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2528         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2529         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2530         runcmd @dpkgsource, qw(--commit .), $patchname;
2531     }
2532 }
2533
2534 sub quiltify_trees_differ ($$;$$) {
2535     my ($x,$y,$finegrained,$ignorenamesr) = @_;
2536     # returns true iff the two tree objects differ other than in debian/
2537     # with $finegrained,
2538     # returns bitmask 01 - differ in upstream files except .gitignore
2539     #                 02 - differ in .gitignore
2540     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
2541     #  is set for each modified .gitignore filename $fn
2542     local $/=undef;
2543     my @cmd = (@git, qw(diff-tree --name-only -z));
2544     push @cmd, qw(-r) if $finegrained;
2545     push @cmd, $x, $y;
2546     my $diffs= cmdoutput @cmd;
2547     my $r = 0;
2548     foreach my $f (split /\0/, $diffs) {
2549         next if $f =~ m#^debian(?:/.*)?$#s;
2550         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
2551         $r |= $isignore ? 02 : 01;
2552         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
2553     }
2554     printdebug "quiltify_trees_differ $x $y => $r\n";
2555     return $r;
2556 }
2557
2558 sub quiltify_tree_sentinelfiles ($) {
2559     # lists the `sentinel' files present in the tree
2560     my ($x) = @_;
2561     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2562         qw(-- debian/rules debian/control);
2563     $r =~ s/\n/,/g;
2564     return $r;
2565 }
2566
2567 sub quiltify_splitbrain_needed () {
2568     if (!$split_brain) {
2569         progress "dgit view: changes are required...";
2570         runcmd @git, qw(checkout -q -b dgit-view);
2571         $split_brain = 1;
2572     }
2573 }
2574
2575 sub quiltify_splitbrain ($$$$$$) {
2576     my ($clogp, $unapplied, $headref, $diffbits,
2577         $editedignores, $cachekey) = @_;
2578     if ($quilt_mode !~ m/gbp|dpm/) {
2579         # treat .gitignore just like any other upstream file
2580         $diffbits = { %$diffbits };
2581         $_ = !!$_ foreach values %$diffbits;
2582     }
2583     # We would like any commits we generate to be reproducible
2584     my @authline = clogp_authline($clogp);
2585     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2586     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2587     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2588
2589     if ($quilt_mode =~ m/gbp|unapplied/ &&
2590         ($diffbits->{H2O} & 01)) {
2591         my $msg =
2592  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
2593  " but git tree differs from orig in upstream files.";
2594         if (!stat_exists "debian/patches") {
2595             $msg .=
2596  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
2597         }
2598         fail $msg;
2599     }
2600     if ($quilt_mode =~ m/gbp|unapplied/ &&
2601         ($diffbits->{O2A} & 01)) { # some patches
2602         quiltify_splitbrain_needed();
2603         progress "dgit view: creating patches-applied version using gbp pq";
2604         runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
2605         # gbp pq import creates a fresh branch; push back to dgit-view
2606         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
2607         runcmd @git, qw(checkout -q dgit-view);
2608     }
2609     if (($diffbits->{H2O} & 02) && # user has modified .gitignore
2610         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
2611         quiltify_splitbrain_needed();
2612         progress "dgit view: creating patch to represent .gitignore changes";
2613         ensuredir "debian/patches";
2614         my $gipatch = "debian/patches/auto-gitignore";
2615         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
2616         stat GIPATCH or die "$gipatch: $!";
2617         fail "$gipatch already exists; but want to create it".
2618             " to record .gitignore changes" if (stat _)[7];
2619         print GIPATCH <<END or die "$gipatch: $!";
2620 Subject: Update .gitignore from Debian packaging branch
2621
2622 The Debian packaging git branch contains these updates to the upstream
2623 .gitignore file(s).  This patch is autogenerated, to provide these
2624 updates to users of the official Debian archive view of the package.
2625
2626 [dgit version $our_version]
2627 ---
2628 END
2629         close GIPATCH or die "$gipatch: $!";
2630         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
2631             $unapplied, $headref, "--", sort keys %$editedignores;
2632         open SERIES, "+>>", "debian/patches/series" or die $!;
2633         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
2634         my $newline;
2635         defined read SERIES, $newline, 1 or die $!;
2636         print SERIES "\n" or die $! unless $newline eq "\n";
2637         print SERIES "auto-gitignore\n" or die $!;
2638         close SERIES or die  $!;
2639         runcmd @git, qw(add -- debian/patches/series), $gipatch;
2640         commit_admin "Commit patch to update .gitignore";
2641     }
2642
2643     my $dgitview = git_rev_parse 'refs/heads/dgit-view';
2644
2645     changedir '../../../..';
2646     ensuredir ".git/logs/refs/dgit-intern";
2647     my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
2648       or die $!;
2649     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
2650         $dgitview;
2651
2652     progress "dgit view: created (commit id $dgitview)";
2653
2654     changedir '.git/dgit/unpack/work';
2655 }
2656
2657 sub quiltify ($$$$) {
2658     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
2659
2660     # Quilt patchification algorithm
2661     #
2662     # We search backwards through the history of the main tree's HEAD
2663     # (T) looking for a start commit S whose tree object is identical
2664     # to to the patch tip tree (ie the tree corresponding to the
2665     # current dpkg-committed patch series).  For these purposes
2666     # `identical' disregards anything in debian/ - this wrinkle is
2667     # necessary because dpkg-source treates debian/ specially.
2668     #
2669     # We can only traverse edges where at most one of the ancestors'
2670     # trees differs (in changes outside in debian/).  And we cannot
2671     # handle edges which change .pc/ or debian/patches.  To avoid
2672     # going down a rathole we avoid traversing edges which introduce
2673     # debian/rules or debian/control.  And we set a limit on the
2674     # number of edges we are willing to look at.
2675     #
2676     # If we succeed, we walk forwards again.  For each traversed edge
2677     # PC (with P parent, C child) (starting with P=S and ending with
2678     # C=T) to we do this:
2679     #  - git checkout C
2680     #  - dpkg-source --commit with a patch name and message derived from C
2681     # After traversing PT, we git commit the changes which
2682     # should be contained within debian/patches.
2683
2684     # The search for the path S..T is breadth-first.  We maintain a
2685     # todo list containing search nodes.  A search node identifies a
2686     # commit, and looks something like this:
2687     #  $p = {
2688     #      Commit => $git_commit_id,
2689     #      Child => $c,                          # or undef if P=T
2690     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
2691     #      Nontrivial => true iff $p..$c has relevant changes
2692     #  };
2693
2694     my @todo;
2695     my @nots;
2696     my $sref_S;
2697     my $max_work=100;
2698     my %considered; # saves being exponential on some weird graphs
2699
2700     my $t_sentinels = quiltify_tree_sentinelfiles $target;
2701
2702     my $not = sub {
2703         my ($search,$whynot) = @_;
2704         printdebug " search NOT $search->{Commit} $whynot\n";
2705         $search->{Whynot} = $whynot;
2706         push @nots, $search;
2707         no warnings qw(exiting);
2708         next;
2709     };
2710
2711     push @todo, {
2712         Commit => $target,
2713     };
2714
2715     while (@todo) {
2716         my $c = shift @todo;
2717         next if $considered{$c->{Commit}}++;
2718
2719         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2720
2721         printdebug "quiltify investigate $c->{Commit}\n";
2722
2723         # are we done?
2724         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2725             printdebug " search finished hooray!\n";
2726             $sref_S = $c;
2727             last;
2728         }
2729
2730         if ($quilt_mode eq 'nofix') {
2731             fail "quilt fixup required but quilt mode is \`nofix'\n".
2732                 "HEAD commit $c->{Commit} differs from tree implied by ".
2733                 " debian/patches (tree object $oldtiptree)";
2734         }
2735         if ($quilt_mode eq 'smash') {
2736             printdebug " search quitting smash\n";
2737             last;
2738         }
2739
2740         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2741         $not->($c, "has $c_sentinels not $t_sentinels")
2742             if $c_sentinels ne $t_sentinels;
2743
2744         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2745         $commitdata =~ m/\n\n/;
2746         $commitdata =~ $`;
2747         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2748         @parents = map { { Commit => $_, Child => $c } } @parents;
2749
2750         $not->($c, "root commit") if !@parents;
2751
2752         foreach my $p (@parents) {
2753             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2754         }
2755         my $ndiffers = grep { $_->{Nontrivial} } @parents;
2756         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2757
2758         foreach my $p (@parents) {
2759             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2760
2761             my @cmd= (@git, qw(diff-tree -r --name-only),
2762                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2763             my $patchstackchange = cmdoutput @cmd;
2764             if (length $patchstackchange) {
2765                 $patchstackchange =~ s/\n/,/g;
2766                 $not->($p, "changed $patchstackchange");
2767             }
2768
2769             printdebug " search queue P=$p->{Commit} ",
2770                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2771             push @todo, $p;
2772         }
2773     }
2774
2775     if (!$sref_S) {
2776         printdebug "quiltify want to smash\n";
2777
2778         my $abbrev = sub {
2779             my $x = $_[0]{Commit};
2780             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2781             return $x;
2782         };
2783         my $reportnot = sub {
2784             my ($notp) = @_;
2785             my $s = $abbrev->($notp);
2786             my $c = $notp->{Child};
2787             $s .= "..".$abbrev->($c) if $c;
2788             $s .= ": ".$notp->{Whynot};
2789             return $s;
2790         };
2791         if ($quilt_mode eq 'linear') {
2792             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
2793             foreach my $notp (@nots) {
2794                 print STDERR "$us:  ", $reportnot->($notp), "\n";
2795             }
2796             print STDERR "$us: $_\n" foreach @$failsuggestion;
2797             fail "quilt fixup naive history linearisation failed.\n".
2798  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2799         } elsif ($quilt_mode eq 'smash') {
2800         } elsif ($quilt_mode eq 'auto') {
2801             progress "quilt fixup cannot be linear, smashing...";
2802         } else {
2803             die "$quilt_mode ?";
2804         }
2805
2806         my $time = time;
2807         my $ncommits = 3;
2808         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2809
2810         quiltify_dpkg_commit "auto-$version-$target-$time",
2811             (getfield $clogp, 'Maintainer'),
2812             "Automatically generated patch ($clogp->{Version})\n".
2813             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2814         return;
2815     }
2816
2817     progress "quiltify linearisation planning successful, executing...";
2818
2819     for (my $p = $sref_S;
2820          my $c = $p->{Child};
2821          $p = $p->{Child}) {
2822         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2823         next unless $p->{Nontrivial};
2824
2825         my $cc = $c->{Commit};
2826
2827         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2828         $commitdata =~ m/\n\n/ or die "$c ?";
2829         $commitdata = $`;
2830         my $msg = $'; #';
2831         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2832         my $author = $1;
2833
2834         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2835
2836         my $title = $1;
2837         my $patchname = $title;
2838         $patchname =~ s/[.:]$//;
2839         $patchname =~ y/ A-Z/-a-z/;
2840         $patchname =~ y/-a-z0-9_.+=~//cd;
2841         $patchname =~ s/^\W/x-$&/;
2842         $patchname = substr($patchname,0,40);
2843         my $index;
2844         for ($index='';
2845              stat "debian/patches/$patchname$index";
2846              $index++) { }
2847         $!==ENOENT or die "$patchname$index $!";
2848
2849         runcmd @git, qw(checkout -q), $cc;
2850
2851         # We use the tip's changelog so that dpkg-source doesn't
2852         # produce complaining messages from dpkg-parsechangelog.  None
2853         # of the information dpkg-source gets from the changelog is
2854         # actually relevant - it gets put into the original message
2855         # which dpkg-source provides our stunt editor, and then
2856         # overwritten.
2857         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2858
2859         quiltify_dpkg_commit "$patchname$index", $author, $msg,
2860             "X-Dgit-Generated: $clogp->{Version} $cc\n";
2861
2862         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2863     }
2864
2865     runcmd @git, qw(checkout -q master);
2866 }
2867
2868 sub build_maybe_quilt_fixup () {
2869     my ($format,$fopts) = get_source_format;
2870     return unless madformat $format;
2871     # sigh
2872
2873     check_for_vendor_patches();
2874
2875     my $clogp = parsechangelog();
2876     my $headref = git_rev_parse('HEAD');
2877
2878     prep_ud();
2879     changedir $ud;
2880
2881     my $upstreamversion=$version;
2882     $upstreamversion =~ s/-[^-]*$//;
2883
2884     if ($fopts->{'single-debian-patch'}) {
2885         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
2886     } else {
2887         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
2888     }
2889
2890     die 'bug' if $split_brain && !$need_split_build_invocation;
2891
2892     changedir '../../../..';
2893     runcmd_ordryrun_local
2894         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2895 }
2896
2897 sub quilt_fixup_mkwork ($) {
2898     my ($headref) = @_;
2899
2900     mkdir "work" or die $!;
2901     changedir "work";
2902     mktree_in_ud_here();
2903     runcmd @git, qw(reset -q --hard), $headref;
2904 }
2905
2906 sub quilt_fixup_linkorigs ($$) {
2907     my ($upstreamversion, $fn) = @_;
2908     # calls $fn->($leafname);
2909
2910     foreach my $f (<../../../../*>) { #/){
2911         my $b=$f; $b =~ s{.*/}{};
2912         {
2913             local ($debuglevel) = $debuglevel-1;
2914             printdebug "QF linkorigs $b, $f ?\n";
2915         }
2916         next unless is_orig_file $b, srcfn $upstreamversion,'';
2917         printdebug "QF linkorigs $b, $f Y\n";
2918         link_ltarget $f, $b or die "$b $!";
2919         $fn->($b);
2920     }
2921 }
2922
2923 sub quilt_fixup_delete_pc () {
2924     runcmd @git, qw(rm -rqf .pc);
2925     commit_admin "Commit removal of .pc (quilt series tracking data)";
2926 }
2927
2928 sub quilt_fixup_singlepatch ($$$) {
2929     my ($clogp, $headref, $upstreamversion) = @_;
2930
2931     progress "starting quiltify (single-debian-patch)";
2932
2933     # dpkg-source --commit generates new patches even if
2934     # single-debian-patch is in debian/source/options.  In order to
2935     # get it to generate debian/patches/debian-changes, it is
2936     # necessary to build the source package.
2937
2938     quilt_fixup_linkorigs($upstreamversion, sub { });
2939     quilt_fixup_mkwork($headref);
2940
2941     rmtree("debian/patches");
2942
2943     runcmd @dpkgsource, qw(-b .);
2944     chdir "..";
2945     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
2946     rename srcfn("$upstreamversion", "/debian/patches"),
2947            "work/debian/patches";
2948
2949     chdir "work";
2950     commit_quilty_patch();
2951 }
2952
2953 sub quilt_make_fake_dsc ($) {
2954     my ($upstreamversion) = @_;
2955
2956     my $fakeversion="$upstreamversion-~~DGITFAKE";
2957
2958     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2959     print $fakedsc <<END or die $!;
2960 Format: 3.0 (quilt)
2961 Source: $package
2962 Version: $fakeversion
2963 Files:
2964 END
2965
2966     my $dscaddfile=sub {
2967         my ($b) = @_;
2968
2969         my $md = new Digest::MD5;
2970
2971         my $fh = new IO::File $b, '<' or die "$b $!";
2972         stat $fh or die $!;
2973         my $size = -s _;
2974
2975         $md->addfile($fh);
2976         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2977     };
2978
2979     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
2980
2981     my @files=qw(debian/source/format debian/rules
2982                  debian/control debian/changelog);
2983     foreach my $maybe (qw(debian/patches debian/source/options
2984                           debian/tests/control)) {
2985         next unless stat_exists "../../../$maybe";
2986         push @files, $maybe;
2987     }
2988
2989     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2990     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
2991
2992     $dscaddfile->($debtar);
2993     close $fakedsc or die $!;
2994 }
2995
2996 sub quilt_check_splitbrain_cache ($$) {
2997     my ($headref, $upstreamversion) = @_;
2998     # Called only if we are in (potentially) split brain mode.
2999     # Called in $ud.
3000     # Computes the cache key and looks in the cache.
3001     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3002
3003     my $splitbrain_cachekey;
3004
3005     progress
3006  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3007     # we look in the reflog of dgit-intern/quilt-cache
3008     # we look for an entry whose message is the key for the cache lookup
3009     my @cachekey = (qw(dgit), $our_version);
3010     push @cachekey, $upstreamversion;
3011     push @cachekey, $quilt_mode;
3012     push @cachekey, $headref;
3013
3014     push @cachekey, hashfile('fake.dsc');
3015
3016     my $srcshash = Digest::SHA->new(256);
3017     my %sfs = ( %INC, '$0(dgit)' => $0 );
3018     foreach my $sfk (sort keys %sfs) {
3019         next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3020         $srcshash->add($sfk,"  ");
3021         $srcshash->add(hashfile($sfs{$sfk}));
3022         $srcshash->add("\n");
3023     }
3024     push @cachekey, $srcshash->hexdigest();
3025     $splitbrain_cachekey = "@cachekey";
3026
3027     my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3028                $splitbraincache);
3029     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3030     debugcmd "|(probably)",@cmd;
3031     my $child = open GC, "-|";  defined $child or die $!;
3032     if (!$child) {
3033         chdir '../../..' or die $!;
3034         if (!stat ".git/logs/refs/$splitbraincache") {
3035             $! == ENOENT or die $!;
3036             printdebug ">(no reflog)\n";
3037             exit 0;
3038         }
3039         exec @cmd; die $!;
3040     }
3041     while (<GC>) {
3042         chomp;
3043         printdebug ">| ", $_, "\n" if $debuglevel > 1;
3044         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3045
3046         my $cachehit = $1;
3047         quilt_fixup_mkwork($headref);
3048         if ($cachehit ne $headref) {
3049             progress "dgit view: found cached (commit id $cachehit)";
3050             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3051             $split_brain = 1;
3052             return ($cachehit, $splitbrain_cachekey);
3053         }
3054         progress "dgit view: found cached, no changes required";
3055         return ($headref, $splitbrain_cachekey);
3056     }
3057     die $! if GC->error;
3058     failedcmd unless close GC;
3059
3060     printdebug "splitbrain cache miss\n";
3061     return (undef, $splitbrain_cachekey);
3062 }
3063
3064 sub quilt_fixup_multipatch ($$$) {
3065     my ($clogp, $headref, $upstreamversion) = @_;
3066
3067     progress "examining quilt state (multiple patches, $quilt_mode mode)";
3068
3069     # Our objective is:
3070     #  - honour any existing .pc in case it has any strangeness
3071     #  - determine the git commit corresponding to the tip of
3072     #    the patch stack (if there is one)
3073     #  - if there is such a git commit, convert each subsequent
3074     #    git commit into a quilt patch with dpkg-source --commit
3075     #  - otherwise convert all the differences in the tree into
3076     #    a single git commit
3077     #
3078     # To do this we:
3079
3080     # Our git tree doesn't necessarily contain .pc.  (Some versions of
3081     # dgit would include the .pc in the git tree.)  If there isn't
3082     # one, we need to generate one by unpacking the patches that we
3083     # have.
3084     #
3085     # We first look for a .pc in the git tree.  If there is one, we
3086     # will use it.  (This is not the normal case.)
3087     #
3088     # Otherwise need to regenerate .pc so that dpkg-source --commit
3089     # can work.  We do this as follows:
3090     #     1. Collect all relevant .orig from parent directory
3091     #     2. Generate a debian.tar.gz out of
3092     #         debian/{patches,rules,source/format,source/options}
3093     #     3. Generate a fake .dsc containing just these fields:
3094     #          Format Source Version Files
3095     #     4. Extract the fake .dsc
3096     #        Now the fake .dsc has a .pc directory.
3097     # (In fact we do this in every case, because in future we will
3098     # want to search for a good base commit for generating patches.)
3099     #
3100     # Then we can actually do the dpkg-source --commit
3101     #     1. Make a new working tree with the same object
3102     #        store as our main tree and check out the main
3103     #        tree's HEAD.
3104     #     2. Copy .pc from the fake's extraction, if necessary
3105     #     3. Run dpkg-source --commit
3106     #     4. If the result has changes to debian/, then
3107     #          - git-add them them
3108     #          - git-add .pc if we had a .pc in-tree
3109     #          - git-commit
3110     #     5. If we had a .pc in-tree, delete it, and git-commit
3111     #     6. Back in the main tree, fast forward to the new HEAD
3112
3113     # Another situation we may have to cope with is gbp-style
3114     # patches-unapplied trees.
3115     #
3116     # We would want to detect these, so we know to escape into
3117     # quilt_fixup_gbp.  However, this is in general not possible.
3118     # Consider a package with a one patch which the dgit user reverts
3119     # (with git-revert or the moral equivalent).
3120     #
3121     # That is indistinguishable in contents from a patches-unapplied
3122     # tree.  And looking at the history to distinguish them is not
3123     # useful because the user might have made a confusing-looking git
3124     # history structure (which ought to produce an error if dgit can't
3125     # cope, not a silent reintroduction of an unwanted patch).
3126     #
3127     # So gbp users will have to pass an option.  But we can usually
3128     # detect their failure to do so: if the tree is not a clean
3129     # patches-applied tree, quilt linearisation fails, but the tree
3130     # _is_ a clean patches-unapplied tree, we can suggest that maybe
3131     # they want --quilt=unapplied.
3132     #
3133     # To help detect this, when we are extracting the fake dsc, we
3134     # first extract it with --skip-patches, and then apply the patches
3135     # afterwards with dpkg-source --before-build.  That lets us save a
3136     # tree object corresponding to .origs.
3137
3138     my $splitbrain_cachekey;
3139
3140     quilt_make_fake_dsc($upstreamversion);
3141
3142     if (quiltmode_splitbrain()) {
3143         my $cachehit;
3144         ($cachehit, $splitbrain_cachekey) =
3145             quilt_check_splitbrain_cache($headref, $upstreamversion);
3146         return if $cachehit;
3147     }
3148
3149     runcmd qw(sh -ec),
3150         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3151
3152     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3153     rename $fakexdir, "fake" or die "$fakexdir $!";
3154
3155     changedir 'fake';
3156
3157     remove_stray_gits();
3158     mktree_in_ud_here();
3159
3160     rmtree '.pc';
3161
3162     runcmd @git, qw(add -Af .);
3163     my $unapplied=git_write_tree();
3164     printdebug "fake orig tree object $unapplied\n";
3165
3166     ensuredir '.pc';
3167
3168     runcmd qw(sh -ec),
3169         'exec dpkg-source --before-build . >/dev/null';
3170
3171     changedir '..';
3172
3173     quilt_fixup_mkwork($headref);
3174
3175     my $mustdeletepc=0;
3176     if (stat_exists ".pc") {
3177         -d _ or die;
3178         progress "Tree already contains .pc - will use it then delete it.";
3179         $mustdeletepc=1;
3180     } else {
3181         rename '../fake/.pc','.pc' or die $!;
3182     }
3183
3184     changedir '../fake';
3185     rmtree '.pc';
3186     runcmd @git, qw(add -Af .);
3187     my $oldtiptree=git_write_tree();
3188     printdebug "fake o+d/p tree object $unapplied\n";
3189     changedir '../work';
3190
3191
3192     # We calculate some guesswork now about what kind of tree this might
3193     # be.  This is mostly for error reporting.
3194
3195     my %editedignores;
3196     my $diffbits = {
3197         # H = user's HEAD
3198         # O = orig, without patches applied
3199         # A = "applied", ie orig with H's debian/patches applied
3200         H2O => quiltify_trees_differ($headref,  $unapplied, 1,\%editedignores),
3201         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
3202         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3203     };
3204
3205     my @dl;
3206     foreach my $b (qw(01 02)) {
3207         foreach my $v (qw(H2O O2A H2A)) {
3208             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3209         }
3210     }
3211     printdebug "differences \@dl @dl.\n";
3212
3213     progress sprintf
3214 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
3215 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
3216                              $dl[0], $dl[1],              $dl[3], $dl[4],
3217                                  $dl[2],                     $dl[5];
3218
3219     my @failsuggestion;
3220     if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3221         push @failsuggestion, "This might be a patches-unapplied branch.";
3222     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3223         push @failsuggestion, "This might be a patches-applied branch.";
3224     }
3225     push @failsuggestion, "Maybe you need to specify one of".
3226         " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3227
3228     if (quiltmode_splitbrain()) {
3229         quiltify_splitbrain($clogp, $unapplied, $headref,
3230                             $diffbits, \%editedignores,
3231                             $splitbrain_cachekey);
3232         return;
3233     }
3234
3235     progress "starting quiltify (multiple patches, $quilt_mode mode)";
3236     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3237
3238     if (!open P, '>>', ".pc/applied-patches") {
3239         $!==&ENOENT or die $!;
3240     } else {
3241         close P;
3242     }
3243
3244     commit_quilty_patch();
3245
3246     if ($mustdeletepc) {
3247         quilt_fixup_delete_pc();
3248     }
3249 }
3250
3251 sub quilt_fixup_editor () {
3252     my $descfn = $ENV{$fakeeditorenv};
3253     my $editing = $ARGV[$#ARGV];
3254     open I1, '<', $descfn or die "$descfn: $!";
3255     open I2, '<', $editing or die "$editing: $!";
3256     unlink $editing or die "$editing: $!";
3257     open O, '>', $editing or die "$editing: $!";
3258     while (<I1>) { print O or die $!; } I1->error and die $!;
3259     my $copying = 0;
3260     while (<I2>) {
3261         $copying ||= m/^\-\-\- /;
3262         next unless $copying;
3263         print O or die $!;
3264     }
3265     I2->error and die $!;
3266     close O or die $1;
3267     exit 0;
3268 }
3269
3270 sub maybe_apply_patches_dirtily () {
3271     return unless $quilt_mode =~ m/gbp|unapplied/;
3272     print STDERR <<END or die $!;
3273
3274 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3275 dgit: Have to apply the patches - making the tree dirty.
3276 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3277
3278 END
3279     $patches_applied_dirtily = 01;
3280     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3281     runcmd qw(dpkg-source --before-build .);
3282 }
3283
3284 sub maybe_unapply_patches_again () {
3285     progress "dgit: Unapplying patches again to tidy up the tree."
3286         if $patches_applied_dirtily;
3287     runcmd qw(dpkg-source --after-build .)
3288         if $patches_applied_dirtily & 01;
3289     rmtree '.pc'
3290         if $patches_applied_dirtily & 02;
3291 }
3292
3293 #----- other building -----
3294
3295 our $clean_using_builder;
3296 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3297 #   clean the tree before building (perhaps invoked indirectly by
3298 #   whatever we are using to run the build), rather than separately
3299 #   and explicitly by us.
3300
3301 sub clean_tree () {
3302     return if $clean_using_builder;
3303     if ($cleanmode eq 'dpkg-source') {
3304         maybe_apply_patches_dirtily();
3305         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3306     } elsif ($cleanmode eq 'dpkg-source-d') {
3307         maybe_apply_patches_dirtily();
3308         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3309     } elsif ($cleanmode eq 'git') {
3310         runcmd_ordryrun_local @git, qw(clean -xdf);
3311     } elsif ($cleanmode eq 'git-ff') {
3312         runcmd_ordryrun_local @git, qw(clean -xdff);
3313     } elsif ($cleanmode eq 'check') {
3314         my $leftovers = cmdoutput @git, qw(clean -xdn);
3315         if (length $leftovers) {
3316             print STDERR $leftovers, "\n" or die $!;
3317             fail "tree contains uncommitted files and --clean=check specified";
3318         }
3319     } elsif ($cleanmode eq 'none') {
3320     } else {
3321         die "$cleanmode ?";
3322     }
3323 }
3324
3325 sub cmd_clean () {
3326     badusage "clean takes no additional arguments" if @ARGV;
3327     notpushing();
3328     clean_tree();
3329     maybe_unapply_patches_again();
3330 }
3331
3332 sub build_prep () {
3333     notpushing();
3334     badusage "-p is not allowed when building" if defined $package;
3335     check_not_dirty();
3336     clean_tree();
3337     my $clogp = parsechangelog();
3338     $isuite = getfield $clogp, 'Distribution';
3339     $package = getfield $clogp, 'Source';
3340     $version = getfield $clogp, 'Version';
3341     build_maybe_quilt_fixup();
3342     if ($rmchanges) {
3343         my $pat = changespat $version;
3344         foreach my $f (glob "$buildproductsdir/$pat") {
3345             if (act_local()) {
3346                 unlink $f or fail "remove old changes file $f: $!";
3347             } else {
3348                 progress "would remove $f";
3349             }
3350         }
3351     }
3352 }
3353
3354 sub changesopts_initial () {
3355     my @opts =@changesopts[1..$#changesopts];
3356 }
3357
3358 sub changesopts_version () {
3359     if (!defined $changes_since_version) {
3360         my @vsns = archive_query('archive_query');
3361         my @quirk = access_quirk();
3362         if ($quirk[0] eq 'backports') {
3363             local $isuite = $quirk[2];
3364             local $csuite;
3365             canonicalise_suite();
3366             push @vsns, archive_query('archive_query');
3367         }
3368         if (@vsns) {
3369             @vsns = map { $_->[0] } @vsns;
3370             @vsns = sort { -version_compare($a, $b) } @vsns;
3371             $changes_since_version = $vsns[0];
3372             progress "changelog will contain changes since $vsns[0]";
3373         } else {
3374             $changes_since_version = '_';
3375             progress "package seems new, not specifying -v<version>";
3376         }
3377     }
3378     if ($changes_since_version ne '_') {
3379         return ("-v$changes_since_version");
3380     } else {
3381         return ();
3382     }
3383 }
3384
3385 sub changesopts () {
3386     return (changesopts_initial(), changesopts_version());
3387 }
3388
3389 sub massage_dbp_args ($;$) {
3390     my ($cmd,$xargs) = @_;
3391     # We need to:
3392     #
3393     #  - if we're going to split the source build out so we can
3394     #    do strange things to it, massage the arguments to dpkg-buildpackage
3395     #    so that the main build doessn't build source (or add an argument
3396     #    to stop it building source by default).
3397     #
3398     #  - add -nc to stop dpkg-source cleaning the source tree,
3399     #    unless we're not doing a split build and want dpkg-source
3400     #    as cleanmode, in which case we can do nothing
3401     #
3402     # return values:
3403     #    0 - source will NOT need to be built separately by caller
3404     #   +1 - source will need to be built separately by caller
3405     #   +2 - source will need to be built separately by caller AND
3406     #        dpkg-buildpackage should not in fact be run at all!
3407     debugcmd '#massaging#', @$cmd if $debuglevel>1;
3408 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3409     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3410         $clean_using_builder = 1;
3411         return 0;
3412     }
3413     # -nc has the side effect of specifying -b if nothing else specified
3414     # and some combinations of -S, -b, et al, are errors, rather than
3415     # later simply overriding earlie.  So we need to:
3416     #  - search the command line for these options
3417     #  - pick the last one
3418     #  - perhaps add our own as a default
3419     #  - perhaps adjust it to the corresponding non-source-building version
3420     my $dmode = '-F';
3421     foreach my $l ($cmd, $xargs) {
3422         next unless $l;
3423         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3424     }
3425     push @$cmd, '-nc';
3426 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3427     my $r = 0;
3428     if ($need_split_build_invocation) {
3429         printdebug "massage split $dmode.\n";
3430         $r = $dmode =~ m/[S]/     ? +2 :
3431              $dmode =~ y/gGF/ABb/ ? +1 :
3432              $dmode =~ m/[ABb]/   ?  0 :
3433              die "$dmode ?";
3434     }
3435     printdebug "massage done $r $dmode.\n";
3436     push @$cmd, $dmode;
3437 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3438     return $r;
3439 }
3440
3441 sub cmd_build {
3442     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3443     my $wantsrc = massage_dbp_args \@dbp;
3444     if ($wantsrc > 0) {
3445         build_source();
3446     } else {
3447         build_prep();
3448     }
3449     if ($wantsrc < 2) {
3450         push @dbp, changesopts_version();
3451         maybe_apply_patches_dirtily();
3452         runcmd_ordryrun_local @dbp;
3453     }
3454     maybe_unapply_patches_again();
3455     printdone "build successful\n";
3456 }
3457
3458 sub cmd_gbp_build {
3459     my @dbp = @dpkgbuildpackage;
3460
3461     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
3462
3463     my @cmd;
3464     if (length executable_on_path('git-buildpackage')) {
3465         @cmd = qw(git-buildpackage);
3466     } else {
3467         @cmd = qw(gbp buildpackage);
3468     }
3469     push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3470
3471     if ($wantsrc > 0) {
3472         build_source();
3473     } else {
3474         if (!$clean_using_builder) {
3475             push @cmd, '--git-cleaner=true';
3476         }
3477         build_prep();
3478     }
3479     if ($wantsrc < 2) {
3480         unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3481             canonicalise_suite();
3482             push @cmd, "--git-debian-branch=".lbranch();
3483         }
3484         push @cmd, changesopts();
3485         maybe_apply_patches_dirtily();
3486         runcmd_ordryrun_local @cmd, @ARGV;
3487     }
3488     maybe_unapply_patches_again();
3489     printdone "build successful\n";
3490 }
3491 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3492
3493 sub build_source {
3494     my $our_cleanmode = $cleanmode;
3495     if ($need_split_build_invocation) {
3496         # Pretend that clean is being done some other way.  This
3497         # forces us not to try to use dpkg-buildpackage to clean and
3498         # build source all in one go; and instead we run dpkg-source
3499         # (and build_prep() will do the clean since $clean_using_builder
3500         # is false).
3501         $our_cleanmode = 'ELSEWHERE';
3502     }
3503     if ($our_cleanmode =~ m/^dpkg-source/) {
3504         # dpkg-source invocation (below) will clean, so build_prep shouldn't
3505         $clean_using_builder = 1;
3506     }
3507     build_prep();
3508     $sourcechanges = changespat $version,'source';
3509     if (act_local()) {
3510         unlink "../$sourcechanges" or $!==ENOENT
3511             or fail "remove $sourcechanges: $!";
3512     }
3513     $dscfn = dscfn($version);
3514     if ($our_cleanmode eq 'dpkg-source') {
3515         maybe_apply_patches_dirtily();
3516         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3517             changesopts();
3518     } elsif ($our_cleanmode eq 'dpkg-source-d') {
3519         maybe_apply_patches_dirtily();
3520         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3521             changesopts();
3522     } else {
3523         my @cmd = (@dpkgsource, qw(-b --));
3524         if ($split_brain) {
3525             changedir $ud;
3526             runcmd_ordryrun_local @cmd, "work";
3527             my @udfiles = <${package}_*>;
3528             changedir "../../..";
3529             foreach my $f (@udfiles) {
3530                 printdebug "source copy, found $f\n";
3531                 next unless
3532                     $f eq $dscfn or
3533                     ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
3534                      $f eq srcfn($version, $&));
3535                 printdebug "source copy, found $f - renaming\n";
3536                 rename "$ud/$f", "../$f" or $!==ENOENT
3537                     or fail "put in place new source file ($f): $!";
3538             }
3539         } else {
3540             my $pwd = must_getcwd();
3541             my $leafdir = basename $pwd;
3542             changedir "..";
3543             runcmd_ordryrun_local @cmd, $leafdir;
3544             changedir $pwd;
3545         }
3546         runcmd_ordryrun_local qw(sh -ec),
3547             'exec >$1; shift; exec "$@"','x',
3548             "../$sourcechanges",
3549             @dpkggenchanges, qw(-S), changesopts();
3550     }
3551 }
3552
3553 sub cmd_build_source {
3554     badusage "build-source takes no additional arguments" if @ARGV;
3555     build_source();
3556     maybe_unapply_patches_again();
3557     printdone "source built, results in $dscfn and $sourcechanges";
3558 }
3559
3560 sub cmd_sbuild {
3561     build_source();
3562     my $pat = changespat $version;
3563     if (!$rmchanges) {
3564         my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
3565         @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
3566         fail "changes files other than source matching $pat".
3567             " already present (@unwanted);".
3568             " building would result in ambiguity about the intended results"
3569             if @unwanted;
3570     }
3571     changedir "..";
3572     if (act_local()) {
3573         stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3574         stat_exists $sourcechanges
3575             or fail "$sourcechanges (in parent directory): $!";
3576     }
3577     runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3578     my @changesfiles = glob $pat;
3579     @changesfiles = sort {
3580         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3581             or $a cmp $b
3582     } @changesfiles;
3583     fail "wrong number of different changes files (@changesfiles)"
3584         unless @changesfiles==2;
3585     my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
3586     foreach my $l (split /\n/, getfield $binchanges, 'Files') {
3587         fail "$l found in binaries changes file $binchanges"
3588             if $l =~ m/\.dsc$/;
3589     }
3590     runcmd_ordryrun_local @mergechanges, @changesfiles;
3591     my $multichanges = changespat $version,'multi';
3592     if (act_local()) {
3593         stat_exists $multichanges or fail "$multichanges: $!";
3594         foreach my $cf (glob $pat) {
3595             next if $cf eq $multichanges;
3596             rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
3597         }
3598     }
3599     maybe_unapply_patches_again();
3600     printdone "build successful, results in $multichanges\n" or die $!;
3601 }
3602
3603 sub cmd_quilt_fixup {
3604     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3605     my $clogp = parsechangelog();
3606     $version = getfield $clogp, 'Version';
3607     $package = getfield $clogp, 'Source';
3608     check_not_dirty();
3609     clean_tree();
3610     build_maybe_quilt_fixup();
3611 }
3612
3613 sub cmd_archive_api_query {
3614     badusage "need only 1 subpath argument" unless @ARGV==1;
3615     my ($subpath) = @ARGV;
3616     my @cmd = archive_api_query_cmd($subpath);
3617     debugcmd ">",@cmd;
3618     exec @cmd or fail "exec curl: $!\n";
3619 }
3620
3621 sub cmd_clone_dgit_repos_server {
3622     badusage "need destination argument" unless @ARGV==1;
3623     my ($destdir) = @ARGV;
3624     $package = '_dgit-repos-server';
3625     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3626     debugcmd ">",@cmd;
3627     exec @cmd or fail "exec git clone: $!\n";
3628 }
3629
3630 sub cmd_setup_mergechangelogs {
3631     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3632     setup_mergechangelogs(1);
3633 }
3634
3635 sub cmd_setup_useremail {
3636     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3637     setup_useremail(1);
3638 }
3639
3640 sub cmd_setup_new_tree {
3641     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3642     setup_new_tree();
3643 }
3644
3645 #---------- argument parsing and main program ----------
3646
3647 sub cmd_version {
3648     print "dgit version $our_version\n" or die $!;
3649     exit 0;
3650 }
3651
3652 our (%valopts_long, %valopts_short);
3653 our @rvalopts;
3654
3655 sub defvalopt ($$$$) {
3656     my ($long,$short,$val_re,$how) = @_;
3657     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3658     $valopts_long{$long} = $oi;
3659     $valopts_short{$short} = $oi;
3660     # $how subref should:
3661     #   do whatever assignemnt or thing it likes with $_[0]
3662     #   if the option should not be passed on to remote, @rvalopts=()
3663     # or $how can be a scalar ref, meaning simply assign the value
3664 }
3665
3666 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3667 defvalopt '--distro',        '-d', '.+',      \$idistro;
3668 defvalopt '',                '-k', '.+',      \$keyid;
3669 defvalopt '--existing-package','', '.*',      \$existing_package;
3670 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
3671 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
3672 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
3673
3674 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3675
3676 defvalopt '', '-C', '.+', sub {
3677     ($changesfile) = (@_);
3678     if ($changesfile =~ s#^(.*)/##) {
3679         $buildproductsdir = $1;
3680     }
3681 };
3682
3683 defvalopt '--initiator-tempdir','','.*', sub {
3684     ($initiator_tempdir) = (@_);
3685     $initiator_tempdir =~ m#^/# or
3686         badusage "--initiator-tempdir must be used specify an".
3687         " absolute, not relative, directory."
3688 };
3689
3690 sub parseopts () {
3691     my $om;
3692
3693     if (defined $ENV{'DGIT_SSH'}) {
3694         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3695     } elsif (defined $ENV{'GIT_SSH'}) {
3696         @ssh = ($ENV{'GIT_SSH'});
3697     }
3698
3699     my $oi;
3700     my $val;
3701     my $valopt = sub {
3702         my ($what) = @_;
3703         @rvalopts = ($_);
3704         if (!defined $val) {
3705             badusage "$what needs a value" unless @ARGV;
3706             $val = shift @ARGV;
3707             push @rvalopts, $val;
3708         }
3709         badusage "bad value \`$val' for $what" unless
3710             $val =~ m/^$oi->{Re}$(?!\n)/s;
3711         my $how = $oi->{How};
3712         if (ref($how) eq 'SCALAR') {
3713             $$how = $val;
3714         } else {
3715             $how->($val);
3716         }
3717         push @ropts, @rvalopts;
3718     };
3719
3720     while (@ARGV) {
3721         last unless $ARGV[0] =~ m/^-/;
3722         $_ = shift @ARGV;
3723         last if m/^--?$/;
3724         if (m/^--/) {
3725             if (m/^--dry-run$/) {
3726                 push @ropts, $_;
3727                 $dryrun_level=2;
3728             } elsif (m/^--damp-run$/) {
3729                 push @ropts, $_;
3730                 $dryrun_level=1;
3731             } elsif (m/^--no-sign$/) {
3732                 push @ropts, $_;
3733                 $sign=0;
3734             } elsif (m/^--help$/) {
3735                 cmd_help();
3736             } elsif (m/^--version$/) {
3737                 cmd_version();
3738             } elsif (m/^--new$/) {
3739                 push @ropts, $_;
3740                 $new_package=1;
3741             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3742                      ($om = $opts_opt_map{$1}) &&
3743                      length $om->[0]) {
3744                 push @ropts, $_;
3745                 $om->[0] = $2;
3746             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3747                      !$opts_opt_cmdonly{$1} &&
3748                      ($om = $opts_opt_map{$1})) {
3749                 push @ropts, $_;
3750                 push @$om, $2;
3751             } elsif (m/^--ignore-dirty$/s) {
3752                 push @ropts, $_;
3753                 $ignoredirty = 1;
3754             } elsif (m/^--no-quilt-fixup$/s) {
3755                 push @ropts, $_;
3756                 $quilt_mode = 'nocheck';
3757             } elsif (m/^--no-rm-on-error$/s) {
3758                 push @ropts, $_;
3759                 $rmonerror = 0;
3760             } elsif (m/^--(no-)?rm-old-changes$/s) {
3761                 push @ropts, $_;
3762                 $rmchanges = !$1;
3763             } elsif (m/^--deliberately-($deliberately_re)$/s) {
3764                 push @ropts, $_;
3765                 push @deliberatelies, $&;
3766             } elsif (m/^--always-split-source-build$/s) {
3767                 # undocumented, for testing
3768                 push @ropts, $_;
3769                 $need_split_build_invocation = 1;
3770             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3771                 $val = $2 ? $' : undef; #';
3772                 $valopt->($oi->{Long});
3773             } else {
3774                 badusage "unknown long option \`$_'";
3775             }
3776         } else {
3777             while (m/^-./s) {
3778                 if (s/^-n/-/) {
3779                     push @ropts, $&;
3780                     $dryrun_level=2;
3781                 } elsif (s/^-L/-/) {
3782                     push @ropts, $&;
3783                     $dryrun_level=1;
3784                 } elsif (s/^-h/-/) {
3785                     cmd_help();
3786                 } elsif (s/^-D/-/) {
3787                     push @ropts, $&;
3788                     $debuglevel++;
3789                     enabledebug();
3790                 } elsif (s/^-N/-/) {
3791                     push @ropts, $&;
3792                     $new_package=1;
3793                 } elsif (m/^-m/) {
3794                     push @ropts, $&;
3795                     push @changesopts, $_;
3796                     $_ = '';
3797                 } elsif (s/^-wn$//s) {
3798                     push @ropts, $&;
3799                     $cleanmode = 'none';
3800                 } elsif (s/^-wg$//s) {
3801                     push @ropts, $&;
3802                     $cleanmode = 'git';
3803                 } elsif (s/^-wgf$//s) {
3804                     push @ropts, $&;
3805                     $cleanmode = 'git-ff';
3806                 } elsif (s/^-wd$//s) {
3807                     push @ropts, $&;
3808                     $cleanmode = 'dpkg-source';
3809                 } elsif (s/^-wdd$//s) {
3810                     push @ropts, $&;
3811                     $cleanmode = 'dpkg-source-d';
3812                 } elsif (s/^-wc$//s) {
3813                     push @ropts, $&;
3814                     $cleanmode = 'check';
3815                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
3816                     $val = $'; #';
3817                     $val = undef unless length $val;
3818                     $valopt->($oi->{Short});
3819                     $_ = '';
3820                 } else {
3821                     badusage "unknown short option \`$_'";
3822                 }
3823             }
3824         }
3825     }
3826 }
3827
3828 sub finalise_opts_opts () {
3829     foreach my $k (keys %opts_opt_map) {
3830         my $om = $opts_opt_map{$k};
3831
3832         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3833         if (defined $v) {
3834             badcfg "cannot set command for $k"
3835                 unless length $om->[0];
3836             $om->[0] = $v;
3837         }
3838
3839         foreach my $c (access_cfg_cfgs("opts-$k")) {
3840             my $vl = $gitcfg{$c};
3841             printdebug "CL $c ",
3842                 ($vl ? join " ", map { shellquote } @$vl : ""),
3843                 "\n" if $debuglevel >= 4;
3844             next unless $vl;
3845             badcfg "cannot configure options for $k"
3846                 if $opts_opt_cmdonly{$k};
3847             my $insertpos = $opts_cfg_insertpos{$k};
3848             @$om = ( @$om[0..$insertpos-1],
3849                      @$vl,
3850                      @$om[$insertpos..$#$om] );
3851         }
3852     }
3853 }
3854
3855 if ($ENV{$fakeeditorenv}) {
3856     git_slurp_config();
3857     quilt_fixup_editor();
3858 }
3859
3860 parseopts();
3861 git_slurp_config();
3862
3863 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3864 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3865     if $dryrun_level == 1;
3866 if (!@ARGV) {
3867     print STDERR $helpmsg or die $!;
3868     exit 8;
3869 }
3870 my $cmd = shift @ARGV;
3871 $cmd =~ y/-/_/;
3872
3873 if (!defined $rmchanges) {
3874     local $access_forpush;
3875     $rmchanges = access_cfg_bool(0, 'rm-old-changes');
3876 }
3877
3878 if (!defined $quilt_mode) {
3879     local $access_forpush;
3880     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3881         // access_cfg('quilt-mode', 'RETURN-UNDEF')
3882         // 'linear';
3883     $quilt_mode =~ m/^($quilt_modes_re)$/
3884         or badcfg "unknown quilt-mode \`$quilt_mode'";
3885     $quilt_mode = $1;
3886 }
3887
3888 $need_split_build_invocation ||= quiltmode_splitbrain();
3889
3890 if (!defined $cleanmode) {
3891     local $access_forpush;
3892     $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
3893     $cleanmode //= 'dpkg-source';
3894
3895     badcfg "unknown clean-mode \`$cleanmode'" unless
3896         $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
3897 }
3898
3899 my $fn = ${*::}{"cmd_$cmd"};
3900 $fn or badusage "unknown operation $cmd";
3901 $fn->();