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