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