dgit

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