dgit

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