dgit

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