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