X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=7306d7d1214abfa0fa8216c21387fd962e164260;hp=8404a19c2509021f1b8242bac094dc86d0d6e523;hb=12ece166a931d546fc6d152f253f7b78e7478dc7;hpb=b7120584994325d4f6d2963ed336110355349fc6 diff --git a/dgit b/dgit index 8404a19c..7306d7d1 100755 --- a/dgit +++ b/dgit @@ -39,7 +39,7 @@ use Debian::Dgit; our $our_version = 'UNRELEASED'; ###substituted### -our @rpushprotovsn_support = qw(3 2); +our @rpushprotovsn_support = qw(3 2); # 4 is new tag format our $protovsn; our $isuite = 'unstable'; @@ -65,6 +65,9 @@ our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|unapplied'; our $we_are_responder; our $initiator_tempdir; our $patches_applied_dirtily = 00; +our $tagformat_want; +our $tagformat; +our $tagformatfn; our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)"); @@ -132,6 +135,11 @@ our @ourdscfield = qw(Dgit Vcs-Dgit-Master); our $csuite; our $instead_distro; +sub debiantag ($$) { + my ($v,$distro) = @_; + return $tagformatfn->($v, $distro); +} + sub lbranch () { return "$branchprefix/$csuite"; } my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$'; sub lref () { return "refs/heads/".lbranch(); } @@ -213,6 +221,16 @@ sub quiltmode_splitbrain () { # where is ,... ... # < dgit-remote-push-ready # +# occasionally: +# +# > progress NBYTES +# [NBYTES message] +# +# > supplementary-message NBYTES # $protovsn >= 3 +# [NBYTES message] +# +# main sequence: +# # > file parsed-changelog # [indicates that output of dpkg-parsechangelog follows] # > data-block NBYTES @@ -227,6 +245,11 @@ sub quiltmode_splitbrain () { # [etc] # # > param head HEAD +# > param csuite SUITE +# > param tagformat old|new +# +# > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward +# # goes into tag, for replay prevention # # > want signed-tag # [indicates that signed tag is wanted] @@ -398,7 +421,7 @@ our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn); sub runcmd { debugcmd "+",@_; - $!=0; $?=0; + $!=0; $?=-1; failedcmd @_ if system @_; } @@ -482,10 +505,12 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit.default.ssh' => 'ssh', 'dgit.default.archive-query' => 'madison:', 'dgit.default.sshpsql-dbname' => 'service=projectb', + 'dgit.default.dgit-tag-format' => 'old,new', '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/push.git-url' => '', 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org', 'dgit-distro.debian/push.git-user-force' => 'dgit', @@ -533,7 +558,7 @@ sub git_slurp_config () { my @cmd = (@git, qw(config -z --get-regexp .*)); debugcmd "|",@cmd; - open GITS, "-|", @cmd or failedcmd @cmd; + open GITS, "-|", @cmd or die $!; while () { chomp or die; printdebug "=> ", (messagequote $_), "\n"; @@ -1107,6 +1132,39 @@ sub archive_query_dummycat ($$) { return sort { -version_compare($a->[0],$b->[0]); } @rows; } +#---------- tag format handling ---------- + +sub access_cfg_tagformats () { + split /\,/, access_cfg('dgit-tag-format'); +} + +sub select_tagformat () { + # sets $tagformatfn + return if $tagformatfn && !$tagformat_want; + die 'bug' if $tagformatfn && $tagformat_want; + # ... $tagformat_want assigned after previous select_tagformat + + my (@supported) = access_cfg_tagformats(); + printdebug "select_tagformat supported @supported\n"; + + $tagformat_want //= [ $supported[0], "distro access configuration", 0 ]; + printdebug "select_tagformat specified @$tagformat_want\n"; + + my ($fmt,$why,$override) = @$tagformat_want; + + fail "target distro supports tag formats @supported". + " but have to use $fmt ($why)" + unless $override + or grep { $_ eq $fmt } @supported; + + $tagformat_want = undef; + $tagformat = $fmt; + $tagformatfn = ${*::}{"debiantag_$fmt"}; + + fail "trying to use unknown tag format \`$fmt' ($why) !" + unless $tagformatfn; +} + #---------- archive query entrypoints and rest of program ---------- sub canonicalise_suite () { @@ -1160,7 +1218,7 @@ sub check_for_git () { " set -e; cd ".access_cfg('git-path').";". " if test -d $package.git; then echo 1; else echo 0; fi"); my $r= cmdoutput @cmd; - if ($r =~ m/^divert (\w+)$/) { + if (defined $r and $r =~ m/^divert (\w+)$/) { my $divert=$1; my ($usedistro,) = access_distros(); # NB that if we are pushing, $usedistro will be $distro/push @@ -1169,7 +1227,7 @@ sub check_for_git () { progress "diverting to $divert (using config for $instead_distro)"; return check_for_git(); } - failedcmd @cmd unless $r =~ m/^[01]$/; + failedcmd @cmd unless defined $r and $r =~ m/^[01]$/; return $r+0; } elsif ($how eq 'url') { my $prefix = access_cfg('git-check-url','git-url'); @@ -1243,7 +1301,7 @@ sub git_write_tree () { sub remove_stray_gits () { my @gitscmd = qw(find -name .git -prune -print0); debugcmd "|",@gitscmd; - open GITS, "-|", @gitscmd or failedcmd @gitscmd; + open GITS, "-|", @gitscmd or die $!; { local $/="\0"; while () { @@ -1259,7 +1317,7 @@ sub remove_stray_gits () { sub mktree_in_ud_from_only_subdir () { # changes into the subdir my (@dirs) = <*/.>; - die unless @dirs==1; + die "@dirs ?" unless @dirs==1; $dirs[0] =~ m#^([^/]+)/\.$# or die; my $dir = $1; changedir $dir; @@ -1541,14 +1599,14 @@ sub git_fetch_us () { runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs; my %here; - my $tagpat = debiantag('*',access_basedistro); + my @tagpats = debiantags('*',access_basedistro); - git_for_each_ref("refs/tags/".$tagpat, sub { + git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub { my ($objid,$objtype,$fullrefname,$reftail) = @_; printdebug "currently $fullrefname=$objid\n"; $here{$fullrefname} = $objid; }); - git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub { + git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub { my ($objid,$objtype,$fullrefname,$reftail) = @_; my $lref = "refs".substr($fullrefname, length lrfetchrefs); printdebug "offered $lref=$objid\n"; @@ -1782,9 +1840,9 @@ sub check_not_dirty () { my @cmd = (@git, qw(diff --quiet HEAD)); debugcmd "+",@cmd; - $!=0; $?=0; system @cmd; - return if !$! && !$?; - if (!$! && $?==256) { + $!=0; $?=-1; system @cmd; + return if !$?; + if ($?==256) { fail "working tree is dirty (does not match HEAD)"; } else { failedcmd @cmd; @@ -1850,11 +1908,15 @@ sub get_source_format () { sub madformat ($) { my ($format) = @_; return 0 unless $format eq '3.0 (quilt)'; + our $quilt_mode_warned; if ($quilt_mode eq 'nocheck') { - progress "Not doing any fixup of \`$format' due to --no-quilt-fixup"; + progress "Not doing any fixup of \`$format' due to". + " ----no-quilt-fixup or --quilt=nocheck" + unless $quilt_mode_warned++; return 0; } - progress "Format \`$format', checking/updating patch stack"; + progress "Format \`$format', need to check/update patch stack" + unless $quilt_mode_warned++; return 1; } @@ -1885,12 +1947,12 @@ sub push_parse_dsc ($$$) { } sub push_mktag ($$$$$$$) { - my ($head,$clogp,$tag, + my ($dgithead,$clogp,$dgittag, $dscfn, $changesfile,$changesfilewhat, - $tfn) = @_; + $tfnbase) = @_; - $dsc->{$ourdscfield[0]} = $head; + $dsc->{$ourdscfield[0]} = $dgithead; $dsc->save("$dscfn.tmp") or die $!; my $changes = parsecontrol($changesfile,$changesfilewhat); @@ -1908,8 +1970,12 @@ sub push_mktag ($$$$$$$) { my $authline = clogp_authline $clogp; my $delibs = join(" ", "",@deliberatelies); my $declaredistro = access_basedistro(); - open TO, '>', $tfn->('.tmp') or die $!; - print TO <', $tfn->('.tmp') or die $!; + print TO <('.tmp'); - if ($sign) { - if (!defined $keyid) { - $keyid = access_cfg('keyid','RETURN-UNDEF'); - } - if (!defined $keyid) { - $keyid = getfield $clogp, 'Maintainer'; - } - unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!; - my @sign_cmd = (@gpg, qw(--detach-sign --armor)); - push @sign_cmd, qw(-u),$keyid if defined $keyid; - push @sign_cmd, $tfn->('.tmp'); - runcmd_ordryrun @sign_cmd; - if (act_scary()) { - $tagobjfn = $tfn->('.signed.tmp'); - runcmd shell_cmd "exec >$tagobjfn", qw(cat --), - $tfn->('.tmp'), $tfn->('.tmp.asc'); + my $tagobjfn = $tfn->('.tmp'); + if ($sign) { + if (!defined $keyid) { + $keyid = access_cfg('keyid','RETURN-UNDEF'); + } + if (!defined $keyid) { + $keyid = getfield $clogp, 'Maintainer'; + } + unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!; + my @sign_cmd = (@gpg, qw(--detach-sign --armor)); + push @sign_cmd, qw(-u),$keyid if defined $keyid; + push @sign_cmd, $tfn->('.tmp'); + runcmd_ordryrun @sign_cmd; + if (act_scary()) { + $tagobjfn = $tfn->('.signed.tmp'); + runcmd shell_cmd "exec >$tagobjfn", qw(cat --), + $tfn->('.tmp'), $tfn->('.tmp.asc'); + } } - } + return $tagobjfn; + }; - return ($tagobjfn); + my @r; + push @r, $mktag->($tfnbase, $dgithead, $dgittag); + return @r; } sub sign_changes ($) { @@ -1970,6 +2040,7 @@ END prep_ud(); access_giturl(); # check that success is vaguely likely + select_tagformat(); my $clogpfn = ".git/dgit/changelog.822.tmp"; runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog); @@ -1991,9 +2062,26 @@ END my $format = getfield $dsc, 'Format'; printdebug "format $format\n"; + my $head = git_rev_parse('HEAD'); + if (madformat($format)) { # user might have not used dgit build, so maybe do this now: - commit_quilty_patch(); + if (quiltmode_splitbrain()) { + my $upstreamversion = $clogp->{Version}; + $upstreamversion =~ s/-[^-]*$//; + changedir $ud; + quilt_make_fake_dsc($upstreamversion); + my ($dgitview, $cachekey) = + quilt_check_splitbrain_cache($head, $upstreamversion); + $dgitview or fail + "--quilt=$quilt_mode but no cached dgit view: + perhaps tree changed since dgit build[-source] ?"; + $split_brain = 1; + changedir '../../../..'; + prep_ud(); # so _only_subdir() works, below + } else { + commit_quilty_patch(); + } } die 'xxx fast forward (should not depend on quilt mode, but will always be needed if we did $split_brain)' if $split_brain; @@ -2009,7 +2097,7 @@ END my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet'; my @diffcmd = (@git, qw(diff), $diffopt, $tree); debugcmd "+",@diffcmd; - $!=0; $?=0; + $!=0; $?=-1; my $r = system @diffcmd; if ($r) { if ($r==256) { @@ -2021,7 +2109,6 @@ END failedcmd @diffcmd; } } - my $head = git_rev_parse('HEAD'); if (!$changesfile) { my $pat = changespat $cversion; my @cs = glob "$buildproductsdir/$pat"; @@ -2037,6 +2124,7 @@ END responder_send_file('changes',$changesfile); responder_send_command("param head $head"); responder_send_command("param csuite $csuite"); + responder_send_command("param tagformat $tagformat"); if (deliberately_not_fast_forward) { git_for_each_ref(lrfetchrefs, sub { @@ -2059,7 +2147,7 @@ END $tagobjfn = $tfn->('.signed.tmp'); responder_receive_files('signed-tag', $tagobjfn); } else { - $tagobjfn = + ($tagobjfn) = push_mktag($head,$clogp,$tag, $dscpath, $changesfile,$changesfile, @@ -2299,7 +2387,7 @@ sub cmd_remote_push_build_host { unless defined $protovsn; responder_send_command("dgit-remote-push-ready $protovsn"); - + rpush_handle_protovsn_bothends(); changedir $dir; &cmd_push; } @@ -2308,6 +2396,17 @@ sub cmd_remote_push_responder { cmd_remote_push_build_host(); } # ... for compatibility with proto vsn.1 dgit (just so that user gets # a good error message) +sub rpush_handle_protovsn_bothends () { + if ($protovsn < 4) { + fail "rpush negotiated protocol version $protovsn". + " which supports old tag format only". + " but trying to use new format (".$tagformat_want->[1].")" + if $tagformat_want && $tagformat_want->[0] ne 'old'; + $tagformat_want = ['old', "rpush negotiated protocol $protovsn", 0]; + } + select_tagformat(); +} + our $i_tmp; sub i_cleanup { @@ -2366,6 +2465,7 @@ sub cmd_rpush { ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ }; die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support; $supplementary_message = '' unless $protovsn >= 3; + rpush_handle_protovsn_bothends(); for (;;) { my ($icmd,$iargs) = initiator_expect { m/^(\S+)(?: (.*))?$/; @@ -2470,11 +2570,18 @@ sub i_want_signed_tag { my $head = $i_param{'head'}; die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../; + select_tagformat(); + if ($protovsn >= 4) { + my $p = $i_param{'tagformat'} // ''; + $p eq $tagformat + or badproto \*RO, "tag format mismatch: $p vs. $tagformat"; + } + die unless $i_param{'csuite'} =~ m/^$suite_re$/; $csuite = $&; push_parse_dsc $i_dscfn, 'remote dsc', $i_version; - my $tagobjfn = + my ($tagobjfn) = push_mktag $head, $i_clogp, $i_tag, $i_dscfn, $i_changesfn, 'remote changes', @@ -2557,7 +2664,7 @@ sub quiltify_tree_sentinelfiles ($) { qw(-- debian/rules debian/control); $r =~ s/\n/,/g; return $r; - } +} sub quiltify_splitbrain_needed () { if (!$split_brain) { @@ -2798,7 +2905,8 @@ sub quiltify ($$$$) { die "$quilt_mode ?"; } - my $time = time; + my $time = $ENV{'GIT_COMMITTER_DATE'} || time; + $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE my $ncommits = 3; my $msg = cmdoutput @git, qw(log), "-n$ncommits"; @@ -2943,8 +3051,117 @@ sub quilt_fixup_singlepatch ($$$) { chdir "work"; commit_quilty_patch(); +} + +sub quilt_make_fake_dsc ($) { + my ($upstreamversion) = @_; + + my $fakeversion="$upstreamversion-~~DGITFAKE"; + + my $fakedsc=new IO::File 'fake.dsc', '>' or die $!; + print $fakedsc <addfile($fh); + print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!; + }; + + quilt_fixup_linkorigs($upstreamversion, $dscaddfile); + my @files=qw(debian/source/format debian/rules + debian/control debian/changelog); + foreach my $maybe (qw(debian/patches debian/source/options + debian/tests/control)) { + next unless stat_exists "../../../$maybe"; + push @files, $maybe; + } + + my $debtar= srcfn $fakeversion,'.debian.tar.gz'; + runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files; + + $dscaddfile->($debtar); + close $fakedsc or die $!; +} + +sub quilt_check_splitbrain_cache ($$) { + my ($headref, $upstreamversion) = @_; + # Called only if we are in (potentially) split brain mode. + # Called in $ud. + # Computes the cache key and looks in the cache. + # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey) + + my $splitbrain_cachekey; + progress + "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode)."; + # we look in the reflog of dgit-intern/quilt-cache + # we look for an entry whose message is the key for the cache lookup + my @cachekey = (qw(dgit), $our_version); + push @cachekey, $upstreamversion; + push @cachekey, $quilt_mode; + push @cachekey, $headref; + + push @cachekey, hashfile('fake.dsc'); + + my $srcshash = Digest::SHA->new(256); + my %sfs = ( %INC, '$0(dgit)' => $0 ); + foreach my $sfk (sort keys %sfs) { + next unless m/^\$0\b/ || m{^Debian/Dgit\b}; + $srcshash->add($sfk," "); + $srcshash->add(hashfile($sfs{$sfk})); + $srcshash->add("\n"); + } + push @cachekey, $srcshash->hexdigest(); + $splitbrain_cachekey = "@cachekey"; + + my @cmd = (@git, qw(reflog), '--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 '../../..' or die $!; + if (!stat ".git/logs/refs/$splitbraincache") { + $! == ENOENT or die $!; + printdebug ">(no reflog)\n"; + exit 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); + if ($cachehit ne $headref) { + progress "dgit view: found cached (commit id $cachehit)"; + runcmd @git, qw(checkout -q -b dgit-view), $cachehit; + $split_brain = 1; + return ($cachehit, $splitbrain_cachekey); + } + 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); } sub quilt_fixup_multipatch ($$$) { @@ -3021,102 +3238,15 @@ sub quilt_fixup_multipatch ($$$) { # afterwards with dpkg-source --before-build. That lets us save a # tree object corresponding to .origs. - my $fakeversion="$upstreamversion-~~DGITFAKE"; - - my $fakedsc=new IO::File 'fake.dsc', '>' or die $!; - print $fakedsc <addfile($fh); - print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!; - }; - - quilt_fixup_linkorigs($upstreamversion, $dscaddfile); - - my @files=qw(debian/source/format debian/rules - debian/control debian/changelog); - foreach my $maybe (qw(debian/patches debian/source/options - debian/tests/control)) { - next unless stat_exists "../../../$maybe"; - push @files, $maybe; - } - - my $debtar= srcfn $fakeversion,'.debian.tar.gz'; - runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files; + my $splitbrain_cachekey; - $dscaddfile->($debtar); - close $fakedsc or die $!; + quilt_make_fake_dsc($upstreamversion); - my $splitbrain_cachekey; if (quiltmode_splitbrain()) { - progress - "dgit: split brain (separate dgit view) may needed (--quilt=$quilt_mode)."; - # we look in the reflog of dgit-intern/quilt-cache - # we look for an entry whose message is the key for the cache lookup - my @cachekey = (qw(dgit), $our_version); - push @cachekey, $upstreamversion; - push @cachekey, $quilt_mode; - push @cachekey, $headref; - - push @cachekey, hashfile('fake.dsc'); - - my $srcshash = Digest::SHA->new(256); - my %sfs = ( %INC, '$0(dgit)' => $0 ); - foreach my $sfk (sort keys %sfs) { - $srcshash->add($sfk," "); - $srcshash->add(hashfile($sfs{$sfk})); - $srcshash->add("\n"); - } - push @cachekey, $srcshash->hexdigest(); - $splitbrain_cachekey = "@cachekey"; - - my @cmd = (@git, qw(reflog), '--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 '../../..' or die $!; - if (!stat ".git/logs/refs/$splitbraincache") { - $! == ENOENT or die $!; - printdebug ">(no reflog)\n"; - exit 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); - if ($cachehit ne $headref) { - progress "dgit view: found cached (commit id $cachehit)"; - runcmd @git, qw(checkout -q -b dgit-view), $cachehit; - $split_brain = 1; - return; - } - progress "dgit view: found cached, no changes required"; - return; - } - die $! if GC->error; - failedcmd unless close GC; - - printdebug "splitbrain cache miss\n"; + my $cachehit; + ($cachehit, $splitbrain_cachekey) = + quilt_check_splitbrain_cache($headref, $upstreamversion); + return if $cachehit; } runcmd qw(sh -ec), @@ -3736,6 +3866,11 @@ sub parseopts () { } elsif (m/^--deliberately-($deliberately_re)$/s) { push @ropts, $_; push @deliberatelies, $&; + } elsif (m/^--dgit-tag-format=(old|new)$/s) { + # undocumented, for testing + 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, $_;