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