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