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