X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=396213475b9cc38ce8d8a63a44231ffe60e329b4;hp=bfc168c253c9423805902428fc7bd43ca9c0e1ec;hb=27ecf86e831ab5a4908a2d0541e0e987e39da48e;hpb=0c285f61c99f278e9cf6b121037bbce8f9d0e3b9 diff --git a/dgit b/dgit index bfc168c2..39621347 100755 --- a/dgit +++ b/dgit @@ -2,8 +2,8 @@ # dgit # Integration between git and Debian-style archives # -# Copyright (C)2013-2017 Ian Jackson -# Copyright (C)2017 Sean Whitton +# Copyright (C)2013-2018 Ian Jackson +# Copyright (C)2017-2018 Sean Whitton # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -63,9 +63,10 @@ our @ropts; our $sign = 1; our $dryrun_level = 0; our $changesfile; -our $buildproductsdir = '..'; +our $buildproductsdir; +our $bpd_glob; our $new_package = 0; -our $ignoredirty = 0; +our $includedirty = 0; our $rmonerror = 1; our @deliberatelies; our %previously; @@ -77,7 +78,7 @@ our $overwrite_version; # undef: not specified; '': check changelog our $quilt_mode; our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied'; our $dodep14tag; -our $split_brain_save; +our %internal_object_save; our $we_are_responder; our $we_are_initiator; our $initiator_tempdir; @@ -90,6 +91,7 @@ our $chase_dsc_distro=1; our %forceopts = map { $_=>0 } qw(unrepresentable unsupported-source-format dsc-changes-mismatch changes-origs-exactly + uploading-binaries uploading-source-only import-gitapply-absurd import-gitapply-no-absurd import-dsc-with-dgit-field); @@ -98,9 +100,6 @@ our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)"); our $suite_re = '[-+.0-9a-z]+'; our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none'; -our $orig_f_comp_re = qr{orig(?:-$extra_orig_namepart_re)?}; -our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)'; -our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?"; our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$'; our $splitbraincache = 'dgit-intern/quilt-cache'; @@ -127,6 +126,8 @@ our (@mergechanges) = qw(mergechanges -f); our (@gbp_build) = (''); our (@gbp_pq) = ('gbp pq'); our (@changesopts) = (''); +our (@pbuilder) = ("sudo -E pbuilder"); +our (@cowbuilder) = ("sudo -E cowbuilder"); our %opts_opt_map = ('dget' => \@dget, # accept for compatibility 'curl' => \@curl, @@ -146,7 +147,9 @@ our %opts_opt_map = ('dget' => \@dget, # accept for compatibility 'gbp-build' => \@gbp_build, 'gbp-pq' => \@gbp_pq, 'ch' => \@changesopts, - 'mergechanges' => \@mergechanges); + 'mergechanges' => \@mergechanges, + 'pbuilder' => \@pbuilder, + 'cowbuilder' => \@cowbuilder); our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1); our %opts_cfg_insertpos = map { @@ -164,7 +167,6 @@ our $keyid; autoflush STDOUT 1; our $supplementary_message = ''; -our $need_split_build_invocation = 0; our $split_brain = 0; END { @@ -188,11 +190,6 @@ sub debiantag ($$) { return $tagformatfn->($v, $distro); } -sub debiantag_maintview ($$) { - my ($v,$distro) = @_; - return "$distro/".dep14_version_mangle $v; -} - sub madformat ($) { $_[0] eq '3.0 (quilt)' } sub lbranch () { return "$branchprefix/$csuite"; } @@ -201,15 +198,13 @@ sub lref () { return "refs/heads/".lbranch(); } sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); } sub rrref () { return server_ref($csuite); } -sub stripepoch ($) { - my ($vsn) = @_; - $vsn =~ s/^\d+\://; - return $vsn; -} - sub srcfn ($$) { - my ($vsn,$sfx) = @_; - return "${package}_".(stripepoch $vsn).$sfx + my ($vsn, $sfx) = @_; + return &source_file_leafname($package, $vsn, $sfx); +} +sub is_orig_file_of_vsn ($$) { + my ($f, $upstreamvsn) = @_; + return is_orig_file_of_p_v($f, $package, $upstreamvsn); } sub dscfn ($) { @@ -222,12 +217,6 @@ sub changespat ($;$) { return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes"; } -sub upstreamversion ($) { - my ($vsn) = @_; - $vsn =~ s/-[^-]+$//; - return $vsn; -} - our $us = 'dgit'; initdebug(''); @@ -278,20 +267,36 @@ sub quiltmode_splitbrain () { } sub opts_opt_multi_cmd { + my $extra = shift; my @cmd; push @cmd, split /\s+/, shift @_; + push @cmd, @$extra; push @cmd, @_; @cmd; } sub gbp_pq { - return opts_opt_multi_cmd @gbp_pq; + return opts_opt_multi_cmd [], @gbp_pq; } sub dgit_privdir () { our $dgit_privdir_made //= ensure_a_playground 'dgit'; } +sub bpd_abs () { + my $r = $buildproductsdir; + $r = "$maindir/$r" unless $r =~ m{^/}; + return $r; +} + +sub get_tree_of_commit ($) { + my ($commitish) = @_; + my $cdata = cmdoutput @git, qw(cat-file commit), $commitish; + $cdata =~ m/\n\n/; $cdata = $`; + $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?"; + return $1; +} + sub branch_gdr_info ($$) { my ($symref, $head) = @_; my ($status, $msg, $current, $ffq_prev, $gdrlast) = @@ -303,21 +308,91 @@ sub branch_gdr_info ($$) { return ($ffq_prev, $gdrlast); } -sub branch_is_gdr ($$) { - my ($symref, $head) = @_; - my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head); - return 0 unless $ffq_prev || $gdrlast; - return 1; -} - sub branch_is_gdr_unstitched_ff ($$$) { my ($symref, $head, $ancestor) = @_; my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head); return 0 unless $ffq_prev; - return 0 unless is_fast_fwd $ancestor, $ffq_prev; + return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev; return 1; } +sub branch_is_gdr ($) { + my ($head) = @_; + # This is quite like git-debrebase's keycommits. + # We have our own implementation because: + # - our algorighm can do fewer tests so is faster + # - it saves testing to see if gdr is installed + + # NB we use this jsut for deciding whether to run gdr make-patches + # Before reusing this algorithm for somthing else, its + # suitability should be reconsidered. + + my $walk = $head; + local $Debian::Dgit::debugcmd_when_debuglevel = 3; + printdebug "branch_is_gdr $head...\n"; + my $get_patches = sub { + my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)]; + return $t // ''; + }; + my $tip_patches = $get_patches->($head); + WALK: + for (;;) { + my $cdata = git_cat_file $walk, 'commit'; + my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,''); + if ($msg =~ m{^\[git-debrebase\ ( + anchor | changelog | make-patches | + merged-breakwater | pseudomerge + ) [: ] }mx) { + # no need to analyse this - it's sufficient + # (gdr classifications: Anchor, MergedBreakwaters) + # (made by gdr: Pseudomerge, Changelog) + printdebug "branch_is_gdr $walk gdr $1 YES\n"; + return 1; + } + my @parents = ($hdrs =~ m/^parent (\w+)$/gm); + if (@parents==2) { + my $walk_tree = get_tree_of_commit $walk; + foreach my $p (@parents) { + my $p_tree = get_tree_of_commit $p; + if ($p_tree eq $walk_tree) { # pseudomerge contriburor + # (gdr classification: Pseudomerge; not made by gdr) + printdebug "branch_is_gdr $walk unmarked pseudomerge\n" + if $debuglevel >= 2; + $walk = $p; + next WALK; + } + } + # some other non-gdr merge + # (gdr classification: VanillaMerge, DgitImportUnpatched, ?) + printdebug "branch_is_gdr $walk ?-2-merge NO\n"; + return 0; + } + if (@parents>2) { + # (gdr classification: ?) + printdebug "branch_is_gdr $walk ?-octopus NO\n"; + return 0; + } + if ($get_patches->($walk) ne $tip_patches) { + # Our parent added, removed, or edited patches, and wasn't + # a gdr make-patches commit. gdr make-patches probably + # won't do that well, then. + # (gdr classification of parent: AddPatches or ?) + printdebug "branch_is_gdr $walk ?-patches NO\n"; + return 0; + } + if ($tip_patches eq '' and + !defined git_cat_file "$walk:debian") { + # (gdr classification of parent: BreakwaterStart + printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n"; + return 1; + } + # (gdr classification: Upstream Packaging Mixed Changelog) + printdebug "branch_is_gdr $walk plain\n" + if $debuglevel >= 2; + $walk = $parents[0]; + } +} + #---------- remote protocol support, common ---------- # remote push initiator/responder protocol: @@ -567,6 +642,7 @@ main usages: dgit [dgit-opts] fetch|pull [dgit-opts] [suite] dgit [dgit-opts] build [dpkg-buildpackage-opts] dgit [dgit-opts] sbuild [sbuild-opts] + dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts] dgit [dgit-opts] push [dgit-opts] [suite] dgit [dgit-opts] push-source [dgit-opts] [suite] dgit [dgit-opts] rpush build-host:build-dir ... @@ -614,6 +690,7 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit.default.sshpsql-dbname' => 'service=projectb', 'dgit.default.aptget-components' => 'main', 'dgit.default.dgit-tag-format' => 'new,old,maint', + 'dgit.default.source-only-uploads' => 'ok', 'dgit.dsc-url-proto-ok.http' => 'true', 'dgit.dsc-url-proto-ok.https' => 'true', 'dgit.dsc-url-proto-ok.git' => 'true', @@ -628,6 +705,7 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit-distro.debian.git-check' => 'url', 'dgit-distro.debian.git-check-suffix' => '/info/refs', 'dgit-distro.debian.new-private-pushers' => 't', + 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new', 'dgit-distro.debian/push.git-url' => '', 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org', 'dgit-distro.debian/push.git-user-force' => 'dgit', @@ -813,7 +891,8 @@ sub access_forpush () { } sub pushing () { - die "$access_forpush ?" if ($access_forpush // 1) ne 1; + confess 'internal error '.Dumper($access_forpush)," ?" if + defined $access_forpush and !$access_forpush; badcfg "pushing but distro is configured readonly" if access_forpush_config() eq '0'; $access_forpush = 1; @@ -959,59 +1038,6 @@ sub access_giturl (;$) { return "$url/$package$suffix"; } -sub parsecontrolfh ($$;$) { - my ($fh, $desc, $allowsigned) = @_; - our $dpkgcontrolhash_noissigned; - my $c; - for (;;) { - my %opts = ('name' => $desc); - $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned; - $c = Dpkg::Control::Hash->new(%opts); - $c->parse($fh,$desc) or die "parsing of $desc failed"; - last if $allowsigned; - last if $dpkgcontrolhash_noissigned; - my $issigned= $c->get_option('is_pgp_signed'); - if (!defined $issigned) { - $dpkgcontrolhash_noissigned= 1; - seek $fh, 0,0 or die "seek $desc: $!"; - } elsif ($issigned) { - fail "control file $desc is (already) PGP-signed. ". - " Note that dgit push needs to modify the .dsc and then". - " do the signature itself"; - } else { - last; - } - } - return $c; -} - -sub parsecontrol { - my ($file, $desc, $allowsigned) = @_; - my $fh = new IO::Handle; - open $fh, '<', $file or die "$file: $!"; - my $c = parsecontrolfh($fh,$desc,$allowsigned); - $fh->error and die $!; - close $fh; - return $c; -} - -sub getfield ($$) { - my ($dctrl,$field) = @_; - my $v = $dctrl->{$field}; - return $v if defined $v; - fail "missing field $field in ".$dctrl->get_option('name'); -} - -sub parsechangelog { - my $c = Dpkg::Control::Hash->new(name => 'parsed changelog'); - my $p = new IO::Handle; - my @cmd = (qw(dpkg-parsechangelog), @_); - open $p, '-|', @cmd or die $!; - $c->parse($p); - $?=0; $!=0; close $p or failedcmd @cmd; - return $c; -} - sub commit_getclogp ($) { # Returns the parsed changelog hashref for a particular commit my ($objid) = @_; @@ -1130,7 +1156,7 @@ sub canonicalise_suite_ftpmasterapi { } qw(codename name); push @matched, $entry; } - fail "unknown suite $isuite" unless @matched; + fail "unknown suite $isuite, maybe -d would help" unless @matched; my $cn; eval { @matched==1 or die "multiple matches for suite $isuite\n"; @@ -1179,6 +1205,12 @@ sub file_in_archive_ftpmasterapi { my $info = api_query($data, "file_in_archive/$pat", 1); } +sub package_not_wholly_new_ftpmasterapi { + my ($proto,$data,$pkg) = @_; + my $info = api_query($data,"madison?package=${pkg}&f=json"); + return !!@$info; +} + #---------- `aptget' archive query method ---------- our $aptget_base; @@ -1286,7 +1318,14 @@ END } my @inreleasefiles = grep { m#/InRelease$# } @releasefiles; @releasefiles = @inreleasefiles if @inreleasefiles; - die "apt updated wrong number of Release files (@releasefiles), erk" + if (!@releasefiles) { + fail <) { - chomp or die; - printdebug "| $_\n"; - m/^(\w+) (\S+)$/ or die "$_ ?"; - push @out, { sha256sum => $1, filename => $2 }; - } - close FIA or die failedcmd @cmd; + my $r = $fn->(); + close FIA or ($!==0 && $?==141) or die failedcmd @cmd; + return $r; +} + +sub file_in_archive_dummycatapi ($$$) { + my ($proto,$data,$filename) = @_; + my @out; + dummycatapi_run_in_mirror ' + find -name "$1" -print0 | + xargs -0r sha256sum + ', [$filename], sub { + while () { + chomp or die; + printdebug "| $_\n"; + m/^(\w+) (\S+)$/ or die "$_ ?"; + push @out, { sha256sum => $1, filename => $2 }; + } + }; return \@out; } +sub package_not_wholly_new_dummycatapi { + my ($proto,$data,$pkg) = @_; + dummycatapi_run_in_mirror " + find -name ${pkg}_*.dsc + ", [], sub { + local $/ = undef; + !!; + }; +} + #---------- `madison' archive query method ---------- sub archive_query_madison { @@ -1420,6 +1480,7 @@ sub canonicalise_suite_madison { } sub file_in_archive_madison { return undef; } +sub package_not_wholly_new_madison { return undef; } #---------- `sshpsql' archive query method ---------- @@ -1497,6 +1558,7 @@ END } sub file_in_archive_sshpsql ($$$) { return undef; } +sub package_not_wholly_new_sshpsql ($$$) { return undef; } #---------- `dummycat' archive query method ---------- @@ -1541,6 +1603,7 @@ sub archive_query_dummycat ($$) { } sub file_in_archive_dummycat () { return undef; } +sub package_not_wholly_new_dummycat () { return undef; } #---------- tag format handling ---------- @@ -1871,13 +1934,6 @@ sub is_orig_file_in_dsc ($$) { return 1; } -sub is_orig_file_of_vsn ($$) { - my ($f, $upstreamvsn) = @_; - my $base = srcfn $upstreamvsn, ''; - return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/; - return 1; -} - # This function determines whether a .changes file is source-only from # the point of view of dak. Thus, it permits *_source.buildinfo # files. @@ -2013,28 +2069,6 @@ sub make_commit ($) { return cmdoutput @git, qw(hash-object -w -t commit), $file; } -sub make_commit_text ($) { - my ($text) = @_; - my ($out, $in); - my @cmd = (@git, qw(hash-object -w -t commit --stdin)); - debugcmd "|",@cmd; - print Dumper($text) if $debuglevel > 1; - my $child = open2($out, $in, @cmd) or die $!; - my $h; - eval { - print $in $text or die $!; - close $in or die $!; - $h = <$out>; - $h =~ m/^\w+$/ or die; - $h = $&; - printdebug "=> $h\n"; - }; - close $out; - waitpid $child, 0 == $child or die "$child $!"; - $? and failedcmd @cmd; - return $h; -} - sub clogp_authline ($) { my ($clogp) = @_; my $author = getfield $clogp, 'Maintainer'; @@ -2130,7 +2164,7 @@ sub generate_commits_from_dsc () { foreach my $fi (@dfi) { my $f = $fi->{Filename}; die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#; - my $upper_f = "$maindir/../$f"; + my $upper_f = (bpd_abs()."/$f"); printdebug "considering reusing $f: "; @@ -2138,12 +2172,12 @@ sub generate_commits_from_dsc () { printdebug "linked (using ...,fetch).\n"; } elsif ((printdebug "($!) "), $! != ENOENT) { - fail "accessing ../$f,fetch: $!"; + fail "accessing $buildproductsdir/$f,fetch: $!"; } elsif (link_ltarget $upper_f, $f) { printdebug "linked.\n"; } elsif ((printdebug "($!) "), $! != ENOENT) { - fail "accessing ../$f: $!"; + fail "accessing $buildproductsdir/$f: $!"; } else { printdebug "absent.\n"; } @@ -2158,14 +2192,14 @@ sub generate_commits_from_dsc () { printdebug "linked.\n"; } elsif ((printdebug "($!) "), $! != EEXIST) { - fail "saving ../$f: $!"; + fail "saving $buildproductsdir/$f: $!"; } elsif (!$refetched) { printdebug "no need.\n"; } elsif (link $f, "$upper_f,fetch") { printdebug "linked (using ...,fetch).\n"; } elsif ((printdebug "($!) "), $! != EEXIST) { - fail "saving ../$f,fetch: $!"; + fail "saving $buildproductsdir/$f,fetch: $!"; } else { printdebug "cannot.\n"; } @@ -2309,22 +2343,14 @@ sub generate_commits_from_dsc () { } my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all); - debugcmd "|",@clogcmd; - open CLOGS, "-|", @clogcmd or die $!; - my $clogp; my $r1clogp; printdebug "import clog search...\n"; + parsechangelog_loop \@clogcmd, "package changelog", sub { + my ($thisstanza, $desc) = @_; + no warnings qw(exiting); - for (;;) { - my $stanzatext = do { local $/=""; ; }; - printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1; - last if !defined $stanzatext; - - my $desc = "package changelog, entry no.$."; - open my $stanzafh, "<", \$stanzatext or die; - my $thisstanza = parsecontrolfh $stanzafh, $desc, 1; $clogp //= $thisstanza; printdebug "import clog $thisstanza->{version} $desc...\n"; @@ -2350,7 +2376,7 @@ sub generate_commits_from_dsc () { # version). Then it remains to choose between the physically # last entry in the file, and the one with the lowest version # number. If these are not the same, we guess that the - # versions were created in a non-monotic order rather than + # versions were created in a non-monotonic order rather than # that the changelog entries have been misordered. printdebug "import clog $thisstanza->{version} vs $upstreamv...\n"; @@ -2359,9 +2385,7 @@ sub generate_commits_from_dsc () { $r1clogp = $thisstanza; printdebug "import clog $r1clogp->{version} becomes r1\n"; - } - die $! if CLOGS->error; - close CLOGS or $?==SIGPIPE or failedcmd @clogcmd; + }; $clogp or fail "package changelog has no entries!"; @@ -2602,7 +2626,7 @@ sub ensure_we_have_orig () { foreach my $fi (@dfi) { my $f = $fi->{Filename}; next unless is_orig_file_in_dsc($f, \@dfi); - complete_file_from_dsc('..', $fi) + complete_file_from_dsc($buildproductsdir, $fi) or next; } } @@ -3218,10 +3242,7 @@ END # here we go, then: my $tree_commit = $mergeinputs[0]{Commit}; - my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit; - $tree =~ m/\n\n/; $tree = $`; - $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?"; - $tree = $1; + my $tree = get_tree_of_commit $tree_commit;; # We use the changelog author of the package in question the # author of this pseudo-merge. This is (roughly) correct if @@ -3489,7 +3510,7 @@ END sub multisuite_suite_child ($$$) { - my ($tsuite, $merginputs, $fn) = @_; + my ($tsuite, $mergeinputs, $fn) = @_; # in child, sets things up, calls $fn->(), and returns undef # in parent, returns canonical suite name for $tsuite my $canonsuitefh = IO::File::new_tmpfile; @@ -3516,7 +3537,7 @@ sub multisuite_suite_child ($$$) { return $csuite; } printdebug "multisuite $tsuite ok (canon=$csuite)\n"; - push @$merginputs, { + push @$mergeinputs, { Ref => lrref, Info => $csuite, }; @@ -3557,10 +3578,9 @@ sub fork_for_multisuite ($) { my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs, sub { @end = (); - fetch(); + fetch_one(); finish 0; }); - # xxx collecte the ref here $csubsuite =~ s/^\Q$cbasesuite\E-/-/; push @csuites, $csubsuite; @@ -3715,7 +3735,7 @@ sub clone ($) { clone_finish($dstdir); } -sub fetch () { +sub fetch_one () { canonicalise_suite(); if (check_for_git()) { git_fetch_us(); @@ -3738,10 +3758,14 @@ END printdone "fetched into ".lrref(); } -sub pull () { +sub dofetch () { my $multi_fetched = fork_for_multisuite(sub { }); - fetch() unless $multi_fetched; # parent - return if $multi_fetched eq '0'; # child + fetch_one() unless $multi_fetched; # parent + finish 0 if $multi_fetched eq '0'; # child +} + +sub pull () { + dofetch(); runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]", lrref(); printdone "fetched to ".lrref()." and merged into HEAD"; @@ -3754,7 +3778,7 @@ sub check_not_dirty () { } } - return if $ignoredirty; + return if $includedirty; git_check_unmodified(); } @@ -3775,11 +3799,11 @@ sub quiltify_nofix_bail ($$) { } sub commit_quilty_patch () { - my $output = cmdoutput @git, qw(status --porcelain); + my $output = cmdoutput @git, qw(status --ignored --porcelain); my %adds; foreach my $l (split /\n/, $output) { next unless $l =~ m/\S/; - if ($l =~ m{^(?:\?\?| [MADRC]) (.pc|debian/patches)}) { + if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) { $adds{$1}++; } } @@ -3847,13 +3871,14 @@ sub madformat_wantfixup ($) { sub maybe_split_brain_save ($$$) { my ($headref, $dgitview, $msg) = @_; # => message fragment "$saved" describing disposition of $dgitview - return "commit id $dgitview" unless defined $split_brain_save; + my $save = $internal_object_save{'dgit-view'}; + return "commit id $dgitview" unless defined $save; my @cmd = (shell_cmd 'cd "$1"; shift', $maindir, git_update_ref_cmd "dgit --dgit-view-save $msg HEAD=$headref", - $split_brain_save, $dgitview); + $save, $dgitview); runcmd @cmd; - return "and left in $split_brain_save"; + return "and left in $save"; } # An "infopair" is a tuple [ $thing, $what ] @@ -4016,7 +4041,7 @@ sub splitbrain_pseudomerge ($$$$) { $@ =~ s/^\n//; chomp $@; print STDERR <{Files} =~ m{\.deb$}m; + my $sourceonlypolicy = access_cfg 'source-only-uploads'; + if ($sourceonlypolicy eq 'ok') { + } elsif ($sourceonlypolicy eq 'always') { + forceable_fail [qw(uploading-binaries)], + "uploading binaries, although distroy policy is source only" + if $hasdebs; + } elsif ($sourceonlypolicy eq 'never') { + forceable_fail [qw(uploading-source-only)], + "source-only upload, although distroy policy requires .debs" + if !$hasdebs; + } elsif ($sourceonlypolicy eq 'not-wholly-new') { + forceable_fail [qw(uploading-source-only)], + "source-only upload, even though package is entirely NEW\n". + "(this is contrary to policy in ".(access_nomdistro()).")" + if !$hasdebs + && $new_package + && !(archive_query('package_not_wholly_new', $package) // 1); + } else { + badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'"; + } + # Perhaps adjust .dsc to contain right set of origs changes_update_origs_from_dsc($dsc, $changes, $upstreamversion, $changesfile) @@ -4427,7 +4484,8 @@ END responder_send_command("param isuite $isuite"); responder_send_command("param tagformat $tagformat"); if (defined $maintviewhead) { - die unless ($protovsn//4) >= 4; + confess "internal error (protovsn=$protovsn)" + if defined $protovsn and $protovsn < 4; responder_send_command("param maint-view $maintviewhead"); } @@ -4502,9 +4560,8 @@ END supplementary_message(<<'END'); Push failed, while obtaining signatures on the .changes and .dsc. If it was just that the signature failed, you may try again by using -debsign by hand to sign the changes - $changesfile -and then dput to complete the upload. +debsign by hand to sign the changes file (see the command dgit tried, +above), and then dput that changes file to complete the upload. If you need to change the package, you must use a new version number. END if ($we_are_responder) { @@ -4597,11 +4654,15 @@ sub branchsuite () { } } -sub fetchpullargs () { +sub package_from_d_control () { if (!defined $package) { my $sourcep = parsecontrol('debian/control','debian/control'); $package = getfield $sourcep, 'Source'; } +} + +sub fetchpullargs () { + package_from_d_control(); if (@ARGV==0) { $isuite = branchsuite(); if (!$isuite) { @@ -4620,9 +4681,7 @@ sub fetchpullargs () { sub cmd_fetch { parseopts(); fetchpullargs(); - my $multi_fetched = fork_for_multisuite(sub { }); - finish 0 if $multi_fetched; - fetch(); + dofetch(); } sub cmd_pull { @@ -4637,6 +4696,40 @@ END pull(); } +sub cmd_checkout { + parseopts(); + package_from_d_control(); + @ARGV==1 or badusage "dgit checkout needs a suite argument"; + ($isuite) = @ARGV; + notpushing(); + + foreach my $canon (qw(0 1)) { + if (!$canon) { + $csuite= $isuite; + } else { + undef $csuite; + canonicalise_suite(); + } + if (length git_get_ref lref()) { + # local branch already exists, yay + last; + } + if (!length git_get_ref lrref()) { + if (!$canon) { + # nope + next; + } + dofetch(); + } + # now lrref exists + runcmd (@git, qw(update-ref), lref(), lrref(), ''); + last; + } + local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg + "dgit checkout $isuite"; + runcmd (@git, qw(checkout), lbranch()); +} + sub cmd_update_vcs_git () { my $specsuite; if (@ARGV==0 || $ARGV[0] =~ m/^-/) { @@ -4654,11 +4747,10 @@ sub cmd_update_vcs_git () { } } - my $sourcep = parsecontrol 'debian/control', 'debian/control'; - $package = getfield $sourcep, 'Source'; + package_from_d_control(); my $ctrl; if ($specsuite eq '.') { - $ctrl = $sourcep; + $ctrl = parsecontrol 'debian/control', 'debian/control'; } else { $isuite = $specsuite; get_archive_dsc(); @@ -4715,21 +4807,6 @@ sub cmd_push { dopush(); } -sub cmd_push_source { - prep_push(); - if ($changesfile) { - my $changes = parsecontrol("$buildproductsdir/$changesfile", - "source changes file"); - unless (test_source_only_changes($changes)) { - fail "user-specified changes file is not source-only"; - } - } else { - # Building a source package is very fast, so just do it - build_source_for_push(); - } - dopush(); -} - #---------- remote commands' implementation ---------- sub pre_remote_push_build_host { @@ -5223,7 +5300,7 @@ END print SERIES "\n" or die $! unless $newline eq "\n"; print SERIES "auto-gitignore\n" or die $!; close SERIES or die $!; - runcmd @git, qw(add -- debian/patches/series), $gipatch; + runcmd @git, qw(add -f -- debian/patches/series), $gipatch; commit_admin <>' - or die $!; - - my $oldcache = git_get_ref "refs/$splitbraincache"; - if ($oldcache eq $dgitview) { - my $tree = cmdoutput qw(git rev-parse), "$dgitview:"; - # git update-ref doesn't always update, in this case. *sigh* - my $dummy = make_commit_text < 1000000000 +0000 -committer Dgit 1000000000 +0000 - -Dummy commit - do not use -END - runcmd @git, qw(update-ref -m), "dgit $our_version - dummy", - "refs/$splitbraincache", $dummy; - } - runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache", - $dgitview; + reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview; changedir "$playground/work"; @@ -5396,13 +5451,20 @@ sub quiltify ($$$$) { }; if ($quilt_mode eq 'linear') { print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n"; + my $all_gdr = !!@nots; foreach my $notp (@nots) { print STDERR "$us: ", $reportnot->($notp), "\n"; + $all_gdr &&= $notp->{Child} && + (git_cat_file $notp->{Child}{Commit}, 'commit') + =~ m{^\[git-debrebase(?! split[: ]).*\]$}m; } - print STDERR "$us: $_\n" foreach @$failsuggestion; + print STDERR "\n"; + $failsuggestion = + [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ] + if $all_gdr; + print STDERR "$us: $_->[1]\n" foreach @$failsuggestion; fail - "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n". - "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch"; + "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n"; } elsif ($quilt_mode eq 'smash') { } elsif ($quilt_mode eq 'auto') { progress "quilt fixup cannot be linear, smashing..."; @@ -5556,7 +5618,7 @@ END if ($quilt_mode eq 'linear' && !$fopts->{'single-debian-patch'} - && branch_is_gdr($symref, $headref)) { + && branch_is_gdr($headref)) { # This is much faster. It also makes patches that gdr # likes better for future updates without laundering. # @@ -5591,14 +5653,12 @@ END quilt_fixup_multipatch($clogp, $headref, $upstreamversion); } - die 'bug' if $split_brain && !$need_split_build_invocation; - changedir $maindir; runcmd_ordryrun_local @git, qw(pull --ff-only -q), "$playground/work", qw(master); } -sub quilt_fixup_mkwork ($) { +sub unpack_playtree_mkwork ($) { my ($headref) = @_; mkdir "work" or die $!; @@ -5607,12 +5667,14 @@ sub quilt_fixup_mkwork ($) { runcmd @git, qw(reset -q --hard), $headref; } -sub quilt_fixup_linkorigs ($$) { +sub unpack_playtree_linkorigs ($$) { my ($upstreamversion, $fn) = @_; # calls $fn->($leafname); - foreach my $f (<$maindir/../*>) { #/){ - my $b=$f; $b =~ s{.*/}{}; + my $bpd_abs = bpd_abs(); + opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!"; + while ($!=0, defined(my $b = readdir QFD)) { + my $f = bpd_abs()."/".$b; { local ($debuglevel) = $debuglevel-1; printdebug "QF linkorigs $b, $f ?\n"; @@ -5622,6 +5684,8 @@ sub quilt_fixup_linkorigs ($$) { link_ltarget $f, $b or die "$b $!"; $fn->($b); } + die "$buildproductsdir: $!" if $!; + closedir QFD; } sub quilt_fixup_delete_pc () { @@ -5643,8 +5707,8 @@ sub quilt_fixup_singlepatch ($$$) { # get it to generate debian/patches/debian-changes, it is # necessary to build the source package. - quilt_fixup_linkorigs($upstreamversion, sub { }); - quilt_fixup_mkwork($headref); + unpack_playtree_linkorigs($upstreamversion, sub { }); + unpack_playtree_mkwork($headref); rmtree("debian/patches"); @@ -5684,7 +5748,7 @@ END print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!; }; - quilt_fixup_linkorigs($upstreamversion, $dscaddfile); + unpack_playtree_linkorigs($upstreamversion, $dscaddfile); my @files=qw(debian/source/format debian/rules debian/control debian/changelog); @@ -5701,6 +5765,31 @@ END close $fakedsc or die $!; } +sub quilt_fakedsc2unapplied ($$) { + my ($headref, $upstreamversion) = @_; + # must be run in the playground + # quilt_make_fake_dsc must have been called + + runcmd qw(sh -ec), + 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null'; + + my $fakexdir= $package.'-'.(stripepoch $upstreamversion); + rename $fakexdir, "fake" or die "$fakexdir $!"; + + changedir 'fake'; + + remove_stray_gits("source package"); + mktree_in_ud_here(); + + rmtree '.pc'; + + rmtree 'debian'; # git checkout commitish paths does not delete! + runcmd @git, qw(checkout -f), $headref, qw(-- debian); + my $unapplied=git_add_write_tree(); + printdebug "fake orig tree object $unapplied\n"; + return $unapplied; +} + sub quilt_check_splitbrain_cache ($$) { my ($headref, $upstreamversion) = @_; # Called only if we are in (potentially) split brain mode. @@ -5732,27 +5821,13 @@ sub quilt_check_splitbrain_cache ($$) { push @cachekey, $srcshash->hexdigest(); $splitbrain_cachekey = "@cachekey"; - my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs', - $splitbraincache); printdebug "splitbrain cachekey $splitbrain_cachekey\n"; - debugcmd "|(probably)",@cmd; - my $child = open GC, "-|"; defined $child or die $!; - if (!$child) { - chdir $maindir or die $!; - if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") { - $! == ENOENT or die $!; - printdebug ">(no reflog)\n"; - finish 0; - } - exec @cmd; die $!; - } - while () { - chomp; - printdebug ">| ", $_, "\n" if $debuglevel > 1; - next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey; - - my $cachehit = $1; - quilt_fixup_mkwork($headref); + + my $cachehit = reflog_cache_lookup + "refs/$splitbraincache", $splitbrain_cachekey; + + if ($cachehit) { + unpack_playtree_mkwork($headref); my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit"; if ($cachehit ne $headref) { progress "dgit view: found cached ($saved)"; @@ -5763,8 +5838,6 @@ sub quilt_check_splitbrain_cache ($$) { progress "dgit view: found cached, no changes required"; return ($headref, $splitbrain_cachekey); } - die $! if GC->error; - failedcmd unless close GC; printdebug "splitbrain cache miss\n"; return (undef, $splitbrain_cachekey); @@ -5854,24 +5927,7 @@ sub quilt_fixup_multipatch ($$$) { quilt_check_splitbrain_cache($headref, $upstreamversion); return if $cachehit; } - - runcmd qw(sh -ec), - 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null'; - - my $fakexdir= $package.'-'.(stripepoch $upstreamversion); - rename $fakexdir, "fake" or die "$fakexdir $!"; - - changedir 'fake'; - - remove_stray_gits("source package"); - mktree_in_ud_here(); - - rmtree '.pc'; - - rmtree 'debian'; # git checkout commitish paths does not delete! - runcmd @git, qw(checkout -f), $headref, qw(-- debian); - my $unapplied=git_add_write_tree(); - printdebug "fake orig tree object $unapplied\n"; + my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion); ensuredir '.pc'; @@ -5883,13 +5939,13 @@ sub quilt_fixup_multipatch ($$$) { failed to apply your git tree's patch stack (from debian/patches/) to the corresponding upstream tarball(s). Your source tree and .orig are probably too inconsistent. dgit can only fix up certain kinds of - anomaly (depending on the quilt mode). See --quilt= in dgit(1). + anomaly (depending on the quilt mode). Please see --quilt= in dgit(1). END } changedir '..'; - quilt_fixup_mkwork($headref); + unpack_playtree_mkwork($headref); my $mustdeletepc=0; if (stat_exists ".pc") { @@ -5949,12 +6005,21 @@ END my @failsuggestion; if (!($diffbits->{O2H} & $diffbits->{O2A})) { - push @failsuggestion, "This might be a patches-unapplied branch."; - } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) { - push @failsuggestion, "This might be a patches-applied branch."; + push @failsuggestion, [ 'unapplied', + "This might be a patches-unapplied branch." ]; + } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) { + push @failsuggestion, [ 'applied', + "This might be a patches-applied branch." ]; } - push @failsuggestion, "Maybe you need to specify one of". - " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?"; + push @failsuggestion, [ 'quilt-mode', + "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ]; + + push @failsuggestion, [ 'gitattrs', + "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ] + if stat_exists '.gitattributes'; + + push @failsuggestion, [ 'origs', + "Maybe orig tarball(s) are not identical to git representation?" ]; if (quiltmode_splitbrain()) { quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree, @@ -6061,6 +6126,10 @@ sub cmd_clean () { maybe_unapply_patches_again(); } +# return values from massage_dbp_args are one or both of these flags +sub WANTSRC_SOURCE () { 01; } # caller should build source (separately) +sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage + sub build_or_push_prep_early () { our $build_or_push_prep_early_done //= 0; return if $build_or_push_prep_early_done++; @@ -6069,6 +6138,7 @@ sub build_or_push_prep_early () { $isuite = getfield $clogp, 'Distribution'; $package = getfield $clogp, 'Source'; $version = getfield $clogp, 'Version'; + $dscfn = dscfn($version); } sub build_prep_early () { @@ -6077,9 +6147,12 @@ sub build_prep_early () { check_not_dirty(); } -sub build_prep () { +sub build_prep ($) { + my ($wantsrc) = @_; build_prep_early(); - clean_tree(); + # clean the tree if we're trying to include dirty changes in the + # source package, or we are running the builder in $maindir + clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER); build_maybe_quilt_fixup(); if ($rmchanges) { my $pat = changespat $version; @@ -6138,28 +6211,11 @@ sub changesopts () { sub massage_dbp_args ($;$) { my ($cmd,$xargs) = @_; - # We need to: - # - # - if we're going to split the source build out so we can - # do strange things to it, massage the arguments to dpkg-buildpackage - # so that the main build doessn't build source (or add an argument - # to stop it building source by default). - # - # - add -nc to stop dpkg-source cleaning the source tree, - # unless we're not doing a split build and want dpkg-source - # as cleanmode, in which case we can do nothing - # - # return values: - # 0 - source will NOT need to be built separately by caller - # +1 - source will need to be built separately by caller - # +2 - source will need to be built separately by caller AND - # dpkg-buildpackage should not in fact be run at all! + # Since we split the source build out so we can do strange things + # to it, massage the arguments to dpkg-buildpackage so that the + # main build doessn't build source (or add an argument to stop it + # building source by default). debugcmd '#massaging#', @$cmd if $debuglevel>1; -#print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation); - if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) { - $clean_using_builder = 1; - return 0; - } # -nc has the side effect of specifying -b if nothing else specified # and some combinations of -S, -b, et al, are errors, rather than # later simply overriding earlie. So we need to: @@ -6174,35 +6230,34 @@ sub massage_dbp_args ($;$) { } push @$cmd, '-nc'; #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode); - my $r = 0; - if ($need_split_build_invocation) { - printdebug "massage split $dmode.\n"; - $r = $dmode =~ m/[S]/ ? +2 : - $dmode =~ y/gGF/ABb/ ? +1 : - $dmode =~ m/[ABb]/ ? 0 : - die "$dmode ?"; - } + my $r = WANTSRC_BUILDER; + printdebug "massage split $dmode.\n"; + $r = $dmode =~ m/[S]/ ? WANTSRC_SOURCE : + $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER : + $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER : + die "$dmode ?"; printdebug "massage done $r $dmode.\n"; push @$cmd, $dmode; #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r); return $r; } -sub in_parent (&) { +sub in_bpd (&) { my ($fn) = @_; my $wasdir = must_getcwd(); - changedir ".."; + changedir $buildproductsdir; $fn->(); changedir $wasdir; } -sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent) +# this sub must run with CWD=$buildproductsdir (eg in in_bpd) +sub postbuild_mergechanges ($) { my ($msg_if_onlyone) = @_; # If there is only one .changes file, fail with $msg_if_onlyone, # or if that is undef, be a no-op. # Returns the changes file to report to the user. my $pat = changespat $version; - my @changesfiles = glob $pat; + my @changesfiles = grep { !m/_multi\.changes/ } glob $pat; @changesfiles = sort { ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/) or $a cmp $b @@ -6238,8 +6293,11 @@ END sub midbuild_checkchanges () { my $pat = changespat $version; return if $rmchanges; - my @unwanted = map { s#^\.\./##; $_; } glob "../$pat"; - @unwanted = grep { $_ ne changespat $version,'source' } @unwanted; + my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat"; + @unwanted = grep { + $_ ne changespat $version,'source' and + $_ ne changespat $version,'multi' + } @unwanted; fail < 0) { + build_prep($wantsrc); + if ($wantsrc & WANTSRC_SOURCE) { build_source(); midbuild_checkchanges_vanilla $wantsrc; - } else { - build_prep(); } - if ($wantsrc < 2) { + if ($wantsrc & WANTSRC_BUILDER) { push @dbp, changesopts_version(); maybe_apply_patches_dirtily(); runcmd_ordryrun_local @dbp; @@ -6297,12 +6358,11 @@ sub cmd_gbp_build { # orig is absent. my $upstreamversion = upstreamversion $version; my $origfnpat = srcfn $upstreamversion, '.orig.tar.*'; - my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat"); + my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat"); if ($gbp_make_orig) { clean_tree(); $cleanmode = 'none'; # don't do it again - $need_split_build_invocation = 1; } my @dbp = @dpkgbuildpackage; @@ -6316,7 +6376,7 @@ sub cmd_gbp_build { $gbp_build[0] = 'gbp buildpackage'; } } - my @cmd = opts_opt_multi_cmd @gbp_build; + my @cmd = opts_opt_multi_cmd [], @gbp_build; push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=".(shellquote @dbp)); @@ -6340,17 +6400,17 @@ sub cmd_gbp_build { } } - if ($wantsrc > 0) { + build_prep($wantsrc); + if ($wantsrc & WANTSRC_SOURCE) { build_source(); midbuild_checkchanges_vanilla $wantsrc; } else { if (!$clean_using_builder) { push @cmd, '--git-cleaner=true'; } - build_prep(); } maybe_unapply_patches_again(); - if ($wantsrc < 2) { + if ($wantsrc & WANTSRC_BUILDER) { push @cmd, changesopts(); runcmd_ordryrun_local @cmd, @ARGV; } @@ -6358,77 +6418,158 @@ sub cmd_gbp_build { } sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0 -sub build_source_for_push { - build_source(); - maybe_unapply_patches_again(); - $changesfile = $sourcechanges; +sub building_source_in_playtree { + # If $includedirty, we have to build the source package from the + # working tree, not a playtree, so that uncommitted changes are + # included (copying or hardlinking them into the playtree could + # cause trouble). + # + # Note that if we are building a source package in split brain + # mode we do not support including uncommitted changes, because + # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is + # building a source package)) => !$includedirty + return !$includedirty; } sub build_source { - build_prep_early(); - build_prep(); $sourcechanges = changespat $version,'source'; if (act_local()) { - unlink "../$sourcechanges" or $!==ENOENT + unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT or fail "remove $sourcechanges: $!"; } - $dscfn = dscfn($version); my @cmd = (@dpkgsource, qw(-b --)); - if ($split_brain) { + my $leafdir; + if (building_source_in_playtree()) { + $leafdir = 'work'; + my $headref = git_rev_parse('HEAD'); + # If we are in split brain, there is already a playtree with + # the thing we should package into a .dsc (thanks to quilt + # fixup). If not, make a playtree + prep_ud() unless $split_brain; changedir $playground; - runcmd_ordryrun_local @cmd, "work"; - my @udfiles = <${package}_*>; - changedir $maindir; - foreach my $f (@udfiles) { - printdebug "source copy, found $f\n"; - next unless - $f eq $dscfn or - ($f =~ m/\.debian\.tar(?:\.\w+)$/ && - $f eq srcfn($version, $&)); - printdebug "source copy, found $f - renaming\n"; - rename "$playground/$f", "../$f" or $!==ENOENT - or fail "put in place new source file ($f): $!"; + unless ($split_brain) { + my $upstreamversion = upstreamversion $version; + unpack_playtree_linkorigs($upstreamversion, sub { }); + unpack_playtree_mkwork($headref); + changedir '..'; } } else { - my $pwd = must_getcwd(); - my $leafdir = basename $pwd; - changedir ".."; - runcmd_ordryrun_local @cmd, $leafdir; - changedir $pwd; + $leafdir = basename $maindir; + changedir '..'; } + runcmd_ordryrun_local @cmd, $leafdir; + + changedir $leafdir; runcmd_ordryrun_local qw(sh -ec), - 'exec >$1; shift; exec "$@"','x', - "../$sourcechanges", + 'exec >../$1; shift; exec "$@"','x', $sourcechanges, @dpkggenchanges, qw(-S), changesopts(); + changedir '..'; + + printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n"; + $dsc = parsecontrol($dscfn, "source package"); + + my $mv = sub { + my ($why, $l) = @_; + printdebug " renaming ($why) $l\n"; + rename "$l", bpd_abs()."/$l" + or fail "put in place new built file ($l): $!"; + }; + foreach my $l (split /\n/, getfield $dsc, 'Files') { + $l =~ m/\S+$/ or next; + $mv->('Files', $&); + } + $mv->('dsc', $dscfn); + $mv->('changes', $sourcechanges); + + changedir $maindir; } sub cmd_build_source { - build_prep_early(); badusage "build-source takes no additional arguments" if @ARGV; + build_prep(WANTSRC_SOURCE); build_source(); maybe_unapply_patches_again(); printdone "source built, results in $dscfn and $sourcechanges"; } -sub cmd_sbuild { +sub cmd_push_source { + prep_push(); + fail "dgit push-source: --include-dirty/--ignore-dirty does not make". + "sense with push-source!" if $includedirty; + build_maybe_quilt_fixup(); + if ($changesfile) { + my $changes = parsecontrol("$buildproductsdir/$changesfile", + "source changes file"); + unless (test_source_only_changes($changes)) { + fail "user-specified changes file is not source-only"; + } + } else { + # Building a source package is very fast, so just do it + build_source(); + die "er, patches are applied dirtily but shouldn't be.." + if $patches_applied_dirtily; + $changesfile = $sourcechanges; + } + dopush(); +} + +sub binary_builder { + my ($bbuilder, $pbmc_msg, @args) = @_; + build_prep(WANTSRC_SOURCE); build_source(); midbuild_checkchanges(); - in_parent { + in_bpd { if (act_local()) { - stat_exists $dscfn or fail "$dscfn (in parent directory): $!"; + stat_exists $dscfn or fail "$dscfn (in build products dir): $!"; stat_exists $sourcechanges - or fail "$sourcechanges (in parent directory): $!"; + or fail "$sourcechanges (in build products dir): $!"; } - runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn; + runcmd_ordryrun_local @$bbuilder, @args; }; maybe_unapply_patches_again(); - in_parent { - postbuild_mergechanges(<{Filename}; - my $here = "../$f"; + my $here = "$buildproductsdir/$f"; if (lstat $here) { next if stat $here; fail "lstat $here works but stat gives $! !"; @@ -6819,9 +6978,9 @@ sub parseopts () { } elsif (m/^--(gbp|dpm)$/s) { push @ropts, "--quilt=$1"; $quilt_mode = $1; - } elsif (m/^--ignore-dirty$/s) { + } elsif (m/^--(?:ignore|include)-dirty$/s) { push @ropts, $_; - $ignoredirty = 1; + $includedirty = 1; } elsif (m/^--no-quilt-fixup$/s) { push @ropts, $_; $quilt_mode = 'nocheck'; @@ -6840,10 +6999,13 @@ sub parseopts () { } elsif (m/^--delayed=(\d+)$/s) { push @ropts, $_; push @dput, $_; - } elsif (m/^--dgit-view-save=(.+)$/s) { + } elsif (my ($k,$v) = + m/^--save-(dgit-view)=(.+)$/s || + m/^--(dgit-view)-save=(.+)$/s + ) { push @ropts, $_; - $split_brain_save = $1; - $split_brain_save =~ s#^(?!refs/)#refs/heads/#; + $v =~ s#^(?!refs/)#refs/heads/#; + $internal_object_save{$k} = $v; } elsif (m/^--(no-)?rm-old-changes$/s) { push @ropts, $_; $rmchanges = !$1; @@ -6863,10 +7025,6 @@ sub parseopts () { push @ropts, $_; $tagformat_want = [ $1, 'command line', 1 ]; # 1 menas overrides distro configuration - } elsif (m/^--always-split-source-build$/s) { - # undocumented, for testing - push @ropts, $_; - $need_split_build_invocation = 1; } elsif (m/^--config-lookup-explode=(.+)$/s) { # undocumented, for testing push @ropts, $_; @@ -6947,8 +7105,8 @@ sub check_env_sanity () { foreach my $name (qw(PIPE CHLD)) { my $signame = "SIG$name"; my $signum = eval "POSIX::$signame" // die; - ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or - die "$signame is set to something other than SIG_DFL\n"; + die "$signame is set to something other than SIG_DFL\n" + if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT'; $blocked->ismember($signum) and die "$signame is blocked\n"; } @@ -7020,7 +7178,8 @@ sub parseopts_late_defaults () { $$vr = $v; } - $need_split_build_invocation ||= quiltmode_splitbrain(); + fail "dgit: --include-dirty is not supported in split view quilt mode" + if $split_brain && $includedirty; if (!defined $cleanmode) { local $access_forpush; @@ -7030,6 +7189,11 @@ sub parseopts_late_defaults () { badcfg "unknown clean-mode \`$cleanmode'" unless $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s; } + + $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF'); + $buildproductsdir //= '..'; + $bpd_glob = $buildproductsdir; + $bpd_glob =~ s#[][\\{}*?~]#\\$&#g; } if ($ENV{$fakeeditorenv}) {