dgit

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