X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=150c11539a46bee1a46c32d256a33a99061bdcf4;hp=23cae18f2acdbc58528293c191cf5baf210239d7;hb=a94e7d03fb7ce841d3c07effc7988f3cb0ed1225;hpb=51f61cf75f6614603782edde86261c9d1bd8c769 diff --git a/dgit b/dgit index 23cae18f..150c1153 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'; @@ -92,7 +97,8 @@ our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git); our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git); our (@dpkggenchanges) = qw(dpkg-genchanges); our (@mergechanges) = qw(mergechanges -f); -our (@gbp) = qw(gbp); +our (@gbp_build) = (''); +our (@gbp_pq) = ('gbp pq'); our (@changesopts) = (''); our %opts_opt_map = ('dget' => \@dget, # accept for compatibility @@ -107,7 +113,8 @@ our %opts_opt_map = ('dget' => \@dget, # accept for compatibility 'dpkg-source' => \@dpkgsource, 'dpkg-buildpackage' => \@dpkgbuildpackage, 'dpkg-genchanges' => \@dpkggenchanges, - 'gbp' => \@gbp, + 'gbp-build' => \@gbp_build, + 'gbp-pq' => \@gbp_pq, 'ch' => \@changesopts, 'mergechanges' => \@mergechanges); @@ -148,6 +155,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 +166,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 +230,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 ($) { @@ -218,6 +248,17 @@ sub quiltmode_splitbrain () { $quilt_mode =~ m/gbp|dpm|unapplied/; } +sub opts_opt_multi_cmd { + my @cmd; + push @cmd, split /\s+/, shift @_; + push @cmd, @_; + @cmd; +} + +sub gbp_pq { + return opts_opt_multi_cmd @gbp_pq; +} + #---------- remote protocol support, common ---------- # remote push initiator/responder protocol: @@ -511,11 +552,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 +890,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 +903,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 +1217,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 +1363,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 +1390,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 +1445,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 +1466,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'; @@ -1471,10 +1566,12 @@ sub check_for_vendor_patches () { sub generate_commits_from_dsc () { # See big comment in fetch_from_archive, below. + # See also README.dsc-import. 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 +1582,312 @@ 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; + + printdebug "import clog search...\n"; + + 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"; + + 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. + + printdebug "import clog $thisstanza->{version} vs $upstreamv...\n"; + + last if version_compare($thisstanza->{version}, $upstreamv) < 0; + $r1clogp = $thisstanza; + + printdebug "import clog $r1clogp->{version} becomes r1\n"; + } + 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. + + printdebug "import tartrees authline $authline\n"; + printdebug "import tartrees r1authline $r1authline\n"; + + foreach my $tt (@tartrees) { + printdebug "import tartree $tt->{F} $tt->{Tree}\n"; + + $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 + } + } + + printdebug "import main commit\n"; + open C, ">../commit.tmp" or die $!; print C <{Commit} +END + print C <{format}) { + printdebug "import apply patches...\n"; + + # regularise the state of the working tree so that + # the checkout of $rawimport_hash works nicely. + my $dappliedcommit = make_commit_text(</dev/null 2>../../gbp-pq-output', + gbp_pq, qw(import); + }; + if ($@) { + { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; } + die $@; + } + + 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); @@ -1597,18 +1953,27 @@ 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 { "$_/*" } - qw(tags heads), $branchprefix; + # 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 *, @@ -1644,8 +2009,6 @@ sub git_fetch_us () { return m/^(?:$specre)$/o; }; - my %lrfetchrefs_f; - my $fetch_iteration = 0; FETCH_ITERATION: for (;;) { @@ -1747,12 +2110,14 @@ END }); git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub { my ($objid,$objtype,$fullrefname,$reftail) = @_; - my $lref = "refs".substr($fullrefname, length lrfetchrefs); + my $lref = "refs".substr($fullrefname, length(lrfetchrefs)); printdebug "offered $lref=$objid\n"; if (!defined $here{$lref}) { my @upd = (@git, qw(update-ref), $lref, $objid, ''); runcmd_ordryrun_local @upd; + lrfetchref_used $fullrefname; } elsif ($here{$lref} eq $objid) { + lrfetchref_used $fullrefname; } else { print STDERR \ "Not updateting $lref from $here{$lref} to $objid.\n"; @@ -1761,14 +2126,9 @@ END } sub mergeinfo_getclogp ($) { - my ($mi) = @_; # Ensures thit $mi->{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 ($) { @@ -1776,8 +2136,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) { @@ -1856,7 +2219,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} @@ -1891,6 +2254,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() @@ -1951,7 +2333,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 && @@ -2054,7 +2437,7 @@ END } else { $hash = $mergeinputs[0]{Commit}; } - progress "fetch hash=$hash\n"; + printdebug "fetch hash=$hash\n"; my $chkff = sub { my ($lasth, $what) = @_; @@ -2073,10 +2456,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) { @@ -2098,7 +2478,11 @@ END dryrun_report @upd_cmd; } } - return 1; + + lrfetchref_used lrfetchref(); + + unshift @end, $del_lrfetchrefs; + return $hash; } sub set_local_git_config ($$) { @@ -2246,7 +2630,11 @@ sub commit_quilty_patch () { } my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds; runcmd_ordryrun_local @git, qw(add -f), @adds; - commit_admin "Commit Debian 3.0 (quilt) metadata"; + commit_admin <[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) = @_; @@ -2342,6 +2916,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; } @@ -2443,9 +3018,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. @@ -2483,7 +3072,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}; @@ -2496,7 +3085,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 @@ -2505,7 +3096,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 --), @@ -2540,11 +3154,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"); } @@ -2600,11 +3216,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}"; } @@ -2761,33 +3374,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 ---------- @@ -3054,13 +3641,10 @@ sub quiltify_dpkg_commit ($$$;$) { mkpath '.git/dgit'; my $descfn = ".git/dgit/quilt-description.tmp"; open O, '>', $descfn or die "$descfn: $!"; - $msg =~ s/\s+$//g; - $msg =~ s/\n/\n /g; - $msg =~ s/^\s+$/ ./mg; + $msg =~ s/\n+/\n\n/; print O <{H2O} & 01)) { my $msg = @@ -3140,15 +3727,30 @@ sub quiltify_splitbrain ($$$$$$) { } fail $msg; } + if ($quilt_mode =~ m/dpm/ && + ($diffbits->{H2A} & 01)) { + fail <{O2A} & 01)) { # some patches quiltify_splitbrain_needed(); progress "dgit view: creating patches-applied version using gbp pq"; - runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import); + runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import); # gbp pq import creates a fresh branch; push back to dgit-view 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(); @@ -3166,7 +3768,7 @@ The Debian packaging git branch contains these updates to the upstream .gitignore file(s). This patch is autogenerated, to provide these updates to users of the official Debian archive view of the package. -[dgit version $our_version] +[dgit ($our_version) update-gitignore] --- END close GIPATCH or die "$gipatch: $!"; @@ -3180,7 +3782,11 @@ END print SERIES "auto-gitignore\n" or die $!; close SERIES or die $!; runcmd @git, qw(add -- debian/patches/series), $gipatch; - commit_admin "Commit patch to update .gitignore"; + commit_admin <(); + my $title = $1; - my $patchname = $title; - $patchname =~ s/[.:]$//; - $patchname =~ y/ A-Z/-a-z/; - $patchname =~ y/-a-z0-9_.+=~//cd; - $patchname =~ s/^\W/x-$&/; - $patchname = substr($patchname,0,40); + my $patchname; + my $patchdir; + + my $gbp_check_suitable = sub { + $_ = shift; + my ($what) = @_; + + eval { + die "contains unexpected slashes\n" if m{//} || m{/$}; + die "contains leading punctuation\n" if m{^\W} || m{/\W}; + die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i; + die "too long" if length > 200; + }; + return $_ unless $@; + print STDERR "quiltifying commit $cc:". + " ignoring/dropping Gbp-Pq $what: $@"; + return undef; + }; + + if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ | + gbp-pq-name: \s* ) + (\S+) \s* \n //ixm) { + $patchname = $gbp_check_suitable->($1, 'Name'); + } + if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ | + gbp-pq-topic: \s* ) + (\S+) \s* \n //ixm) { + $patchdir = $gbp_check_suitable->($1, 'Topic'); + } + + $strip_nls->(); + + if (!defined $patchname) { + $patchname = $title; + $patchname =~ s/[.:]$//; + $patchname =~ y/ A-Z/-a-z/; + $patchname =~ y/-a-z0-9_.+=~//cd; + $patchname =~ s/^\W/x-$&/; + $patchname = substr($patchname,0,40); + } + if (!defined $patchdir) { + $patchdir = ''; + } + if (length $patchdir) { + $patchname = "$patchdir/$patchname"; + } + if ($patchname =~ m{^(.*)/}) { + mkpath "debian/patches/$1"; + } + my $index; for ($index=''; stat "debian/patches/$patchname$index"; @@ -3401,6 +4057,7 @@ sub quiltify ($$$$) { runcmd @git, qw(checkout -q), $target, qw(debian/changelog); quiltify_dpkg_commit "$patchname$index", $author, $msg, + "Date: $commitdate\n". "X-Dgit-Generated: $clogp->{Version} $cc\n"; runcmd @git, qw(checkout -q), $cc, qw(debian/changelog); @@ -3411,11 +4068,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); @@ -3466,7 +4133,11 @@ sub quilt_fixup_linkorigs ($$) { sub quilt_fixup_delete_pc () { runcmd @git, qw(rm -rqf .pc); - commit_admin "Commit removal of .pc (quilt series tracking data)"; + commit_admin < 0) { @@ -4020,16 +4699,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 @@ -4112,6 +4790,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): $!"; @@ -4140,6 +4819,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 $!; } @@ -4301,6 +4981,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; @@ -4419,6 +5105,9 @@ if (!@ARGV) { my $cmd = shift @ARGV; $cmd =~ y/-/_/; +my $pre_fn = ${*::}{"pre_$cmd"}; +$pre_fn->() if $pre_fn; + if (!defined $rmchanges) { local $access_forpush; $rmchanges = access_cfg_bool(0, 'rm-old-changes');