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