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