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