X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=ea74cad71b04284b045a8d5a3e74641425e8335d;hp=4e43d21ddf9d07583bb64d69123ae54745b83faa;hb=e439ec13f6645a1f84b31cc09bfa5e6fbc1b8fc2;hpb=f0599eec2a9ca6691de636c89a339572d38250d4 diff --git a/dgit b/dgit index 4e43d21d..ea74cad7 100755 --- a/dgit +++ b/dgit @@ -78,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; @@ -100,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'; @@ -116,7 +113,7 @@ our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L)); our (@dput) = qw(dput); our (@debsign) = qw(debsign); our (@gpg) = qw(gpg); -our (@sbuild) = qw(sbuild); +our (@sbuild) = (qw(sbuild --no-source)); our (@ssh) = 'ssh'; our (@dgit) = qw(dgit); our (@git_debrebase) = qw(git-debrebase); @@ -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(''); @@ -300,6 +289,14 @@ sub bpd_abs () { 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) = @@ -311,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: @@ -1089,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"; @@ -1867,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. @@ -2009,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'; @@ -3204,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 @@ -3475,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; @@ -3502,7 +3537,7 @@ sub multisuite_suite_child ($$$) { return $csuite; } printdebug "multisuite $tsuite ok (canon=$csuite)\n"; - push @$merginputs, { + push @$mergeinputs, { Ref => lrref, Info => $csuite, }; @@ -3546,7 +3581,6 @@ sub fork_for_multisuite ($) { fetch_one(); finish 0; }); - # xxx collecte the ref here $csubsuite =~ s/^\Q$cbasesuite\E-/-/; push @csuites, $csubsuite; @@ -3837,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 ] @@ -4275,6 +4310,15 @@ END my $actualhead = git_rev_parse('HEAD'); if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) { + if (quiltmode_splitbrain()) { + my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead); + fail <>' - 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"; @@ -5430,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..."; @@ -5590,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. # @@ -5737,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. @@ -5768,26 +5821,12 @@ 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; + + 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) { @@ -5799,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); @@ -5890,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'; @@ -5985,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, @@ -6197,16 +6226,27 @@ sub massage_dbp_args ($;$) { my $dmode = '-F'; foreach my $l ($cmd, $xargs) { next unless $l; - @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l; + @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l; } push @$cmd, '-nc'; #print STDERR "MASS1 ",Dumper($cmd, $xargs, $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 ?"; + if ($dmode =~ s/^--build=//) { + $r = 0; + my @d = split /,/, $dmode; + $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d; + $r |= WANTSRC_SOURCE if grep { s/^source$// } @d; + $r |= WANTSRC_BUILDER if grep { m/./ } @d; + fail "Wanted to build nothing!" unless $r; + $dmode = '--build='. join ',', grep m/./, @d; + } else { + $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); @@ -6295,9 +6335,10 @@ sub postbuild_mergechanges_vanilla ($) { sub cmd_build { build_prep_early(); $buildproductsdir eq '..' or print STDERR <