X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=e05c57436d7f06d9c6f298d5039436e4d1544601;hb=573bb223c92c66b367114a0d1238be35013cdba2;hp=d3b2ec7ee5cfde2e9c36d05efa6fba4d340a8ef8;hpb=140e8c84b7e36eacbf9802c8a04f40eb32ef59ce;p=dgit.git diff --git a/dgit b/dgit index d3b2ec7e..e05c5743 100755 --- a/dgit +++ b/dgit @@ -36,6 +36,7 @@ use Digest::SHA; use Digest::MD5; use List::Util qw(any); use List::MoreUtils qw(pairwise); +use Carp; use Debian::Dgit; @@ -62,8 +63,9 @@ our $existing_package = 'dpkg'; our $cleanmode; our $changes_since_version; our $rmchanges; +our $overwrite_version; # undef: not specified; '': check changelog our $quilt_mode; -our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|unapplied'; +our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied'; our $we_are_responder; our $initiator_tempdir; our $patches_applied_dirtily = 00; @@ -75,6 +77,9 @@ 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 = 'orig(?:-[-0-9a-z]+)?'; +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'; @@ -148,6 +153,8 @@ sub debiantag_maintview ($$) { return "$distro/$v"; } +sub madformat ($) { $_[0] eq '3.0 (quilt)' } + sub lbranch () { return "$branchprefix/$csuite"; } my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$'; sub lref () { return "refs/heads/".lbranch(); } @@ -157,6 +164,27 @@ sub rrref () { return server_ref($csuite); } sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; } sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); } +# We fetch some parts of lrfetchrefs/*. Ideally we delete these +# locally fetched refs because they have unhelpful names and clutter +# up gitk etc. So we track whether we have "used up" head ref (ie, +# whether we have made another local ref which refers to this object). +# +# (If we deleted them unconditionally, then we might end up +# re-fetching the same git objects each time dgit fetch was run.) +# +# So, leach use of lrfetchrefs needs to be accompanied by arrangements +# in git_fetch_us to fetch the refs in question, and possibly a call +# to lrfetchref_used. + +our (%lrfetchrefs_f, %lrfetchrefs_d); +# $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid + +sub lrfetchref_used ($) { + my ($fullrefname) = @_; + my $objid = $lrfetchrefs_f{$fullrefname}; + $lrfetchrefs_d{$fullrefname} = $objid if defined $objid; +} + sub stripepoch ($) { my ($vsn) = @_; $vsn =~ s/^\d+\://; @@ -200,7 +228,7 @@ sub no_such_package () { sub changedir ($) { my ($newdir) = @_; printdebug "CD $newdir\n"; - chdir $newdir or die "chdir: $newdir: $!"; + chdir $newdir or confess "chdir: $newdir: $!"; } sub deliberately ($) { @@ -511,11 +539,16 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit.default.archive-query' => 'madison:', 'dgit.default.sshpsql-dbname' => 'service=projectb', 'dgit.default.dgit-tag-format' => 'old,new,maint', + # old means "repo server accepts pushes with old dgit tags" + # new means "repo server accepts pushes with new dgit tags" + # maint means "repo server accepts split brain pushes" + # hist means "repo server may have old pushes without new tag" + # ("hist" is implied by "old") 'dgit-distro.debian.archive-query' => 'ftpmasterapi:', 'dgit-distro.debian.git-check' => 'url', 'dgit-distro.debian.git-check-suffix' => '/info/refs', 'dgit-distro.debian.new-private-pushers' => 't', - 'dgit-distro.debian.dgit-tag-format' => 'old', + 'dgit-distro.debian.dgit-tag-format' => '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', @@ -844,11 +877,11 @@ sub getfield ($$) { my ($dctrl,$field) = @_; my $v = $dctrl->{$field}; return $v if defined $v; - fail "missing field $field in ".$v->get_option('name'); + fail "missing field $field in ".$dctrl->get_option('name'); } sub parsechangelog { - my $c = Dpkg::Control::Hash->new(); + my $c = Dpkg::Control::Hash->new(name => 'parsed changelog'); my $p = new IO::Handle; my @cmd = (qw(dpkg-parsechangelog), @_); open $p, '-|', @cmd or die $!; @@ -857,6 +890,19 @@ sub parsechangelog { return $c; } +sub commit_getclogp ($) { + # Returns the parsed changelog hashref for a particular commit + my ($objid) = @_; + our %commit_getclogp_memo; + my $memo = $commit_getclogp_memo{$objid}; + return $memo if $memo; + mkpath '.git/dgit'; + my $mclog = ".git/dgit/clog-$objid"; + runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob), + "$objid:debian/changelog"; + $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog"); +} + sub must_getcwd () { my $d = getcwd(); defined $d or fail "getcwd failed: $!"; @@ -1158,7 +1204,7 @@ sub select_tagformat () { die 'bug' if $tagformatfn && $tagformat_want; # ... $tagformat_want assigned after previous select_tagformat - my (@supported) = grep { $_ ne 'maint' } access_cfg_tagformats(); + my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats(); printdebug "select_tagformat supported @supported\n"; $tagformat_want //= [ $supported[0], "distro access configuration", 0 ]; @@ -1304,6 +1350,7 @@ sub prep_ud (;$) { sub mktree_in_ud_here () { runcmd qw(git init -q); + runcmd qw(git config gc.auto 0); rmtree('.git/objects'); symlink '../../../../objects','.git/objects' or die $!; } @@ -1330,20 +1377,25 @@ sub remove_stray_gits () { $!=0; $?=0; close GITS or failedcmd @gitscmd; } -sub mktree_in_ud_from_only_subdir () { +sub mktree_in_ud_from_only_subdir (;$) { + my ($raw) = @_; + # changes into the subdir my (@dirs) = <*/.>; - die "@dirs ?" unless @dirs==1; + die "expected one subdir but found @dirs ?" unless @dirs==1; $dirs[0] =~ m#^([^/]+)/\.$# or die; my $dir = $1; changedir $dir; remove_stray_gits(); mktree_in_ud_here(); - my ($format, $fopts) = get_source_format(); - if (madformat($format)) { - rmtree '.pc'; + if (!$raw) { + my ($format, $fopts) = get_source_format(); + if (madformat($format)) { + rmtree '.pc'; + } } + runcmd @git, qw(add -Af); my $tree=git_write_tree(); return ($tree,$dir); @@ -1380,12 +1432,20 @@ sub dsc_files () { map { $_->{Filename} } dsc_files_info(); } -sub is_orig_file ($;$) { - local ($_) = $_[0]; - my $base = $_[1]; - m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0; - defined $base or return 1; - return $` eq $base; +sub is_orig_file_in_dsc ($$) { + my ($f, $dsc_files_info) = @_; + return 0 if @$dsc_files_info <= 1; + # One file means no origs, and the filename doesn't have a "what + # part of dsc" component. (Consider versions ending `.orig'.) + return 0 unless $f =~ m/\.$orig_f_tail_re$/o; + 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; } sub make_commit ($) { @@ -1393,6 +1453,28 @@ 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'; @@ -1474,7 +1556,8 @@ sub generate_commits_from_dsc () { prep_ud(); changedir $ud; - foreach my $fi (dsc_files_info()) { + my @dfi = dsc_files_info(); + foreach my $fi (@dfi) { my $f = $fi->{Filename}; die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#; @@ -1485,53 +1568,276 @@ sub generate_commits_from_dsc () { complete_file_from_dsc('.', $fi) or next; - if (is_orig_file($f)) { + if (is_orig_file_in_dsc($f, \@dfi)) { link $f, "../../../../$f" or $!==&EEXIST or die "$f $!"; } } + # We unpack and record the orig tarballs first, so that we only + # need disk space for one private copy of the unpacked source. + # But we can't make them into commits until we have the metadata + # from the debian/changelog, so we record the tree objects now and + # make them into commits later. + my @tartrees; + my $upstreamv = $dsc->{version}; + $upstreamv =~ s/-[^-]+$//; + my $orig_f_base = srcfn $upstreamv, ''; + + foreach my $fi (@dfi) { + # We actually import, and record as a commit, every tarball + # (unless there is only one file, in which case there seems + # little point. + + my $f = $fi->{Filename}; + printdebug "import considering $f "; + (printdebug "only one dfi\n"), next if @dfi == 1; + (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/; + (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o; + my $compr_ext = $1; + + my ($orig_f_part) = + $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/; + + printdebug "Y ", (join ' ', map { $_//"(none)" } + $compr_ext, $orig_f_part + ), "\n"; + + my $input = new IO::File $f, '<' or die "$f $!"; + my $compr_pid; + my @compr_cmd; + + if (defined $compr_ext) { + my $cname = + Dpkg::Compression::compression_guess_from_filename $f; + fail "Dpkg::Compression cannot handle file $f in source package" + if defined $compr_ext && !defined $cname; + my $compr_proc = + new Dpkg::Compression::Process compression => $cname; + my @compr_cmd = $compr_proc->get_uncompress_cmdline(); + my $compr_fh = new IO::Handle; + my $compr_pid = open $compr_fh, "-|" // die $!; + if (!$compr_pid) { + open STDIN, "<&", $input or die $!; + exec @compr_cmd; + die "dgit (child): exec $compr_cmd[0]: $!\n"; + } + $input = $compr_fh; + } + + rmtree "../unpack-tar"; + mkdir "../unpack-tar" or die $!; + my @tarcmd = qw(tar -x -f - + --no-same-owner --no-same-permissions + --no-acls --no-xattrs --no-selinux); + my $tar_pid = fork // die $!; + if (!$tar_pid) { + chdir "../unpack-tar" or die $!; + open STDIN, "<&", $input or die $!; + exec @tarcmd; + die "dgit (child): exec $tarcmd[0]: $!"; + } + $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!; + !$? or failedcmd @tarcmd; + + close $input or + (@compr_cmd ? failedcmd @compr_cmd + : die $!); + # finally, we have the results in "tarball", but maybe + # with the wrong permissions + + runcmd qw(chmod -R +rwX ../unpack-tar); + changedir "../unpack-tar"; + my ($tree) = mktree_in_ud_from_only_subdir(1); + changedir "../../unpack"; + rmtree "../unpack-tar"; + + my $ent = [ $f, $tree ]; + push @tartrees, { + Orig => !!$orig_f_part, + Sort => (!$orig_f_part ? 2 : + $orig_f_part =~ m/-/g ? 1 : + 0), + F => $f, + Tree => $tree, + }; + } + + @tartrees = sort { + # put any without "_" first (spec is not clear whether files + # are always in the usual order). Tarballs without "_" are + # the main orig or the debian tarball. + $a->{Sort} <=> $b->{Sort} or + $a->{F} cmp $b->{F} + } @tartrees; + + my $any_orig = grep { $_->{Orig} } @tartrees; + my $dscfn = "$package.dsc"; + my $treeimporthow = 'package'; + open D, ">", $dscfn or die "$dscfn: $!"; print D $dscdata or die "$dscfn: $!"; close D or die "$dscfn: $!"; my @cmd = qw(dpkg-source); push @cmd, '--no-check' if $dsc_checked; + if (madformat $dsc->{format}) { + push @cmd, '--skip-patches'; + $treeimporthow = 'unpatched'; + } push @cmd, qw(-x --), $dscfn; runcmd @cmd; my ($tree,$dir) = mktree_in_ud_from_only_subdir(); - check_for_vendor_patches() if madformat($dsc->{format}); - runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp'; - my $clogp = parsecontrol('../changelog.tmp',"commit's changelog"); + if (madformat $dsc->{format}) { + check_for_vendor_patches(); + } + + my $dappliedtree; + if (madformat $dsc->{format}) { + my @pcmd = qw(dpkg-source --before-build .); + runcmd shell_cmd 'exec >/dev/null', @pcmd; + rmtree '.pc'; + runcmd @git, qw(add -Af); + $dappliedtree = git_write_tree(); + } + + my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all); + debugcmd "|",@clogcmd; + open CLOGS, "-|", @clogcmd or die $!; + + my $clogp; + my $r1clogp; + + for (;;) { + my $stanzatext = do { local $/=""; ; }; + last if !defined $stanzatext; + + my $desc = "package changelog, entry no.$."; + open my $stanzafh, "<", \$stanzatext or die; + my $thisstanza = parsecontrolfh $stanzafh, $desc, 1; + $clogp //= $thisstanza; + + last if !$any_orig; # we don't need $r1clogp + + # We look for the first (most recent) changelog entry whose + # version number is lower than the upstream version of this + # package. Then the last (least recent) previous changelog + # entry is treated as the one which introduced this upstream + # version and used for the synthetic commits for the upstream + # tarballs. + + # One might think that a more sophisticated algorithm would be + # necessary. But: we do not want to scan the whole changelog + # file. Stopping when we see an earlier version, which + # necessarily then is an earlier upstream version, is the only + # realistic way to do that. Then, either the earliest + # changelog entry we have seen so far is indeed the earliest + # upload of this upstream version; or there are only changelog + # entries relating to later upstream versions (which is not + # possible unless the changelog and .dsc disagree about the + # 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 + # that the changelog entries have been misordered. + + last if version_compare($thisstanza->{version}, $upstreamv) < 0; + $r1clogp = $thisstanza; + } + die $! if CLOGS->error; + close CLOGS or $?==(SIGPIPE<<8) or failedcmd @clogcmd; + + $clogp or fail "package changelog has no entries!"; + my $authline = clogp_authline $clogp; my $changes = getfield $clogp, 'Changes'; + my $cversion = getfield $clogp, 'Version'; + + if (@tartrees) { + $r1clogp //= $clogp; # maybe there's only one entry; + my $r1authline = clogp_authline $r1clogp; + # Strictly, r1authline might now be wrong if it's going to be + # unused because !$any_orig. Whatever. + + foreach my $tt (@tartrees) { + $tt->{Commit} = make_commit_text($tt->{Orig} ? <{Tree} +author $r1authline +committer $r1authline + +Import $tt->{F} + +[dgit import orig $tt->{F}] +END_O +tree $tt->{Tree} +author $authline +committer $authline + +Import $tt->{F} + +[dgit import tarball $package $cversion $tt->{F}] +END_T + } + } + open C, ">../commit.tmp" or die $!; print C <{Commit} +END + print C <{format}) { + # regularise the state of the working tree so that + # the checkout of $rawimport_hash works nicely. + my $dappliedcommit = make_commit_text(</dev/null', @gbp, qw(pq import); + my $gapplied = git_rev_parse('HEAD'); + my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:); + $gappliedtree eq $dappliedtree or + fail < $rawimport_hash, Info => "Import of source package", }; my @output = ($rawimport_mergeinput); - progress "synthesised git commit from .dsc $cversion"; + if ($lastpush_mergeinput) { - my $lastpush_hash = $lastpush_mergeinput->{Commit}; - runcmd @git, qw(reset -q --hard), $lastpush_hash; - runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp'; - my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog'); + my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput); my $oversion = getfield $oldclogp, 'Version'; my $vcmp = version_compare($oversion, $cversion); @@ -1549,6 +1855,9 @@ $later_warning_msg END @output = $lastpush_mergeinput; } else { + # Same version. Use what's in the server git branch, + # discarding our own import. (This could happen if the + # server automatically imports all packages into git.) @output = $lastpush_mergeinput; } } @@ -1594,19 +1903,152 @@ sub complete_file_from_dsc ($$) { } sub ensure_we_have_orig () { - foreach my $fi (dsc_files_info()) { + my @dfi = dsc_files_info(); + foreach my $fi (@dfi) { my $f = $fi->{Filename}; - next unless is_orig_file($f); + next unless is_orig_file_in_dsc($f, \@dfi); complete_file_from_dsc('..', $fi) or next; } } sub git_fetch_us () { - my @specs = - map { "+refs/$_/*:".lrfetchrefs."/$_/*" } - qw(tags heads), $branchprefix; - runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs; + # Want to fetch only what we are going to use, unless + # deliberately-not-ff, in which case we must fetch everything. + + my @specs = deliberately_not_fast_forward ? qw(tags/*) : + map { "tags/$_" } + (quiltmode_splitbrain + ? (map { $_->('*',access_basedistro) } + \&debiantag_new, \&debiantag_maintview) + : debiantags('*',access_basedistro)); + push @specs, server_branch($csuite); + push @specs, qw(heads/*) if deliberately_not_fast_forward; + + # This is rather miserable: + # When git-fetch --prune is passed a fetchspec ending with a *, + # it does a plausible thing. If there is no * then: + # - it matches subpaths too, even if the supplied refspec + # starts refs, and behaves completely madly if the source + # has refs/refs/something. (See, for example, Debian #NNNN.) + # - if there is no matching remote ref, it bombs out the whole + # fetch. + # We want to fetch a fixed ref, and we don't know in advance + # if it exists, so this is not suitable. + # + # Our workaround is to use git-ls-remote. git-ls-remote has its + # own qairks. Notably, it has the absurd multi-tail-matching + # behaviour: git-ls-remote R refs/foo can report refs/foo AND + # refs/refs/foo etc. + # + # Also, we want an idempotent snapshot, but we have to make two + # calls to the remote: one to git-ls-remote and to git-fetch. The + # solution is use git-ls-remote to obtain a target state, and + # git-fetch to try to generate it. If we don't manage to generate + # the target state, we try again. + + my $specre = join '|', map { + my $x = $_; + $x =~ s/\W/\\$&/g; + $x =~ s/\\\*$/.*/; + "(?:refs/$x)"; + } @specs; + printdebug "git_fetch_us specre=$specre\n"; + my $wanted_rref = sub { + local ($_) = @_; + return m/^(?:$specre)$/o; + }; + + my $fetch_iteration = 0; + FETCH_ITERATION: + for (;;) { + if (++$fetch_iteration > 10) { + fail "too many iterations trying to get sane fetch!"; + } + + my @look = map { "refs/$_" } @specs; + my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look); + debugcmd "|",@lcmd; + + my %wantr; + open GITLS, "-|", @lcmd or die $!; + while () { + printdebug "=> ", $_; + m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?"; + my ($objid,$rrefname) = ($1,$2); + if (!$wanted_rref->($rrefname)) { + print STDERR <($rrefname)) { + printdebug <'; + my $want = $wantr{$rrefname}; + next if $got eq $want; + if (!defined $objgot{$want}) { + print STDERR <{Clogp} exists and returns it - return $mi->{Clogp} if $mi->{Clogp}; - my $mclog = ".git/dgit/clog-$mi->{Commit}"; - mkpath '.git/dgit'; - runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob), - "$mi->{Commit}:debian/changelog"; - $mi->{Clogp} = parsechangelog("-l$mclog"); + my ($mi) = @_; + $mi->{Clogp} = commit_getclogp($mi->{Commit}); } sub mergeinfo_version ($) { @@ -1647,8 +2086,11 @@ sub mergeinfo_version ($) { } sub fetch_from_archive () { - # ensures that lrref() is what is actually in the archive, - # one way or another + # Ensures that lrref() is what is actually in the archive, one way + # or another, according to us - ie this client's + # appropritaely-updated archive view. Also returns the commit id. + # If there is nothing in the archive, leaves lrref alone and + # returns undef. git_fetch_us must have already been called. get_archive_dsc(); if ($dsc) { @@ -1727,7 +2169,7 @@ sub fetch_from_archive () { # Finally: we do not necessarily reify the public view (as # described above). This is so that we do not end up stacking two # pseudo-merges. So what we actually do is figure out the inputs - # to any public view psuedo-merge and put them in @mergeinputs. + # to any public view pseudo-merge and put them in @mergeinputs. my @mergeinputs; # $mergeinputs[]{Commit} @@ -1762,6 +2204,25 @@ sub fetch_from_archive () { Info => "Dgit field in .dsc from archive", }; + my $cwd = getcwd(); + my $del_lrfetchrefs = sub { + changedir $cwd; + my $gur; + printdebug "del_lrfetchrefs...\n"; + foreach my $fullrefname (sort keys %lrfetchrefs_d) { + my $objid = $lrfetchrefs_d{$fullrefname}; + printdebug "del_lrfetchrefs: $objid $fullrefname\n"; + if (!$gur) { + $gur ||= new IO::Handle; + open $gur, "|-", qw(git update-ref --stdin) or die $!; + } + printf $gur "delete %s %s\n", $fullrefname, $objid; + } + if ($gur) { + close $gur or failedcmd "git update-ref delete lrfetchrefs"; + } + }; + if (defined $dsc_hash) { fail "missing remote git history even though dsc has hash -". " could not find ref ".rref()." at ".access_giturl() @@ -1822,7 +2283,8 @@ But we were not able to obtain any version from the archive or git. END } - return 0; + unshift @end, $del_lrfetchrefs; + return undef; } if ($lastfetch_hash && @@ -1944,10 +2406,7 @@ END if (defined $skew_warning_vsn) { mkpath '.git/dgit'; printdebug "SKEW CHECK WANT $skew_warning_vsn\n"; - my $clogf = ".git/dgit/changelog.tmp"; - runcmd shell_cmd "exec >$clogf", - @git, qw(cat-file blob), "$hash:debian/changelog"; - my $gotclogp = parsechangelog("-l$clogf"); + my $gotclogp = commit_getclogp($hash); my $got_vsn = getfield $gotclogp, 'Version'; printdebug "SKEW CHECK GOT $got_vsn\n"; if (version_compare($got_vsn, $skew_warning_vsn) < 0) { @@ -1969,7 +2428,11 @@ END dryrun_report @upd_cmd; } } - return 1; + + lrfetchref_used lrfetchref(); + + unshift @end, $del_lrfetchrefs; + return $hash; } sub set_local_git_config ($$) { @@ -2151,7 +2614,7 @@ sub get_source_format () { return ($_, \%options); } -sub madformat ($) { +sub madformat_wantfixup ($) { my ($format) = @_; return 0 unless $format eq '3.0 (quilt)'; our $quilt_mode_warned; @@ -2166,6 +2629,192 @@ sub madformat ($) { return 1; } +# An "infopair" is a tuple [ $thing, $what ] +# (often $thing is a commit hash; $what is a description) + +sub infopair_cond_equal ($$) { + my ($x,$y) = @_; + $x->[0] eq $y->[0] or fail <[1] ($x->[0]) not equal to $y->[1] ($y->[0]) +END +}; + +sub infopair_lrf_tag_lookup ($$) { + my ($tagnames, $what) = @_; + # $tagname may be an array ref + my @tagnames = ref $tagnames ? @$tagnames : ($tagnames); + printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n"; + foreach my $tagname (@tagnames) { + my $lrefname = lrfetchrefs."/tags/$tagname"; + my $tagobj = $lrfetchrefs_f{$lrefname}; + next unless defined $tagobj; + printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n"; + return [ git_rev_parse($tagobj), $what ]; + } + fail @tagnames==1 ? <[0], $desc->[0]) or fail <[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward +END +}; + +sub pseudomerge_version_check ($$) { + my ($clogp, $archive_hash) = @_; + + my $arch_clogp = commit_getclogp $archive_hash; + my $i_arch_v = [ (getfield $arch_clogp, 'Version'), + 'version currently in archive' ]; + if (defined $overwrite_version) { + if (length $overwrite_version) { + infopair_cond_equal([ $overwrite_version, + '--overwrite= version' ], + $i_arch_v); + } else { + my $v = $i_arch_v->[0]; + progress "Checking package changelog for archive version $v ..."; + eval { + my @xa = ("-f$v", "-t$v"); + my $vclogp = parsechangelog @xa; + my $cv = [ (getfield $vclogp, 'Version'), + "Version field from dpkg-parsechangelog @xa" ]; + infopair_cond_equal($i_arch_v, $cv); + }; + if ($@) { + $@ =~ s/^dgit: //gm; + fail "$@". + "Perhaps debian/changelog does not mention $v ?"; + } + } + } + + printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n"; + return $i_arch_v; +} + +sub pseudomerge_make_commit ($$$$ $$) { + my ($clogp, $dgitview, $archive_hash, $i_arch_v, + $msg_cmd, $msg_msg) = @_; + progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]..."; + + my $tree = cmdoutput qw(git rev-parse), "${dgitview}:"; + my $authline = clogp_authline $clogp; + + chomp $msg_msg; + $msg_cmd .= + !defined $overwrite_version ? "" + : !length $overwrite_version ? " --overwrite" + : " --overwrite=".$overwrite_version; + + mkpath '.git/dgit'; + my $pmf = ".git/dgit/pseudomerge"; + open MC, ">", $pmf or die "$pmf $!"; + print MC < $merged_dgitview + printdebug "splitbrain_pseudomerge...\n"; + # + # We: debian/PREVIOUS HEAD($maintview) + # expect: o ----------------- o + # \ \ + # o o + # a/d/PREVIOUS $dgitview + # $archive_hash \ + # If so, \ \ + # we do: `------------------ o + # this: $dgitview' + # + + printdebug "splitbrain_pseudomerge...\n"; + + my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash); + + return $dgitview unless defined $archive_hash; + + if (!defined $overwrite_version) { + progress "Checking that HEAD inciudes all changes in archive..."; + } + + return $dgitview if is_fast_fwd $archive_hash, $dgitview; + + my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro; + my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag"); + my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro; + my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag"); + my $i_archive = [ $archive_hash, "current archive contents" ]; + + printdebug "splitbrain_pseudomerge i_archive @$i_archive\n"; + + infopair_cond_equal($i_dgit, $i_archive); + infopair_cond_ff($i_dep14, $i_dgit); + $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]); + + my $r = pseudomerge_make_commit + $clogp, $dgitview, $archive_hash, $i_arch_v, + "dgit --quilt=$quilt_mode", + (defined $overwrite_version ? <[0] +END_MAKEFF + + progress "Made pseudo-merge of $i_arch_v->[0] into dgit view."; + return $r; +} + +sub plain_overwrite_pseudomerge ($$$) { + my ($clogp, $head, $archive_hash) = @_; + + printdebug "plain_overwrite_pseudomerge..."; + + my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash); + + my @tagformats = access_cfg_tagformats(); + my @t_overwr = + map { $_->($i_arch_v->[0], access_basedistro) } + (grep { m/^(?:old|hist)$/ } @tagformats) + ? \&debiantags : \&debiantag_new; + my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag"; + my $i_archive = [ $archive_hash, "current archive contents" ]; + + infopair_cond_equal($i_overwr, $i_archive); + + return $head if is_fast_fwd $archive_hash, $head; + + my $m = "Declare fast forward from $i_arch_v->[0]"; + + my $r = pseudomerge_make_commit + $clogp, $head, $archive_hash, $i_arch_v, + "dgit", $m; + + runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head; + + progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD."; + return $r; +} + sub push_parse_changelog ($) { my ($clogpfn) = @_; @@ -2213,6 +2862,7 @@ sub push_tagwants ($$$$) { $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro); $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; }; } + printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants); return @tagwants; } @@ -2314,9 +2964,23 @@ sub sign_changes ($) { } } -sub dopush ($) { - my ($forceflag) = @_; +sub dopush () { printdebug "actually entering push\n"; + + supplementary_message(<<'END'); +Push failed, while checking state of the archive. +You can retry the push, after fixing the problem, if you like. +END + if (check_for_git()) { + git_fetch_us(); + } + my $archive_hash = fetch_from_archive(); + if (!$archive_hash) { + $new_package or + fail "package appears to be new in this suite;". + " if this is intentional, use --new"; + } + supplementary_message(<<'END'); Push failed, while preparing your push. You can retry the push, after fixing the problem, if you like. @@ -2354,7 +3018,7 @@ END my $dgithead = $actualhead; my $maintviewhead = undef; - if (madformat($format)) { + if (madformat_wantfixup($format)) { # user might have not used dgit build, so maybe do this now: if (quiltmode_splitbrain()) { my $upstreamversion = $clogp->{Version}; @@ -2367,7 +3031,9 @@ END "--quilt=$quilt_mode but no cached dgit view: perhaps tree changed since dgit build[-source] ?"; $split_brain = 1; - $dgithead = $dgitview; + $dgithead = splitbrain_pseudomerge($clogp, + $actualhead, $dgitview, + $archive_hash); $maintviewhead = $actualhead; changedir '../../../..'; prep_ud(); # so _only_subdir() works, below @@ -2376,7 +3042,30 @@ END } } + if (defined $overwrite_version && !defined $maintviewhead) { + $dgithead = plain_overwrite_pseudomerge($clogp, + $dgithead, + $archive_hash); + } + check_not_dirty(); + + my $forceflag = ''; + if ($archive_hash) { + if (is_fast_fwd($archive_hash, $dgithead)) { + # ok + } elsif (deliberately_not_fast_forward) { + $forceflag = '+'; + } else { + fail "dgit push: HEAD is not a descendant". + " of the archive's version.\n". + "To overwrite the archive's contents,". + " pass --overwrite[=VERSION].\n". + "To rewind history, if permitted by the archive,". + " use --deliberately-not-fast-forward."; + } + } + changedir $ud; progress "checking that $dscfn corresponds to HEAD"; runcmd qw(dpkg-source -x --), @@ -2411,11 +3100,13 @@ END $changesfile = "$buildproductsdir/$changesfile"; } + # Checks complete, we're going to try and go ahead: + responder_send_file('changes',$changesfile); responder_send_command("param head $dgithead"); responder_send_command("param csuite $csuite"); responder_send_command("param tagformat $tagformat"); - if (quiltmode_splitbrain) { + if (defined $maintviewhead) { die unless ($protovsn//4) >= 4; responder_send_command("param maint-view $maintviewhead"); } @@ -2471,11 +3162,8 @@ END create_remote_git_repo(); } - my @pushrefs = $forceflag."HEAD:".rrref(); + my @pushrefs = $forceflag.$dgithead.":".rrref(); foreach my $tw (@tagwants) { - my $view = $tw->{View}; - next unless $view eq 'dgit' - or any { $_ eq $view } access_cfg_tagformats(); push @pushrefs, $forceflag."refs/tags/$tw->{Tag}"; } @@ -2632,33 +3320,7 @@ sub cmd_push { fail "dgit push: changelog specifies $isuite ($csuite)". " but command line specifies $specsuite"; } - supplementary_message(<<'END'); -Push failed, while checking state of the archive. -You can retry the push, after fixing the problem, if you like. -END - if (check_for_git()) { - git_fetch_us(); - } - my $forceflag = ''; - if (fetch_from_archive()) { - if (is_fast_fwd(lrref(), 'HEAD')) { - # ok - } elsif (deliberately_not_fast_forward) { - $forceflag = '+'; - } else { - fail "dgit push: HEAD is not a descendant". - " of the archive's version.\n". - "dgit: To overwrite its contents,". - " use git merge -s ours ".lrref().".\n". - "dgit: To rewind history, if permitted by the archive,". - " use --deliberately-not-fast-forward"; - } - } else { - $new_package or - fail "package appears to be new in this suite;". - " if this is intentional, use --new"; - } - dopush($forceflag); + dopush(); } #---------- remote commands' implementation ---------- @@ -3011,6 +3673,13 @@ sub quiltify_splitbrain ($$$$$$) { } fail $msg; } + if ($quilt_mode =~ m/dpm/ && + ($diffbits->{H2A} & 01)) { + fail <{O2A} & 01)) { # some patches quiltify_splitbrain_needed(); @@ -3020,6 +3689,14 @@ sub quiltify_splitbrain ($$$$$$) { runcmd @git, qw(update-ref refs/heads/dgit-view HEAD); runcmd @git, qw(checkout -q dgit-view); } + if ($quilt_mode =~ m/gbp|dpm/ && + ($diffbits->{O2A} & 02)) { + fail <{H2O} & 02) && # user has modified .gitignore !($diffbits->{O2A} & 02)) { # patches do not change .gitignore quiltify_splitbrain_needed(); @@ -3282,11 +3959,21 @@ sub quiltify ($$$$) { sub build_maybe_quilt_fixup () { my ($format,$fopts) = get_source_format; - return unless madformat $format; + return unless madformat_wantfixup $format; # sigh check_for_vendor_patches(); + if (quiltmode_splitbrain) { + foreach my $needtf (qw(new maint)) { + next if grep { $_ eq $needtf } access_cfg_tagformats; + fail <($b); @@ -3356,12 +4043,12 @@ sub quilt_fixup_singlepatch ($$$) { rmtree("debian/patches"); runcmd @dpkgsource, qw(-b .); - chdir ".."; + changedir ".."; runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc"); rename srcfn("$upstreamversion", "/debian/patches"), "work/debian/patches"; - chdir "work"; + changedir "work"; commit_quilty_patch(); } @@ -3703,6 +4390,7 @@ sub maybe_unapply_patches_again () { if $patches_applied_dirtily & 01; rmtree '.pc' if $patches_applied_dirtily & 02; + $patches_applied_dirtily = 0; } #----- other building ----- @@ -3891,16 +4579,15 @@ sub cmd_gbp_build { } build_prep(); } + maybe_unapply_patches_again(); if ($wantsrc < 2) { unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) { canonicalise_suite(); push @cmd, "--git-debian-branch=".lbranch(); } push @cmd, changesopts(); - maybe_apply_patches_dirtily(); runcmd_ordryrun_local @cmd, @ARGV; } - maybe_unapply_patches_again(); printdone "build successful\n"; } sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0 @@ -3983,6 +4670,7 @@ sub cmd_sbuild { " building would result in ambiguity about the intended results" if @unwanted; } + my $wasdir = must_getcwd(); changedir ".."; if (act_local()) { stat_exists $dscfn or fail "$dscfn (in parent directory): $!"; @@ -4011,6 +4699,7 @@ sub cmd_sbuild { rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!"; } } + changedir $wasdir; maybe_unapply_patches_again(); printdone "build successful, results in $multichanges\n" or die $!; } @@ -4172,6 +4861,12 @@ sub parseopts () { } elsif (m/^--no-rm-on-error$/s) { push @ropts, $_; $rmonerror = 0; + } elsif (m/^--overwrite$/s) { + push @ropts, $_; + $overwrite_version = ''; + } elsif (m/^--overwrite=(.+)$/s) { + push @ropts, $_; + $overwrite_version = $1; } elsif (m/^--(no-)?rm-old-changes$/s) { push @ropts, $_; $rmchanges = !$1;