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