| 1 | #!/usr/bin/perl |
| 2 | # These two should go upon release to make the script Perl 5.005 compatible |
| 3 | use strict; |
| 4 | use warnings; |
| 5 | |
| 6 | =head1 NAME |
| 7 | |
| 8 | make_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 | |
| 18 | This program creates the files holding the information |
| 19 | about locally applied patches to the source code. The created |
| 20 | files are F<git_version.h> and F<lib/Config_git.pl>. |
| 21 | |
| 22 | =head2 F<lib/Config_git.pl> |
| 23 | |
| 24 | Contains status information from git in a form meant to be processed |
| 25 | by the tied hash logic of Config.pm. It is actually optional, |
| 26 | although -V:git.\* will be uninformative without it. |
| 27 | |
| 28 | C<git_version.h> contains similar information in a C header file |
| 29 | format, designed to be used by patchlevel.h. This file is obtained |
| 30 | from stock_git_version.h if miniperl is not available, and then |
| 31 | later on replaced by the version created by this script. |
| 32 | |
| 33 | =head1 AUTHOR |
| 34 | |
| 35 | Yves Orton, Kenichi Ishigaki, Max Maischein |
| 36 | |
| 37 | =head1 COPYRIGHT |
| 38 | |
| 39 | Same 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 | |
| 49 | my ($subcd, $srcdir); |
| 50 | our $opt_v = scalar grep $_ eq '-v', @ARGV; |
| 51 | |
| 52 | BEGIN { |
| 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 | |
| 73 | sub 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 | |
| 81 | sub 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 | |
| 90 | sub 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 | |
| 110 | sub 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 | |
| 125 | my $unpushed_commits = ' '; |
| 126 | my ($read, $branch, $snapshot_created, $commit_id, $describe)= ("") x 5; |
| 127 | my ($changed, $extra_info, $commit_title)= ("") x 3; |
| 128 | |
| 129 | if (my $patch_file= read_file(".patch")) { |
| 130 | ($branch, $snapshot_created, $commit_id, $describe) = split /\s+/, $patch_file; |
| 131 | $extra_info = "git_snapshot_date='$snapshot_created'"; |
| 132 | $commit_title = "Snapshot of:"; |
| 133 | } |
| 134 | elsif (-d "$srcdir/.git") { |
| 135 | # git branch | awk 'BEGIN{ORS=""} /\*/ { print $2 }' |
| 136 | ($branch) = map { /\* ([^(]\S*)/ ? $1 : () } backtick("git branch"); |
| 137 | $branch //= ""; |
| 138 | my ($remote,$merge); |
| 139 | if (length $branch) { |
| 140 | $merge= backtick("git config branch.$branch.merge"); |
| 141 | $merge = "" unless $? == 0; |
| 142 | $merge =~ s!^refs/heads/!!; |
| 143 | $remote= backtick("git config branch.$branch.remote"); |
| 144 | $remote = "" unless $? == 0; |
| 145 | } |
| 146 | $commit_id = backtick("git rev-parse HEAD"); |
| 147 | $describe = backtick("git describe"); |
| 148 | my $commit_created = backtick(qq{git log -1 --pretty="format:%ci"}); |
| 149 | $extra_info = "git_commit_date='$commit_created'"; |
| 150 | backtick("git diff --no-ext-diff --quiet --exit-code"); |
| 151 | $changed = $?; |
| 152 | unless ($changed) { |
| 153 | backtick("git diff-index --cached --quiet HEAD --"); |
| 154 | $changed = $?; |
| 155 | } |
| 156 | |
| 157 | if (length $branch && length $remote) { |
| 158 | # git cherry $remote/$branch | awk 'BEGIN{ORS=","} /\+/ {print $2}' | sed -e 's/,$//' |
| 159 | my $unpushed_commit_list = |
| 160 | join ",", map { (split /\s/, $_)[1] } |
| 161 | grep {/\+/} backtick("git cherry $remote/$merge"); |
| 162 | # git cherry $remote/$branch | awk 'BEGIN{ORS="\t\\\\\n"} /\+/ {print ",\"" $2 "\""}' |
| 163 | $unpushed_commits = |
| 164 | join "", map { ',"'.(split /\s/, $_)[1]."\"\t\\\n" } |
| 165 | grep {/\+/} backtick("git cherry $remote/$merge"); |
| 166 | if (length $unpushed_commits) { |
| 167 | $commit_title = "Local Commit:"; |
| 168 | my $ancestor = backtick("git rev-parse $remote/$merge"); |
| 169 | $extra_info = "$extra_info |
| 170 | git_ancestor='$ancestor' |
| 171 | git_remote_branch='$remote/$merge' |
| 172 | git_unpushed='$unpushed_commit_list'"; |
| 173 | } |
| 174 | } |
| 175 | if ($changed) { |
| 176 | $commit_title = "Derived from:"; |
| 177 | } |
| 178 | $commit_title ||= "Commit id:"; |
| 179 | } |
| 180 | |
| 181 | # we extract the filename out of the warning header, so dont mess with that |
| 182 | write_files(<<"EOF_HEADER", <<"EOF_CONFIG"); |
| 183 | /************************************************************************** |
| 184 | * WARNING: 'git_version.h' is automatically generated by make_patchnum.pl |
| 185 | * DO NOT EDIT DIRECTLY - edit make_patchnum.pl instead |
| 186 | ***************************************************************************/ |
| 187 | @{[$describe ? "#define PERL_PATCHNUM \"$describe\"" : ()]} |
| 188 | #define PERL_GIT_UNPUSHED_COMMITS\t\t\\ |
| 189 | $unpushed_commits/*leave-this-comment*/ |
| 190 | @{[$changed ? "#define PERL_GIT_UNCOMMITTED_CHANGES" : ()]} |
| 191 | EOF_HEADER |
| 192 | ###################################################################### |
| 193 | # WARNING: 'lib/Config_git.pl' is generated by make_patchnum.pl |
| 194 | # DO NOT EDIT DIRECTLY - edit make_patchnum.pl instead |
| 195 | ###################################################################### |
| 196 | \$Config::Git_Data=<<'ENDOFGIT'; |
| 197 | git_commit_id='$commit_id' |
| 198 | git_describe='$describe' |
| 199 | git_branch='$branch' |
| 200 | git_uncommitted_changes='$changed' |
| 201 | git_commit_id_title='$commit_title' |
| 202 | $extra_info |
| 203 | ENDOFGIT |
| 204 | EOF_CONFIG |
| 205 | # ex: set ts=8 sts=4 sw=4 et ft=perl: |