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|dpm|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     runcmd qw(git config gc.auto 0);
1344     rmtree('.git/objects');
1345     symlink '../../../../objects','.git/objects' or die $!;
1346 }
1347
1348 sub git_write_tree () {
1349     my $tree = cmdoutput @git, qw(write-tree);
1350     $tree =~ m/^\w+$/ or die "$tree ?";
1351     return $tree;
1352 }
1353
1354 sub remove_stray_gits () {
1355     my @gitscmd = qw(find -name .git -prune -print0);
1356     debugcmd "|",@gitscmd;
1357     open GITS, "-|", @gitscmd or die $!;
1358     {
1359         local $/="\0";
1360         while (<GITS>) {
1361             chomp or die;
1362             print STDERR "$us: warning: removing from source package: ",
1363                 (messagequote $_), "\n";
1364             rmtree $_;
1365         }
1366     }
1367     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1368 }
1369
1370 sub mktree_in_ud_from_only_subdir () {
1371     # changes into the subdir
1372     my (@dirs) = <*/.>;
1373     die "@dirs ?" unless @dirs==1;
1374     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1375     my $dir = $1;
1376     changedir $dir;
1377
1378     remove_stray_gits();
1379     mktree_in_ud_here();
1380     my ($format, $fopts) = get_source_format();
1381     if (madformat($format)) {
1382         rmtree '.pc';
1383     }
1384     runcmd @git, qw(add -Af);
1385     my $tree=git_write_tree();
1386     return ($tree,$dir);
1387 }
1388
1389 sub dsc_files_info () {
1390     foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1391                        ['Checksums-Sha1',  'Digest::SHA', 'new(1)'],
1392                        ['Files',           'Digest::MD5', 'new()']) {
1393         my ($fname, $module, $method) = @$csumi;
1394         my $field = $dsc->{$fname};
1395         next unless defined $field;
1396         eval "use $module; 1;" or die $@;
1397         my @out;
1398         foreach (split /\n/, $field) {
1399             next unless m/\S/;
1400             m/^(\w+) (\d+) (\S+)$/ or
1401                 fail "could not parse .dsc $fname line \`$_'";
1402             my $digester = eval "$module"."->$method;" or die $@;
1403             push @out, {
1404                 Hash => $1,
1405                 Bytes => $2,
1406                 Filename => $3,
1407                 Digester => $digester,
1408             };
1409         }
1410         return @out;
1411     }
1412     fail "missing any supported Checksums-* or Files field in ".
1413         $dsc->get_option('name');
1414 }
1415
1416 sub dsc_files () {
1417     map { $_->{Filename} } dsc_files_info();
1418 }
1419
1420 sub is_orig_file ($;$) {
1421     local ($_) = $_[0];
1422     my $base = $_[1];
1423     m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1424     defined $base or return 1;
1425     return $` eq $base;
1426 }
1427
1428 sub make_commit ($) {
1429     my ($file) = @_;
1430     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1431 }
1432
1433 sub clogp_authline ($) {
1434     my ($clogp) = @_;
1435     my $author = getfield $clogp, 'Maintainer';
1436     $author =~ s#,.*##ms;
1437     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1438     my $authline = "$author $date";
1439     $authline =~ m/$git_authline_re/o or
1440         fail "unexpected commit author line format \`$authline'".
1441         " (was generated from changelog Maintainer field)";
1442     return ($1,$2,$3) if wantarray;
1443     return $authline;
1444 }
1445
1446 sub vendor_patches_distro ($$) {
1447     my ($checkdistro, $what) = @_;
1448     return unless defined $checkdistro;
1449
1450     my $series = "debian/patches/\L$checkdistro\E.series";
1451     printdebug "checking for vendor-specific $series ($what)\n";
1452
1453     if (!open SERIES, "<", $series) {
1454         die "$series $!" unless $!==ENOENT;
1455         return;
1456     }
1457     while (<SERIES>) {
1458         next unless m/\S/;
1459         next if m/^\s+\#/;
1460
1461         print STDERR <<END;
1462
1463 Unfortunately, this source package uses a feature of dpkg-source where
1464 the same source package unpacks to different source code on different
1465 distros.  dgit cannot safely operate on such packages on affected
1466 distros, because the meaning of source packages is not stable.
1467
1468 Please ask the distro/maintainer to remove the distro-specific series
1469 files and use a different technique (if necessary, uploading actually
1470 different packages, if different distros are supposed to have
1471 different code).
1472
1473 END
1474         fail "Found active distro-specific series file for".
1475             " $checkdistro ($what): $series, cannot continue";
1476     }
1477     die "$series $!" if SERIES->error;
1478     close SERIES;
1479 }
1480
1481 sub check_for_vendor_patches () {
1482     # This dpkg-source feature doesn't seem to be documented anywhere!
1483     # But it can be found in the changelog (reformatted):
1484
1485     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
1486     #   Author: Raphael Hertzog <hertzog@debian.org>
1487     #   Date: Sun  Oct  3  09:36:48  2010 +0200
1488
1489     #   dpkg-source: correctly create .pc/.quilt_series with alternate
1490     #   series files
1491     #
1492     #   If you have debian/patches/ubuntu.series and you were
1493     #   unpacking the source package on ubuntu, quilt was still
1494     #   directed to debian/patches/series instead of
1495     #   debian/patches/ubuntu.series.
1496     #
1497     #   debian/changelog                        |    3 +++
1498     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
1499     #   2 files changed, 6 insertions(+), 1 deletion(-)
1500
1501     use Dpkg::Vendor;
1502     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1503     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1504                          "Dpkg::Vendor \`current vendor'");
1505     vendor_patches_distro(access_basedistro(),
1506                           "distro being accessed");
1507 }
1508
1509 sub generate_commits_from_dsc () {
1510     # See big comment in fetch_from_archive, below.
1511     prep_ud();
1512     changedir $ud;
1513
1514     foreach my $fi (dsc_files_info()) {
1515         my $f = $fi->{Filename};
1516         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1517
1518         link_ltarget "../../../$f", $f
1519             or $!==&ENOENT
1520             or die "$f $!";
1521
1522         complete_file_from_dsc('.', $fi)
1523             or next;
1524
1525         if (is_orig_file($f)) {
1526             link $f, "../../../../$f"
1527                 or $!==&EEXIST
1528                 or die "$f $!";
1529         }
1530     }
1531
1532     my $dscfn = "$package.dsc";
1533
1534     open D, ">", $dscfn or die "$dscfn: $!";
1535     print D $dscdata or die "$dscfn: $!";
1536     close D or die "$dscfn: $!";
1537     my @cmd = qw(dpkg-source);
1538     push @cmd, '--no-check' if $dsc_checked;
1539     push @cmd, qw(-x --), $dscfn;
1540     runcmd @cmd;
1541
1542     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1543     check_for_vendor_patches() if madformat($dsc->{format});
1544     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1545     my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1546     my $authline = clogp_authline $clogp;
1547     my $changes = getfield $clogp, 'Changes';
1548     open C, ">../commit.tmp" or die $!;
1549     print C <<END or die $!;
1550 tree $tree
1551 author $authline
1552 committer $authline
1553
1554 $changes
1555
1556 # imported from the archive
1557 END
1558     close C or die $!;
1559     my $rawimport_hash = make_commit qw(../commit.tmp);
1560     my $cversion = getfield $clogp, 'Version';
1561     my $rawimport_mergeinput = {
1562         Commit => $rawimport_hash,
1563         Info => "Import of source package",
1564     };
1565     my @output = ($rawimport_mergeinput);
1566     progress "synthesised git commit from .dsc $cversion";
1567     if ($lastpush_mergeinput) {
1568         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1569         my $oversion = getfield $oldclogp, 'Version';
1570         my $vcmp =
1571             version_compare($oversion, $cversion);
1572         if ($vcmp < 0) {
1573             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1574                 { Message => <<END, ReverseParents => 1 });
1575 Record $package ($cversion) in archive suite $csuite
1576 END
1577         } elsif ($vcmp > 0) {
1578             print STDERR <<END or die $!;
1579
1580 Version actually in archive:   $cversion (older)
1581 Last version pushed with dgit: $oversion (newer or same)
1582 $later_warning_msg
1583 END
1584             @output = $lastpush_mergeinput;
1585         } else {
1586             # Same version.  Use what's in the server git branch,
1587             # discarding our own import.  (This could happen if the
1588             # server automatically imports all packages into git.)
1589             @output = $lastpush_mergeinput;
1590         }
1591     }
1592     changedir '../../../..';
1593     rmtree($ud);
1594     return @output;
1595 }
1596
1597 sub complete_file_from_dsc ($$) {
1598     our ($dstdir, $fi) = @_;
1599     # Ensures that we have, in $dir, the file $fi, with the correct
1600     # contents.  (Downloading it from alongside $dscurl if necessary.)
1601
1602     my $f = $fi->{Filename};
1603     my $tf = "$dstdir/$f";
1604     my $downloaded = 0;
1605
1606     if (stat_exists $tf) {
1607         progress "using existing $f";
1608     } else {
1609         my $furl = $dscurl;
1610         $furl =~ s{/[^/]+$}{};
1611         $furl .= "/$f";
1612         die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1613         die "$f ?" if $f =~ m#/#;
1614         runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1615         return 0 if !act_local();
1616         $downloaded = 1;
1617     }
1618
1619     open F, "<", "$tf" or die "$tf: $!";
1620     $fi->{Digester}->reset();
1621     $fi->{Digester}->addfile(*F);
1622     F->error and die $!;
1623     my $got = $fi->{Digester}->hexdigest();
1624     $got eq $fi->{Hash} or
1625         fail "file $f has hash $got but .dsc".
1626             " demands hash $fi->{Hash} ".
1627             ($downloaded ? "(got wrong file from archive!)"
1628              : "(perhaps you should delete this file?)");
1629
1630     return 1;
1631 }
1632
1633 sub ensure_we_have_orig () {
1634     foreach my $fi (dsc_files_info()) {
1635         my $f = $fi->{Filename};
1636         next unless is_orig_file($f);
1637         complete_file_from_dsc('..', $fi)
1638             or next;
1639     }
1640 }
1641
1642 sub git_fetch_us () {
1643     # Want to fetch only what we are going to use, unless
1644     # deliberately-not-ff, in which case we must fetch everything.
1645
1646     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1647         map { "tags/$_" }
1648         (quiltmode_splitbrain
1649          ? (map { $_->('*',access_basedistro) }
1650             \&debiantag_new, \&debiantag_maintview)
1651          : debiantags('*',access_basedistro));
1652     push @specs, server_branch($csuite);
1653     push @specs, qw(heads/*) if deliberately_not_fast_forward;
1654
1655     # This is rather miserable:
1656     # When git-fetch --prune is passed a fetchspec ending with a *,
1657     # it does a plausible thing.  If there is no * then:
1658     # - it matches subpaths too, even if the supplied refspec
1659     #   starts refs, and behaves completely madly if the source
1660     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
1661     # - if there is no matching remote ref, it bombs out the whole
1662     #   fetch.
1663     # We want to fetch a fixed ref, and we don't know in advance
1664     # if it exists, so this is not suitable.
1665     #
1666     # Our workaround is to use git-ls-remote.  git-ls-remote has its
1667     # own qairks.  Notably, it has the absurd multi-tail-matching
1668     # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1669     # refs/refs/foo etc.
1670     #
1671     # Also, we want an idempotent snapshot, but we have to make two
1672     # calls to the remote: one to git-ls-remote and to git-fetch.  The
1673     # solution is use git-ls-remote to obtain a target state, and
1674     # git-fetch to try to generate it.  If we don't manage to generate
1675     # the target state, we try again.
1676
1677     my $specre = join '|', map {
1678         my $x = $_;
1679         $x =~ s/\W/\\$&/g;
1680         $x =~ s/\\\*$/.*/;
1681         "(?:refs/$x)";
1682     } @specs;
1683     printdebug "git_fetch_us specre=$specre\n";
1684     my $wanted_rref = sub {
1685         local ($_) = @_;
1686         return m/^(?:$specre)$/o;
1687     };
1688
1689     my $fetch_iteration = 0;
1690     FETCH_ITERATION:
1691     for (;;) {
1692         if (++$fetch_iteration > 10) {
1693             fail "too many iterations trying to get sane fetch!";
1694         }
1695
1696         my @look = map { "refs/$_" } @specs;
1697         my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1698         debugcmd "|",@lcmd;
1699
1700         my %wantr;
1701         open GITLS, "-|", @lcmd or die $!;
1702         while (<GITLS>) {
1703             printdebug "=> ", $_;
1704             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1705             my ($objid,$rrefname) = ($1,$2);
1706             if (!$wanted_rref->($rrefname)) {
1707                 print STDERR <<END;
1708 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1709 END
1710                 next;
1711             }
1712             $wantr{$rrefname} = $objid;
1713         }
1714         $!=0; $?=0;
1715         close GITLS or failedcmd @lcmd;
1716
1717         # OK, now %want is exactly what we want for refs in @specs
1718         my @fspecs = map {
1719             return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1720             "+refs/$_:".lrfetchrefs."/$_";
1721         } @specs;
1722
1723         my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1724         runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1725             @fspecs;
1726
1727         %lrfetchrefs_f = ();
1728         my %objgot;
1729
1730         git_for_each_ref(lrfetchrefs, sub {
1731             my ($objid,$objtype,$lrefname,$reftail) = @_;
1732             $lrfetchrefs_f{$lrefname} = $objid;
1733             $objgot{$objid} = 1;
1734         });
1735
1736         foreach my $lrefname (sort keys %lrfetchrefs_f) {
1737             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
1738             if (!exists $wantr{$rrefname}) {
1739                 if ($wanted_rref->($rrefname)) {
1740                     printdebug <<END;
1741 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
1742 END
1743                 } else {
1744                     print STDERR <<END
1745 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
1746 END
1747                 }
1748                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
1749                 delete $lrfetchrefs_f{$lrefname};
1750                 next;
1751             }
1752         }
1753         foreach my $rrefname (sort keys %wantr) {
1754             my $lrefname = lrfetchrefs.substr($rrefname, 4);
1755             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
1756             my $want = $wantr{$rrefname};
1757             next if $got eq $want;
1758             if (!defined $objgot{$want}) {
1759                 print STDERR <<END;
1760 warning: git-ls-remote suggests we want $lrefname
1761 warning:  and it should refer to $want
1762 warning:  but git-fetch didn't fetch that object to any relevant ref.
1763 warning:  This may be due to a race with someone updating the server.
1764 warning:  Will try again...
1765 END
1766                 next FETCH_ITERATION;
1767             }
1768             printdebug <<END;
1769 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
1770 END
1771             runcmd_ordryrun_local @git, qw(update-ref -m),
1772                 "dgit fetch git-fetch fixup", $lrefname, $want;
1773             $lrfetchrefs_f{$lrefname} = $want;
1774         }
1775         last;
1776     }
1777     printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
1778         Dumper(\%lrfetchrefs_f);
1779
1780     my %here;
1781     my @tagpats = debiantags('*',access_basedistro);
1782
1783     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1784         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1785         printdebug "currently $fullrefname=$objid\n";
1786         $here{$fullrefname} = $objid;
1787     });
1788     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1789         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1790         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
1791         printdebug "offered $lref=$objid\n";
1792         if (!defined $here{$lref}) {
1793             my @upd = (@git, qw(update-ref), $lref, $objid, '');
1794             runcmd_ordryrun_local @upd;
1795             lrfetchref_used $fullrefname;
1796         } elsif ($here{$lref} eq $objid) {
1797             lrfetchref_used $fullrefname;
1798         } else {
1799             print STDERR \
1800                 "Not updateting $lref from $here{$lref} to $objid.\n";
1801         }
1802     });
1803 }
1804
1805 sub mergeinfo_getclogp ($) {
1806     # Ensures thit $mi->{Clogp} exists and returns it
1807     my ($mi) = @_;
1808     $mi->{Clogp} = commit_getclogp($mi->{Commit});
1809 }
1810
1811 sub mergeinfo_version ($) {
1812     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1813 }
1814
1815 sub fetch_from_archive () {
1816     # Ensures that lrref() is what is actually in the archive, one way
1817     # or another, according to us - ie this client's
1818     # appropritaely-updated archive view.  Also returns the commit id.
1819     # If there is nothing in the archive, leaves lrref alone and
1820     # returns undef.  git_fetch_us must have already been called.
1821     get_archive_dsc();
1822
1823     if ($dsc) {
1824         foreach my $field (@ourdscfield) {
1825             $dsc_hash = $dsc->{$field};
1826             last if defined $dsc_hash;
1827         }
1828         if (defined $dsc_hash) {
1829             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1830             $dsc_hash = $&;
1831             progress "last upload to archive specified git hash";
1832         } else {
1833             progress "last upload to archive has NO git hash";
1834         }
1835     } else {
1836         progress "no version available from the archive";
1837     }
1838
1839     # If the archive's .dsc has a Dgit field, there are three
1840     # relevant git commitids we need to choose between and/or merge
1841     # together:
1842     #   1. $dsc_hash: the Dgit field from the archive
1843     #   2. $lastpush_hash: the suite branch on the dgit git server
1844     #   3. $lastfetch_hash: our local tracking brach for the suite
1845     #
1846     # These may all be distinct and need not be in any fast forward
1847     # relationship:
1848     #
1849     # If the dsc was pushed to this suite, then the server suite
1850     # branch will have been updated; but it might have been pushed to
1851     # a different suite and copied by the archive.  Conversely a more
1852     # recent version may have been pushed with dgit but not appeared
1853     # in the archive (yet).
1854     #
1855     # $lastfetch_hash may be awkward because archive imports
1856     # (particularly, imports of Dgit-less .dscs) are performed only as
1857     # needed on individual clients, so different clients may perform a
1858     # different subset of them - and these imports are only made
1859     # public during push.  So $lastfetch_hash may represent a set of
1860     # imports different to a subsequent upload by a different dgit
1861     # client.
1862     #
1863     # Our approach is as follows:
1864     #
1865     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1866     # descendant of $dsc_hash, then it was pushed by a dgit user who
1867     # had based their work on $dsc_hash, so we should prefer it.
1868     # Otherwise, $dsc_hash was installed into this suite in the
1869     # archive other than by a dgit push, and (necessarily) after the
1870     # last dgit push into that suite (since a dgit push would have
1871     # been descended from the dgit server git branch); thus, in that
1872     # case, we prefer the archive's version (and produce a
1873     # pseudo-merge to overwrite the dgit server git branch).
1874     #
1875     # (If there is no Dgit field in the archive's .dsc then
1876     # generate_commit_from_dsc uses the version numbers to decide
1877     # whether the suite branch or the archive is newer.  If the suite
1878     # branch is newer it ignores the archive's .dsc; otherwise it
1879     # generates an import of the .dsc, and produces a pseudo-merge to
1880     # overwrite the suite branch with the archive contents.)
1881     #
1882     # The outcome of that part of the algorithm is the `public view',
1883     # and is same for all dgit clients: it does not depend on any
1884     # unpublished history in the local tracking branch.
1885     #
1886     # As between the public view and the local tracking branch: The
1887     # local tracking branch is only updated by dgit fetch, and
1888     # whenever dgit fetch runs it includes the public view in the
1889     # local tracking branch.  Therefore if the public view is not
1890     # descended from the local tracking branch, the local tracking
1891     # branch must contain history which was imported from the archive
1892     # but never pushed; and, its tip is now out of date.  So, we make
1893     # a pseudo-merge to overwrite the old imports and stitch the old
1894     # history in.
1895     #
1896     # Finally: we do not necessarily reify the public view (as
1897     # described above).  This is so that we do not end up stacking two
1898     # pseudo-merges.  So what we actually do is figure out the inputs
1899     # to any public view pseudo-merge and put them in @mergeinputs.
1900
1901     my @mergeinputs;
1902     # $mergeinputs[]{Commit}
1903     # $mergeinputs[]{Info}
1904     # $mergeinputs[0] is the one whose tree we use
1905     # @mergeinputs is in the order we use in the actual commit)
1906     #
1907     # Also:
1908     # $mergeinputs[]{Message} is a commit message to use
1909     # $mergeinputs[]{ReverseParents} if def specifies that parent
1910     #                                list should be in opposite order
1911     # Such an entry has no Commit or Info.  It applies only when found
1912     # in the last entry.  (This ugliness is to support making
1913     # identical imports to previous dgit versions.)
1914
1915     my $lastpush_hash = git_get_ref(lrfetchref());
1916     printdebug "previous reference hash=$lastpush_hash\n";
1917     $lastpush_mergeinput = $lastpush_hash && {
1918         Commit => $lastpush_hash,
1919         Info => "dgit suite branch on dgit git server",
1920     };
1921
1922     my $lastfetch_hash = git_get_ref(lrref());
1923     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1924     my $lastfetch_mergeinput = $lastfetch_hash && {
1925         Commit => $lastfetch_hash,
1926         Info => "dgit client's archive history view",
1927     };
1928
1929     my $dsc_mergeinput = $dsc_hash && {
1930         Commit => $dsc_hash,
1931         Info => "Dgit field in .dsc from archive",
1932     };
1933
1934     my $cwd = getcwd();
1935     my $del_lrfetchrefs = sub {
1936         changedir $cwd;
1937         my $gur;
1938         printdebug "del_lrfetchrefs...\n";
1939         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
1940             my $objid = $lrfetchrefs_d{$fullrefname};
1941             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
1942             if (!$gur) {
1943                 $gur ||= new IO::Handle;
1944                 open $gur, "|-", qw(git update-ref --stdin) or die $!;
1945             }
1946             printf $gur "delete %s %s\n", $fullrefname, $objid;
1947         }
1948         if ($gur) {
1949             close $gur or failedcmd "git update-ref delete lrfetchrefs";
1950         }
1951     };
1952
1953     if (defined $dsc_hash) {
1954         fail "missing remote git history even though dsc has hash -".
1955             " could not find ref ".rref()." at ".access_giturl()
1956             unless $lastpush_hash;
1957         ensure_we_have_orig();
1958         if ($dsc_hash eq $lastpush_hash) {
1959             @mergeinputs = $dsc_mergeinput
1960         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1961             print STDERR <<END or die $!;
1962
1963 Git commit in archive is behind the last version allegedly pushed/uploaded.
1964 Commit referred to by archive: $dsc_hash
1965 Last version pushed with dgit: $lastpush_hash
1966 $later_warning_msg
1967 END
1968             @mergeinputs = ($lastpush_mergeinput);
1969         } else {
1970             # Archive has .dsc which is not a descendant of the last dgit
1971             # push.  This can happen if the archive moves .dscs about.
1972             # Just follow its lead.
1973             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
1974                 progress "archive .dsc names newer git commit";
1975                 @mergeinputs = ($dsc_mergeinput);
1976             } else {
1977                 progress "archive .dsc names other git commit, fixing up";
1978                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
1979             }
1980         }
1981     } elsif ($dsc) {
1982         @mergeinputs = generate_commits_from_dsc();
1983         # We have just done an import.  Now, our import algorithm might
1984         # have been improved.  But even so we do not want to generate
1985         # a new different import of the same package.  So if the
1986         # version numbers are the same, just use our existing version.
1987         # If the version numbers are different, the archive has changed
1988         # (perhaps, rewound).
1989         if ($lastfetch_mergeinput &&
1990             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
1991                               (mergeinfo_version $mergeinputs[0]) )) {
1992             @mergeinputs = ($lastfetch_mergeinput);
1993         }
1994     } elsif ($lastpush_hash) {
1995         # only in git, not in the archive yet
1996         @mergeinputs = ($lastpush_mergeinput);
1997         print STDERR <<END or die $!;
1998
1999 Package not found in the archive, but has allegedly been pushed using dgit.
2000 $later_warning_msg
2001 END
2002     } else {
2003         printdebug "nothing found!\n";
2004         if (defined $skew_warning_vsn) {
2005             print STDERR <<END or die $!;
2006
2007 Warning: relevant archive skew detected.
2008 Archive allegedly contains $skew_warning_vsn
2009 But we were not able to obtain any version from the archive or git.
2010
2011 END
2012         }
2013         unshift @end, $del_lrfetchrefs;
2014         return undef;
2015     }
2016
2017     if ($lastfetch_hash &&
2018         !grep {
2019             my $h = $_->{Commit};
2020             $h and is_fast_fwd($lastfetch_hash, $h);
2021             # If true, one of the existing parents of this commit
2022             # is a descendant of the $lastfetch_hash, so we'll
2023             # be ff from that automatically.
2024         } @mergeinputs
2025         ) {
2026         # Otherwise:
2027         push @mergeinputs, $lastfetch_mergeinput;
2028     }
2029
2030     printdebug "fetch mergeinfos:\n";
2031     foreach my $mi (@mergeinputs) {
2032         if ($mi->{Info}) {
2033             printdebug " commit $mi->{Commit} $mi->{Info}\n";
2034         } else {
2035             printdebug sprintf " ReverseParents=%d Message=%s",
2036                 $mi->{ReverseParents}, $mi->{Message};
2037         }
2038     }
2039
2040     my $compat_info= pop @mergeinputs
2041         if $mergeinputs[$#mergeinputs]{Message};
2042
2043     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2044
2045     my $hash;
2046     if (@mergeinputs > 1) {
2047         # here we go, then:
2048         my $tree_commit = $mergeinputs[0]{Commit};
2049
2050         my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2051         $tree =~ m/\n\n/;  $tree = $`;
2052         $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2053         $tree = $1;
2054
2055         # We use the changelog author of the package in question the
2056         # author of this pseudo-merge.  This is (roughly) correct if
2057         # this commit is simply representing aa non-dgit upload.
2058         # (Roughly because it does not record sponsorship - but we
2059         # don't have sponsorship info because that's in the .changes,
2060         # which isn't in the archivw.)
2061         #
2062         # But, it might be that we are representing archive history
2063         # updates (including in-archive copies).  These are not really
2064         # the responsibility of the person who created the .dsc, but
2065         # there is no-one whose name we should better use.  (The
2066         # author of the .dsc-named commit is clearly worse.)
2067
2068         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2069         my $author = clogp_authline $useclogp;
2070         my $cversion = getfield $useclogp, 'Version';
2071
2072         my $mcf = ".git/dgit/mergecommit";
2073         open MC, ">", $mcf or die "$mcf $!";
2074         print MC <<END or die $!;
2075 tree $tree
2076 END
2077
2078         my @parents = grep { $_->{Commit} } @mergeinputs;
2079         @parents = reverse @parents if $compat_info->{ReverseParents};
2080         print MC <<END or die $! foreach @parents;
2081 parent $_->{Commit}
2082 END
2083
2084         print MC <<END or die $!;
2085 author $author
2086 committer $author
2087
2088 END
2089
2090         if (defined $compat_info->{Message}) {
2091             print MC $compat_info->{Message} or die $!;
2092         } else {
2093             print MC <<END or die $!;
2094 Record $package ($cversion) in archive suite $csuite
2095
2096 Record that
2097 END
2098             my $message_add_info = sub {
2099                 my ($mi) = (@_);
2100                 my $mversion = mergeinfo_version $mi;
2101                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
2102                     or die $!;
2103             };
2104
2105             $message_add_info->($mergeinputs[0]);
2106             print MC <<END or die $!;
2107 should be treated as descended from
2108 END
2109             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2110         }
2111
2112         close MC or die $!;
2113         $hash = make_commit $mcf;
2114     } else {
2115         $hash = $mergeinputs[0]{Commit};
2116     }
2117     progress "fetch hash=$hash\n";
2118
2119     my $chkff = sub {
2120         my ($lasth, $what) = @_;
2121         return unless $lasth;
2122         die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2123     };
2124
2125     $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2126     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2127
2128     runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2129             'DGIT_ARCHIVE', $hash;
2130     cmdoutput @git, qw(log -n2), $hash;
2131     # ... gives git a chance to complain if our commit is malformed
2132
2133     if (defined $skew_warning_vsn) {
2134         mkpath '.git/dgit';
2135         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2136         my $gotclogp = commit_getclogp($hash);
2137         my $got_vsn = getfield $gotclogp, 'Version';
2138         printdebug "SKEW CHECK GOT $got_vsn\n";
2139         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2140             print STDERR <<END or die $!;
2141
2142 Warning: archive skew detected.  Using the available version:
2143 Archive allegedly contains    $skew_warning_vsn
2144 We were able to obtain only   $got_vsn
2145
2146 END
2147         }
2148     }
2149
2150     if ($lastfetch_hash ne $hash) {
2151         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2152         if (act_local()) {
2153             cmdoutput @upd_cmd;
2154         } else {
2155             dryrun_report @upd_cmd;
2156         }
2157     }
2158
2159     lrfetchref_used lrfetchref();
2160
2161     unshift @end, $del_lrfetchrefs;
2162     return $hash;
2163 }
2164
2165 sub set_local_git_config ($$) {
2166     my ($k, $v) = @_;
2167     runcmd @git, qw(config), $k, $v;
2168 }
2169
2170 sub setup_mergechangelogs (;$) {
2171     my ($always) = @_;
2172     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2173
2174     my $driver = 'dpkg-mergechangelogs';
2175     my $cb = "merge.$driver";
2176     my $attrs = '.git/info/attributes';
2177     ensuredir '.git/info';
2178
2179     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2180     if (!open ATTRS, "<", $attrs) {
2181         $!==ENOENT or die "$attrs: $!";
2182     } else {
2183         while (<ATTRS>) {
2184             chomp;
2185             next if m{^debian/changelog\s};
2186             print NATTRS $_, "\n" or die $!;
2187         }
2188         ATTRS->error and die $!;
2189         close ATTRS;
2190     }
2191     print NATTRS "debian/changelog merge=$driver\n" or die $!;
2192     close NATTRS;
2193
2194     set_local_git_config "$cb.name", 'debian/changelog merge driver';
2195     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2196
2197     rename "$attrs.new", "$attrs" or die "$attrs: $!";
2198 }
2199
2200 sub setup_useremail (;$) {
2201     my ($always) = @_;
2202     return unless $always || access_cfg_bool(1, 'setup-useremail');
2203
2204     my $setup = sub {
2205         my ($k, $envvar) = @_;
2206         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2207         return unless defined $v;
2208         set_local_git_config "user.$k", $v;
2209     };
2210
2211     $setup->('email', 'DEBEMAIL');
2212     $setup->('name', 'DEBFULLNAME');
2213 }
2214
2215 sub setup_new_tree () {
2216     setup_mergechangelogs();
2217     setup_useremail();
2218 }
2219
2220 sub clone ($) {
2221     my ($dstdir) = @_;
2222     canonicalise_suite();
2223     badusage "dry run makes no sense with clone" unless act_local();
2224     my $hasgit = check_for_git();
2225     mkdir $dstdir or fail "create \`$dstdir': $!";
2226     changedir $dstdir;
2227     runcmd @git, qw(init -q);
2228     my $giturl = access_giturl(1);
2229     if (defined $giturl) {
2230         open H, "> .git/HEAD" or die $!;
2231         print H "ref: ".lref()."\n" or die $!;
2232         close H or die $!;
2233         runcmd @git, qw(remote add), 'origin', $giturl;
2234     }
2235     if ($hasgit) {
2236         progress "fetching existing git history";
2237         git_fetch_us();
2238         runcmd_ordryrun_local @git, qw(fetch origin);
2239     } else {
2240         progress "starting new git history";
2241     }
2242     fetch_from_archive() or no_such_package;
2243     my $vcsgiturl = $dsc->{'Vcs-Git'};
2244     if (length $vcsgiturl) {
2245         $vcsgiturl =~ s/\s+-b\s+\S+//g;
2246         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2247     }
2248     setup_new_tree();
2249     runcmd @git, qw(reset --hard), lrref();
2250     printdone "ready for work in $dstdir";
2251 }
2252
2253 sub fetch () {
2254     if (check_for_git()) {
2255         git_fetch_us();
2256     }
2257     fetch_from_archive() or no_such_package();
2258     printdone "fetched into ".lrref();
2259 }
2260
2261 sub pull () {
2262     fetch();
2263     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2264         lrref();
2265     printdone "fetched to ".lrref()." and merged into HEAD";
2266 }
2267
2268 sub check_not_dirty () {
2269     foreach my $f (qw(local-options local-patch-header)) {
2270         if (stat_exists "debian/source/$f") {
2271             fail "git tree contains debian/source/$f";
2272         }
2273     }
2274
2275     return if $ignoredirty;
2276
2277     my @cmd = (@git, qw(diff --quiet HEAD));
2278     debugcmd "+",@cmd;
2279     $!=0; $?=-1; system @cmd;
2280     return if !$?;
2281     if ($?==256) {
2282         fail "working tree is dirty (does not match HEAD)";
2283     } else {
2284         failedcmd @cmd;
2285     }
2286 }
2287
2288 sub commit_admin ($) {
2289     my ($m) = @_;
2290     progress "$m";
2291     runcmd_ordryrun_local @git, qw(commit -m), $m;
2292 }
2293
2294 sub commit_quilty_patch () {
2295     my $output = cmdoutput @git, qw(status --porcelain);
2296     my %adds;
2297     foreach my $l (split /\n/, $output) {
2298         next unless $l =~ m/\S/;
2299         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2300             $adds{$1}++;
2301         }
2302     }
2303     delete $adds{'.pc'}; # if there wasn't one before, don't add it
2304     if (!%adds) {
2305         progress "nothing quilty to commit, ok.";
2306         return;
2307     }
2308     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2309     runcmd_ordryrun_local @git, qw(add -f), @adds;
2310     commit_admin "Commit Debian 3.0 (quilt) metadata";
2311 }
2312
2313 sub get_source_format () {
2314     my %options;
2315     if (open F, "debian/source/options") {
2316         while (<F>) {
2317             next if m/^\s*\#/;
2318             next unless m/\S/;
2319             s/\s+$//; # ignore missing final newline
2320             if (m/\s*\#\s*/) {
2321                 my ($k, $v) = ($`, $'); #');
2322                 $v =~ s/^"(.*)"$/$1/;
2323                 $options{$k} = $v;
2324             } else {
2325                 $options{$_} = 1;
2326             }
2327         }
2328         F->error and die $!;
2329         close F;
2330     } else {
2331         die $! unless $!==&ENOENT;
2332     }
2333
2334     if (!open F, "debian/source/format") {
2335         die $! unless $!==&ENOENT;
2336         return '';
2337     }
2338     $_ = <F>;
2339     F->error and die $!;
2340     chomp;
2341     return ($_, \%options);
2342 }
2343
2344 sub madformat ($) {
2345     my ($format) = @_;
2346     return 0 unless $format eq '3.0 (quilt)';
2347     our $quilt_mode_warned;
2348     if ($quilt_mode eq 'nocheck') {
2349         progress "Not doing any fixup of \`$format' due to".
2350             " ----no-quilt-fixup or --quilt=nocheck"
2351             unless $quilt_mode_warned++;
2352         return 0;
2353     }
2354     progress "Format \`$format', need to check/update patch stack"
2355         unless $quilt_mode_warned++;
2356     return 1;
2357 }
2358
2359 # An "infopair" is a tuple [ $thing, $what ]
2360 # (often $thing is a commit hash; $what is a description)
2361
2362 sub infopair_cond_equal ($$) {
2363     my ($x,$y) = @_;
2364     $x->[0] eq $y->[0] or fail <<END;
2365 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2366 END
2367 };
2368
2369 sub infopair_lrf_tag_lookup ($$) {
2370     my ($tagnames, $what) = @_;
2371     # $tagname may be an array ref
2372     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2373     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2374     foreach my $tagname (@tagnames) {
2375         my $lrefname = lrfetchrefs."/tags/$tagname";
2376         my $tagobj = $lrfetchrefs_f{$lrefname};
2377         next unless defined $tagobj;
2378         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2379         return [ git_rev_parse($tagobj), $what ];
2380     }
2381     fail @tagnames==1 ? <<END : <<END;
2382 Wanted tag $what (@tagnames) on dgit server, but not found
2383 END
2384 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2385 END
2386 }
2387
2388 sub infopair_cond_ff ($$) {
2389     my ($anc,$desc) = @_;
2390     is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2391 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2392 END
2393 };
2394
2395 sub splitbrain_pseudomerge ($$$$) {
2396     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2397     # => $merged_dgitview
2398     printdebug "splitbrain_pseudomerge...\n";
2399     #
2400     #     We:      debian/PREVIOUS    HEAD($maintview)
2401     # expect:          o ----------------- o
2402     #                    \                   \
2403     #                     o                   o
2404     #                 a/d/PREVIOUS        $dgitview
2405     #                $archive_hash              \
2406     #  If so,                \                   \
2407     #  we do:                 `------------------ o
2408     #   this:                                   $dgitview'
2409     #
2410
2411     my $arch_clogp = commit_getclogp $archive_hash;
2412     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2413                      'version currently in archive' ];
2414
2415     printdebug "splitbrain_pseudomerge i_arch_v @$i_arch_v\n";
2416
2417     return $dgitview unless defined $archive_hash;
2418
2419     if (defined $overwrite_version) {
2420         progress "Declaring that HEAD inciudes all changes in archive...";
2421         progress "Checking that $overwrite_version does so...";
2422         infopair_cond_equal([ $overwrite_version, '--overwrite= version' ],
2423                             $i_arch_v);
2424     } else {
2425         progress "Checking that HEAD inciudes all changes in archive...";
2426     }
2427
2428     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2429
2430     my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2431     my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2432     my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2433     my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2434     my $i_archive = [ $archive_hash, "current archive contents" ];
2435
2436     printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2437
2438     infopair_cond_equal($i_dgit, $i_archive);
2439     infopair_cond_ff($i_dep14, $i_dgit);
2440     $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2441
2442     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2443     my $authline = clogp_authline $clogp;
2444
2445     mkpath '.git/dgit';
2446     my $pmf = ".git/dgit/pseudomerge";
2447     open MC, ">", $pmf or die "$pmf $!";
2448     print MC <<END or die $!;
2449 tree $tree
2450 parent $dgitview
2451 parent $archive_hash
2452 author $authline
2453 commiter $authline
2454
2455 END
2456     if (defined $overwrite_version) {
2457         print MC <<END;
2458 Declare fast forward from $overwrite_version
2459
2460 [dgit --quilt=$quilt_mode --overwrite-version=$overwrite_version]
2461 END
2462     } else {
2463         print MC <<END;
2464 Make fast forward from $i_arch_v->[0]
2465
2466 [dgit --quilt=$quilt_mode]
2467 END
2468     }
2469     close MC or die $!;
2470
2471     progress "Making pseudo-merge of $i_arch_v->[0] into dgit view.";
2472     return make_commit($pmf);
2473 }
2474
2475 sub push_parse_changelog ($) {
2476     my ($clogpfn) = @_;
2477
2478     my $clogp = Dpkg::Control::Hash->new();
2479     $clogp->load($clogpfn) or die;
2480
2481     $package = getfield $clogp, 'Source';
2482     my $cversion = getfield $clogp, 'Version';
2483     my $tag = debiantag($cversion, access_basedistro);
2484     runcmd @git, qw(check-ref-format), $tag;
2485
2486     my $dscfn = dscfn($cversion);
2487
2488     return ($clogp, $cversion, $dscfn);
2489 }
2490
2491 sub push_parse_dsc ($$$) {
2492     my ($dscfn,$dscfnwhat, $cversion) = @_;
2493     $dsc = parsecontrol($dscfn,$dscfnwhat);
2494     my $dversion = getfield $dsc, 'Version';
2495     my $dscpackage = getfield $dsc, 'Source';
2496     ($dscpackage eq $package && $dversion eq $cversion) or
2497         fail "$dscfn is for $dscpackage $dversion".
2498             " but debian/changelog is for $package $cversion";
2499 }
2500
2501 sub push_tagwants ($$$$) {
2502     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2503     my @tagwants;
2504     push @tagwants, {
2505         TagFn => \&debiantag,
2506         Objid => $dgithead,
2507         TfSuffix => '',
2508         View => 'dgit',
2509     };
2510     if (defined $maintviewhead) {
2511         push @tagwants, {
2512             TagFn => \&debiantag_maintview,
2513             Objid => $maintviewhead,
2514             TfSuffix => '-maintview',
2515             View => 'maint',
2516         };
2517     }
2518     foreach my $tw (@tagwants) {
2519         $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2520         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2521     }
2522     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2523     return @tagwants;
2524 }
2525
2526 sub push_mktags ($$ $$ $) {
2527     my ($clogp,$dscfn,
2528         $changesfile,$changesfilewhat,
2529         $tagwants) = @_;
2530
2531     die unless $tagwants->[0]{View} eq 'dgit';
2532
2533     $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2534     $dsc->save("$dscfn.tmp") or die $!;
2535
2536     my $changes = parsecontrol($changesfile,$changesfilewhat);
2537     foreach my $field (qw(Source Distribution Version)) {
2538         $changes->{$field} eq $clogp->{$field} or
2539             fail "changes field $field \`$changes->{$field}'".
2540                 " does not match changelog \`$clogp->{$field}'";
2541     }
2542
2543     my $cversion = getfield $clogp, 'Version';
2544     my $clogsuite = getfield $clogp, 'Distribution';
2545
2546     # We make the git tag by hand because (a) that makes it easier
2547     # to control the "tagger" (b) we can do remote signing
2548     my $authline = clogp_authline $clogp;
2549     my $delibs = join(" ", "",@deliberatelies);
2550     my $declaredistro = access_basedistro();
2551
2552     my $mktag = sub {
2553         my ($tw) = @_;
2554         my $tfn = $tw->{Tfn};
2555         my $head = $tw->{Objid};
2556         my $tag = $tw->{Tag};
2557
2558         open TO, '>', $tfn->('.tmp') or die $!;
2559         print TO <<END or die $!;
2560 object $head
2561 type commit
2562 tag $tag
2563 tagger $authline
2564
2565 END
2566         if ($tw->{View} eq 'dgit') {
2567             print TO <<END or die $!;
2568 $package release $cversion for $clogsuite ($csuite) [dgit]
2569 [dgit distro=$declaredistro$delibs]
2570 END
2571             foreach my $ref (sort keys %previously) {
2572                 print TO <<END or die $!;
2573 [dgit previously:$ref=$previously{$ref}]
2574 END
2575             }
2576         } elsif ($tw->{View} eq 'maint') {
2577             print TO <<END or die $!;
2578 $package release $cversion for $clogsuite ($csuite)
2579 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2580 END
2581         } else {
2582             die Dumper($tw)."?";
2583         }
2584
2585         close TO or die $!;
2586
2587         my $tagobjfn = $tfn->('.tmp');
2588         if ($sign) {
2589             if (!defined $keyid) {
2590                 $keyid = access_cfg('keyid','RETURN-UNDEF');
2591             }
2592             if (!defined $keyid) {
2593                 $keyid = getfield $clogp, 'Maintainer';
2594             }
2595             unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2596             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2597             push @sign_cmd, qw(-u),$keyid if defined $keyid;
2598             push @sign_cmd, $tfn->('.tmp');
2599             runcmd_ordryrun @sign_cmd;
2600             if (act_scary()) {
2601                 $tagobjfn = $tfn->('.signed.tmp');
2602                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2603                     $tfn->('.tmp'), $tfn->('.tmp.asc');
2604             }
2605         }
2606         return $tagobjfn;
2607     };
2608
2609     my @r = map { $mktag->($_); } @$tagwants;
2610     return @r;
2611 }
2612
2613 sub sign_changes ($) {
2614     my ($changesfile) = @_;
2615     if ($sign) {
2616         my @debsign_cmd = @debsign;
2617         push @debsign_cmd, "-k$keyid" if defined $keyid;
2618         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2619         push @debsign_cmd, $changesfile;
2620         runcmd_ordryrun @debsign_cmd;
2621     }
2622 }
2623
2624 sub dopush () {
2625     printdebug "actually entering push\n";
2626
2627     supplementary_message(<<'END');
2628 Push failed, while checking state of the archive.
2629 You can retry the push, after fixing the problem, if you like.
2630 END
2631     if (check_for_git()) {
2632         git_fetch_us();
2633     }
2634     my $archive_hash = fetch_from_archive();
2635     if (!$archive_hash) {
2636         $new_package or
2637             fail "package appears to be new in this suite;".
2638                 " if this is intentional, use --new";
2639     }
2640
2641     supplementary_message(<<'END');
2642 Push failed, while preparing your push.
2643 You can retry the push, after fixing the problem, if you like.
2644 END
2645
2646     need_tagformat 'new', "quilt mode $quilt_mode"
2647         if quiltmode_splitbrain;
2648
2649     prep_ud();
2650
2651     access_giturl(); # check that success is vaguely likely
2652     select_tagformat();
2653
2654     my $clogpfn = ".git/dgit/changelog.822.tmp";
2655     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2656
2657     responder_send_file('parsed-changelog', $clogpfn);
2658
2659     my ($clogp, $cversion, $dscfn) =
2660         push_parse_changelog("$clogpfn");
2661
2662     my $dscpath = "$buildproductsdir/$dscfn";
2663     stat_exists $dscpath or
2664         fail "looked for .dsc $dscfn, but $!;".
2665             " maybe you forgot to build";
2666
2667     responder_send_file('dsc', $dscpath);
2668
2669     push_parse_dsc($dscpath, $dscfn, $cversion);
2670
2671     my $format = getfield $dsc, 'Format';
2672     printdebug "format $format\n";
2673
2674     my $actualhead = git_rev_parse('HEAD');
2675     my $dgithead = $actualhead;
2676     my $maintviewhead = undef;
2677
2678     if (madformat($format)) {
2679         # user might have not used dgit build, so maybe do this now:
2680         if (quiltmode_splitbrain()) {
2681             my $upstreamversion = $clogp->{Version};
2682             $upstreamversion =~ s/-[^-]*$//;
2683             changedir $ud;
2684             quilt_make_fake_dsc($upstreamversion);
2685             my ($dgitview, $cachekey) =
2686                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2687             $dgitview or fail
2688  "--quilt=$quilt_mode but no cached dgit view:
2689  perhaps tree changed since dgit build[-source] ?";
2690             $split_brain = 1;
2691             $dgithead = splitbrain_pseudomerge($clogp,
2692                                                $actualhead, $dgitview,
2693                                                $archive_hash);
2694             $maintviewhead = $actualhead;
2695             changedir '../../../..';
2696             prep_ud(); # so _only_subdir() works, below
2697         } else {
2698             commit_quilty_patch();
2699         }
2700     }
2701
2702     check_not_dirty();
2703
2704     my $forceflag = '';
2705     if ($archive_hash) {
2706         if (is_fast_fwd($archive_hash, $dgithead)) {
2707             # ok
2708         } elsif (deliberately_not_fast_forward) {
2709             $forceflag = '+';
2710         } else {
2711             fail "dgit push: HEAD is not a descendant".
2712                 " of the archive's version.\n".
2713                 "dgit: To overwrite its contents,".
2714                 " use git merge -s ours ".lrref().".\n".
2715                 "dgit: To rewind history, if permitted by the archive,".
2716                 " use --deliberately-not-fast-forward";
2717         }
2718     }
2719
2720     changedir $ud;
2721     progress "checking that $dscfn corresponds to HEAD";
2722     runcmd qw(dpkg-source -x --),
2723         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2724     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2725     check_for_vendor_patches() if madformat($dsc->{format});
2726     changedir '../../../..';
2727     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2728     my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2729     debugcmd "+",@diffcmd;
2730     $!=0; $?=-1;
2731     my $r = system @diffcmd;
2732     if ($r) {
2733         if ($r==256) {
2734             fail "$dscfn specifies a different tree to your HEAD commit;".
2735                 " perhaps you forgot to build".
2736                 ($diffopt eq '--exit-code' ? "" :
2737                  " (run with -D to see full diff output)");
2738         } else {
2739             failedcmd @diffcmd;
2740         }
2741     }
2742     if (!$changesfile) {
2743         my $pat = changespat $cversion;
2744         my @cs = glob "$buildproductsdir/$pat";
2745         fail "failed to find unique changes file".
2746             " (looked for $pat in $buildproductsdir);".
2747             " perhaps you need to use dgit -C"
2748             unless @cs==1;
2749         ($changesfile) = @cs;
2750     } else {
2751         $changesfile = "$buildproductsdir/$changesfile";
2752     }
2753
2754     # Checks complete, we're going to try and go ahead:
2755
2756     responder_send_file('changes',$changesfile);
2757     responder_send_command("param head $dgithead");
2758     responder_send_command("param csuite $csuite");
2759     responder_send_command("param tagformat $tagformat");
2760     if (defined $maintviewhead) {
2761         die unless ($protovsn//4) >= 4;
2762         responder_send_command("param maint-view $maintviewhead");
2763     }
2764
2765     if (deliberately_not_fast_forward) {
2766         git_for_each_ref(lrfetchrefs, sub {
2767             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2768             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2769             responder_send_command("previously $rrefname=$objid");
2770             $previously{$rrefname} = $objid;
2771         });
2772     }
2773
2774     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2775                                  ".git/dgit/tag");
2776     my @tagobjfns;
2777
2778     supplementary_message(<<'END');
2779 Push failed, while signing the tag.
2780 You can retry the push, after fixing the problem, if you like.
2781 END
2782     # If we manage to sign but fail to record it anywhere, it's fine.
2783     if ($we_are_responder) {
2784         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2785         responder_receive_files('signed-tag', @tagobjfns);
2786     } else {
2787         @tagobjfns = push_mktags($clogp,$dscpath,
2788                               $changesfile,$changesfile,
2789                               \@tagwants);
2790     }
2791     supplementary_message(<<'END');
2792 Push failed, *after* signing the tag.
2793 If you want to try again, you should use a new version number.
2794 END
2795
2796     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2797
2798     foreach my $tw (@tagwants) {
2799         my $tag = $tw->{Tag};
2800         my $tagobjfn = $tw->{TagObjFn};
2801         my $tag_obj_hash =
2802             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2803         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2804         runcmd_ordryrun_local
2805             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2806     }
2807
2808     supplementary_message(<<'END');
2809 Push failed, while updating the remote git repository - see messages above.
2810 If you want to try again, you should use a new version number.
2811 END
2812     if (!check_for_git()) {
2813         create_remote_git_repo();
2814     }
2815
2816     my @pushrefs = $forceflag.$dgithead.":".rrref();
2817     foreach my $tw (@tagwants) {
2818         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2819     }
2820
2821     runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2822     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2823
2824     supplementary_message(<<'END');
2825 Push failed, after updating the remote git repository.
2826 If you want to try again, you must use a new version number.
2827 END
2828     if ($we_are_responder) {
2829         my $dryrunsuffix = act_local() ? "" : ".tmp";
2830         responder_receive_files('signed-dsc-changes',
2831                                 "$dscpath$dryrunsuffix",
2832                                 "$changesfile$dryrunsuffix");
2833     } else {
2834         if (act_local()) {
2835             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2836         } else {
2837             progress "[new .dsc left in $dscpath.tmp]";
2838         }
2839         sign_changes $changesfile;
2840     }
2841
2842     supplementary_message(<<END);
2843 Push failed, while uploading package(s) to the archive server.
2844 You can retry the upload of exactly these same files with dput of:
2845   $changesfile
2846 If that .changes file is broken, you will need to use a new version
2847 number for your next attempt at the upload.
2848 END
2849     my $host = access_cfg('upload-host','RETURN-UNDEF');
2850     my @hostarg = defined($host) ? ($host,) : ();
2851     runcmd_ordryrun @dput, @hostarg, $changesfile;
2852     printdone "pushed and uploaded $cversion";
2853
2854     supplementary_message('');
2855     responder_send_command("complete");
2856 }
2857
2858 sub cmd_clone {
2859     parseopts();
2860     notpushing();
2861     my $dstdir;
2862     badusage "-p is not allowed with clone; specify as argument instead"
2863         if defined $package;
2864     if (@ARGV==1) {
2865         ($package) = @ARGV;
2866     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2867         ($package,$isuite) = @ARGV;
2868     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2869         ($package,$dstdir) = @ARGV;
2870     } elsif (@ARGV==3) {
2871         ($package,$isuite,$dstdir) = @ARGV;
2872     } else {
2873         badusage "incorrect arguments to dgit clone";
2874     }
2875     $dstdir ||= "$package";
2876
2877     if (stat_exists $dstdir) {
2878         fail "$dstdir already exists";
2879     }
2880
2881     my $cwd_remove;
2882     if ($rmonerror && !$dryrun_level) {
2883         $cwd_remove= getcwd();
2884         unshift @end, sub {
2885             return unless defined $cwd_remove;
2886             if (!chdir "$cwd_remove") {
2887                 return if $!==&ENOENT;
2888                 die "chdir $cwd_remove: $!";
2889             }
2890             if (stat $dstdir) {
2891                 rmtree($dstdir) or die "remove $dstdir: $!\n";
2892             } elsif (!grep { $! == $_ }
2893                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2894             } else {
2895                 print STDERR "check whether to remove $dstdir: $!\n";
2896             }
2897         };
2898     }
2899
2900     clone($dstdir);
2901     $cwd_remove = undef;
2902 }
2903
2904 sub branchsuite () {
2905     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2906     if ($branch =~ m#$lbranch_re#o) {
2907         return $1;
2908     } else {
2909         return undef;
2910     }
2911 }
2912
2913 sub fetchpullargs () {
2914     notpushing();
2915     if (!defined $package) {
2916         my $sourcep = parsecontrol('debian/control','debian/control');
2917         $package = getfield $sourcep, 'Source';
2918     }
2919     if (@ARGV==0) {
2920 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
2921         if (!$isuite) {
2922             my $clogp = parsechangelog();
2923             $isuite = getfield $clogp, 'Distribution';
2924         }
2925         canonicalise_suite();
2926         progress "fetching from suite $csuite";
2927     } elsif (@ARGV==1) {
2928         ($isuite) = @ARGV;
2929         canonicalise_suite();
2930     } else {
2931         badusage "incorrect arguments to dgit fetch or dgit pull";
2932     }
2933 }
2934
2935 sub cmd_fetch {
2936     parseopts();
2937     fetchpullargs();
2938     fetch();
2939 }
2940
2941 sub cmd_pull {
2942     parseopts();
2943     fetchpullargs();
2944     pull();
2945 }
2946
2947 sub cmd_push {
2948     parseopts();
2949     pushing();
2950     badusage "-p is not allowed with dgit push" if defined $package;
2951     check_not_dirty();
2952     my $clogp = parsechangelog();
2953     $package = getfield $clogp, 'Source';
2954     my $specsuite;
2955     if (@ARGV==0) {
2956     } elsif (@ARGV==1) {
2957         ($specsuite) = (@ARGV);
2958     } else {
2959         badusage "incorrect arguments to dgit push";
2960     }
2961     $isuite = getfield $clogp, 'Distribution';
2962     if ($new_package) {
2963         local ($package) = $existing_package; # this is a hack
2964         canonicalise_suite();
2965     } else {
2966         canonicalise_suite();
2967     }
2968     if (defined $specsuite &&
2969         $specsuite ne $isuite &&
2970         $specsuite ne $csuite) {
2971             fail "dgit push: changelog specifies $isuite ($csuite)".
2972                 " but command line specifies $specsuite";
2973     }
2974     dopush();
2975 }
2976
2977 #---------- remote commands' implementation ----------
2978
2979 sub cmd_remote_push_build_host {
2980     my ($nrargs) = shift @ARGV;
2981     my (@rargs) = @ARGV[0..$nrargs-1];
2982     @ARGV = @ARGV[$nrargs..$#ARGV];
2983     die unless @rargs;
2984     my ($dir,$vsnwant) = @rargs;
2985     # vsnwant is a comma-separated list; we report which we have
2986     # chosen in our ready response (so other end can tell if they
2987     # offered several)
2988     $debugprefix = ' ';
2989     $we_are_responder = 1;
2990     $us .= " (build host)";
2991
2992     pushing();
2993
2994     open PI, "<&STDIN" or die $!;
2995     open STDIN, "/dev/null" or die $!;
2996     open PO, ">&STDOUT" or die $!;
2997     autoflush PO 1;
2998     open STDOUT, ">&STDERR" or die $!;
2999     autoflush STDOUT 1;
3000
3001     $vsnwant //= 1;
3002     ($protovsn) = grep {
3003         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3004     } @rpushprotovsn_support;
3005
3006     fail "build host has dgit rpush protocol versions ".
3007         (join ",", @rpushprotovsn_support).
3008         " but invocation host has $vsnwant"
3009         unless defined $protovsn;
3010
3011     responder_send_command("dgit-remote-push-ready $protovsn");
3012     rpush_handle_protovsn_bothends();
3013     changedir $dir;
3014     &cmd_push;
3015 }
3016
3017 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3018 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3019 #     a good error message)
3020
3021 sub rpush_handle_protovsn_bothends () {
3022     if ($protovsn < 4) {
3023         need_tagformat 'old', "rpush negotiated protocol $protovsn";
3024     }
3025     select_tagformat();
3026 }
3027
3028 our $i_tmp;
3029
3030 sub i_cleanup {
3031     local ($@, $?);
3032     my $report = i_child_report();
3033     if (defined $report) {
3034         printdebug "($report)\n";
3035     } elsif ($i_child_pid) {
3036         printdebug "(killing build host child $i_child_pid)\n";
3037         kill 15, $i_child_pid;
3038     }
3039     if (defined $i_tmp && !defined $initiator_tempdir) {
3040         changedir "/";
3041         eval { rmtree $i_tmp; };
3042     }
3043 }
3044
3045 END { i_cleanup(); }
3046
3047 sub i_method {
3048     my ($base,$selector,@args) = @_;
3049     $selector =~ s/\-/_/g;
3050     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3051 }
3052
3053 sub cmd_rpush {
3054     pushing();
3055     my $host = nextarg;
3056     my $dir;
3057     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3058         $host = $1;
3059         $dir = $'; #';
3060     } else {
3061         $dir = nextarg;
3062     }
3063     $dir =~ s{^-}{./-};
3064     my @rargs = ($dir);
3065     push @rargs, join ",", @rpushprotovsn_support;
3066     my @rdgit;
3067     push @rdgit, @dgit;
3068     push @rdgit, @ropts;
3069     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3070     push @rdgit, @ARGV;
3071     my @cmd = (@ssh, $host, shellquote @rdgit);
3072     debugcmd "+",@cmd;
3073
3074     if (defined $initiator_tempdir) {
3075         rmtree $initiator_tempdir;
3076         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3077         $i_tmp = $initiator_tempdir;
3078     } else {
3079         $i_tmp = tempdir();
3080     }
3081     $i_child_pid = open2(\*RO, \*RI, @cmd);
3082     changedir $i_tmp;
3083     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3084     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3085     $supplementary_message = '' unless $protovsn >= 3;
3086
3087     fail "rpush negotiated protocol version $protovsn".
3088         " which does not support quilt mode $quilt_mode"
3089         if quiltmode_splitbrain;
3090
3091     rpush_handle_protovsn_bothends();
3092     for (;;) {
3093         my ($icmd,$iargs) = initiator_expect {
3094             m/^(\S+)(?: (.*))?$/;
3095             ($1,$2);
3096         };
3097         i_method "i_resp", $icmd, $iargs;
3098     }
3099 }
3100
3101 sub i_resp_progress ($) {
3102     my ($rhs) = @_;
3103     my $msg = protocol_read_bytes \*RO, $rhs;
3104     progress $msg;
3105 }
3106
3107 sub i_resp_supplementary_message ($) {
3108     my ($rhs) = @_;
3109     $supplementary_message = protocol_read_bytes \*RO, $rhs;
3110 }
3111
3112 sub i_resp_complete {
3113     my $pid = $i_child_pid;
3114     $i_child_pid = undef; # prevents killing some other process with same pid
3115     printdebug "waiting for build host child $pid...\n";
3116     my $got = waitpid $pid, 0;
3117     die $! unless $got == $pid;
3118     die "build host child failed $?" if $?;
3119
3120     i_cleanup();
3121     printdebug "all done\n";
3122     exit 0;
3123 }
3124
3125 sub i_resp_file ($) {
3126     my ($keyword) = @_;
3127     my $localname = i_method "i_localname", $keyword;
3128     my $localpath = "$i_tmp/$localname";
3129     stat_exists $localpath and
3130         badproto \*RO, "file $keyword ($localpath) twice";
3131     protocol_receive_file \*RO, $localpath;
3132     i_method "i_file", $keyword;
3133 }
3134
3135 our %i_param;
3136
3137 sub i_resp_param ($) {
3138     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3139     $i_param{$1} = $2;
3140 }
3141
3142 sub i_resp_previously ($) {
3143     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3144         or badproto \*RO, "bad previously spec";
3145     my $r = system qw(git check-ref-format), $1;
3146     die "bad previously ref spec ($r)" if $r;
3147     $previously{$1} = $2;
3148 }
3149
3150 our %i_wanted;
3151
3152 sub i_resp_want ($) {
3153     my ($keyword) = @_;
3154     die "$keyword ?" if $i_wanted{$keyword}++;
3155     my @localpaths = i_method "i_want", $keyword;
3156     printdebug "[[  $keyword @localpaths\n";
3157     foreach my $localpath (@localpaths) {
3158         protocol_send_file \*RI, $localpath;
3159     }
3160     print RI "files-end\n" or die $!;
3161 }
3162
3163 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3164
3165 sub i_localname_parsed_changelog {
3166     return "remote-changelog.822";
3167 }
3168 sub i_file_parsed_changelog {
3169     ($i_clogp, $i_version, $i_dscfn) =
3170         push_parse_changelog "$i_tmp/remote-changelog.822";
3171     die if $i_dscfn =~ m#/|^\W#;
3172 }
3173
3174 sub i_localname_dsc {
3175     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3176     return $i_dscfn;
3177 }
3178 sub i_file_dsc { }
3179
3180 sub i_localname_changes {
3181     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3182     $i_changesfn = $i_dscfn;
3183     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3184     return $i_changesfn;
3185 }
3186 sub i_file_changes { }
3187
3188 sub i_want_signed_tag {
3189     printdebug Dumper(\%i_param, $i_dscfn);
3190     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3191         && defined $i_param{'csuite'}
3192         or badproto \*RO, "premature desire for signed-tag";
3193     my $head = $i_param{'head'};
3194     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3195
3196     my $maintview = $i_param{'maint-view'};
3197     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3198
3199     select_tagformat();
3200     if ($protovsn >= 4) {
3201         my $p = $i_param{'tagformat'} // '<undef>';
3202         $p eq $tagformat
3203             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3204     }
3205
3206     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3207     $csuite = $&;
3208     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3209
3210     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3211
3212     return
3213         push_mktags $i_clogp, $i_dscfn,
3214             $i_changesfn, 'remote changes',
3215             \@tagwants;
3216 }
3217
3218 sub i_want_signed_dsc_changes {
3219     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3220     sign_changes $i_changesfn;
3221     return ($i_dscfn, $i_changesfn);
3222 }
3223
3224 #---------- building etc. ----------
3225
3226 our $version;
3227 our $sourcechanges;
3228 our $dscfn;
3229
3230 #----- `3.0 (quilt)' handling -----
3231
3232 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3233
3234 sub quiltify_dpkg_commit ($$$;$) {
3235     my ($patchname,$author,$msg, $xinfo) = @_;
3236     $xinfo //= '';
3237
3238     mkpath '.git/dgit';
3239     my $descfn = ".git/dgit/quilt-description.tmp";
3240     open O, '>', $descfn or die "$descfn: $!";
3241     $msg =~ s/\s+$//g;
3242     $msg =~ s/\n/\n /g;
3243     $msg =~ s/^\s+$/ ./mg;
3244     print O <<END or die $!;
3245 Description: $msg
3246 Author: $author
3247 $xinfo
3248 ---
3249
3250 END
3251     close O or die $!;
3252
3253     {
3254         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3255         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3256         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3257         runcmd @dpkgsource, qw(--commit .), $patchname;
3258     }
3259 }
3260
3261 sub quiltify_trees_differ ($$;$$) {
3262     my ($x,$y,$finegrained,$ignorenamesr) = @_;
3263     # returns true iff the two tree objects differ other than in debian/
3264     # with $finegrained,
3265     # returns bitmask 01 - differ in upstream files except .gitignore
3266     #                 02 - differ in .gitignore
3267     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3268     #  is set for each modified .gitignore filename $fn
3269     local $/=undef;
3270     my @cmd = (@git, qw(diff-tree --name-only -z));
3271     push @cmd, qw(-r) if $finegrained;
3272     push @cmd, $x, $y;
3273     my $diffs= cmdoutput @cmd;
3274     my $r = 0;
3275     foreach my $f (split /\0/, $diffs) {
3276         next if $f =~ m#^debian(?:/.*)?$#s;
3277         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3278         $r |= $isignore ? 02 : 01;
3279         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3280     }
3281     printdebug "quiltify_trees_differ $x $y => $r\n";
3282     return $r;
3283 }
3284
3285 sub quiltify_tree_sentinelfiles ($) {
3286     # lists the `sentinel' files present in the tree
3287     my ($x) = @_;
3288     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3289         qw(-- debian/rules debian/control);
3290     $r =~ s/\n/,/g;
3291     return $r;
3292 }
3293
3294 sub quiltify_splitbrain_needed () {
3295     if (!$split_brain) {
3296         progress "dgit view: changes are required...";
3297         runcmd @git, qw(checkout -q -b dgit-view);
3298         $split_brain = 1;
3299     }
3300 }
3301
3302 sub quiltify_splitbrain ($$$$$$) {
3303     my ($clogp, $unapplied, $headref, $diffbits,
3304         $editedignores, $cachekey) = @_;
3305     if ($quilt_mode !~ m/gbp|dpm/) {
3306         # treat .gitignore just like any other upstream file
3307         $diffbits = { %$diffbits };
3308         $_ = !!$_ foreach values %$diffbits;
3309     }
3310     # We would like any commits we generate to be reproducible
3311     my @authline = clogp_authline($clogp);
3312     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
3313     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3314     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
3315
3316     if ($quilt_mode =~ m/gbp|unapplied/ &&
3317         ($diffbits->{H2O} & 01)) {
3318         my $msg =
3319  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3320  " but git tree differs from orig in upstream files.";
3321         if (!stat_exists "debian/patches") {
3322             $msg .=
3323  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3324         }
3325         fail $msg;
3326     }
3327     if ($quilt_mode =~ m/dpm/ &&
3328         ($diffbits->{H2A} & 01)) {
3329         fail <<END;
3330 --quilt=$quilt_mode specified, implying patches-applied git tree
3331  but git tree differs from result of applying debian/patches to upstream
3332 END
3333     }
3334     if ($quilt_mode =~ m/gbp|unapplied/ &&
3335         ($diffbits->{O2A} & 01)) { # some patches
3336         quiltify_splitbrain_needed();
3337         progress "dgit view: creating patches-applied version using gbp pq";
3338         runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3339         # gbp pq import creates a fresh branch; push back to dgit-view
3340         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3341         runcmd @git, qw(checkout -q dgit-view);
3342     }
3343     if ($quilt_mode =~ m/gbp|dpm/ &&
3344         ($diffbits->{O2A} & 02)) {
3345         fail <<END
3346 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3347  tool which does not create patches for changes to upstream
3348  .gitignores: but, such patches exist in debian/patches.
3349 END
3350     }
3351     if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3352         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3353         quiltify_splitbrain_needed();
3354         progress "dgit view: creating patch to represent .gitignore changes";
3355         ensuredir "debian/patches";
3356         my $gipatch = "debian/patches/auto-gitignore";
3357         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3358         stat GIPATCH or die "$gipatch: $!";
3359         fail "$gipatch already exists; but want to create it".
3360             " to record .gitignore changes" if (stat _)[7];
3361         print GIPATCH <<END or die "$gipatch: $!";
3362 Subject: Update .gitignore from Debian packaging branch
3363
3364 The Debian packaging git branch contains these updates to the upstream
3365 .gitignore file(s).  This patch is autogenerated, to provide these
3366 updates to users of the official Debian archive view of the package.
3367
3368 [dgit version $our_version]
3369 ---
3370 END
3371         close GIPATCH or die "$gipatch: $!";
3372         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3373             $unapplied, $headref, "--", sort keys %$editedignores;
3374         open SERIES, "+>>", "debian/patches/series" or die $!;
3375         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3376         my $newline;
3377         defined read SERIES, $newline, 1 or die $!;
3378         print SERIES "\n" or die $! unless $newline eq "\n";
3379         print SERIES "auto-gitignore\n" or die $!;
3380         close SERIES or die  $!;
3381         runcmd @git, qw(add -- debian/patches/series), $gipatch;
3382         commit_admin "Commit patch to update .gitignore";
3383     }
3384
3385     my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3386
3387     changedir '../../../..';
3388     ensuredir ".git/logs/refs/dgit-intern";
3389     my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3390       or die $!;
3391     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3392         $dgitview;
3393
3394     progress "dgit view: created (commit id $dgitview)";
3395
3396     changedir '.git/dgit/unpack/work';
3397 }
3398
3399 sub quiltify ($$$$) {
3400     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3401
3402     # Quilt patchification algorithm
3403     #
3404     # We search backwards through the history of the main tree's HEAD
3405     # (T) looking for a start commit S whose tree object is identical
3406     # to to the patch tip tree (ie the tree corresponding to the
3407     # current dpkg-committed patch series).  For these purposes
3408     # `identical' disregards anything in debian/ - this wrinkle is
3409     # necessary because dpkg-source treates debian/ specially.
3410     #
3411     # We can only traverse edges where at most one of the ancestors'
3412     # trees differs (in changes outside in debian/).  And we cannot
3413     # handle edges which change .pc/ or debian/patches.  To avoid
3414     # going down a rathole we avoid traversing edges which introduce
3415     # debian/rules or debian/control.  And we set a limit on the
3416     # number of edges we are willing to look at.
3417     #
3418     # If we succeed, we walk forwards again.  For each traversed edge
3419     # PC (with P parent, C child) (starting with P=S and ending with
3420     # C=T) to we do this:
3421     #  - git checkout C
3422     #  - dpkg-source --commit with a patch name and message derived from C
3423     # After traversing PT, we git commit the changes which
3424     # should be contained within debian/patches.
3425
3426     # The search for the path S..T is breadth-first.  We maintain a
3427     # todo list containing search nodes.  A search node identifies a
3428     # commit, and looks something like this:
3429     #  $p = {
3430     #      Commit => $git_commit_id,
3431     #      Child => $c,                          # or undef if P=T
3432     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
3433     #      Nontrivial => true iff $p..$c has relevant changes
3434     #  };
3435
3436     my @todo;
3437     my @nots;
3438     my $sref_S;
3439     my $max_work=100;
3440     my %considered; # saves being exponential on some weird graphs
3441
3442     my $t_sentinels = quiltify_tree_sentinelfiles $target;
3443
3444     my $not = sub {
3445         my ($search,$whynot) = @_;
3446         printdebug " search NOT $search->{Commit} $whynot\n";
3447         $search->{Whynot} = $whynot;
3448         push @nots, $search;
3449         no warnings qw(exiting);
3450         next;
3451     };
3452
3453     push @todo, {
3454         Commit => $target,
3455     };
3456
3457     while (@todo) {
3458         my $c = shift @todo;
3459         next if $considered{$c->{Commit}}++;
3460
3461         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3462
3463         printdebug "quiltify investigate $c->{Commit}\n";
3464
3465         # are we done?
3466         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3467             printdebug " search finished hooray!\n";
3468             $sref_S = $c;
3469             last;
3470         }
3471
3472         if ($quilt_mode eq 'nofix') {
3473             fail "quilt fixup required but quilt mode is \`nofix'\n".
3474                 "HEAD commit $c->{Commit} differs from tree implied by ".
3475                 " debian/patches (tree object $oldtiptree)";
3476         }
3477         if ($quilt_mode eq 'smash') {
3478             printdebug " search quitting smash\n";
3479             last;
3480         }
3481
3482         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3483         $not->($c, "has $c_sentinels not $t_sentinels")
3484             if $c_sentinels ne $t_sentinels;
3485
3486         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3487         $commitdata =~ m/\n\n/;
3488         $commitdata =~ $`;
3489         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3490         @parents = map { { Commit => $_, Child => $c } } @parents;
3491
3492         $not->($c, "root commit") if !@parents;
3493
3494         foreach my $p (@parents) {
3495             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3496         }
3497         my $ndiffers = grep { $_->{Nontrivial} } @parents;
3498         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3499
3500         foreach my $p (@parents) {
3501             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3502
3503             my @cmd= (@git, qw(diff-tree -r --name-only),
3504                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3505             my $patchstackchange = cmdoutput @cmd;
3506             if (length $patchstackchange) {
3507                 $patchstackchange =~ s/\n/,/g;
3508                 $not->($p, "changed $patchstackchange");
3509             }
3510
3511             printdebug " search queue P=$p->{Commit} ",
3512                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3513             push @todo, $p;
3514         }
3515     }
3516
3517     if (!$sref_S) {
3518         printdebug "quiltify want to smash\n";
3519
3520         my $abbrev = sub {
3521             my $x = $_[0]{Commit};
3522             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3523             return $x;
3524         };
3525         my $reportnot = sub {
3526             my ($notp) = @_;
3527             my $s = $abbrev->($notp);
3528             my $c = $notp->{Child};
3529             $s .= "..".$abbrev->($c) if $c;
3530             $s .= ": ".$notp->{Whynot};
3531             return $s;
3532         };
3533         if ($quilt_mode eq 'linear') {
3534             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
3535             foreach my $notp (@nots) {
3536                 print STDERR "$us:  ", $reportnot->($notp), "\n";
3537             }
3538             print STDERR "$us: $_\n" foreach @$failsuggestion;
3539             fail "quilt fixup naive history linearisation failed.\n".
3540  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3541         } elsif ($quilt_mode eq 'smash') {
3542         } elsif ($quilt_mode eq 'auto') {
3543             progress "quilt fixup cannot be linear, smashing...";
3544         } else {
3545             die "$quilt_mode ?";
3546         }
3547
3548         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3549         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3550         my $ncommits = 3;
3551         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3552
3553         quiltify_dpkg_commit "auto-$version-$target-$time",
3554             (getfield $clogp, 'Maintainer'),
3555             "Automatically generated patch ($clogp->{Version})\n".
3556             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3557         return;
3558     }
3559
3560     progress "quiltify linearisation planning successful, executing...";
3561
3562     for (my $p = $sref_S;
3563          my $c = $p->{Child};
3564          $p = $p->{Child}) {
3565         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3566         next unless $p->{Nontrivial};
3567
3568         my $cc = $c->{Commit};
3569
3570         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3571         $commitdata =~ m/\n\n/ or die "$c ?";
3572         $commitdata = $`;
3573         my $msg = $'; #';
3574         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3575         my $author = $1;
3576
3577         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3578
3579         my $title = $1;
3580         my $patchname = $title;
3581         $patchname =~ s/[.:]$//;
3582         $patchname =~ y/ A-Z/-a-z/;
3583         $patchname =~ y/-a-z0-9_.+=~//cd;
3584         $patchname =~ s/^\W/x-$&/;
3585         $patchname = substr($patchname,0,40);
3586         my $index;
3587         for ($index='';
3588              stat "debian/patches/$patchname$index";
3589              $index++) { }
3590         $!==ENOENT or die "$patchname$index $!";
3591
3592         runcmd @git, qw(checkout -q), $cc;
3593
3594         # We use the tip's changelog so that dpkg-source doesn't
3595         # produce complaining messages from dpkg-parsechangelog.  None
3596         # of the information dpkg-source gets from the changelog is
3597         # actually relevant - it gets put into the original message
3598         # which dpkg-source provides our stunt editor, and then
3599         # overwritten.
3600         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3601
3602         quiltify_dpkg_commit "$patchname$index", $author, $msg,
3603             "X-Dgit-Generated: $clogp->{Version} $cc\n";
3604
3605         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3606     }
3607
3608     runcmd @git, qw(checkout -q master);
3609 }
3610
3611 sub build_maybe_quilt_fixup () {
3612     my ($format,$fopts) = get_source_format;
3613     return unless madformat $format;
3614     # sigh
3615
3616     check_for_vendor_patches();
3617
3618     my $clogp = parsechangelog();
3619     my $headref = git_rev_parse('HEAD');
3620
3621     prep_ud();
3622     changedir $ud;
3623
3624     my $upstreamversion=$version;
3625     $upstreamversion =~ s/-[^-]*$//;
3626
3627     if ($fopts->{'single-debian-patch'}) {
3628         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3629     } else {
3630         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3631     }
3632
3633     die 'bug' if $split_brain && !$need_split_build_invocation;
3634
3635     changedir '../../../..';
3636     runcmd_ordryrun_local
3637         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3638 }
3639
3640 sub quilt_fixup_mkwork ($) {
3641     my ($headref) = @_;
3642
3643     mkdir "work" or die $!;
3644     changedir "work";
3645     mktree_in_ud_here();
3646     runcmd @git, qw(reset -q --hard), $headref;
3647 }
3648
3649 sub quilt_fixup_linkorigs ($$) {
3650     my ($upstreamversion, $fn) = @_;
3651     # calls $fn->($leafname);
3652
3653     foreach my $f (<../../../../*>) { #/){
3654         my $b=$f; $b =~ s{.*/}{};
3655         {
3656             local ($debuglevel) = $debuglevel-1;
3657             printdebug "QF linkorigs $b, $f ?\n";
3658         }
3659         next unless is_orig_file $b, srcfn $upstreamversion,'';
3660         printdebug "QF linkorigs $b, $f Y\n";
3661         link_ltarget $f, $b or die "$b $!";
3662         $fn->($b);
3663     }
3664 }
3665
3666 sub quilt_fixup_delete_pc () {
3667     runcmd @git, qw(rm -rqf .pc);
3668     commit_admin "Commit removal of .pc (quilt series tracking data)";
3669 }
3670
3671 sub quilt_fixup_singlepatch ($$$) {
3672     my ($clogp, $headref, $upstreamversion) = @_;
3673
3674     progress "starting quiltify (single-debian-patch)";
3675
3676     # dpkg-source --commit generates new patches even if
3677     # single-debian-patch is in debian/source/options.  In order to
3678     # get it to generate debian/patches/debian-changes, it is
3679     # necessary to build the source package.
3680
3681     quilt_fixup_linkorigs($upstreamversion, sub { });
3682     quilt_fixup_mkwork($headref);
3683
3684     rmtree("debian/patches");
3685
3686     runcmd @dpkgsource, qw(-b .);
3687     chdir "..";
3688     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3689     rename srcfn("$upstreamversion", "/debian/patches"),
3690            "work/debian/patches";
3691
3692     chdir "work";
3693     commit_quilty_patch();
3694 }
3695
3696 sub quilt_make_fake_dsc ($) {
3697     my ($upstreamversion) = @_;
3698
3699     my $fakeversion="$upstreamversion-~~DGITFAKE";
3700
3701     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3702     print $fakedsc <<END or die $!;
3703 Format: 3.0 (quilt)
3704 Source: $package
3705 Version: $fakeversion
3706 Files:
3707 END
3708
3709     my $dscaddfile=sub {
3710         my ($b) = @_;
3711
3712         my $md = new Digest::MD5;
3713
3714         my $fh = new IO::File $b, '<' or die "$b $!";
3715         stat $fh or die $!;
3716         my $size = -s _;
3717
3718         $md->addfile($fh);
3719         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3720     };
3721
3722     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3723
3724     my @files=qw(debian/source/format debian/rules
3725                  debian/control debian/changelog);
3726     foreach my $maybe (qw(debian/patches debian/source/options
3727                           debian/tests/control)) {
3728         next unless stat_exists "../../../$maybe";
3729         push @files, $maybe;
3730     }
3731
3732     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3733     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3734
3735     $dscaddfile->($debtar);
3736     close $fakedsc or die $!;
3737 }
3738
3739 sub quilt_check_splitbrain_cache ($$) {
3740     my ($headref, $upstreamversion) = @_;
3741     # Called only if we are in (potentially) split brain mode.
3742     # Called in $ud.
3743     # Computes the cache key and looks in the cache.
3744     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3745
3746     my $splitbrain_cachekey;
3747
3748     progress
3749  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3750     # we look in the reflog of dgit-intern/quilt-cache
3751     # we look for an entry whose message is the key for the cache lookup
3752     my @cachekey = (qw(dgit), $our_version);
3753     push @cachekey, $upstreamversion;
3754     push @cachekey, $quilt_mode;
3755     push @cachekey, $headref;
3756
3757     push @cachekey, hashfile('fake.dsc');
3758
3759     my $srcshash = Digest::SHA->new(256);
3760     my %sfs = ( %INC, '$0(dgit)' => $0 );
3761     foreach my $sfk (sort keys %sfs) {
3762         next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3763         $srcshash->add($sfk,"  ");
3764         $srcshash->add(hashfile($sfs{$sfk}));
3765         $srcshash->add("\n");
3766     }
3767     push @cachekey, $srcshash->hexdigest();
3768     $splitbrain_cachekey = "@cachekey";
3769
3770     my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3771                $splitbraincache);
3772     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3773     debugcmd "|(probably)",@cmd;
3774     my $child = open GC, "-|";  defined $child or die $!;
3775     if (!$child) {
3776         chdir '../../..' or die $!;
3777         if (!stat ".git/logs/refs/$splitbraincache") {
3778             $! == ENOENT or die $!;
3779             printdebug ">(no reflog)\n";
3780             exit 0;
3781         }
3782         exec @cmd; die $!;
3783     }
3784     while (<GC>) {
3785         chomp;
3786         printdebug ">| ", $_, "\n" if $debuglevel > 1;
3787         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3788
3789         my $cachehit = $1;
3790         quilt_fixup_mkwork($headref);
3791         if ($cachehit ne $headref) {
3792             progress "dgit view: found cached (commit id $cachehit)";
3793             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3794             $split_brain = 1;
3795             return ($cachehit, $splitbrain_cachekey);
3796         }
3797         progress "dgit view: found cached, no changes required";
3798         return ($headref, $splitbrain_cachekey);
3799     }
3800     die $! if GC->error;
3801     failedcmd unless close GC;
3802
3803     printdebug "splitbrain cache miss\n";
3804     return (undef, $splitbrain_cachekey);
3805 }
3806
3807 sub quilt_fixup_multipatch ($$$) {
3808     my ($clogp, $headref, $upstreamversion) = @_;
3809
3810     progress "examining quilt state (multiple patches, $quilt_mode mode)";
3811
3812     # Our objective is:
3813     #  - honour any existing .pc in case it has any strangeness
3814     #  - determine the git commit corresponding to the tip of
3815     #    the patch stack (if there is one)
3816     #  - if there is such a git commit, convert each subsequent
3817     #    git commit into a quilt patch with dpkg-source --commit
3818     #  - otherwise convert all the differences in the tree into
3819     #    a single git commit
3820     #
3821     # To do this we:
3822
3823     # Our git tree doesn't necessarily contain .pc.  (Some versions of
3824     # dgit would include the .pc in the git tree.)  If there isn't
3825     # one, we need to generate one by unpacking the patches that we
3826     # have.
3827     #
3828     # We first look for a .pc in the git tree.  If there is one, we
3829     # will use it.  (This is not the normal case.)
3830     #
3831     # Otherwise need to regenerate .pc so that dpkg-source --commit
3832     # can work.  We do this as follows:
3833     #     1. Collect all relevant .orig from parent directory
3834     #     2. Generate a debian.tar.gz out of
3835     #         debian/{patches,rules,source/format,source/options}
3836     #     3. Generate a fake .dsc containing just these fields:
3837     #          Format Source Version Files
3838     #     4. Extract the fake .dsc
3839     #        Now the fake .dsc has a .pc directory.
3840     # (In fact we do this in every case, because in future we will
3841     # want to search for a good base commit for generating patches.)
3842     #
3843     # Then we can actually do the dpkg-source --commit
3844     #     1. Make a new working tree with the same object
3845     #        store as our main tree and check out the main
3846     #        tree's HEAD.
3847     #     2. Copy .pc from the fake's extraction, if necessary
3848     #     3. Run dpkg-source --commit
3849     #     4. If the result has changes to debian/, then
3850     #          - git-add them them
3851     #          - git-add .pc if we had a .pc in-tree
3852     #          - git-commit
3853     #     5. If we had a .pc in-tree, delete it, and git-commit
3854     #     6. Back in the main tree, fast forward to the new HEAD
3855
3856     # Another situation we may have to cope with is gbp-style
3857     # patches-unapplied trees.
3858     #
3859     # We would want to detect these, so we know to escape into
3860     # quilt_fixup_gbp.  However, this is in general not possible.
3861     # Consider a package with a one patch which the dgit user reverts
3862     # (with git-revert or the moral equivalent).
3863     #
3864     # That is indistinguishable in contents from a patches-unapplied
3865     # tree.  And looking at the history to distinguish them is not
3866     # useful because the user might have made a confusing-looking git
3867     # history structure (which ought to produce an error if dgit can't
3868     # cope, not a silent reintroduction of an unwanted patch).
3869     #
3870     # So gbp users will have to pass an option.  But we can usually
3871     # detect their failure to do so: if the tree is not a clean
3872     # patches-applied tree, quilt linearisation fails, but the tree
3873     # _is_ a clean patches-unapplied tree, we can suggest that maybe
3874     # they want --quilt=unapplied.
3875     #
3876     # To help detect this, when we are extracting the fake dsc, we
3877     # first extract it with --skip-patches, and then apply the patches
3878     # afterwards with dpkg-source --before-build.  That lets us save a
3879     # tree object corresponding to .origs.
3880
3881     my $splitbrain_cachekey;
3882
3883     quilt_make_fake_dsc($upstreamversion);
3884
3885     if (quiltmode_splitbrain()) {
3886         my $cachehit;
3887         ($cachehit, $splitbrain_cachekey) =
3888             quilt_check_splitbrain_cache($headref, $upstreamversion);
3889         return if $cachehit;
3890     }
3891
3892     runcmd qw(sh -ec),
3893         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3894
3895     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3896     rename $fakexdir, "fake" or die "$fakexdir $!";
3897
3898     changedir 'fake';
3899
3900     remove_stray_gits();
3901     mktree_in_ud_here();
3902
3903     rmtree '.pc';
3904
3905     runcmd @git, qw(add -Af .);
3906     my $unapplied=git_write_tree();
3907     printdebug "fake orig tree object $unapplied\n";
3908
3909     ensuredir '.pc';
3910
3911     runcmd qw(sh -ec),
3912         'exec dpkg-source --before-build . >/dev/null';
3913
3914     changedir '..';
3915
3916     quilt_fixup_mkwork($headref);
3917
3918     my $mustdeletepc=0;
3919     if (stat_exists ".pc") {
3920         -d _ or die;
3921         progress "Tree already contains .pc - will use it then delete it.";
3922         $mustdeletepc=1;
3923     } else {
3924         rename '../fake/.pc','.pc' or die $!;
3925     }
3926
3927     changedir '../fake';
3928     rmtree '.pc';
3929     runcmd @git, qw(add -Af .);
3930     my $oldtiptree=git_write_tree();
3931     printdebug "fake o+d/p tree object $unapplied\n";
3932     changedir '../work';
3933
3934
3935     # We calculate some guesswork now about what kind of tree this might
3936     # be.  This is mostly for error reporting.
3937
3938     my %editedignores;
3939     my $diffbits = {
3940         # H = user's HEAD
3941         # O = orig, without patches applied
3942         # A = "applied", ie orig with H's debian/patches applied
3943         H2O => quiltify_trees_differ($headref,  $unapplied, 1,\%editedignores),
3944         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
3945         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3946     };
3947
3948     my @dl;
3949     foreach my $b (qw(01 02)) {
3950         foreach my $v (qw(H2O O2A H2A)) {
3951             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3952         }
3953     }
3954     printdebug "differences \@dl @dl.\n";
3955
3956     progress sprintf
3957 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
3958 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
3959                              $dl[0], $dl[1],              $dl[3], $dl[4],
3960                                  $dl[2],                     $dl[5];
3961
3962     my @failsuggestion;
3963     if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3964         push @failsuggestion, "This might be a patches-unapplied branch.";
3965     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3966         push @failsuggestion, "This might be a patches-applied branch.";
3967     }
3968     push @failsuggestion, "Maybe you need to specify one of".
3969         " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3970
3971     if (quiltmode_splitbrain()) {
3972         quiltify_splitbrain($clogp, $unapplied, $headref,
3973                             $diffbits, \%editedignores,
3974                             $splitbrain_cachekey);
3975         return;
3976     }
3977
3978     progress "starting quiltify (multiple patches, $quilt_mode mode)";
3979     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3980
3981     if (!open P, '>>', ".pc/applied-patches") {
3982         $!==&ENOENT or die $!;
3983     } else {
3984         close P;
3985     }
3986
3987     commit_quilty_patch();
3988
3989     if ($mustdeletepc) {
3990         quilt_fixup_delete_pc();
3991     }
3992 }
3993
3994 sub quilt_fixup_editor () {
3995     my $descfn = $ENV{$fakeeditorenv};
3996     my $editing = $ARGV[$#ARGV];
3997     open I1, '<', $descfn or die "$descfn: $!";
3998     open I2, '<', $editing or die "$editing: $!";
3999     unlink $editing or die "$editing: $!";
4000     open O, '>', $editing or die "$editing: $!";
4001     while (<I1>) { print O or die $!; } I1->error and die $!;
4002     my $copying = 0;
4003     while (<I2>) {
4004         $copying ||= m/^\-\-\- /;
4005         next unless $copying;
4006         print O or die $!;
4007     }
4008     I2->error and die $!;
4009     close O or die $1;
4010     exit 0;
4011 }
4012
4013 sub maybe_apply_patches_dirtily () {
4014     return unless $quilt_mode =~ m/gbp|unapplied/;
4015     print STDERR <<END or die $!;
4016
4017 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4018 dgit: Have to apply the patches - making the tree dirty.
4019 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4020
4021 END
4022     $patches_applied_dirtily = 01;
4023     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4024     runcmd qw(dpkg-source --before-build .);
4025 }
4026
4027 sub maybe_unapply_patches_again () {
4028     progress "dgit: Unapplying patches again to tidy up the tree."
4029         if $patches_applied_dirtily;
4030     runcmd qw(dpkg-source --after-build .)
4031         if $patches_applied_dirtily & 01;
4032     rmtree '.pc'
4033         if $patches_applied_dirtily & 02;
4034     $patches_applied_dirtily = 0;
4035 }
4036
4037 #----- other building -----
4038
4039 our $clean_using_builder;
4040 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4041 #   clean the tree before building (perhaps invoked indirectly by
4042 #   whatever we are using to run the build), rather than separately
4043 #   and explicitly by us.
4044
4045 sub clean_tree () {
4046     return if $clean_using_builder;
4047     if ($cleanmode eq 'dpkg-source') {
4048         maybe_apply_patches_dirtily();
4049         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4050     } elsif ($cleanmode eq 'dpkg-source-d') {
4051         maybe_apply_patches_dirtily();
4052         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4053     } elsif ($cleanmode eq 'git') {
4054         runcmd_ordryrun_local @git, qw(clean -xdf);
4055     } elsif ($cleanmode eq 'git-ff') {
4056         runcmd_ordryrun_local @git, qw(clean -xdff);
4057     } elsif ($cleanmode eq 'check') {
4058         my $leftovers = cmdoutput @git, qw(clean -xdn);
4059         if (length $leftovers) {
4060             print STDERR $leftovers, "\n" or die $!;
4061             fail "tree contains uncommitted files and --clean=check specified";
4062         }
4063     } elsif ($cleanmode eq 'none') {
4064     } else {
4065         die "$cleanmode ?";
4066     }
4067 }
4068
4069 sub cmd_clean () {
4070     badusage "clean takes no additional arguments" if @ARGV;
4071     notpushing();
4072     clean_tree();
4073     maybe_unapply_patches_again();
4074 }
4075
4076 sub build_prep () {
4077     notpushing();
4078     badusage "-p is not allowed when building" if defined $package;
4079     check_not_dirty();
4080     clean_tree();
4081     my $clogp = parsechangelog();
4082     $isuite = getfield $clogp, 'Distribution';
4083     $package = getfield $clogp, 'Source';
4084     $version = getfield $clogp, 'Version';
4085     build_maybe_quilt_fixup();
4086     if ($rmchanges) {
4087         my $pat = changespat $version;
4088         foreach my $f (glob "$buildproductsdir/$pat") {
4089             if (act_local()) {
4090                 unlink $f or fail "remove old changes file $f: $!";
4091             } else {
4092                 progress "would remove $f";
4093             }
4094         }
4095     }
4096 }
4097
4098 sub changesopts_initial () {
4099     my @opts =@changesopts[1..$#changesopts];
4100 }
4101
4102 sub changesopts_version () {
4103     if (!defined $changes_since_version) {
4104         my @vsns = archive_query('archive_query');
4105         my @quirk = access_quirk();
4106         if ($quirk[0] eq 'backports') {
4107             local $isuite = $quirk[2];
4108             local $csuite;
4109             canonicalise_suite();
4110             push @vsns, archive_query('archive_query');
4111         }
4112         if (@vsns) {
4113             @vsns = map { $_->[0] } @vsns;
4114             @vsns = sort { -version_compare($a, $b) } @vsns;
4115             $changes_since_version = $vsns[0];
4116             progress "changelog will contain changes since $vsns[0]";
4117         } else {
4118             $changes_since_version = '_';
4119             progress "package seems new, not specifying -v<version>";
4120         }
4121     }
4122     if ($changes_since_version ne '_') {
4123         return ("-v$changes_since_version");
4124     } else {
4125         return ();
4126     }
4127 }
4128
4129 sub changesopts () {
4130     return (changesopts_initial(), changesopts_version());
4131 }
4132
4133 sub massage_dbp_args ($;$) {
4134     my ($cmd,$xargs) = @_;
4135     # We need to:
4136     #
4137     #  - if we're going to split the source build out so we can
4138     #    do strange things to it, massage the arguments to dpkg-buildpackage
4139     #    so that the main build doessn't build source (or add an argument
4140     #    to stop it building source by default).
4141     #
4142     #  - add -nc to stop dpkg-source cleaning the source tree,
4143     #    unless we're not doing a split build and want dpkg-source
4144     #    as cleanmode, in which case we can do nothing
4145     #
4146     # return values:
4147     #    0 - source will NOT need to be built separately by caller
4148     #   +1 - source will need to be built separately by caller
4149     #   +2 - source will need to be built separately by caller AND
4150     #        dpkg-buildpackage should not in fact be run at all!
4151     debugcmd '#massaging#', @$cmd if $debuglevel>1;
4152 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4153     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4154         $clean_using_builder = 1;
4155         return 0;
4156     }
4157     # -nc has the side effect of specifying -b if nothing else specified
4158     # and some combinations of -S, -b, et al, are errors, rather than
4159     # later simply overriding earlie.  So we need to:
4160     #  - search the command line for these options
4161     #  - pick the last one
4162     #  - perhaps add our own as a default
4163     #  - perhaps adjust it to the corresponding non-source-building version
4164     my $dmode = '-F';
4165     foreach my $l ($cmd, $xargs) {
4166         next unless $l;
4167         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4168     }
4169     push @$cmd, '-nc';
4170 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4171     my $r = 0;
4172     if ($need_split_build_invocation) {
4173         printdebug "massage split $dmode.\n";
4174         $r = $dmode =~ m/[S]/     ? +2 :
4175              $dmode =~ y/gGF/ABb/ ? +1 :
4176              $dmode =~ m/[ABb]/   ?  0 :
4177              die "$dmode ?";
4178     }
4179     printdebug "massage done $r $dmode.\n";
4180     push @$cmd, $dmode;
4181 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4182     return $r;
4183 }
4184
4185 sub cmd_build {
4186     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4187     my $wantsrc = massage_dbp_args \@dbp;
4188     if ($wantsrc > 0) {
4189         build_source();
4190     } else {
4191         build_prep();
4192     }
4193     if ($wantsrc < 2) {
4194         push @dbp, changesopts_version();
4195         maybe_apply_patches_dirtily();
4196         runcmd_ordryrun_local @dbp;
4197     }
4198     maybe_unapply_patches_again();
4199     printdone "build successful\n";
4200 }
4201
4202 sub cmd_gbp_build {
4203     my @dbp = @dpkgbuildpackage;
4204
4205     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4206
4207     my @cmd;
4208     if (length executable_on_path('git-buildpackage')) {
4209         @cmd = qw(git-buildpackage);
4210     } else {
4211         @cmd = qw(gbp buildpackage);
4212     }
4213     push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4214
4215     if ($wantsrc > 0) {
4216         build_source();
4217     } else {
4218         if (!$clean_using_builder) {
4219             push @cmd, '--git-cleaner=true';
4220         }
4221         build_prep();
4222     }
4223     maybe_unapply_patches_again();
4224     if ($wantsrc < 2) {
4225         unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4226             canonicalise_suite();
4227             push @cmd, "--git-debian-branch=".lbranch();
4228         }
4229         push @cmd, changesopts();
4230         runcmd_ordryrun_local @cmd, @ARGV;
4231     }
4232     printdone "build successful\n";
4233 }
4234 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4235
4236 sub build_source {
4237     my $our_cleanmode = $cleanmode;
4238     if ($need_split_build_invocation) {
4239         # Pretend that clean is being done some other way.  This
4240         # forces us not to try to use dpkg-buildpackage to clean and
4241         # build source all in one go; and instead we run dpkg-source
4242         # (and build_prep() will do the clean since $clean_using_builder
4243         # is false).
4244         $our_cleanmode = 'ELSEWHERE';
4245     }
4246     if ($our_cleanmode =~ m/^dpkg-source/) {
4247         # dpkg-source invocation (below) will clean, so build_prep shouldn't
4248         $clean_using_builder = 1;
4249     }
4250     build_prep();
4251     $sourcechanges = changespat $version,'source';
4252     if (act_local()) {
4253         unlink "../$sourcechanges" or $!==ENOENT
4254             or fail "remove $sourcechanges: $!";
4255     }
4256     $dscfn = dscfn($version);
4257     if ($our_cleanmode eq 'dpkg-source') {
4258         maybe_apply_patches_dirtily();
4259         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4260             changesopts();
4261     } elsif ($our_cleanmode eq 'dpkg-source-d') {
4262         maybe_apply_patches_dirtily();
4263         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4264             changesopts();
4265     } else {
4266         my @cmd = (@dpkgsource, qw(-b --));
4267         if ($split_brain) {
4268             changedir $ud;
4269             runcmd_ordryrun_local @cmd, "work";
4270             my @udfiles = <${package}_*>;
4271             changedir "../../..";
4272             foreach my $f (@udfiles) {
4273                 printdebug "source copy, found $f\n";
4274                 next unless
4275                     $f eq $dscfn or
4276                     ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4277                      $f eq srcfn($version, $&));
4278                 printdebug "source copy, found $f - renaming\n";
4279                 rename "$ud/$f", "../$f" or $!==ENOENT
4280                     or fail "put in place new source file ($f): $!";
4281             }
4282         } else {
4283             my $pwd = must_getcwd();
4284             my $leafdir = basename $pwd;
4285             changedir "..";
4286             runcmd_ordryrun_local @cmd, $leafdir;
4287             changedir $pwd;
4288         }
4289         runcmd_ordryrun_local qw(sh -ec),
4290             'exec >$1; shift; exec "$@"','x',
4291             "../$sourcechanges",
4292             @dpkggenchanges, qw(-S), changesopts();
4293     }
4294 }
4295
4296 sub cmd_build_source {
4297     badusage "build-source takes no additional arguments" if @ARGV;
4298     build_source();
4299     maybe_unapply_patches_again();
4300     printdone "source built, results in $dscfn and $sourcechanges";
4301 }
4302
4303 sub cmd_sbuild {
4304     build_source();
4305     my $pat = changespat $version;
4306     if (!$rmchanges) {
4307         my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4308         @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4309         fail "changes files other than source matching $pat".
4310             " already present (@unwanted);".
4311             " building would result in ambiguity about the intended results"
4312             if @unwanted;
4313     }
4314     my $wasdir = must_getcwd();
4315     changedir "..";
4316     if (act_local()) {
4317         stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4318         stat_exists $sourcechanges
4319             or fail "$sourcechanges (in parent directory): $!";
4320     }
4321     runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4322     my @changesfiles = glob $pat;
4323     @changesfiles = sort {
4324         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4325             or $a cmp $b
4326     } @changesfiles;
4327     fail "wrong number of different changes files (@changesfiles)"
4328         unless @changesfiles==2;
4329     my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4330     foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4331         fail "$l found in binaries changes file $binchanges"
4332             if $l =~ m/\.dsc$/;
4333     }
4334     runcmd_ordryrun_local @mergechanges, @changesfiles;
4335     my $multichanges = changespat $version,'multi';
4336     if (act_local()) {
4337         stat_exists $multichanges or fail "$multichanges: $!";
4338         foreach my $cf (glob $pat) {
4339             next if $cf eq $multichanges;
4340             rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4341         }
4342     }
4343     changedir $wasdir;
4344     maybe_unapply_patches_again();
4345     printdone "build successful, results in $multichanges\n" or die $!;
4346 }
4347
4348 sub cmd_quilt_fixup {
4349     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4350     my $clogp = parsechangelog();
4351     $version = getfield $clogp, 'Version';
4352     $package = getfield $clogp, 'Source';
4353     check_not_dirty();
4354     clean_tree();
4355     build_maybe_quilt_fixup();
4356 }
4357
4358 sub cmd_archive_api_query {
4359     badusage "need only 1 subpath argument" unless @ARGV==1;
4360     my ($subpath) = @ARGV;
4361     my @cmd = archive_api_query_cmd($subpath);
4362     debugcmd ">",@cmd;
4363     exec @cmd or fail "exec curl: $!\n";
4364 }
4365
4366 sub cmd_clone_dgit_repos_server {
4367     badusage "need destination argument" unless @ARGV==1;
4368     my ($destdir) = @ARGV;
4369     $package = '_dgit-repos-server';
4370     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4371     debugcmd ">",@cmd;
4372     exec @cmd or fail "exec git clone: $!\n";
4373 }
4374
4375 sub cmd_setup_mergechangelogs {
4376     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4377     setup_mergechangelogs(1);
4378 }
4379
4380 sub cmd_setup_useremail {
4381     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4382     setup_useremail(1);
4383 }
4384
4385 sub cmd_setup_new_tree {
4386     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4387     setup_new_tree();
4388 }
4389
4390 #---------- argument parsing and main program ----------
4391
4392 sub cmd_version {
4393     print "dgit version $our_version\n" or die $!;
4394     exit 0;
4395 }
4396
4397 our (%valopts_long, %valopts_short);
4398 our @rvalopts;
4399
4400 sub defvalopt ($$$$) {
4401     my ($long,$short,$val_re,$how) = @_;
4402     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4403     $valopts_long{$long} = $oi;
4404     $valopts_short{$short} = $oi;
4405     # $how subref should:
4406     #   do whatever assignemnt or thing it likes with $_[0]
4407     #   if the option should not be passed on to remote, @rvalopts=()
4408     # or $how can be a scalar ref, meaning simply assign the value
4409 }
4410
4411 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4412 defvalopt '--distro',        '-d', '.+',      \$idistro;
4413 defvalopt '',                '-k', '.+',      \$keyid;
4414 defvalopt '--existing-package','', '.*',      \$existing_package;
4415 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
4416 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
4417 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
4418
4419 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4420
4421 defvalopt '', '-C', '.+', sub {
4422     ($changesfile) = (@_);
4423     if ($changesfile =~ s#^(.*)/##) {
4424         $buildproductsdir = $1;
4425     }
4426 };
4427
4428 defvalopt '--initiator-tempdir','','.*', sub {
4429     ($initiator_tempdir) = (@_);
4430     $initiator_tempdir =~ m#^/# or
4431         badusage "--initiator-tempdir must be used specify an".
4432         " absolute, not relative, directory."
4433 };
4434
4435 sub parseopts () {
4436     my $om;
4437
4438     if (defined $ENV{'DGIT_SSH'}) {
4439         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4440     } elsif (defined $ENV{'GIT_SSH'}) {
4441         @ssh = ($ENV{'GIT_SSH'});
4442     }
4443
4444     my $oi;
4445     my $val;
4446     my $valopt = sub {
4447         my ($what) = @_;
4448         @rvalopts = ($_);
4449         if (!defined $val) {
4450             badusage "$what needs a value" unless @ARGV;
4451             $val = shift @ARGV;
4452             push @rvalopts, $val;
4453         }
4454         badusage "bad value \`$val' for $what" unless
4455             $val =~ m/^$oi->{Re}$(?!\n)/s;
4456         my $how = $oi->{How};
4457         if (ref($how) eq 'SCALAR') {
4458             $$how = $val;
4459         } else {
4460             $how->($val);
4461         }
4462         push @ropts, @rvalopts;
4463     };
4464
4465     while (@ARGV) {
4466         last unless $ARGV[0] =~ m/^-/;
4467         $_ = shift @ARGV;
4468         last if m/^--?$/;
4469         if (m/^--/) {
4470             if (m/^--dry-run$/) {
4471                 push @ropts, $_;
4472                 $dryrun_level=2;
4473             } elsif (m/^--damp-run$/) {
4474                 push @ropts, $_;
4475                 $dryrun_level=1;
4476             } elsif (m/^--no-sign$/) {
4477                 push @ropts, $_;
4478                 $sign=0;
4479             } elsif (m/^--help$/) {
4480                 cmd_help();
4481             } elsif (m/^--version$/) {
4482                 cmd_version();
4483             } elsif (m/^--new$/) {
4484                 push @ropts, $_;
4485                 $new_package=1;
4486             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4487                      ($om = $opts_opt_map{$1}) &&
4488                      length $om->[0]) {
4489                 push @ropts, $_;
4490                 $om->[0] = $2;
4491             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4492                      !$opts_opt_cmdonly{$1} &&
4493                      ($om = $opts_opt_map{$1})) {
4494                 push @ropts, $_;
4495                 push @$om, $2;
4496             } elsif (m/^--ignore-dirty$/s) {
4497                 push @ropts, $_;
4498                 $ignoredirty = 1;
4499             } elsif (m/^--no-quilt-fixup$/s) {
4500                 push @ropts, $_;
4501                 $quilt_mode = 'nocheck';
4502             } elsif (m/^--no-rm-on-error$/s) {
4503                 push @ropts, $_;
4504                 $rmonerror = 0;
4505             } elsif (m/^--(no-)?rm-old-changes$/s) {
4506                 push @ropts, $_;
4507                 $rmchanges = !$1;
4508             } elsif (m/^--deliberately-($deliberately_re)$/s) {
4509                 push @ropts, $_;
4510                 push @deliberatelies, $&;
4511             } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4512                 # undocumented, for testing
4513                 push @ropts, $_;
4514                 $tagformat_want = [ $1, 'command line', 1 ];
4515                 # 1 menas overrides distro configuration
4516             } elsif (m/^--always-split-source-build$/s) {
4517                 # undocumented, for testing
4518                 push @ropts, $_;
4519                 $need_split_build_invocation = 1;
4520             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4521                 $val = $2 ? $' : undef; #';
4522                 $valopt->($oi->{Long});
4523             } else {
4524                 badusage "unknown long option \`$_'";
4525             }
4526         } else {
4527             while (m/^-./s) {
4528                 if (s/^-n/-/) {
4529                     push @ropts, $&;
4530                     $dryrun_level=2;
4531                 } elsif (s/^-L/-/) {
4532                     push @ropts, $&;
4533                     $dryrun_level=1;
4534                 } elsif (s/^-h/-/) {
4535                     cmd_help();
4536                 } elsif (s/^-D/-/) {
4537                     push @ropts, $&;
4538                     $debuglevel++;
4539                     enabledebug();
4540                 } elsif (s/^-N/-/) {
4541                     push @ropts, $&;
4542                     $new_package=1;
4543                 } elsif (m/^-m/) {
4544                     push @ropts, $&;
4545                     push @changesopts, $_;
4546                     $_ = '';
4547                 } elsif (s/^-wn$//s) {
4548                     push @ropts, $&;
4549                     $cleanmode = 'none';
4550                 } elsif (s/^-wg$//s) {
4551                     push @ropts, $&;
4552                     $cleanmode = 'git';
4553                 } elsif (s/^-wgf$//s) {
4554                     push @ropts, $&;
4555                     $cleanmode = 'git-ff';
4556                 } elsif (s/^-wd$//s) {
4557                     push @ropts, $&;
4558                     $cleanmode = 'dpkg-source';
4559                 } elsif (s/^-wdd$//s) {
4560                     push @ropts, $&;
4561                     $cleanmode = 'dpkg-source-d';
4562                 } elsif (s/^-wc$//s) {
4563                     push @ropts, $&;
4564                     $cleanmode = 'check';
4565                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4566                     $val = $'; #';
4567                     $val = undef unless length $val;
4568                     $valopt->($oi->{Short});
4569                     $_ = '';
4570                 } else {
4571                     badusage "unknown short option \`$_'";
4572                 }
4573             }
4574         }
4575     }
4576 }
4577
4578 sub finalise_opts_opts () {
4579     foreach my $k (keys %opts_opt_map) {
4580         my $om = $opts_opt_map{$k};
4581
4582         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4583         if (defined $v) {
4584             badcfg "cannot set command for $k"
4585                 unless length $om->[0];
4586             $om->[0] = $v;
4587         }
4588
4589         foreach my $c (access_cfg_cfgs("opts-$k")) {
4590             my $vl = $gitcfg{$c};
4591             printdebug "CL $c ",
4592                 ($vl ? join " ", map { shellquote } @$vl : ""),
4593                 "\n" if $debuglevel >= 4;
4594             next unless $vl;
4595             badcfg "cannot configure options for $k"
4596                 if $opts_opt_cmdonly{$k};
4597             my $insertpos = $opts_cfg_insertpos{$k};
4598             @$om = ( @$om[0..$insertpos-1],
4599                      @$vl,
4600                      @$om[$insertpos..$#$om] );
4601         }
4602     }
4603 }
4604
4605 if ($ENV{$fakeeditorenv}) {
4606     git_slurp_config();
4607     quilt_fixup_editor();
4608 }
4609
4610 parseopts();
4611 git_slurp_config();
4612
4613 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4614 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4615     if $dryrun_level == 1;
4616 if (!@ARGV) {
4617     print STDERR $helpmsg or die $!;
4618     exit 8;
4619 }
4620 my $cmd = shift @ARGV;
4621 $cmd =~ y/-/_/;
4622
4623 if (!defined $rmchanges) {
4624     local $access_forpush;
4625     $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4626 }
4627
4628 if (!defined $quilt_mode) {
4629     local $access_forpush;
4630     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4631         // access_cfg('quilt-mode', 'RETURN-UNDEF')
4632         // 'linear';
4633     $quilt_mode =~ m/^($quilt_modes_re)$/
4634         or badcfg "unknown quilt-mode \`$quilt_mode'";
4635     $quilt_mode = $1;
4636 }
4637
4638 $need_split_build_invocation ||= quiltmode_splitbrain();
4639
4640 if (!defined $cleanmode) {
4641     local $access_forpush;
4642     $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4643     $cleanmode //= 'dpkg-source';
4644
4645     badcfg "unknown clean-mode \`$cleanmode'" unless
4646         $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4647 }
4648
4649 my $fn = ${*::}{"cmd_$cmd"};
4650 $fn or badusage "unknown operation $cmd";
4651 $fn->();