dgit

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