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