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