dgit

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