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