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