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