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