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