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 # test 1st to see if we're a -Dmksymlinks target dir 55 $subcd = ''; 56 $srcdir = $root; 57 if (-l "./Configure") { 58 $srcdir = readlink("./Configure"); 59 $srcdir =~ s/Configure//; 60 $subcd = "cd $srcdir &&"; # activate backtick fragment 61 } 62 while (!-e "$root/perl.c" and length($root)<100) { 63 if ($root eq '.') { 64 $root=".."; 65 } else { 66 $root.="/.."; 67 } 68 } 69 die "Can't find toplevel" if !-e "$root/perl.c"; 70 sub path_to { "$root/$_[0]" } # use $_[0] if this'd be placed in toplevel. 71} 72 73sub read_file { 74 my $file = path_to(@_); 75 return "" unless -e $file; 76 open my $fh, '<', $file 77 or die "Failed to open for read '$file':$!"; 78 return do { local $/; <$fh> }; 79} 80 81sub write_file { 82 my ($file, $content) = @_; 83 $file= path_to($file); 84 open my $fh, '>', $file 85 or die "Failed to open for write '$file':$!"; 86 print $fh $content; 87 close $fh; 88} 89 90sub backtick { 91 # only for git. If we're in a -Dmksymlinks build-dir, we need to 92 # cd to src so git will work . Probably a better way. 93 my $command = shift; 94 if (wantarray) { 95 my @result= `$subcd $command`; 96 #warn "$subcd $command: \$?=$?\n" if $?; 97 print "#> $subcd $command ->\n @result\n" if !$? and $opt_v; 98 chomp @result; 99 return @result; 100 } else { 101 my $result= `$subcd $command`; 102 $result="" if ! defined $result; 103 #warn "$subcd $command: \$?=$?\n" if $?; 104 print "#> $subcd $command ->\n $result\n" if !$? and $opt_v; 105 chomp $result; 106 return $result; 107 } 108} 109 110sub write_files { 111 my %content= map { /WARNING: '([^']+)'/ || die "Bad mojo!"; $1 => $_ } @_; 112 my @files= sort keys %content; 113 my $files= join " and ", map { "'$_'" } @files; 114 foreach my $file (@files) { 115 if (read_file($file) ne $content{$file}) { 116 print "Updating $files\n"; 117 write_file($_,$content{$_}) for @files; 118 return 1; 119 } 120 } 121 print "Reusing $files\n"; 122 return 0; 123} 124 125my $unpushed_commits = ' '; 126my ($read, $branch, $snapshot_created, $commit_id, $describe)= ("") x 5; 127my ($changed, $extra_info, $commit_title)= ("") x 3; 128 129my $git_patch_file; 130if (my $patch_file= read_file(".patch")) { 131 ($branch, $snapshot_created, $commit_id, $describe) = split /\s+/, $patch_file; 132 $extra_info = "git_snapshot_date='$snapshot_created'"; 133 $commit_title = "Snapshot of:"; 134} 135elsif ($git_patch_file = read_file(".git_patch") and $git_patch_file !~ /\A\$Format:%H/) { 136 chomp $git_patch_file; 137 ($commit_id, my $commit_date, my $names) 138 = split /\|/, $git_patch_file; 139 140 my @names = split /,\s*/, $names; 141 142 ($branch) = map m{^HEAD -> (.*)}, @names; 143 if (!$branch) { 144 ($branch) = map m{^(blead|maint/.*)}, @names; 145 } 146 if (!$branch) { 147 ($branch) = map m{^tag: (.*)}, @names; 148 $describe = $branch; 149 } 150 if (!$branch) { 151 my ($pr) = map m{^refs/pull/([0-9]+)/}, @names; 152 $branch = "pull-request-$pr"; 153 } 154 if (!$branch) { 155 $branch = $names[0] || $commit_id; 156 } 157 158 $describe ||= $commit_id; 159 $extra_info = "git_commit_date='$commit_date'\n"; 160 $extra_info .= "git_snapshot_date='$commit_date'\n"; 161 $commit_title = "Snapshot of:"; 162} 163elsif (-d "$srcdir/.git") { 164 # git branch | awk 'BEGIN{ORS=""} /\*/ { print $2 }' 165 ($branch) = map { /\* ([^(]\S*)/ ? $1 : () } backtick("git branch"); 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