Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: chip/bind2
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 205 lines (178 sloc) 6.792 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204
#!/usr/bin/perl
# These two should go upon release to make the script Perl 5.005 compatible
use strict;
use warnings;

=head1 NAME

make_patchnum.pl - make patchnum

=head1 SYNOPSIS

miniperl make_patchnum.pl

perl make_patchnum.pl

=head1 DESCRIPTION

This program creates the files holding the information
about locally applied patches to the source code. The created
files are F<git_version.h> and F<lib/Config_git.pl>.

=head2 C<lib/Config_git.pl>

Contains status information from git in a form meant to be processed
by the tied hash logic of Config.pm. It is actually optional,
although -V:git.\* will be uninformative without it.

C<git_version.h> contains similar information in a C header file
format, designed to be used by patchlevel.h. This file is obtained
from stock_git_version.h if miniperl is not available, and then
later on replaced by the version created by this script.

=head1 AUTHOR

Yves Orton, Kenichi Ishigaki, Max Maischein

=head1 COPYRIGHT

Same terms as Perl itself.

=cut

# from a -Dmksymlink target dir, I need to cd to the git-src tree to
# use git (like script does). Presuming that's not unique, one fix is
# to follow Configure's symlink-path to run git. Maybe GIT_DIR or
# path-args can solve it, if so we should advise here, I tried only
# very briefly ('cd -' works too).

my ($subcd, $srcdir);
our $opt_v = scalar grep $_ eq '-v', @ARGV;

BEGIN {
    my $root=".";
    # test 1st to see if we're a -Dmksymlinks target dir
    $subcd = '';
    $srcdir = $root;
    if (-l "./Configure") {
$srcdir = readlink("./Configure");
$srcdir =~ s/Configure//;
$subcd = "cd $srcdir &&"; # activate backtick fragment
    }
    while (!-e "$root/perl.c" and length($root)<100) {
        if ($root eq '.') {
            $root="..";
        } else {
            $root.="/..";
        }
    }
    die "Can't find toplevel" if !-e "$root/perl.c";
    sub path_to { "$root/$_[0]" } # use $_[0] if this'd be placed in toplevel.
}

sub read_file {
    my $file = path_to(@_);
    return "" unless -e $file;
    open my $fh, '<', $file
        or die "Failed to open for read '$file':$!";
    return do { local $/; <$fh> };
}

sub write_file {
    my ($file, $content) = @_;
    $file= path_to($file);
    open my $fh, '>', $file
        or die "Failed to open for write '$file':$!";
    print $fh $content;
    close $fh;
}

sub backtick {
    # only for git. If we're in a -Dmksymlinks build-dir, we need to
    # cd to src so git will work . Probably a better way.
    my $command = shift;
    if (wantarray) {
        my @result= `$subcd $command`;
        #warn "$subcd $command: \$?=$?\n" if $?;
        print "#> $subcd $command ->\n @result\n" if !$? and $opt_v;
        chomp @result;
        return @result;
    } else {
        my $result= `$subcd $command`;
        $result="" if ! defined $result;
        warn "$subcd $command: \$?=$?\n" if $?;
        print "#> $subcd $command ->\n $result\n" if !$? and $opt_v;
        chomp $result;
        return $result;
    }
}

sub write_files {
    my %content= map { /WARNING: '([^']+)'/ || die "Bad mojo!"; $1 => $_ } @_;
    my @files= sort keys %content;
    my $files= join " and ", map { "'$_'" } @files;
    foreach my $file (@files) {
        if (read_file($file) ne $content{$file}) {
            print "Updating $files\n";
            write_file($_,$content{$_}) for @files;
            return 1;
        }
    }
    print "Reusing $files\n";
    return 0;
}

my $unpushed_commits = ' ';
my ($read, $branch, $snapshot_created, $commit_id, $describe)= ("") x 5;
my ($changed, $extra_info, $commit_title)= ("") x 3;

if (my $patch_file= read_file(".patch")) {
    ($branch, $snapshot_created, $commit_id, $describe) = split /\s+/, $patch_file;
    $extra_info = "git_snapshot_date='$snapshot_created'";
    $commit_title = "Snapshot of:";
}
elsif (-d "$srcdir/.git") {
    # git branch | awk 'BEGIN{ORS=""} /\*/ { print $2 }'
    ($branch) = map { /\* ([^(]\S*)/ ? $1 : "" } backtick("git branch");
    my ($remote,$merge);
    if (length $branch) {
        $merge= backtick("git config branch.$branch.merge");
        $merge = "" unless $? == 0;
        $merge =~ s!^refs/heads/!!;
        $remote= backtick("git config branch.$branch.remote");
        $remote = "" unless $? == 0;
    }
    $commit_id = backtick("git rev-parse HEAD");
    $describe = backtick("git describe");
    my $commit_created = backtick(qq{git log -1 --pretty="format:%ci"});
    $extra_info = "git_commit_date='$commit_created'";
    backtick("git diff --no-ext-diff --quiet --exit-code");
    $changed = $?;
    unless ($changed) {
        backtick("git diff-index --cached --quiet HEAD --");
        $changed = $?;
    }

    if (length $branch && length $remote) {
        # git cherry $remote/$branch | awk 'BEGIN{ORS=","} /\+/ {print $2}' | sed -e 's/,$//'
        my $unpushed_commit_list =
            join ",", map { (split /\s/, $_)[1] }
            grep {/\+/} backtick("git cherry $remote/$merge");
        # git cherry $remote/$branch | awk 'BEGIN{ORS="\t\\\\\n"} /\+/ {print ",\"" $2 "\""}'
        $unpushed_commits =
            join "", map { ',"'.(split /\s/, $_)[1]."\"\t\\\n" }
            grep {/\+/} backtick("git cherry $remote/$merge");
        if (length $unpushed_commits) {
            $commit_title = "Local Commit:";
            my $ancestor = backtick("git rev-parse $remote/$merge");
            $extra_info = "$extra_info
git_ancestor='$ancestor'
git_remote_branch='$remote/$merge'
git_unpushed='$unpushed_commit_list'";
        }
    }
    if ($changed) {
        $commit_title = "Derived from:";
    }
    $commit_title ||= "Commit id:";
}

# we extract the filename out of the warning header, so dont mess with that
write_files(<<"EOF_HEADER", <<"EOF_CONFIG");
/**************************************************************************
* WARNING: 'git_version.h' is automatically generated by make_patchnum.pl
* DO NOT EDIT DIRECTLY - edit make_patchnum.pl instead
***************************************************************************/
@{[$describe ? "#define PERL_PATCHNUM \"$describe\"" : ()]}
#define PERL_GIT_UNPUSHED_COMMITS\t\t\\
$unpushed_commits/*leave-this-comment*/
@{[$changed ? "#define PERL_GIT_UNCOMMITTED_CHANGES" : ()]}
EOF_HEADER
######################################################################
# WARNING: 'lib/Config_git.pl' is generated by make_patchnum.pl
# DO NOT EDIT DIRECTLY - edit make_patchnum.pl instead
######################################################################
\$Config::Git_Data=<<'ENDOFGIT';
git_commit_id='$commit_id'
git_describe='$describe'
git_branch='$branch'
git_uncommitted_changes='$changed'
git_commit_id_title='$commit_title'
$extra_info
ENDOFGIT
EOF_CONFIG
# ex: set ts=8 sts=4 sw=4 et ft=perl:
Something went wrong with that request. Please try again.