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