dgit

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