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