1#!/usr/bin/perl 2# These two should go upon release to make the script Perl 5.005 compatible 3use strict; 4use warnings; 5 6=head1 NAME 7 8make_patchnum.pl - make patchnum 9 10=head1 SYNOPSIS 11 12 miniperl make_patchnum.pl 13 14 perl make_patchnum.pl 15 16=head1 DESCRIPTION 17 18This program creates the files holding the information 19about locally applied patches to the source code. The created 20files are F<git_version.h> and F<lib/Config_git.pl>. 21 22=head2 F<lib/Config_git.pl> 23 24Contains status information from git in a form meant to be processed 25by the tied hash logic of Config.pm. It is actually optional, 26although -V:git.\* will be uninformative without it. 27 28C<git_version.h> contains similar information in a C header file 29format, designed to be used by patchlevel.h. This file is obtained 30from stock_git_version.h if miniperl is not available, and then 31later on replaced by the version created by this script. 32 33=head1 AUTHOR 34 35Yves Orton, Kenichi Ishigaki, Max Maischein 36 37=head1 COPYRIGHT 38 39Same terms as Perl itself. 40 41=cut 42 43# from a -Dmksymlink target dir, I need to cd to the git-src tree to 44# use git (like script does). Presuming that's not unique, one fix is 45# to follow Configure's symlink-path to run git. Maybe GIT_DIR or 46# path-args can solve it, if so we should advise here, I tried only 47# very briefly ('cd -' works too). 48 49my ($subcd, $srcdir); 50our $opt_v = scalar grep $_ eq '-v', @ARGV; 51 52BEGIN { 53 my $root="."; 54 while (!-e "$root/perl.c" and length($root)<100) { 55 if ($root eq '.') { 56 $root=".."; 57 } else { 58 $root.="/.."; 59 } 60 } 61 die "Can't find toplevel" if !-e "$root/perl.c"; 62 sub path_to { "$root/$_[0]" } # use $_[0] if this'd be placed in toplevel. 63 64 # test to see if we're a -Dmksymlinks target dir 65 $subcd = ''; 66 $srcdir = $root; 67 if (-l "$root/Configure") { 68 $srcdir = readlink("$root/Configure"); 69 $srcdir =~ s/Configure//; 70 $subcd = "cd $srcdir &&"; # activate backtick fragment 71 } 72} 73 74sub read_file { 75 my $file = path_to(@_); 76 return "" unless -e $file; 77 open my $fh, '<', $file 78 or die "Failed to open for read '$file':$!"; 79 return do { local $/; <$fh> }; 80} 81 82sub write_file { 83 my ($file, $content) = @_; 84 $file= path_to($file); 85 open my $fh, '>', $file 86 or die "Failed to open for write '$file':$!"; 87 print $fh $content; 88 close $fh; 89} 90 91sub backtick { 92 # only for git. If we're in a -Dmksymlinks build-dir, we need to 93 # cd to src so git will work . Probably a better way. 94 my $command = shift; 95 if (wantarray) { 96 my @result= `$subcd $command`; 97 #warn "$subcd $command: \$?=$?\n" if $?; 98 print "#> $subcd $command ->\n @result\n" if !$? and $opt_v; 99 chomp @result; 100 return @result; 101 } else { 102 my $result= `$subcd $command`; 103 $result="" if ! defined $result; 104 #warn "$subcd $command: \$?=$?\n" if $?; 105 print "#> $subcd $command ->\n $result\n" if !$? and $opt_v; 106 chomp $result; 107 return $result; 108 } 109} 110 111sub write_files { 112 my %content= map { /WARNING: '([^']+)'/ || die "Bad mojo!"; $1 => $_ } @_; 113 my @files= sort keys %content; 114 my $files= join " and ", map { "'$_'" } @files; 115 foreach my $file (@files) { 116 if (read_file($file) ne $content{$file}) { 117 print "Updating $files\n"; 118 write_file($_,$content{$_}) for @files; 119 return 1; 120 } 121 } 122 print "Reusing $files\n"; 123 return 0; 124} 125 126my $unpushed_commits = ' '; 127my ($read, $branch, $snapshot_created, $commit_id, $describe)= ("") x 5; 128my ($changed, $extra_info, $commit_title)= ("") x 3; 129 130my $git_patch_file; 131if (my $patch_file= read_file(".patch")) { 132 ($branch, $snapshot_created, $commit_id, $describe) = split /\s+/, $patch_file; 133 $extra_info = "git_snapshot_date='$snapshot_created'"; 134 $commit_title = "Snapshot of:"; 135} 136elsif ($git_patch_file = read_file(".git_patch") and $git_patch_file !~ /\A\$Format:%H/) { 137 chomp $git_patch_file; 138 ($commit_id, my $commit_date, my $names) 139 = split /\|/, $git_patch_file; 140 141 my @names = split /,\s*/, $names; 142 143 ($branch) = map m{^HEAD -> (.*)}, @names; 144 if (!$branch) { 145 ($branch) = map m{^(blead|maint/.*)}, @names; 146 } 147 if (!$branch) { 148 ($branch) = map m{^tag: (.*)}, @names; 149 $describe = $branch; 150 } 151 if (!$branch) { 152 my ($pr) = map m{^refs/pull/([0-9]+)/}, @names; 153 $branch = "pull-request-$pr"; 154 } 155 if (!$branch) { 156 $branch = $names[0] || $commit_id; 157 } 158 159 $describe ||= $commit_id; 160 $extra_info = "git_commit_date='$commit_date'\n"; 161 $extra_info .= "git_snapshot_date='$commit_date'\n"; 162 $commit_title = "Snapshot of:"; 163} 164elsif (-d "$srcdir/.git") { 165 ($branch) = backtick("git symbolic-ref -q HEAD") =~ m#^refs/heads/(.+)$#; 166 $branch //= ""; 167 my ($remote,$merge); 168 if (length $branch) { 169 $merge= backtick("git config branch.$branch.merge"); 170 $merge = "" unless $? == 0; 171 $merge =~ s!^refs/heads/!!; 172 $remote= backtick("git config branch.$branch.remote"); 173 $remote = "" unless $? == 0; 174 } 175 $commit_id = backtick("git rev-parse HEAD"); 176 $describe = backtick("git describe"); 177 my $commit_created = backtick(qq{git log -1 --pretty="format:%ci"}); 178 $extra_info = "git_commit_date='$commit_created'"; 179 backtick("git diff --no-ext-diff --quiet --exit-code"); 180 $changed = $?; 181 unless ($changed) { 182 backtick("git diff-index --cached --quiet HEAD --"); 183 $changed = $?; 184 } 185 186 if (length $branch && length $remote) { 187 # git cherry $remote/$branch | awk 'BEGIN{ORS=","} /\+/ {print $2}' | sed -e 's/,$//' 188 my $unpushed_commit_list = 189 join ",", map { (split /\s/, $_)[1] } 190 grep {/\+/} backtick("git cherry $remote/$merge"); 191 # git cherry $remote/$branch | awk 'BEGIN{ORS="\t\\\\\n"} /\+/ {print ",\"" $2 "\""}' 192 $unpushed_commits = 193 join "", map { ',"'.(split /\s/, $_)[1]."\"\t\\\n" } 194 grep {/\+/} backtick("git cherry $remote/$merge"); 195 if (length $unpushed_commits) { 196 $commit_title = "Local Commit:"; 197 my $ancestor = backtick("git rev-parse $remote/$merge"); 198 $extra_info = "$extra_info 199git_ancestor='$ancestor' 200git_remote_branch='$remote/$merge' 201git_unpushed='$unpushed_commit_list'"; 202 } 203 } 204 if ($changed) { 205 $commit_title = "Derived from:"; 206 } 207 $commit_title ||= "Commit id:"; 208} 209 210# we extract the filename out of the warning header, so don't mess with that 211write_files(<<"EOF_HEADER", <<"EOF_CONFIG"); 212/************************************************************************** 213* WARNING: 'git_version.h' is automatically generated by make_patchnum.pl 214* DO NOT EDIT DIRECTLY - edit make_patchnum.pl instead 215***************************************************************************/ 216@{[$describe ? "#define PERL_PATCHNUM \"$describe\"" : ()]} 217#define PERL_GIT_UNPUSHED_COMMITS\t\t\\ 218$unpushed_commits/*leave-this-comment*/ 219@{[$changed ? "#define PERL_GIT_UNCOMMITTED_CHANGES" : ()]} 220EOF_HEADER 221###################################################################### 222# WARNING: 'lib/Config_git.pl' is generated by make_patchnum.pl 223# DO NOT EDIT DIRECTLY - edit make_patchnum.pl instead 224###################################################################### 225\$Config::Git_Data=<<'ENDOFGIT'; 226git_commit_id='$commit_id' 227git_describe='$describe' 228git_branch='$branch' 229git_uncommitted_changes='$changed' 230git_commit_id_title='$commit_title' 231$extra_info 232ENDOFGIT 233EOF_CONFIG 234# ex: set ts=8 sts=4 sw=4 et ft=perl: 235