dgit

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