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 #---------- tag format handling ----------
1136
1137 sub select_tagformat () {
1138     # sets $tagformatfn
1139     return if $tagformatfn && !$tagformat_want;
1140     die 'bug' if $tagformatfn && $tagformat_want;
1141     # ... $tagformat_want assigned after previous select_tagformat
1142
1143     my (@supported) = split /\,/, access_cfg('dgit-tag-format');
1144     printdebug "select_tagformat supported @supported\n";
1145
1146     $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1147     printdebug "select_tagformat specified @$tagformat_want\n";
1148
1149     my ($fmt,$why,$override) = @$tagformat_want;
1150
1151     fail "target distro supports tag formats @supported".
1152         " but have to use $fmt ($why)"
1153         unless $override
1154             or grep { $_ eq $fmt } @supported;
1155
1156     $tagformat_want = undef;
1157     $tagformat = $fmt;
1158     $tagformatfn = ${*::}{"debiantag_$fmt"};
1159
1160     fail "trying to use unknown tag format \`$fmt' ($why) !"
1161         unless $tagformatfn;
1162 }
1163
1164 #---------- archive query entrypoints and rest of program ----------
1165
1166 sub canonicalise_suite () {
1167     return if defined $csuite;
1168     fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1169     $csuite = archive_query('canonicalise_suite');
1170     if ($isuite ne $csuite) {
1171         progress "canonical suite name for $isuite is $csuite";
1172     }
1173 }
1174
1175 sub get_archive_dsc () {
1176     canonicalise_suite();
1177     my @vsns = archive_query('archive_query');
1178     foreach my $vinfo (@vsns) {
1179         my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1180         $dscurl = access_cfg('mirror').$subpath;
1181         $dscdata = url_get($dscurl);
1182         if (!$dscdata) {
1183             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1184             next;
1185         }
1186         if ($digester) {
1187             $digester->reset();
1188             $digester->add($dscdata);
1189             my $got = $digester->hexdigest();
1190             $got eq $digest or
1191                 fail "$dscurl has hash $got but".
1192                     " archive told us to expect $digest";
1193         }
1194         my $dscfh = new IO::File \$dscdata, '<' or die $!;
1195         printdebug Dumper($dscdata) if $debuglevel>1;
1196         $dsc = parsecontrolfh($dscfh,$dscurl,1);
1197         printdebug Dumper($dsc) if $debuglevel>1;
1198         my $fmt = getfield $dsc, 'Format';
1199         fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1200         $dsc_checked = !!$digester;
1201         return;
1202     }
1203     $dsc = undef;
1204 }
1205
1206 sub check_for_git ();
1207 sub check_for_git () {
1208     # returns 0 or 1
1209     my $how = access_cfg('git-check');
1210     if ($how eq 'ssh-cmd') {
1211         my @cmd =
1212             (access_cfg_ssh, access_gituserhost(),
1213              access_runeinfo("git-check $package").
1214              " set -e; cd ".access_cfg('git-path').";".
1215              " if test -d $package.git; then echo 1; else echo 0; fi");
1216         my $r= cmdoutput @cmd;
1217         if (defined $r and $r =~ m/^divert (\w+)$/) {
1218             my $divert=$1;
1219             my ($usedistro,) = access_distros();
1220             # NB that if we are pushing, $usedistro will be $distro/push
1221             $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1222             $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1223             progress "diverting to $divert (using config for $instead_distro)";
1224             return check_for_git();
1225         }
1226         failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1227         return $r+0;
1228     } elsif ($how eq 'url') {
1229         my $prefix = access_cfg('git-check-url','git-url');
1230         my $suffix = access_cfg('git-check-suffix','git-suffix',
1231                                 'RETURN-UNDEF') // '.git';
1232         my $url = "$prefix/$package$suffix";
1233         my @cmd = (qw(curl -sS -I), $url);
1234         my $result = cmdoutput @cmd;
1235         $result =~ s/^\S+ 200 .*\n\r?\n//;
1236         # curl -sS -I with https_proxy prints
1237         # HTTP/1.0 200 Connection established
1238         $result =~ m/^\S+ (404|200) /s or
1239             fail "unexpected results from git check query - ".
1240                 Dumper($prefix, $result);
1241         my $code = $1;
1242         if ($code eq '404') {
1243             return 0;
1244         } elsif ($code eq '200') {
1245             return 1;
1246         } else {
1247             die;
1248         }
1249     } elsif ($how eq 'true') {
1250         return 1;
1251     } elsif ($how eq 'false') {
1252         return 0;
1253     } else {
1254         badcfg "unknown git-check \`$how'";
1255     }
1256 }
1257
1258 sub create_remote_git_repo () {
1259     my $how = access_cfg('git-create');
1260     if ($how eq 'ssh-cmd') {
1261         runcmd_ordryrun
1262             (access_cfg_ssh, access_gituserhost(),
1263              access_runeinfo("git-create $package").
1264              "set -e; cd ".access_cfg('git-path').";".
1265              " cp -a _template $package.git");
1266     } elsif ($how eq 'true') {
1267         # nothing to do
1268     } else {
1269         badcfg "unknown git-create \`$how'";
1270     }
1271 }
1272
1273 our ($dsc_hash,$lastpush_hash);
1274
1275 our $ud = '.git/dgit/unpack';
1276
1277 sub prep_ud (;$) {
1278     my ($d) = @_;
1279     $d //= $ud;
1280     rmtree($d);
1281     mkpath '.git/dgit';
1282     mkdir $d or die $!;
1283 }
1284
1285 sub mktree_in_ud_here () {
1286     runcmd qw(git init -q);
1287     rmtree('.git/objects');
1288     symlink '../../../../objects','.git/objects' or die $!;
1289 }
1290
1291 sub git_write_tree () {
1292     my $tree = cmdoutput @git, qw(write-tree);
1293     $tree =~ m/^\w+$/ or die "$tree ?";
1294     return $tree;
1295 }
1296
1297 sub remove_stray_gits () {
1298     my @gitscmd = qw(find -name .git -prune -print0);
1299     debugcmd "|",@gitscmd;
1300     open GITS, "-|", @gitscmd or die $!;
1301     {
1302         local $/="\0";
1303         while (<GITS>) {
1304             chomp or die;
1305             print STDERR "$us: warning: removing from source package: ",
1306                 (messagequote $_), "\n";
1307             rmtree $_;
1308         }
1309     }
1310     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1311 }
1312
1313 sub mktree_in_ud_from_only_subdir () {
1314     # changes into the subdir
1315     my (@dirs) = <*/.>;
1316     die "@dirs ?" unless @dirs==1;
1317     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1318     my $dir = $1;
1319     changedir $dir;
1320
1321     remove_stray_gits();
1322     mktree_in_ud_here();
1323     my ($format, $fopts) = get_source_format();
1324     if (madformat($format)) {
1325         rmtree '.pc';
1326     }
1327     runcmd @git, qw(add -Af);
1328     my $tree=git_write_tree();
1329     return ($tree,$dir);
1330 }
1331
1332 sub dsc_files_info () {
1333     foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1334                        ['Checksums-Sha1',  'Digest::SHA', 'new(1)'],
1335                        ['Files',           'Digest::MD5', 'new()']) {
1336         my ($fname, $module, $method) = @$csumi;
1337         my $field = $dsc->{$fname};
1338         next unless defined $field;
1339         eval "use $module; 1;" or die $@;
1340         my @out;
1341         foreach (split /\n/, $field) {
1342             next unless m/\S/;
1343             m/^(\w+) (\d+) (\S+)$/ or
1344                 fail "could not parse .dsc $fname line \`$_'";
1345             my $digester = eval "$module"."->$method;" or die $@;
1346             push @out, {
1347                 Hash => $1,
1348                 Bytes => $2,
1349                 Filename => $3,
1350                 Digester => $digester,
1351             };
1352         }
1353         return @out;
1354     }
1355     fail "missing any supported Checksums-* or Files field in ".
1356         $dsc->get_option('name');
1357 }
1358
1359 sub dsc_files () {
1360     map { $_->{Filename} } dsc_files_info();
1361 }
1362
1363 sub is_orig_file ($;$) {
1364     local ($_) = $_[0];
1365     my $base = $_[1];
1366     m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1367     defined $base or return 1;
1368     return $` eq $base;
1369 }
1370
1371 sub make_commit ($) {
1372     my ($file) = @_;
1373     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1374 }
1375
1376 sub clogp_authline ($) {
1377     my ($clogp) = @_;
1378     my $author = getfield $clogp, 'Maintainer';
1379     $author =~ s#,.*##ms;
1380     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1381     my $authline = "$author $date";
1382     $authline =~ m/$git_authline_re/o or
1383         fail "unexpected commit author line format \`$authline'".
1384         " (was generated from changelog Maintainer field)";
1385     return ($1,$2,$3) if wantarray;
1386     return $authline;
1387 }
1388
1389 sub vendor_patches_distro ($$) {
1390     my ($checkdistro, $what) = @_;
1391     return unless defined $checkdistro;
1392
1393     my $series = "debian/patches/\L$checkdistro\E.series";
1394     printdebug "checking for vendor-specific $series ($what)\n";
1395
1396     if (!open SERIES, "<", $series) {
1397         die "$series $!" unless $!==ENOENT;
1398         return;
1399     }
1400     while (<SERIES>) {
1401         next unless m/\S/;
1402         next if m/^\s+\#/;
1403
1404         print STDERR <<END;
1405
1406 Unfortunately, this source package uses a feature of dpkg-source where
1407 the same source package unpacks to different source code on different
1408 distros.  dgit cannot safely operate on such packages on affected
1409 distros, because the meaning of source packages is not stable.
1410
1411 Please ask the distro/maintainer to remove the distro-specific series
1412 files and use a different technique (if necessary, uploading actually
1413 different packages, if different distros are supposed to have
1414 different code).
1415
1416 END
1417         fail "Found active distro-specific series file for".
1418             " $checkdistro ($what): $series, cannot continue";
1419     }
1420     die "$series $!" if SERIES->error;
1421     close SERIES;
1422 }
1423
1424 sub check_for_vendor_patches () {
1425     # This dpkg-source feature doesn't seem to be documented anywhere!
1426     # But it can be found in the changelog (reformatted):
1427
1428     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
1429     #   Author: Raphael Hertzog <hertzog@debian.org>
1430     #   Date: Sun  Oct  3  09:36:48  2010 +0200
1431
1432     #   dpkg-source: correctly create .pc/.quilt_series with alternate
1433     #   series files
1434     #
1435     #   If you have debian/patches/ubuntu.series and you were
1436     #   unpacking the source package on ubuntu, quilt was still
1437     #   directed to debian/patches/series instead of
1438     #   debian/patches/ubuntu.series.
1439     #
1440     #   debian/changelog                        |    3 +++
1441     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
1442     #   2 files changed, 6 insertions(+), 1 deletion(-)
1443
1444     use Dpkg::Vendor;
1445     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1446     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1447                          "Dpkg::Vendor \`current vendor'");
1448     vendor_patches_distro(access_basedistro(),
1449                           "distro being accessed");
1450 }
1451
1452 sub generate_commit_from_dsc () {
1453     prep_ud();
1454     changedir $ud;
1455
1456     foreach my $fi (dsc_files_info()) {
1457         my $f = $fi->{Filename};
1458         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1459
1460         link_ltarget "../../../$f", $f
1461             or $!==&ENOENT
1462             or die "$f $!";
1463
1464         complete_file_from_dsc('.', $fi)
1465             or next;
1466
1467         if (is_orig_file($f)) {
1468             link $f, "../../../../$f"
1469                 or $!==&EEXIST
1470                 or die "$f $!";
1471         }
1472     }
1473
1474     my $dscfn = "$package.dsc";
1475
1476     open D, ">", $dscfn or die "$dscfn: $!";
1477     print D $dscdata or die "$dscfn: $!";
1478     close D or die "$dscfn: $!";
1479     my @cmd = qw(dpkg-source);
1480     push @cmd, '--no-check' if $dsc_checked;
1481     push @cmd, qw(-x --), $dscfn;
1482     runcmd @cmd;
1483
1484     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1485     check_for_vendor_patches() if madformat($dsc->{format});
1486     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1487     my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1488     my $authline = clogp_authline $clogp;
1489     my $changes = getfield $clogp, 'Changes';
1490     open C, ">../commit.tmp" or die $!;
1491     print C <<END or die $!;
1492 tree $tree
1493 author $authline
1494 committer $authline
1495
1496 $changes
1497
1498 # imported from the archive
1499 END
1500     close C or die $!;
1501     my $outputhash = make_commit qw(../commit.tmp);
1502     my $cversion = getfield $clogp, 'Version';
1503     progress "synthesised git commit from .dsc $cversion";
1504     if ($lastpush_hash) {
1505         runcmd @git, qw(reset -q --hard), $lastpush_hash;
1506         runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1507         my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1508         my $oversion = getfield $oldclogp, 'Version';
1509         my $vcmp =
1510             version_compare($oversion, $cversion);
1511         if ($vcmp < 0) {
1512             # git upload/ is earlier vsn than archive, use archive
1513             open C, ">../commit2.tmp" or die $!;
1514             print C <<END or die $!;
1515 tree $tree
1516 parent $lastpush_hash
1517 parent $outputhash
1518 author $authline
1519 committer $authline
1520
1521 Record $package ($cversion) in archive suite $csuite
1522 END
1523             $outputhash = make_commit qw(../commit2.tmp);
1524         } elsif ($vcmp > 0) {
1525             print STDERR <<END or die $!;
1526
1527 Version actually in archive:    $cversion (older)
1528 Last allegedly pushed/uploaded: $oversion (newer or same)
1529 $later_warning_msg
1530 END
1531             $outputhash = $lastpush_hash;
1532         } else {
1533             $outputhash = $lastpush_hash;
1534         }
1535     }
1536     changedir '../../../..';
1537     runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1538             'DGIT_ARCHIVE', $outputhash;
1539     cmdoutput @git, qw(log -n2), $outputhash;
1540     # ... gives git a chance to complain if our commit is malformed
1541     rmtree($ud);
1542     return $outputhash;
1543 }
1544
1545 sub complete_file_from_dsc ($$) {
1546     our ($dstdir, $fi) = @_;
1547     # Ensures that we have, in $dir, the file $fi, with the correct
1548     # contents.  (Downloading it from alongside $dscurl if necessary.)
1549
1550     my $f = $fi->{Filename};
1551     my $tf = "$dstdir/$f";
1552     my $downloaded = 0;
1553
1554     if (stat_exists $tf) {
1555         progress "using existing $f";
1556     } else {
1557         my $furl = $dscurl;
1558         $furl =~ s{/[^/]+$}{};
1559         $furl .= "/$f";
1560         die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1561         die "$f ?" if $f =~ m#/#;
1562         runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1563         return 0 if !act_local();
1564         $downloaded = 1;
1565     }
1566
1567     open F, "<", "$tf" or die "$tf: $!";
1568     $fi->{Digester}->reset();
1569     $fi->{Digester}->addfile(*F);
1570     F->error and die $!;
1571     my $got = $fi->{Digester}->hexdigest();
1572     $got eq $fi->{Hash} or
1573         fail "file $f has hash $got but .dsc".
1574             " demands hash $fi->{Hash} ".
1575             ($downloaded ? "(got wrong file from archive!)"
1576              : "(perhaps you should delete this file?)");
1577
1578     return 1;
1579 }
1580
1581 sub ensure_we_have_orig () {
1582     foreach my $fi (dsc_files_info()) {
1583         my $f = $fi->{Filename};
1584         next unless is_orig_file($f);
1585         complete_file_from_dsc('..', $fi)
1586             or next;
1587     }
1588 }
1589
1590 sub git_fetch_us () {
1591     my @specs = (fetchspec());
1592     push @specs,
1593         map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1594         qw(tags heads);
1595     runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1596
1597     my %here;
1598     my @tagpats = debiantags('*',access_basedistro);
1599
1600     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1601         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1602         printdebug "currently $fullrefname=$objid\n";
1603         $here{$fullrefname} = $objid;
1604     });
1605     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1606         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1607         my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1608         printdebug "offered $lref=$objid\n";
1609         if (!defined $here{$lref}) {
1610             my @upd = (@git, qw(update-ref), $lref, $objid, '');
1611             runcmd_ordryrun_local @upd;
1612         } elsif ($here{$lref} eq $objid) {
1613         } else {
1614             print STDERR \
1615                 "Not updateting $lref from $here{$lref} to $objid.\n";
1616         }
1617     });
1618 }
1619
1620 sub fetch_from_archive () {
1621     # ensures that lrref() is what is actually in the archive,
1622     #  one way or another
1623     get_archive_dsc();
1624
1625     if ($dsc) {
1626         foreach my $field (@ourdscfield) {
1627             $dsc_hash = $dsc->{$field};
1628             last if defined $dsc_hash;
1629         }
1630         if (defined $dsc_hash) {
1631             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1632             $dsc_hash = $&;
1633             progress "last upload to archive specified git hash";
1634         } else {
1635             progress "last upload to archive has NO git hash";
1636         }
1637     } else {
1638         progress "no version available from the archive";
1639     }
1640
1641     $lastpush_hash = git_get_ref(lrref());
1642     printdebug "previous reference hash=$lastpush_hash\n";
1643     my $hash;
1644     if (defined $dsc_hash) {
1645         fail "missing remote git history even though dsc has hash -".
1646             " could not find ref ".lrref().
1647             " (should have been fetched from ".access_giturl()."#".rrref().")"
1648             unless $lastpush_hash;
1649         $hash = $dsc_hash;
1650         ensure_we_have_orig();
1651         if ($dsc_hash eq $lastpush_hash) {
1652         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1653             print STDERR <<END or die $!;
1654
1655 Git commit in archive is behind the last version allegedly pushed/uploaded.
1656 Commit referred to by archive:  $dsc_hash
1657 Last allegedly pushed/uploaded: $lastpush_hash
1658 $later_warning_msg
1659 END
1660             $hash = $lastpush_hash;
1661         } else {
1662             fail "git head (".lrref()."=$lastpush_hash) is not a ".
1663                 "descendant of archive's .dsc hash ($dsc_hash)";
1664         }
1665     } elsif ($dsc) {
1666         $hash = generate_commit_from_dsc();
1667     } elsif ($lastpush_hash) {
1668         # only in git, not in the archive yet
1669         $hash = $lastpush_hash;
1670         print STDERR <<END or die $!;
1671
1672 Package not found in the archive, but has allegedly been pushed using dgit.
1673 $later_warning_msg
1674 END
1675     } else {
1676         printdebug "nothing found!\n";
1677         if (defined $skew_warning_vsn) {
1678             print STDERR <<END or die $!;
1679
1680 Warning: relevant archive skew detected.
1681 Archive allegedly contains $skew_warning_vsn
1682 But we were not able to obtain any version from the archive or git.
1683
1684 END
1685         }
1686         return 0;
1687     }
1688     printdebug "current hash=$hash\n";
1689     if ($lastpush_hash) {
1690         fail "not fast forward on last upload branch!".
1691             " (archive's version left in DGIT_ARCHIVE)"
1692             unless is_fast_fwd($lastpush_hash, $hash);
1693     }
1694     if (defined $skew_warning_vsn) {
1695         mkpath '.git/dgit';
1696         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1697         my $clogf = ".git/dgit/changelog.tmp";
1698         runcmd shell_cmd "exec >$clogf",
1699             @git, qw(cat-file blob), "$hash:debian/changelog";
1700         my $gotclogp = parsechangelog("-l$clogf");
1701         my $got_vsn = getfield $gotclogp, 'Version';
1702         printdebug "SKEW CHECK GOT $got_vsn\n";
1703         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1704             print STDERR <<END or die $!;
1705
1706 Warning: archive skew detected.  Using the available version:
1707 Archive allegedly contains    $skew_warning_vsn
1708 We were able to obtain only   $got_vsn
1709
1710 END
1711         }
1712     }
1713     if ($lastpush_hash ne $hash) {
1714         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1715         if (act_local()) {
1716             cmdoutput @upd_cmd;
1717         } else {
1718             dryrun_report @upd_cmd;
1719         }
1720     }
1721     return 1;
1722 }
1723
1724 sub set_local_git_config ($$) {
1725     my ($k, $v) = @_;
1726     runcmd @git, qw(config), $k, $v;
1727 }
1728
1729 sub setup_mergechangelogs (;$) {
1730     my ($always) = @_;
1731     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1732
1733     my $driver = 'dpkg-mergechangelogs';
1734     my $cb = "merge.$driver";
1735     my $attrs = '.git/info/attributes';
1736     ensuredir '.git/info';
1737
1738     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1739     if (!open ATTRS, "<", $attrs) {
1740         $!==ENOENT or die "$attrs: $!";
1741     } else {
1742         while (<ATTRS>) {
1743             chomp;
1744             next if m{^debian/changelog\s};
1745             print NATTRS $_, "\n" or die $!;
1746         }
1747         ATTRS->error and die $!;
1748         close ATTRS;
1749     }
1750     print NATTRS "debian/changelog merge=$driver\n" or die $!;
1751     close NATTRS;
1752
1753     set_local_git_config "$cb.name", 'debian/changelog merge driver';
1754     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1755
1756     rename "$attrs.new", "$attrs" or die "$attrs: $!";
1757 }
1758
1759 sub setup_useremail (;$) {
1760     my ($always) = @_;
1761     return unless $always || access_cfg_bool(1, 'setup-useremail');
1762
1763     my $setup = sub {
1764         my ($k, $envvar) = @_;
1765         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
1766         return unless defined $v;
1767         set_local_git_config "user.$k", $v;
1768     };
1769
1770     $setup->('email', 'DEBEMAIL');
1771     $setup->('name', 'DEBFULLNAME');
1772 }
1773
1774 sub setup_new_tree () {
1775     setup_mergechangelogs();
1776     setup_useremail();
1777 }
1778
1779 sub clone ($) {
1780     my ($dstdir) = @_;
1781     canonicalise_suite();
1782     badusage "dry run makes no sense with clone" unless act_local();
1783     my $hasgit = check_for_git();
1784     mkdir $dstdir or fail "create \`$dstdir': $!";
1785     changedir $dstdir;
1786     runcmd @git, qw(init -q);
1787     my $giturl = access_giturl(1);
1788     if (defined $giturl) {
1789         set_local_git_config "remote.$remotename.fetch", fetchspec();
1790         open H, "> .git/HEAD" or die $!;
1791         print H "ref: ".lref()."\n" or die $!;
1792         close H or die $!;
1793         runcmd @git, qw(remote add), 'origin', $giturl;
1794     }
1795     if ($hasgit) {
1796         progress "fetching existing git history";
1797         git_fetch_us();
1798         runcmd_ordryrun_local @git, qw(fetch origin);
1799     } else {
1800         progress "starting new git history";
1801     }
1802     fetch_from_archive() or no_such_package;
1803     my $vcsgiturl = $dsc->{'Vcs-Git'};
1804     if (length $vcsgiturl) {
1805         $vcsgiturl =~ s/\s+-b\s+\S+//g;
1806         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1807     }
1808     setup_new_tree();
1809     runcmd @git, qw(reset --hard), lrref();
1810     printdone "ready for work in $dstdir";
1811 }
1812
1813 sub fetch () {
1814     if (check_for_git()) {
1815         git_fetch_us();
1816     }
1817     fetch_from_archive() or no_such_package();
1818     printdone "fetched into ".lrref();
1819 }
1820
1821 sub pull () {
1822     fetch();
1823     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1824         lrref();
1825     printdone "fetched to ".lrref()." and merged into HEAD";
1826 }
1827
1828 sub check_not_dirty () {
1829     foreach my $f (qw(local-options local-patch-header)) {
1830         if (stat_exists "debian/source/$f") {
1831             fail "git tree contains debian/source/$f";
1832         }
1833     }
1834
1835     return if $ignoredirty;
1836
1837     my @cmd = (@git, qw(diff --quiet HEAD));
1838     debugcmd "+",@cmd;
1839     $!=0; $?=-1; system @cmd;
1840     return if !$?;
1841     if ($?==256) {
1842         fail "working tree is dirty (does not match HEAD)";
1843     } else {
1844         failedcmd @cmd;
1845     }
1846 }
1847
1848 sub commit_admin ($) {
1849     my ($m) = @_;
1850     progress "$m";
1851     runcmd_ordryrun_local @git, qw(commit -m), $m;
1852 }
1853
1854 sub commit_quilty_patch () {
1855     my $output = cmdoutput @git, qw(status --porcelain);
1856     my %adds;
1857     foreach my $l (split /\n/, $output) {
1858         next unless $l =~ m/\S/;
1859         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1860             $adds{$1}++;
1861         }
1862     }
1863     delete $adds{'.pc'}; # if there wasn't one before, don't add it
1864     if (!%adds) {
1865         progress "nothing quilty to commit, ok.";
1866         return;
1867     }
1868     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
1869     runcmd_ordryrun_local @git, qw(add -f), @adds;
1870     commit_admin "Commit Debian 3.0 (quilt) metadata";
1871 }
1872
1873 sub get_source_format () {
1874     my %options;
1875     if (open F, "debian/source/options") {
1876         while (<F>) {
1877             next if m/^\s*\#/;
1878             next unless m/\S/;
1879             s/\s+$//; # ignore missing final newline
1880             if (m/\s*\#\s*/) {
1881                 my ($k, $v) = ($`, $'); #');
1882                 $v =~ s/^"(.*)"$/$1/;
1883                 $options{$k} = $v;
1884             } else {
1885                 $options{$_} = 1;
1886             }
1887         }
1888         F->error and die $!;
1889         close F;
1890     } else {
1891         die $! unless $!==&ENOENT;
1892     }
1893
1894     if (!open F, "debian/source/format") {
1895         die $! unless $!==&ENOENT;
1896         return '';
1897     }
1898     $_ = <F>;
1899     F->error and die $!;
1900     chomp;
1901     return ($_, \%options);
1902 }
1903
1904 sub madformat ($) {
1905     my ($format) = @_;
1906     return 0 unless $format eq '3.0 (quilt)';
1907     our $quilt_mode_warned;
1908     if ($quilt_mode eq 'nocheck') {
1909         progress "Not doing any fixup of \`$format' due to".
1910             " ----no-quilt-fixup or --quilt=nocheck"
1911             unless $quilt_mode_warned++;
1912         return 0;
1913     }
1914     progress "Format \`$format', need to check/update patch stack"
1915         unless $quilt_mode_warned++;
1916     return 1;
1917 }
1918
1919 sub push_parse_changelog ($) {
1920     my ($clogpfn) = @_;
1921
1922     my $clogp = Dpkg::Control::Hash->new();
1923     $clogp->load($clogpfn) or die;
1924
1925     $package = getfield $clogp, 'Source';
1926     my $cversion = getfield $clogp, 'Version';
1927     my $tag = debiantag($cversion, access_basedistro);
1928     runcmd @git, qw(check-ref-format), $tag;
1929
1930     my $dscfn = dscfn($cversion);
1931
1932     return ($clogp, $cversion, $tag, $dscfn);
1933 }
1934
1935 sub push_parse_dsc ($$$) {
1936     my ($dscfn,$dscfnwhat, $cversion) = @_;
1937     $dsc = parsecontrol($dscfn,$dscfnwhat);
1938     my $dversion = getfield $dsc, 'Version';
1939     my $dscpackage = getfield $dsc, 'Source';
1940     ($dscpackage eq $package && $dversion eq $cversion) or
1941         fail "$dscfn is for $dscpackage $dversion".
1942             " but debian/changelog is for $package $cversion";
1943 }
1944
1945 sub push_mktag ($$$$$$$) {
1946     my ($dgithead,$clogp,$dgittag,
1947         $dscfn,
1948         $changesfile,$changesfilewhat,
1949         $tfnbase) = @_;
1950
1951     $dsc->{$ourdscfield[0]} = $dgithead;
1952     $dsc->save("$dscfn.tmp") or die $!;
1953
1954     my $changes = parsecontrol($changesfile,$changesfilewhat);
1955     foreach my $field (qw(Source Distribution Version)) {
1956         $changes->{$field} eq $clogp->{$field} or
1957             fail "changes field $field \`$changes->{$field}'".
1958                 " does not match changelog \`$clogp->{$field}'";
1959     }
1960
1961     my $cversion = getfield $clogp, 'Version';
1962     my $clogsuite = getfield $clogp, 'Distribution';
1963
1964     # We make the git tag by hand because (a) that makes it easier
1965     # to control the "tagger" (b) we can do remote signing
1966     my $authline = clogp_authline $clogp;
1967     my $delibs = join(" ", "",@deliberatelies);
1968     my $declaredistro = access_basedistro();
1969
1970     my $mktag = sub {
1971         my ($tfn, $head, $tag) = @_;
1972
1973         open TO, '>', $tfn->('.tmp') or die $!;
1974         print TO <<END or die $!;
1975 object $head
1976 type commit
1977 tag $tag
1978 tagger $authline
1979
1980 $package release $cversion for $clogsuite ($csuite) [dgit]
1981 [dgit distro=$declaredistro$delibs]
1982 END
1983         foreach my $ref (sort keys %previously) {
1984             print TO <<END or die $!;
1985 [dgit previously:$ref=$previously{$ref}]
1986 END
1987         }
1988
1989         close TO or die $!;
1990
1991         my $tagobjfn = $tfn->('.tmp');
1992         if ($sign) {
1993             if (!defined $keyid) {
1994                 $keyid = access_cfg('keyid','RETURN-UNDEF');
1995             }
1996             if (!defined $keyid) {
1997                 $keyid = getfield $clogp, 'Maintainer';
1998             }
1999             unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2000             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2001             push @sign_cmd, qw(-u),$keyid if defined $keyid;
2002             push @sign_cmd, $tfn->('.tmp');
2003             runcmd_ordryrun @sign_cmd;
2004             if (act_scary()) {
2005                 $tagobjfn = $tfn->('.signed.tmp');
2006                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2007                     $tfn->('.tmp'), $tfn->('.tmp.asc');
2008             }
2009         }
2010         return $tagobjfn;
2011     };
2012
2013     my @r;
2014     push @r, $mktag->($tfnbase, $dgithead, $dgittag);
2015     return @r;
2016 }
2017
2018 sub sign_changes ($) {
2019     my ($changesfile) = @_;
2020     if ($sign) {
2021         my @debsign_cmd = @debsign;
2022         push @debsign_cmd, "-k$keyid" if defined $keyid;
2023         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2024         push @debsign_cmd, $changesfile;
2025         runcmd_ordryrun @debsign_cmd;
2026     }
2027 }
2028
2029 sub dopush ($) {
2030     my ($forceflag) = @_;
2031     printdebug "actually entering push\n";
2032     supplementary_message(<<'END');
2033 Push failed, while preparing your push.
2034 You can retry the push, after fixing the problem, if you like.
2035 END
2036     prep_ud();
2037
2038     access_giturl(); # check that success is vaguely likely
2039     select_tagformat();
2040
2041     my $clogpfn = ".git/dgit/changelog.822.tmp";
2042     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2043
2044     responder_send_file('parsed-changelog', $clogpfn);
2045
2046     my ($clogp, $cversion, $tag, $dscfn) =
2047         push_parse_changelog("$clogpfn");
2048
2049     my $dscpath = "$buildproductsdir/$dscfn";
2050     stat_exists $dscpath or
2051         fail "looked for .dsc $dscfn, but $!;".
2052             " maybe you forgot to build";
2053
2054     responder_send_file('dsc', $dscpath);
2055
2056     push_parse_dsc($dscpath, $dscfn, $cversion);
2057
2058     my $format = getfield $dsc, 'Format';
2059     printdebug "format $format\n";
2060
2061     my $head = git_rev_parse('HEAD');
2062
2063     if (madformat($format)) {
2064         # user might have not used dgit build, so maybe do this now:
2065         if (quiltmode_splitbrain()) {
2066             my $upstreamversion = $clogp->{Version};
2067             $upstreamversion =~ s/-[^-]*$//;
2068             changedir $ud;
2069             quilt_make_fake_dsc($upstreamversion);
2070             my ($dgitview, $cachekey) =
2071                 quilt_check_splitbrain_cache($head, $upstreamversion);
2072             $dgitview or fail
2073  "--quilt=$quilt_mode but no cached dgit view:
2074  perhaps tree changed since dgit build[-source] ?";
2075             $split_brain = 1;
2076             changedir '../../../..';
2077             prep_ud(); # so _only_subdir() works, below
2078         } else {
2079             commit_quilty_patch();
2080         }
2081     }
2082
2083     die 'xxx fast forward (should not depend on quilt mode, but will always be needed if we did $split_brain)' if $split_brain;
2084
2085     check_not_dirty();
2086     changedir $ud;
2087     progress "checking that $dscfn corresponds to HEAD";
2088     runcmd qw(dpkg-source -x --),
2089         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2090     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2091     check_for_vendor_patches() if madformat($dsc->{format});
2092     changedir '../../../..';
2093     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2094     my @diffcmd = (@git, qw(diff), $diffopt, $tree);
2095     debugcmd "+",@diffcmd;
2096     $!=0; $?=-1;
2097     my $r = system @diffcmd;
2098     if ($r) {
2099         if ($r==256) {
2100             fail "$dscfn specifies a different tree to your HEAD commit;".
2101                 " perhaps you forgot to build".
2102                 ($diffopt eq '--exit-code' ? "" :
2103                  " (run with -D to see full diff output)");
2104         } else {
2105             failedcmd @diffcmd;
2106         }
2107     }
2108     if (!$changesfile) {
2109         my $pat = changespat $cversion;
2110         my @cs = glob "$buildproductsdir/$pat";
2111         fail "failed to find unique changes file".
2112             " (looked for $pat in $buildproductsdir);".
2113             " perhaps you need to use dgit -C"
2114             unless @cs==1;
2115         ($changesfile) = @cs;
2116     } else {
2117         $changesfile = "$buildproductsdir/$changesfile";
2118     }
2119
2120     responder_send_file('changes',$changesfile);
2121     responder_send_command("param head $head");
2122     responder_send_command("param csuite $csuite");
2123     responder_send_command("param tagformat $tagformat");
2124
2125     if (deliberately_not_fast_forward) {
2126         git_for_each_ref(lrfetchrefs, sub {
2127             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2128             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2129             responder_send_command("previously $rrefname=$objid");
2130             $previously{$rrefname} = $objid;
2131         });
2132     }
2133
2134     my $tfn = sub { ".git/dgit/tag$_[0]"; };
2135     my $tagobjfn;
2136
2137     supplementary_message(<<'END');
2138 Push failed, while signing the tag.
2139 You can retry the push, after fixing the problem, if you like.
2140 END
2141     # If we manage to sign but fail to record it anywhere, it's fine.
2142     if ($we_are_responder) {
2143         $tagobjfn = $tfn->('.signed.tmp');
2144         responder_receive_files('signed-tag', $tagobjfn);
2145     } else {
2146         ($tagobjfn) =
2147             push_mktag($head,$clogp,$tag,
2148                        $dscpath,
2149                        $changesfile,$changesfile,
2150                        $tfn);
2151     }
2152     supplementary_message(<<'END');
2153 Push failed, *after* signing the tag.
2154 If you want to try again, you should use a new version number.
2155 END
2156
2157     my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2158     runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2159     runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2160
2161     supplementary_message(<<'END');
2162 Push failed, while updating the remote git repository - see messages above.
2163 If you want to try again, you should use a new version number.
2164 END
2165     if (!check_for_git()) {
2166         create_remote_git_repo();
2167     }
2168     runcmd_ordryrun @git, qw(push),access_giturl(),
2169         $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2170     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2171
2172     supplementary_message(<<'END');
2173 Push failed, after updating the remote git repository.
2174 If you want to try again, you must use a new version number.
2175 END
2176     if ($we_are_responder) {
2177         my $dryrunsuffix = act_local() ? "" : ".tmp";
2178         responder_receive_files('signed-dsc-changes',
2179                                 "$dscpath$dryrunsuffix",
2180                                 "$changesfile$dryrunsuffix");
2181     } else {
2182         if (act_local()) {
2183             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2184         } else {
2185             progress "[new .dsc left in $dscpath.tmp]";
2186         }
2187         sign_changes $changesfile;
2188     }
2189
2190     supplementary_message(<<END);
2191 Push failed, while uploading package(s) to the archive server.
2192 You can retry the upload of exactly these same files with dput of:
2193   $changesfile
2194 If that .changes file is broken, you will need to use a new version
2195 number for your next attempt at the upload.
2196 END
2197     my $host = access_cfg('upload-host','RETURN-UNDEF');
2198     my @hostarg = defined($host) ? ($host,) : ();
2199     runcmd_ordryrun @dput, @hostarg, $changesfile;
2200     printdone "pushed and uploaded $cversion";
2201
2202     supplementary_message('');
2203     responder_send_command("complete");
2204 }
2205
2206 sub cmd_clone {
2207     parseopts();
2208     notpushing();
2209     my $dstdir;
2210     badusage "-p is not allowed with clone; specify as argument instead"
2211         if defined $package;
2212     if (@ARGV==1) {
2213         ($package) = @ARGV;
2214     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2215         ($package,$isuite) = @ARGV;
2216     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2217         ($package,$dstdir) = @ARGV;
2218     } elsif (@ARGV==3) {
2219         ($package,$isuite,$dstdir) = @ARGV;
2220     } else {
2221         badusage "incorrect arguments to dgit clone";
2222     }
2223     $dstdir ||= "$package";
2224
2225     if (stat_exists $dstdir) {
2226         fail "$dstdir already exists";
2227     }
2228
2229     my $cwd_remove;
2230     if ($rmonerror && !$dryrun_level) {
2231         $cwd_remove= getcwd();
2232         unshift @end, sub {
2233             return unless defined $cwd_remove;
2234             if (!chdir "$cwd_remove") {
2235                 return if $!==&ENOENT;
2236                 die "chdir $cwd_remove: $!";
2237             }
2238             if (stat $dstdir) {
2239                 rmtree($dstdir) or die "remove $dstdir: $!\n";
2240             } elsif (!grep { $! == $_ }
2241                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2242             } else {
2243                 print STDERR "check whether to remove $dstdir: $!\n";
2244             }
2245         };
2246     }
2247
2248     clone($dstdir);
2249     $cwd_remove = undef;
2250 }
2251
2252 sub branchsuite () {
2253     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2254     if ($branch =~ m#$lbranch_re#o) {
2255         return $1;
2256     } else {
2257         return undef;
2258     }
2259 }
2260
2261 sub fetchpullargs () {
2262     notpushing();
2263     if (!defined $package) {
2264         my $sourcep = parsecontrol('debian/control','debian/control');
2265         $package = getfield $sourcep, 'Source';
2266     }
2267     if (@ARGV==0) {
2268 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
2269         if (!$isuite) {
2270             my $clogp = parsechangelog();
2271             $isuite = getfield $clogp, 'Distribution';
2272         }
2273         canonicalise_suite();
2274         progress "fetching from suite $csuite";
2275     } elsif (@ARGV==1) {
2276         ($isuite) = @ARGV;
2277         canonicalise_suite();
2278     } else {
2279         badusage "incorrect arguments to dgit fetch or dgit pull";
2280     }
2281 }
2282
2283 sub cmd_fetch {
2284     parseopts();
2285     fetchpullargs();
2286     fetch();
2287 }
2288
2289 sub cmd_pull {
2290     parseopts();
2291     fetchpullargs();
2292     pull();
2293 }
2294
2295 sub cmd_push {
2296     parseopts();
2297     pushing();
2298     badusage "-p is not allowed with dgit push" if defined $package;
2299     check_not_dirty();
2300     my $clogp = parsechangelog();
2301     $package = getfield $clogp, 'Source';
2302     my $specsuite;
2303     if (@ARGV==0) {
2304     } elsif (@ARGV==1) {
2305         ($specsuite) = (@ARGV);
2306     } else {
2307         badusage "incorrect arguments to dgit push";
2308     }
2309     $isuite = getfield $clogp, 'Distribution';
2310     if ($new_package) {
2311         local ($package) = $existing_package; # this is a hack
2312         canonicalise_suite();
2313     } else {
2314         canonicalise_suite();
2315     }
2316     if (defined $specsuite &&
2317         $specsuite ne $isuite &&
2318         $specsuite ne $csuite) {
2319             fail "dgit push: changelog specifies $isuite ($csuite)".
2320                 " but command line specifies $specsuite";
2321     }
2322     supplementary_message(<<'END');
2323 Push failed, while checking state of the archive.
2324 You can retry the push, after fixing the problem, if you like.
2325 END
2326     if (check_for_git()) {
2327         git_fetch_us();
2328     }
2329     my $forceflag = '';
2330     if (fetch_from_archive()) {
2331         if (is_fast_fwd(lrref(), 'HEAD')) {
2332             # ok
2333         } elsif (deliberately_not_fast_forward) {
2334             $forceflag = '+';
2335         } else {
2336             fail "dgit push: HEAD is not a descendant".
2337                 " of the archive's version.\n".
2338                 "dgit: To overwrite its contents,".
2339                 " use git merge -s ours ".lrref().".\n".
2340                 "dgit: To rewind history, if permitted by the archive,".
2341                 " use --deliberately-not-fast-forward";
2342         }
2343     } else {
2344         $new_package or
2345             fail "package appears to be new in this suite;".
2346                 " if this is intentional, use --new";
2347     }
2348     dopush($forceflag);
2349 }
2350
2351 #---------- remote commands' implementation ----------
2352
2353 sub cmd_remote_push_build_host {
2354     my ($nrargs) = shift @ARGV;
2355     my (@rargs) = @ARGV[0..$nrargs-1];
2356     @ARGV = @ARGV[$nrargs..$#ARGV];
2357     die unless @rargs;
2358     my ($dir,$vsnwant) = @rargs;
2359     # vsnwant is a comma-separated list; we report which we have
2360     # chosen in our ready response (so other end can tell if they
2361     # offered several)
2362     $debugprefix = ' ';
2363     $we_are_responder = 1;
2364     $us .= " (build host)";
2365
2366     pushing();
2367
2368     open PI, "<&STDIN" or die $!;
2369     open STDIN, "/dev/null" or die $!;
2370     open PO, ">&STDOUT" or die $!;
2371     autoflush PO 1;
2372     open STDOUT, ">&STDERR" or die $!;
2373     autoflush STDOUT 1;
2374
2375     $vsnwant //= 1;
2376     ($protovsn) = grep {
2377         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2378     } @rpushprotovsn_support;
2379
2380     fail "build host has dgit rpush protocol versions ".
2381         (join ",", @rpushprotovsn_support).
2382         " but invocation host has $vsnwant"
2383         unless defined $protovsn;
2384
2385     responder_send_command("dgit-remote-push-ready $protovsn");
2386     rpush_handle_protovsn_bothends();
2387     changedir $dir;
2388     &cmd_push;
2389 }
2390
2391 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2392 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2393 #     a good error message)
2394
2395 sub rpush_handle_protovsn_bothends () {
2396     if ($protovsn < 4) {
2397         fail "rpush negotiated protocol version $protovsn".
2398             " which supports old tag format only".
2399             " but trying to use new format (".$tagformat_want->[1].")"
2400             if $tagformat_want && $tagformat_want->[0] ne 'old';
2401         $tagformat_want = ['old', "rpush negotiated protocol $protovsn", 0];
2402     }
2403     select_tagformat();
2404 }
2405
2406 our $i_tmp;
2407
2408 sub i_cleanup {
2409     local ($@, $?);
2410     my $report = i_child_report();
2411     if (defined $report) {
2412         printdebug "($report)\n";
2413     } elsif ($i_child_pid) {
2414         printdebug "(killing build host child $i_child_pid)\n";
2415         kill 15, $i_child_pid;
2416     }
2417     if (defined $i_tmp && !defined $initiator_tempdir) {
2418         changedir "/";
2419         eval { rmtree $i_tmp; };
2420     }
2421 }
2422
2423 END { i_cleanup(); }
2424
2425 sub i_method {
2426     my ($base,$selector,@args) = @_;
2427     $selector =~ s/\-/_/g;
2428     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2429 }
2430
2431 sub cmd_rpush {
2432     pushing();
2433     my $host = nextarg;
2434     my $dir;
2435     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2436         $host = $1;
2437         $dir = $'; #';
2438     } else {
2439         $dir = nextarg;
2440     }
2441     $dir =~ s{^-}{./-};
2442     my @rargs = ($dir);
2443     push @rargs, join ",", @rpushprotovsn_support;
2444     my @rdgit;
2445     push @rdgit, @dgit;
2446     push @rdgit, @ropts;
2447     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2448     push @rdgit, @ARGV;
2449     my @cmd = (@ssh, $host, shellquote @rdgit);
2450     debugcmd "+",@cmd;
2451
2452     if (defined $initiator_tempdir) {
2453         rmtree $initiator_tempdir;
2454         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2455         $i_tmp = $initiator_tempdir;
2456     } else {
2457         $i_tmp = tempdir();
2458     }
2459     $i_child_pid = open2(\*RO, \*RI, @cmd);
2460     changedir $i_tmp;
2461     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2462     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2463     $supplementary_message = '' unless $protovsn >= 3;
2464     rpush_handle_protovsn_bothends();
2465     for (;;) {
2466         my ($icmd,$iargs) = initiator_expect {
2467             m/^(\S+)(?: (.*))?$/;
2468             ($1,$2);
2469         };
2470         i_method "i_resp", $icmd, $iargs;
2471     }
2472 }
2473
2474 sub i_resp_progress ($) {
2475     my ($rhs) = @_;
2476     my $msg = protocol_read_bytes \*RO, $rhs;
2477     progress $msg;
2478 }
2479
2480 sub i_resp_supplementary_message ($) {
2481     my ($rhs) = @_;
2482     $supplementary_message = protocol_read_bytes \*RO, $rhs;
2483 }
2484
2485 sub i_resp_complete {
2486     my $pid = $i_child_pid;
2487     $i_child_pid = undef; # prevents killing some other process with same pid
2488     printdebug "waiting for build host child $pid...\n";
2489     my $got = waitpid $pid, 0;
2490     die $! unless $got == $pid;
2491     die "build host child failed $?" if $?;
2492
2493     i_cleanup();
2494     printdebug "all done\n";
2495     exit 0;
2496 }
2497
2498 sub i_resp_file ($) {
2499     my ($keyword) = @_;
2500     my $localname = i_method "i_localname", $keyword;
2501     my $localpath = "$i_tmp/$localname";
2502     stat_exists $localpath and
2503         badproto \*RO, "file $keyword ($localpath) twice";
2504     protocol_receive_file \*RO, $localpath;
2505     i_method "i_file", $keyword;
2506 }
2507
2508 our %i_param;
2509
2510 sub i_resp_param ($) {
2511     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2512     $i_param{$1} = $2;
2513 }
2514
2515 sub i_resp_previously ($) {
2516     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2517         or badproto \*RO, "bad previously spec";
2518     my $r = system qw(git check-ref-format), $1;
2519     die "bad previously ref spec ($r)" if $r;
2520     $previously{$1} = $2;
2521 }
2522
2523 our %i_wanted;
2524
2525 sub i_resp_want ($) {
2526     my ($keyword) = @_;
2527     die "$keyword ?" if $i_wanted{$keyword}++;
2528     my @localpaths = i_method "i_want", $keyword;
2529     printdebug "[[  $keyword @localpaths\n";
2530     foreach my $localpath (@localpaths) {
2531         protocol_send_file \*RI, $localpath;
2532     }
2533     print RI "files-end\n" or die $!;
2534 }
2535
2536 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2537
2538 sub i_localname_parsed_changelog {
2539     return "remote-changelog.822";
2540 }
2541 sub i_file_parsed_changelog {
2542     ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2543         push_parse_changelog "$i_tmp/remote-changelog.822";
2544     die if $i_dscfn =~ m#/|^\W#;
2545 }
2546
2547 sub i_localname_dsc {
2548     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2549     return $i_dscfn;
2550 }
2551 sub i_file_dsc { }
2552
2553 sub i_localname_changes {
2554     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2555     $i_changesfn = $i_dscfn;
2556     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2557     return $i_changesfn;
2558 }
2559 sub i_file_changes { }
2560
2561 sub i_want_signed_tag {
2562     printdebug Dumper(\%i_param, $i_dscfn);
2563     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2564         && defined $i_param{'csuite'}
2565         or badproto \*RO, "premature desire for signed-tag";
2566     my $head = $i_param{'head'};
2567     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2568
2569     select_tagformat();
2570     if ($protovsn >= 4) {
2571         my $p = $i_param{'tagformat'} // '<undef>';
2572         $p eq $tagformat
2573             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
2574     }
2575
2576     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2577     $csuite = $&;
2578     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2579
2580     my ($tagobjfn) =
2581         push_mktag $head, $i_clogp, $i_tag,
2582             $i_dscfn,
2583             $i_changesfn, 'remote changes',
2584             sub { "tag$_[0]"; };
2585
2586     return $tagobjfn;
2587 }
2588
2589 sub i_want_signed_dsc_changes {
2590     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2591     sign_changes $i_changesfn;
2592     return ($i_dscfn, $i_changesfn);
2593 }
2594
2595 #---------- building etc. ----------
2596
2597 our $version;
2598 our $sourcechanges;
2599 our $dscfn;
2600
2601 #----- `3.0 (quilt)' handling -----
2602
2603 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2604
2605 sub quiltify_dpkg_commit ($$$;$) {
2606     my ($patchname,$author,$msg, $xinfo) = @_;
2607     $xinfo //= '';
2608
2609     mkpath '.git/dgit';
2610     my $descfn = ".git/dgit/quilt-description.tmp";
2611     open O, '>', $descfn or die "$descfn: $!";
2612     $msg =~ s/\s+$//g;
2613     $msg =~ s/\n/\n /g;
2614     $msg =~ s/^\s+$/ ./mg;
2615     print O <<END or die $!;
2616 Description: $msg
2617 Author: $author
2618 $xinfo
2619 ---
2620
2621 END
2622     close O or die $!;
2623
2624     {
2625         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2626         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2627         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2628         runcmd @dpkgsource, qw(--commit .), $patchname;
2629     }
2630 }
2631
2632 sub quiltify_trees_differ ($$;$$) {
2633     my ($x,$y,$finegrained,$ignorenamesr) = @_;
2634     # returns true iff the two tree objects differ other than in debian/
2635     # with $finegrained,
2636     # returns bitmask 01 - differ in upstream files except .gitignore
2637     #                 02 - differ in .gitignore
2638     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
2639     #  is set for each modified .gitignore filename $fn
2640     local $/=undef;
2641     my @cmd = (@git, qw(diff-tree --name-only -z));
2642     push @cmd, qw(-r) if $finegrained;
2643     push @cmd, $x, $y;
2644     my $diffs= cmdoutput @cmd;
2645     my $r = 0;
2646     foreach my $f (split /\0/, $diffs) {
2647         next if $f =~ m#^debian(?:/.*)?$#s;
2648         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
2649         $r |= $isignore ? 02 : 01;
2650         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
2651     }
2652     printdebug "quiltify_trees_differ $x $y => $r\n";
2653     return $r;
2654 }
2655
2656 sub quiltify_tree_sentinelfiles ($) {
2657     # lists the `sentinel' files present in the tree
2658     my ($x) = @_;
2659     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2660         qw(-- debian/rules debian/control);
2661     $r =~ s/\n/,/g;
2662     return $r;
2663 }
2664
2665 sub quiltify_splitbrain_needed () {
2666     if (!$split_brain) {
2667         progress "dgit view: changes are required...";
2668         runcmd @git, qw(checkout -q -b dgit-view);
2669         $split_brain = 1;
2670     }
2671 }
2672
2673 sub quiltify_splitbrain ($$$$$$) {
2674     my ($clogp, $unapplied, $headref, $diffbits,
2675         $editedignores, $cachekey) = @_;
2676     if ($quilt_mode !~ m/gbp|dpm/) {
2677         # treat .gitignore just like any other upstream file
2678         $diffbits = { %$diffbits };
2679         $_ = !!$_ foreach values %$diffbits;
2680     }
2681     # We would like any commits we generate to be reproducible
2682     my @authline = clogp_authline($clogp);
2683     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2684     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2685     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2686
2687     if ($quilt_mode =~ m/gbp|unapplied/ &&
2688         ($diffbits->{H2O} & 01)) {
2689         my $msg =
2690  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
2691  " but git tree differs from orig in upstream files.";
2692         if (!stat_exists "debian/patches") {
2693             $msg .=
2694  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
2695         }
2696         fail $msg;
2697     }
2698     if ($quilt_mode =~ m/gbp|unapplied/ &&
2699         ($diffbits->{O2A} & 01)) { # some patches
2700         quiltify_splitbrain_needed();
2701         progress "dgit view: creating patches-applied version using gbp pq";
2702         runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
2703         # gbp pq import creates a fresh branch; push back to dgit-view
2704         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
2705         runcmd @git, qw(checkout -q dgit-view);
2706     }
2707     if (($diffbits->{H2O} & 02) && # user has modified .gitignore
2708         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
2709         quiltify_splitbrain_needed();
2710         progress "dgit view: creating patch to represent .gitignore changes";
2711         ensuredir "debian/patches";
2712         my $gipatch = "debian/patches/auto-gitignore";
2713         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
2714         stat GIPATCH or die "$gipatch: $!";
2715         fail "$gipatch already exists; but want to create it".
2716             " to record .gitignore changes" if (stat _)[7];
2717         print GIPATCH <<END or die "$gipatch: $!";
2718 Subject: Update .gitignore from Debian packaging branch
2719
2720 The Debian packaging git branch contains these updates to the upstream
2721 .gitignore file(s).  This patch is autogenerated, to provide these
2722 updates to users of the official Debian archive view of the package.
2723
2724 [dgit version $our_version]
2725 ---
2726 END
2727         close GIPATCH or die "$gipatch: $!";
2728         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
2729             $unapplied, $headref, "--", sort keys %$editedignores;
2730         open SERIES, "+>>", "debian/patches/series" or die $!;
2731         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
2732         my $newline;
2733         defined read SERIES, $newline, 1 or die $!;
2734         print SERIES "\n" or die $! unless $newline eq "\n";
2735         print SERIES "auto-gitignore\n" or die $!;
2736         close SERIES or die  $!;
2737         runcmd @git, qw(add -- debian/patches/series), $gipatch;
2738         commit_admin "Commit patch to update .gitignore";
2739     }
2740
2741     my $dgitview = git_rev_parse 'refs/heads/dgit-view';
2742
2743     changedir '../../../..';
2744     ensuredir ".git/logs/refs/dgit-intern";
2745     my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
2746       or die $!;
2747     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
2748         $dgitview;
2749
2750     progress "dgit view: created (commit id $dgitview)";
2751
2752     changedir '.git/dgit/unpack/work';
2753 }
2754
2755 sub quiltify ($$$$) {
2756     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
2757
2758     # Quilt patchification algorithm
2759     #
2760     # We search backwards through the history of the main tree's HEAD
2761     # (T) looking for a start commit S whose tree object is identical
2762     # to to the patch tip tree (ie the tree corresponding to the
2763     # current dpkg-committed patch series).  For these purposes
2764     # `identical' disregards anything in debian/ - this wrinkle is
2765     # necessary because dpkg-source treates debian/ specially.
2766     #
2767     # We can only traverse edges where at most one of the ancestors'
2768     # trees differs (in changes outside in debian/).  And we cannot
2769     # handle edges which change .pc/ or debian/patches.  To avoid
2770     # going down a rathole we avoid traversing edges which introduce
2771     # debian/rules or debian/control.  And we set a limit on the
2772     # number of edges we are willing to look at.
2773     #
2774     # If we succeed, we walk forwards again.  For each traversed edge
2775     # PC (with P parent, C child) (starting with P=S and ending with
2776     # C=T) to we do this:
2777     #  - git checkout C
2778     #  - dpkg-source --commit with a patch name and message derived from C
2779     # After traversing PT, we git commit the changes which
2780     # should be contained within debian/patches.
2781
2782     # The search for the path S..T is breadth-first.  We maintain a
2783     # todo list containing search nodes.  A search node identifies a
2784     # commit, and looks something like this:
2785     #  $p = {
2786     #      Commit => $git_commit_id,
2787     #      Child => $c,                          # or undef if P=T
2788     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
2789     #      Nontrivial => true iff $p..$c has relevant changes
2790     #  };
2791
2792     my @todo;
2793     my @nots;
2794     my $sref_S;
2795     my $max_work=100;
2796     my %considered; # saves being exponential on some weird graphs
2797
2798     my $t_sentinels = quiltify_tree_sentinelfiles $target;
2799
2800     my $not = sub {
2801         my ($search,$whynot) = @_;
2802         printdebug " search NOT $search->{Commit} $whynot\n";
2803         $search->{Whynot} = $whynot;
2804         push @nots, $search;
2805         no warnings qw(exiting);
2806         next;
2807     };
2808
2809     push @todo, {
2810         Commit => $target,
2811     };
2812
2813     while (@todo) {
2814         my $c = shift @todo;
2815         next if $considered{$c->{Commit}}++;
2816
2817         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2818
2819         printdebug "quiltify investigate $c->{Commit}\n";
2820
2821         # are we done?
2822         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2823             printdebug " search finished hooray!\n";
2824             $sref_S = $c;
2825             last;
2826         }
2827
2828         if ($quilt_mode eq 'nofix') {
2829             fail "quilt fixup required but quilt mode is \`nofix'\n".
2830                 "HEAD commit $c->{Commit} differs from tree implied by ".
2831                 " debian/patches (tree object $oldtiptree)";
2832         }
2833         if ($quilt_mode eq 'smash') {
2834             printdebug " search quitting smash\n";
2835             last;
2836         }
2837
2838         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2839         $not->($c, "has $c_sentinels not $t_sentinels")
2840             if $c_sentinels ne $t_sentinels;
2841
2842         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2843         $commitdata =~ m/\n\n/;
2844         $commitdata =~ $`;
2845         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2846         @parents = map { { Commit => $_, Child => $c } } @parents;
2847
2848         $not->($c, "root commit") if !@parents;
2849
2850         foreach my $p (@parents) {
2851             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2852         }
2853         my $ndiffers = grep { $_->{Nontrivial} } @parents;
2854         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2855
2856         foreach my $p (@parents) {
2857             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2858
2859             my @cmd= (@git, qw(diff-tree -r --name-only),
2860                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2861             my $patchstackchange = cmdoutput @cmd;
2862             if (length $patchstackchange) {
2863                 $patchstackchange =~ s/\n/,/g;
2864                 $not->($p, "changed $patchstackchange");
2865             }
2866
2867             printdebug " search queue P=$p->{Commit} ",
2868                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2869             push @todo, $p;
2870         }
2871     }
2872
2873     if (!$sref_S) {
2874         printdebug "quiltify want to smash\n";
2875
2876         my $abbrev = sub {
2877             my $x = $_[0]{Commit};
2878             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2879             return $x;
2880         };
2881         my $reportnot = sub {
2882             my ($notp) = @_;
2883             my $s = $abbrev->($notp);
2884             my $c = $notp->{Child};
2885             $s .= "..".$abbrev->($c) if $c;
2886             $s .= ": ".$notp->{Whynot};
2887             return $s;
2888         };
2889         if ($quilt_mode eq 'linear') {
2890             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
2891             foreach my $notp (@nots) {
2892                 print STDERR "$us:  ", $reportnot->($notp), "\n";
2893             }
2894             print STDERR "$us: $_\n" foreach @$failsuggestion;
2895             fail "quilt fixup naive history linearisation failed.\n".
2896  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2897         } elsif ($quilt_mode eq 'smash') {
2898         } elsif ($quilt_mode eq 'auto') {
2899             progress "quilt fixup cannot be linear, smashing...";
2900         } else {
2901             die "$quilt_mode ?";
2902         }
2903
2904         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
2905         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
2906         my $ncommits = 3;
2907         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2908
2909         quiltify_dpkg_commit "auto-$version-$target-$time",
2910             (getfield $clogp, 'Maintainer'),
2911             "Automatically generated patch ($clogp->{Version})\n".
2912             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2913         return;
2914     }
2915
2916     progress "quiltify linearisation planning successful, executing...";
2917
2918     for (my $p = $sref_S;
2919          my $c = $p->{Child};
2920          $p = $p->{Child}) {
2921         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2922         next unless $p->{Nontrivial};
2923
2924         my $cc = $c->{Commit};
2925
2926         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2927         $commitdata =~ m/\n\n/ or die "$c ?";
2928         $commitdata = $`;
2929         my $msg = $'; #';
2930         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2931         my $author = $1;
2932
2933         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2934
2935         my $title = $1;
2936         my $patchname = $title;
2937         $patchname =~ s/[.:]$//;
2938         $patchname =~ y/ A-Z/-a-z/;
2939         $patchname =~ y/-a-z0-9_.+=~//cd;
2940         $patchname =~ s/^\W/x-$&/;
2941         $patchname = substr($patchname,0,40);
2942         my $index;
2943         for ($index='';
2944              stat "debian/patches/$patchname$index";
2945              $index++) { }
2946         $!==ENOENT or die "$patchname$index $!";
2947
2948         runcmd @git, qw(checkout -q), $cc;
2949
2950         # We use the tip's changelog so that dpkg-source doesn't
2951         # produce complaining messages from dpkg-parsechangelog.  None
2952         # of the information dpkg-source gets from the changelog is
2953         # actually relevant - it gets put into the original message
2954         # which dpkg-source provides our stunt editor, and then
2955         # overwritten.
2956         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2957
2958         quiltify_dpkg_commit "$patchname$index", $author, $msg,
2959             "X-Dgit-Generated: $clogp->{Version} $cc\n";
2960
2961         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2962     }
2963
2964     runcmd @git, qw(checkout -q master);
2965 }
2966
2967 sub build_maybe_quilt_fixup () {
2968     my ($format,$fopts) = get_source_format;
2969     return unless madformat $format;
2970     # sigh
2971
2972     check_for_vendor_patches();
2973
2974     my $clogp = parsechangelog();
2975     my $headref = git_rev_parse('HEAD');
2976
2977     prep_ud();
2978     changedir $ud;
2979
2980     my $upstreamversion=$version;
2981     $upstreamversion =~ s/-[^-]*$//;
2982
2983     if ($fopts->{'single-debian-patch'}) {
2984         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
2985     } else {
2986         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
2987     }
2988
2989     die 'bug' if $split_brain && !$need_split_build_invocation;
2990
2991     changedir '../../../..';
2992     runcmd_ordryrun_local
2993         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2994 }
2995
2996 sub quilt_fixup_mkwork ($) {
2997     my ($headref) = @_;
2998
2999     mkdir "work" or die $!;
3000     changedir "work";
3001     mktree_in_ud_here();
3002     runcmd @git, qw(reset -q --hard), $headref;
3003 }
3004
3005 sub quilt_fixup_linkorigs ($$) {
3006     my ($upstreamversion, $fn) = @_;
3007     # calls $fn->($leafname);
3008
3009     foreach my $f (<../../../../*>) { #/){
3010         my $b=$f; $b =~ s{.*/}{};
3011         {
3012             local ($debuglevel) = $debuglevel-1;
3013             printdebug "QF linkorigs $b, $f ?\n";
3014         }
3015         next unless is_orig_file $b, srcfn $upstreamversion,'';
3016         printdebug "QF linkorigs $b, $f Y\n";
3017         link_ltarget $f, $b or die "$b $!";
3018         $fn->($b);
3019     }
3020 }
3021
3022 sub quilt_fixup_delete_pc () {
3023     runcmd @git, qw(rm -rqf .pc);
3024     commit_admin "Commit removal of .pc (quilt series tracking data)";
3025 }
3026
3027 sub quilt_fixup_singlepatch ($$$) {
3028     my ($clogp, $headref, $upstreamversion) = @_;
3029
3030     progress "starting quiltify (single-debian-patch)";
3031
3032     # dpkg-source --commit generates new patches even if
3033     # single-debian-patch is in debian/source/options.  In order to
3034     # get it to generate debian/patches/debian-changes, it is
3035     # necessary to build the source package.
3036
3037     quilt_fixup_linkorigs($upstreamversion, sub { });
3038     quilt_fixup_mkwork($headref);
3039
3040     rmtree("debian/patches");
3041
3042     runcmd @dpkgsource, qw(-b .);
3043     chdir "..";
3044     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3045     rename srcfn("$upstreamversion", "/debian/patches"),
3046            "work/debian/patches";
3047
3048     chdir "work";
3049     commit_quilty_patch();
3050 }
3051
3052 sub quilt_make_fake_dsc ($) {
3053     my ($upstreamversion) = @_;
3054
3055     my $fakeversion="$upstreamversion-~~DGITFAKE";
3056
3057     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3058     print $fakedsc <<END or die $!;
3059 Format: 3.0 (quilt)
3060 Source: $package
3061 Version: $fakeversion
3062 Files:
3063 END
3064
3065     my $dscaddfile=sub {
3066         my ($b) = @_;
3067
3068         my $md = new Digest::MD5;
3069
3070         my $fh = new IO::File $b, '<' or die "$b $!";
3071         stat $fh or die $!;
3072         my $size = -s _;
3073
3074         $md->addfile($fh);
3075         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3076     };
3077
3078     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3079
3080     my @files=qw(debian/source/format debian/rules
3081                  debian/control debian/changelog);
3082     foreach my $maybe (qw(debian/patches debian/source/options
3083                           debian/tests/control)) {
3084         next unless stat_exists "../../../$maybe";
3085         push @files, $maybe;
3086     }
3087
3088     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3089     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3090
3091     $dscaddfile->($debtar);
3092     close $fakedsc or die $!;
3093 }
3094
3095 sub quilt_check_splitbrain_cache ($$) {
3096     my ($headref, $upstreamversion) = @_;
3097     # Called only if we are in (potentially) split brain mode.
3098     # Called in $ud.
3099     # Computes the cache key and looks in the cache.
3100     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3101
3102     my $splitbrain_cachekey;
3103
3104     progress
3105  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3106     # we look in the reflog of dgit-intern/quilt-cache
3107     # we look for an entry whose message is the key for the cache lookup
3108     my @cachekey = (qw(dgit), $our_version);
3109     push @cachekey, $upstreamversion;
3110     push @cachekey, $quilt_mode;
3111     push @cachekey, $headref;
3112
3113     push @cachekey, hashfile('fake.dsc');
3114
3115     my $srcshash = Digest::SHA->new(256);
3116     my %sfs = ( %INC, '$0(dgit)' => $0 );
3117     foreach my $sfk (sort keys %sfs) {
3118         next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3119         $srcshash->add($sfk,"  ");
3120         $srcshash->add(hashfile($sfs{$sfk}));
3121         $srcshash->add("\n");
3122     }
3123     push @cachekey, $srcshash->hexdigest();
3124     $splitbrain_cachekey = "@cachekey";
3125
3126     my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3127                $splitbraincache);
3128     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3129     debugcmd "|(probably)",@cmd;
3130     my $child = open GC, "-|";  defined $child or die $!;
3131     if (!$child) {
3132         chdir '../../..' or die $!;
3133         if (!stat ".git/logs/refs/$splitbraincache") {
3134             $! == ENOENT or die $!;
3135             printdebug ">(no reflog)\n";
3136             exit 0;
3137         }
3138         exec @cmd; die $!;
3139     }
3140     while (<GC>) {
3141         chomp;
3142         printdebug ">| ", $_, "\n" if $debuglevel > 1;
3143         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3144
3145         my $cachehit = $1;
3146         quilt_fixup_mkwork($headref);
3147         if ($cachehit ne $headref) {
3148             progress "dgit view: found cached (commit id $cachehit)";
3149             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3150             $split_brain = 1;
3151             return ($cachehit, $splitbrain_cachekey);
3152         }
3153         progress "dgit view: found cached, no changes required";
3154         return ($headref, $splitbrain_cachekey);
3155     }
3156     die $! if GC->error;
3157     failedcmd unless close GC;
3158
3159     printdebug "splitbrain cache miss\n";
3160     return (undef, $splitbrain_cachekey);
3161 }
3162
3163 sub quilt_fixup_multipatch ($$$) {
3164     my ($clogp, $headref, $upstreamversion) = @_;
3165
3166     progress "examining quilt state (multiple patches, $quilt_mode mode)";
3167
3168     # Our objective is:
3169     #  - honour any existing .pc in case it has any strangeness
3170     #  - determine the git commit corresponding to the tip of
3171     #    the patch stack (if there is one)
3172     #  - if there is such a git commit, convert each subsequent
3173     #    git commit into a quilt patch with dpkg-source --commit
3174     #  - otherwise convert all the differences in the tree into
3175     #    a single git commit
3176     #
3177     # To do this we:
3178
3179     # Our git tree doesn't necessarily contain .pc.  (Some versions of
3180     # dgit would include the .pc in the git tree.)  If there isn't
3181     # one, we need to generate one by unpacking the patches that we
3182     # have.
3183     #
3184     # We first look for a .pc in the git tree.  If there is one, we
3185     # will use it.  (This is not the normal case.)
3186     #
3187     # Otherwise need to regenerate .pc so that dpkg-source --commit
3188     # can work.  We do this as follows:
3189     #     1. Collect all relevant .orig from parent directory
3190     #     2. Generate a debian.tar.gz out of
3191     #         debian/{patches,rules,source/format,source/options}
3192     #     3. Generate a fake .dsc containing just these fields:
3193     #          Format Source Version Files
3194     #     4. Extract the fake .dsc
3195     #        Now the fake .dsc has a .pc directory.
3196     # (In fact we do this in every case, because in future we will
3197     # want to search for a good base commit for generating patches.)
3198     #
3199     # Then we can actually do the dpkg-source --commit
3200     #     1. Make a new working tree with the same object
3201     #        store as our main tree and check out the main
3202     #        tree's HEAD.
3203     #     2. Copy .pc from the fake's extraction, if necessary
3204     #     3. Run dpkg-source --commit
3205     #     4. If the result has changes to debian/, then
3206     #          - git-add them them
3207     #          - git-add .pc if we had a .pc in-tree
3208     #          - git-commit
3209     #     5. If we had a .pc in-tree, delete it, and git-commit
3210     #     6. Back in the main tree, fast forward to the new HEAD
3211
3212     # Another situation we may have to cope with is gbp-style
3213     # patches-unapplied trees.
3214     #
3215     # We would want to detect these, so we know to escape into
3216     # quilt_fixup_gbp.  However, this is in general not possible.
3217     # Consider a package with a one patch which the dgit user reverts
3218     # (with git-revert or the moral equivalent).
3219     #
3220     # That is indistinguishable in contents from a patches-unapplied
3221     # tree.  And looking at the history to distinguish them is not
3222     # useful because the user might have made a confusing-looking git
3223     # history structure (which ought to produce an error if dgit can't
3224     # cope, not a silent reintroduction of an unwanted patch).
3225     #
3226     # So gbp users will have to pass an option.  But we can usually
3227     # detect their failure to do so: if the tree is not a clean
3228     # patches-applied tree, quilt linearisation fails, but the tree
3229     # _is_ a clean patches-unapplied tree, we can suggest that maybe
3230     # they want --quilt=unapplied.
3231     #
3232     # To help detect this, when we are extracting the fake dsc, we
3233     # first extract it with --skip-patches, and then apply the patches
3234     # afterwards with dpkg-source --before-build.  That lets us save a
3235     # tree object corresponding to .origs.
3236
3237     my $splitbrain_cachekey;
3238
3239     quilt_make_fake_dsc($upstreamversion);
3240
3241     if (quiltmode_splitbrain()) {
3242         my $cachehit;
3243         ($cachehit, $splitbrain_cachekey) =
3244             quilt_check_splitbrain_cache($headref, $upstreamversion);
3245         return if $cachehit;
3246     }
3247
3248     runcmd qw(sh -ec),
3249         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3250
3251     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3252     rename $fakexdir, "fake" or die "$fakexdir $!";
3253
3254     changedir 'fake';
3255
3256     remove_stray_gits();
3257     mktree_in_ud_here();
3258
3259     rmtree '.pc';
3260
3261     runcmd @git, qw(add -Af .);
3262     my $unapplied=git_write_tree();
3263     printdebug "fake orig tree object $unapplied\n";
3264
3265     ensuredir '.pc';
3266
3267     runcmd qw(sh -ec),
3268         'exec dpkg-source --before-build . >/dev/null';
3269
3270     changedir '..';
3271
3272     quilt_fixup_mkwork($headref);
3273
3274     my $mustdeletepc=0;
3275     if (stat_exists ".pc") {
3276         -d _ or die;
3277         progress "Tree already contains .pc - will use it then delete it.";
3278         $mustdeletepc=1;
3279     } else {
3280         rename '../fake/.pc','.pc' or die $!;
3281     }
3282
3283     changedir '../fake';
3284     rmtree '.pc';
3285     runcmd @git, qw(add -Af .);
3286     my $oldtiptree=git_write_tree();
3287     printdebug "fake o+d/p tree object $unapplied\n";
3288     changedir '../work';
3289
3290
3291     # We calculate some guesswork now about what kind of tree this might
3292     # be.  This is mostly for error reporting.
3293
3294     my %editedignores;
3295     my $diffbits = {
3296         # H = user's HEAD
3297         # O = orig, without patches applied
3298         # A = "applied", ie orig with H's debian/patches applied
3299         H2O => quiltify_trees_differ($headref,  $unapplied, 1,\%editedignores),
3300         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
3301         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3302     };
3303
3304     my @dl;
3305     foreach my $b (qw(01 02)) {
3306         foreach my $v (qw(H2O O2A H2A)) {
3307             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3308         }
3309     }
3310     printdebug "differences \@dl @dl.\n";
3311
3312     progress sprintf
3313 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
3314 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
3315                              $dl[0], $dl[1],              $dl[3], $dl[4],
3316                                  $dl[2],                     $dl[5];
3317
3318     my @failsuggestion;
3319     if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3320         push @failsuggestion, "This might be a patches-unapplied branch.";
3321     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3322         push @failsuggestion, "This might be a patches-applied branch.";
3323     }
3324     push @failsuggestion, "Maybe you need to specify one of".
3325         " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3326
3327     if (quiltmode_splitbrain()) {
3328         quiltify_splitbrain($clogp, $unapplied, $headref,
3329                             $diffbits, \%editedignores,
3330                             $splitbrain_cachekey);
3331         return;
3332     }
3333
3334     progress "starting quiltify (multiple patches, $quilt_mode mode)";
3335     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3336
3337     if (!open P, '>>', ".pc/applied-patches") {
3338         $!==&ENOENT or die $!;
3339     } else {
3340         close P;
3341     }
3342
3343     commit_quilty_patch();
3344
3345     if ($mustdeletepc) {
3346         quilt_fixup_delete_pc();
3347     }
3348 }
3349
3350 sub quilt_fixup_editor () {
3351     my $descfn = $ENV{$fakeeditorenv};
3352     my $editing = $ARGV[$#ARGV];
3353     open I1, '<', $descfn or die "$descfn: $!";
3354     open I2, '<', $editing or die "$editing: $!";
3355     unlink $editing or die "$editing: $!";
3356     open O, '>', $editing or die "$editing: $!";
3357     while (<I1>) { print O or die $!; } I1->error and die $!;
3358     my $copying = 0;
3359     while (<I2>) {
3360         $copying ||= m/^\-\-\- /;
3361         next unless $copying;
3362         print O or die $!;
3363     }
3364     I2->error and die $!;
3365     close O or die $1;
3366     exit 0;
3367 }
3368
3369 sub maybe_apply_patches_dirtily () {
3370     return unless $quilt_mode =~ m/gbp|unapplied/;
3371     print STDERR <<END or die $!;
3372
3373 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3374 dgit: Have to apply the patches - making the tree dirty.
3375 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3376
3377 END
3378     $patches_applied_dirtily = 01;
3379     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3380     runcmd qw(dpkg-source --before-build .);
3381 }
3382
3383 sub maybe_unapply_patches_again () {
3384     progress "dgit: Unapplying patches again to tidy up the tree."
3385         if $patches_applied_dirtily;
3386     runcmd qw(dpkg-source --after-build .)
3387         if $patches_applied_dirtily & 01;
3388     rmtree '.pc'
3389         if $patches_applied_dirtily & 02;
3390 }
3391
3392 #----- other building -----
3393
3394 our $clean_using_builder;
3395 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3396 #   clean the tree before building (perhaps invoked indirectly by
3397 #   whatever we are using to run the build), rather than separately
3398 #   and explicitly by us.
3399
3400 sub clean_tree () {
3401     return if $clean_using_builder;
3402     if ($cleanmode eq 'dpkg-source') {
3403         maybe_apply_patches_dirtily();
3404         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3405     } elsif ($cleanmode eq 'dpkg-source-d') {
3406         maybe_apply_patches_dirtily();
3407         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3408     } elsif ($cleanmode eq 'git') {
3409         runcmd_ordryrun_local @git, qw(clean -xdf);
3410     } elsif ($cleanmode eq 'git-ff') {
3411         runcmd_ordryrun_local @git, qw(clean -xdff);
3412     } elsif ($cleanmode eq 'check') {
3413         my $leftovers = cmdoutput @git, qw(clean -xdn);
3414         if (length $leftovers) {
3415             print STDERR $leftovers, "\n" or die $!;
3416             fail "tree contains uncommitted files and --clean=check specified";
3417         }
3418     } elsif ($cleanmode eq 'none') {
3419     } else {
3420         die "$cleanmode ?";
3421     }
3422 }
3423
3424 sub cmd_clean () {
3425     badusage "clean takes no additional arguments" if @ARGV;
3426     notpushing();
3427     clean_tree();
3428     maybe_unapply_patches_again();
3429 }
3430
3431 sub build_prep () {
3432     notpushing();
3433     badusage "-p is not allowed when building" if defined $package;
3434     check_not_dirty();
3435     clean_tree();
3436     my $clogp = parsechangelog();
3437     $isuite = getfield $clogp, 'Distribution';
3438     $package = getfield $clogp, 'Source';
3439     $version = getfield $clogp, 'Version';
3440     build_maybe_quilt_fixup();
3441     if ($rmchanges) {
3442         my $pat = changespat $version;
3443         foreach my $f (glob "$buildproductsdir/$pat") {
3444             if (act_local()) {
3445                 unlink $f or fail "remove old changes file $f: $!";
3446             } else {
3447                 progress "would remove $f";
3448             }
3449         }
3450     }
3451 }
3452
3453 sub changesopts_initial () {
3454     my @opts =@changesopts[1..$#changesopts];
3455 }
3456
3457 sub changesopts_version () {
3458     if (!defined $changes_since_version) {
3459         my @vsns = archive_query('archive_query');
3460         my @quirk = access_quirk();
3461         if ($quirk[0] eq 'backports') {
3462             local $isuite = $quirk[2];
3463             local $csuite;
3464             canonicalise_suite();
3465             push @vsns, archive_query('archive_query');
3466         }
3467         if (@vsns) {
3468             @vsns = map { $_->[0] } @vsns;
3469             @vsns = sort { -version_compare($a, $b) } @vsns;
3470             $changes_since_version = $vsns[0];
3471             progress "changelog will contain changes since $vsns[0]";
3472         } else {
3473             $changes_since_version = '_';
3474             progress "package seems new, not specifying -v<version>";
3475         }
3476     }
3477     if ($changes_since_version ne '_') {
3478         return ("-v$changes_since_version");
3479     } else {
3480         return ();
3481     }
3482 }
3483
3484 sub changesopts () {
3485     return (changesopts_initial(), changesopts_version());
3486 }
3487
3488 sub massage_dbp_args ($;$) {
3489     my ($cmd,$xargs) = @_;
3490     # We need to:
3491     #
3492     #  - if we're going to split the source build out so we can
3493     #    do strange things to it, massage the arguments to dpkg-buildpackage
3494     #    so that the main build doessn't build source (or add an argument
3495     #    to stop it building source by default).
3496     #
3497     #  - add -nc to stop dpkg-source cleaning the source tree,
3498     #    unless we're not doing a split build and want dpkg-source
3499     #    as cleanmode, in which case we can do nothing
3500     #
3501     # return values:
3502     #    0 - source will NOT need to be built separately by caller
3503     #   +1 - source will need to be built separately by caller
3504     #   +2 - source will need to be built separately by caller AND
3505     #        dpkg-buildpackage should not in fact be run at all!
3506     debugcmd '#massaging#', @$cmd if $debuglevel>1;
3507 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3508     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3509         $clean_using_builder = 1;
3510         return 0;
3511     }
3512     # -nc has the side effect of specifying -b if nothing else specified
3513     # and some combinations of -S, -b, et al, are errors, rather than
3514     # later simply overriding earlie.  So we need to:
3515     #  - search the command line for these options
3516     #  - pick the last one
3517     #  - perhaps add our own as a default
3518     #  - perhaps adjust it to the corresponding non-source-building version
3519     my $dmode = '-F';
3520     foreach my $l ($cmd, $xargs) {
3521         next unless $l;
3522         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3523     }
3524     push @$cmd, '-nc';
3525 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3526     my $r = 0;
3527     if ($need_split_build_invocation) {
3528         printdebug "massage split $dmode.\n";
3529         $r = $dmode =~ m/[S]/     ? +2 :
3530              $dmode =~ y/gGF/ABb/ ? +1 :
3531              $dmode =~ m/[ABb]/   ?  0 :
3532              die "$dmode ?";
3533     }
3534     printdebug "massage done $r $dmode.\n";
3535     push @$cmd, $dmode;
3536 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3537     return $r;
3538 }
3539
3540 sub cmd_build {
3541     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3542     my $wantsrc = massage_dbp_args \@dbp;
3543     if ($wantsrc > 0) {
3544         build_source();
3545     } else {
3546         build_prep();
3547     }
3548     if ($wantsrc < 2) {
3549         push @dbp, changesopts_version();
3550         maybe_apply_patches_dirtily();
3551         runcmd_ordryrun_local @dbp;
3552     }
3553     maybe_unapply_patches_again();
3554     printdone "build successful\n";
3555 }
3556
3557 sub cmd_gbp_build {
3558     my @dbp = @dpkgbuildpackage;
3559
3560     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
3561
3562     my @cmd;
3563     if (length executable_on_path('git-buildpackage')) {
3564         @cmd = qw(git-buildpackage);
3565     } else {
3566         @cmd = qw(gbp buildpackage);
3567     }
3568     push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3569
3570     if ($wantsrc > 0) {
3571         build_source();
3572     } else {
3573         if (!$clean_using_builder) {
3574             push @cmd, '--git-cleaner=true';
3575         }
3576         build_prep();
3577     }
3578     if ($wantsrc < 2) {
3579         unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3580             canonicalise_suite();
3581             push @cmd, "--git-debian-branch=".lbranch();
3582         }
3583         push @cmd, changesopts();
3584         maybe_apply_patches_dirtily();
3585         runcmd_ordryrun_local @cmd, @ARGV;
3586     }
3587     maybe_unapply_patches_again();
3588     printdone "build successful\n";
3589 }
3590 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3591
3592 sub build_source {
3593     my $our_cleanmode = $cleanmode;
3594     if ($need_split_build_invocation) {
3595         # Pretend that clean is being done some other way.  This
3596         # forces us not to try to use dpkg-buildpackage to clean and
3597         # build source all in one go; and instead we run dpkg-source
3598         # (and build_prep() will do the clean since $clean_using_builder
3599         # is false).
3600         $our_cleanmode = 'ELSEWHERE';
3601     }
3602     if ($our_cleanmode =~ m/^dpkg-source/) {
3603         # dpkg-source invocation (below) will clean, so build_prep shouldn't
3604         $clean_using_builder = 1;
3605     }
3606     build_prep();
3607     $sourcechanges = changespat $version,'source';
3608     if (act_local()) {
3609         unlink "../$sourcechanges" or $!==ENOENT
3610             or fail "remove $sourcechanges: $!";
3611     }
3612     $dscfn = dscfn($version);
3613     if ($our_cleanmode eq 'dpkg-source') {
3614         maybe_apply_patches_dirtily();
3615         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3616             changesopts();
3617     } elsif ($our_cleanmode eq 'dpkg-source-d') {
3618         maybe_apply_patches_dirtily();
3619         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3620             changesopts();
3621     } else {
3622         my @cmd = (@dpkgsource, qw(-b --));
3623         if ($split_brain) {
3624             changedir $ud;
3625             runcmd_ordryrun_local @cmd, "work";
3626             my @udfiles = <${package}_*>;
3627             changedir "../../..";
3628             foreach my $f (@udfiles) {
3629                 printdebug "source copy, found $f\n";
3630                 next unless
3631                     $f eq $dscfn or
3632                     ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
3633                      $f eq srcfn($version, $&));
3634                 printdebug "source copy, found $f - renaming\n";
3635                 rename "$ud/$f", "../$f" or $!==ENOENT
3636                     or fail "put in place new source file ($f): $!";
3637             }
3638         } else {
3639             my $pwd = must_getcwd();
3640             my $leafdir = basename $pwd;
3641             changedir "..";
3642             runcmd_ordryrun_local @cmd, $leafdir;
3643             changedir $pwd;
3644         }
3645         runcmd_ordryrun_local qw(sh -ec),
3646             'exec >$1; shift; exec "$@"','x',
3647             "../$sourcechanges",
3648             @dpkggenchanges, qw(-S), changesopts();
3649     }
3650 }
3651
3652 sub cmd_build_source {
3653     badusage "build-source takes no additional arguments" if @ARGV;
3654     build_source();
3655     maybe_unapply_patches_again();
3656     printdone "source built, results in $dscfn and $sourcechanges";
3657 }
3658
3659 sub cmd_sbuild {
3660     build_source();
3661     my $pat = changespat $version;
3662     if (!$rmchanges) {
3663         my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
3664         @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
3665         fail "changes files other than source matching $pat".
3666             " already present (@unwanted);".
3667             " building would result in ambiguity about the intended results"
3668             if @unwanted;
3669     }
3670     changedir "..";
3671     if (act_local()) {
3672         stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3673         stat_exists $sourcechanges
3674             or fail "$sourcechanges (in parent directory): $!";
3675     }
3676     runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3677     my @changesfiles = glob $pat;
3678     @changesfiles = sort {
3679         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3680             or $a cmp $b
3681     } @changesfiles;
3682     fail "wrong number of different changes files (@changesfiles)"
3683         unless @changesfiles==2;
3684     my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
3685     foreach my $l (split /\n/, getfield $binchanges, 'Files') {
3686         fail "$l found in binaries changes file $binchanges"
3687             if $l =~ m/\.dsc$/;
3688     }
3689     runcmd_ordryrun_local @mergechanges, @changesfiles;
3690     my $multichanges = changespat $version,'multi';
3691     if (act_local()) {
3692         stat_exists $multichanges or fail "$multichanges: $!";
3693         foreach my $cf (glob $pat) {
3694             next if $cf eq $multichanges;
3695             rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
3696         }
3697     }
3698     maybe_unapply_patches_again();
3699     printdone "build successful, results in $multichanges\n" or die $!;
3700 }
3701
3702 sub cmd_quilt_fixup {
3703     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3704     my $clogp = parsechangelog();
3705     $version = getfield $clogp, 'Version';
3706     $package = getfield $clogp, 'Source';
3707     check_not_dirty();
3708     clean_tree();
3709     build_maybe_quilt_fixup();
3710 }
3711
3712 sub cmd_archive_api_query {
3713     badusage "need only 1 subpath argument" unless @ARGV==1;
3714     my ($subpath) = @ARGV;
3715     my @cmd = archive_api_query_cmd($subpath);
3716     debugcmd ">",@cmd;
3717     exec @cmd or fail "exec curl: $!\n";
3718 }
3719
3720 sub cmd_clone_dgit_repos_server {
3721     badusage "need destination argument" unless @ARGV==1;
3722     my ($destdir) = @ARGV;
3723     $package = '_dgit-repos-server';
3724     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3725     debugcmd ">",@cmd;
3726     exec @cmd or fail "exec git clone: $!\n";
3727 }
3728
3729 sub cmd_setup_mergechangelogs {
3730     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3731     setup_mergechangelogs(1);
3732 }
3733
3734 sub cmd_setup_useremail {
3735     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3736     setup_useremail(1);
3737 }
3738
3739 sub cmd_setup_new_tree {
3740     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3741     setup_new_tree();
3742 }
3743
3744 #---------- argument parsing and main program ----------
3745
3746 sub cmd_version {
3747     print "dgit version $our_version\n" or die $!;
3748     exit 0;
3749 }
3750
3751 our (%valopts_long, %valopts_short);
3752 our @rvalopts;
3753
3754 sub defvalopt ($$$$) {
3755     my ($long,$short,$val_re,$how) = @_;
3756     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3757     $valopts_long{$long} = $oi;
3758     $valopts_short{$short} = $oi;
3759     # $how subref should:
3760     #   do whatever assignemnt or thing it likes with $_[0]
3761     #   if the option should not be passed on to remote, @rvalopts=()
3762     # or $how can be a scalar ref, meaning simply assign the value
3763 }
3764
3765 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3766 defvalopt '--distro',        '-d', '.+',      \$idistro;
3767 defvalopt '',                '-k', '.+',      \$keyid;
3768 defvalopt '--existing-package','', '.*',      \$existing_package;
3769 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
3770 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
3771 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
3772
3773 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3774
3775 defvalopt '', '-C', '.+', sub {
3776     ($changesfile) = (@_);
3777     if ($changesfile =~ s#^(.*)/##) {
3778         $buildproductsdir = $1;
3779     }
3780 };
3781
3782 defvalopt '--initiator-tempdir','','.*', sub {
3783     ($initiator_tempdir) = (@_);
3784     $initiator_tempdir =~ m#^/# or
3785         badusage "--initiator-tempdir must be used specify an".
3786         " absolute, not relative, directory."
3787 };
3788
3789 sub parseopts () {
3790     my $om;
3791
3792     if (defined $ENV{'DGIT_SSH'}) {
3793         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3794     } elsif (defined $ENV{'GIT_SSH'}) {
3795         @ssh = ($ENV{'GIT_SSH'});
3796     }
3797
3798     my $oi;
3799     my $val;
3800     my $valopt = sub {
3801         my ($what) = @_;
3802         @rvalopts = ($_);
3803         if (!defined $val) {
3804             badusage "$what needs a value" unless @ARGV;
3805             $val = shift @ARGV;
3806             push @rvalopts, $val;
3807         }
3808         badusage "bad value \`$val' for $what" unless
3809             $val =~ m/^$oi->{Re}$(?!\n)/s;
3810         my $how = $oi->{How};
3811         if (ref($how) eq 'SCALAR') {
3812             $$how = $val;
3813         } else {
3814             $how->($val);
3815         }
3816         push @ropts, @rvalopts;
3817     };
3818
3819     while (@ARGV) {
3820         last unless $ARGV[0] =~ m/^-/;
3821         $_ = shift @ARGV;
3822         last if m/^--?$/;
3823         if (m/^--/) {
3824             if (m/^--dry-run$/) {
3825                 push @ropts, $_;
3826                 $dryrun_level=2;
3827             } elsif (m/^--damp-run$/) {
3828                 push @ropts, $_;
3829                 $dryrun_level=1;
3830             } elsif (m/^--no-sign$/) {
3831                 push @ropts, $_;
3832                 $sign=0;
3833             } elsif (m/^--help$/) {
3834                 cmd_help();
3835             } elsif (m/^--version$/) {
3836                 cmd_version();
3837             } elsif (m/^--new$/) {
3838                 push @ropts, $_;
3839                 $new_package=1;
3840             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3841                      ($om = $opts_opt_map{$1}) &&
3842                      length $om->[0]) {
3843                 push @ropts, $_;
3844                 $om->[0] = $2;
3845             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3846                      !$opts_opt_cmdonly{$1} &&
3847                      ($om = $opts_opt_map{$1})) {
3848                 push @ropts, $_;
3849                 push @$om, $2;
3850             } elsif (m/^--ignore-dirty$/s) {
3851                 push @ropts, $_;
3852                 $ignoredirty = 1;
3853             } elsif (m/^--no-quilt-fixup$/s) {
3854                 push @ropts, $_;
3855                 $quilt_mode = 'nocheck';
3856             } elsif (m/^--no-rm-on-error$/s) {
3857                 push @ropts, $_;
3858                 $rmonerror = 0;
3859             } elsif (m/^--(no-)?rm-old-changes$/s) {
3860                 push @ropts, $_;
3861                 $rmchanges = !$1;
3862             } elsif (m/^--deliberately-($deliberately_re)$/s) {
3863                 push @ropts, $_;
3864                 push @deliberatelies, $&;
3865             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
3866                 # undocumented, for testing
3867                 push @ropts, $_;
3868                 $tagformat_want = [ $1, 'command line', 1 ];
3869                 # 1 menas overrides distro configuration
3870             } elsif (m/^--always-split-source-build$/s) {
3871                 # undocumented, for testing
3872                 push @ropts, $_;
3873                 $need_split_build_invocation = 1;
3874             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3875                 $val = $2 ? $' : undef; #';
3876                 $valopt->($oi->{Long});
3877             } else {
3878                 badusage "unknown long option \`$_'";
3879             }
3880         } else {
3881             while (m/^-./s) {
3882                 if (s/^-n/-/) {
3883                     push @ropts, $&;
3884                     $dryrun_level=2;
3885                 } elsif (s/^-L/-/) {
3886                     push @ropts, $&;
3887                     $dryrun_level=1;
3888                 } elsif (s/^-h/-/) {
3889                     cmd_help();
3890                 } elsif (s/^-D/-/) {
3891                     push @ropts, $&;
3892                     $debuglevel++;
3893                     enabledebug();
3894                 } elsif (s/^-N/-/) {
3895                     push @ropts, $&;
3896                     $new_package=1;
3897                 } elsif (m/^-m/) {
3898                     push @ropts, $&;
3899                     push @changesopts, $_;
3900                     $_ = '';
3901                 } elsif (s/^-wn$//s) {
3902                     push @ropts, $&;
3903                     $cleanmode = 'none';
3904                 } elsif (s/^-wg$//s) {
3905                     push @ropts, $&;
3906                     $cleanmode = 'git';
3907                 } elsif (s/^-wgf$//s) {
3908                     push @ropts, $&;
3909                     $cleanmode = 'git-ff';
3910                 } elsif (s/^-wd$//s) {
3911                     push @ropts, $&;
3912                     $cleanmode = 'dpkg-source';
3913                 } elsif (s/^-wdd$//s) {
3914                     push @ropts, $&;
3915                     $cleanmode = 'dpkg-source-d';
3916                 } elsif (s/^-wc$//s) {
3917                     push @ropts, $&;
3918                     $cleanmode = 'check';
3919                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
3920                     $val = $'; #';
3921                     $val = undef unless length $val;
3922                     $valopt->($oi->{Short});
3923                     $_ = '';
3924                 } else {
3925                     badusage "unknown short option \`$_'";
3926                 }
3927             }
3928         }
3929     }
3930 }
3931
3932 sub finalise_opts_opts () {
3933     foreach my $k (keys %opts_opt_map) {
3934         my $om = $opts_opt_map{$k};
3935
3936         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3937         if (defined $v) {
3938             badcfg "cannot set command for $k"
3939                 unless length $om->[0];
3940             $om->[0] = $v;
3941         }
3942
3943         foreach my $c (access_cfg_cfgs("opts-$k")) {
3944             my $vl = $gitcfg{$c};
3945             printdebug "CL $c ",
3946                 ($vl ? join " ", map { shellquote } @$vl : ""),
3947                 "\n" if $debuglevel >= 4;
3948             next unless $vl;
3949             badcfg "cannot configure options for $k"
3950                 if $opts_opt_cmdonly{$k};
3951             my $insertpos = $opts_cfg_insertpos{$k};
3952             @$om = ( @$om[0..$insertpos-1],
3953                      @$vl,
3954                      @$om[$insertpos..$#$om] );
3955         }
3956     }
3957 }
3958
3959 if ($ENV{$fakeeditorenv}) {
3960     git_slurp_config();
3961     quilt_fixup_editor();
3962 }
3963
3964 parseopts();
3965 git_slurp_config();
3966
3967 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3968 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3969     if $dryrun_level == 1;
3970 if (!@ARGV) {
3971     print STDERR $helpmsg or die $!;
3972     exit 8;
3973 }
3974 my $cmd = shift @ARGV;
3975 $cmd =~ y/-/_/;
3976
3977 if (!defined $rmchanges) {
3978     local $access_forpush;
3979     $rmchanges = access_cfg_bool(0, 'rm-old-changes');
3980 }
3981
3982 if (!defined $quilt_mode) {
3983     local $access_forpush;
3984     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3985         // access_cfg('quilt-mode', 'RETURN-UNDEF')
3986         // 'linear';
3987     $quilt_mode =~ m/^($quilt_modes_re)$/
3988         or badcfg "unknown quilt-mode \`$quilt_mode'";
3989     $quilt_mode = $1;
3990 }
3991
3992 $need_split_build_invocation ||= quiltmode_splitbrain();
3993
3994 if (!defined $cleanmode) {
3995     local $access_forpush;
3996     $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
3997     $cleanmode //= 'dpkg-source';
3998
3999     badcfg "unknown clean-mode \`$cleanmode'" unless
4000         $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4001 }
4002
4003 my $fn = ${*::}{"cmd_$cmd"};
4004 $fn or badusage "unknown operation $cmd";
4005 $fn->();