dgit

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