dgit

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