dgit

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