1 | # |
---|
2 | use Config; |
---|
3 | use File::Compare qw(compare); |
---|
4 | use File::Copy qw(copy); |
---|
5 | my $OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i; |
---|
6 | my $name = $0; |
---|
7 | $name =~ s#^(.*)\.PL$#../$1.SH#; |
---|
8 | my %opt; |
---|
9 | while (@ARGV && $ARGV[0] =~ /^([\w_]+)=(.*)$/) |
---|
10 | { |
---|
11 | $opt{$1}=$2; |
---|
12 | shift(@ARGV); |
---|
13 | } |
---|
14 | my $patchlevel = $opt{INST_VER}; |
---|
15 | $patchlevel =~ s|^[\\/]||; |
---|
16 | $patchlevel =~ s|~VERSION~|$Config{version}|g; |
---|
17 | $patchlevel ||= $Config{version}; |
---|
18 | $patchlevel = qq["$patchlevel"]; |
---|
19 | |
---|
20 | open(SH,"<$name") || die "Cannot open $name:$!"; |
---|
21 | while (<SH>) |
---|
22 | { |
---|
23 | last if /^sed/; |
---|
24 | } |
---|
25 | ($term,$file,$pat) = /^sed\s+<<(\S+)\s+>(\S+)\s+(.*)$/; |
---|
26 | |
---|
27 | my $str = "sub munge\n{\n"; |
---|
28 | |
---|
29 | while ($pat =~ s/-e\s+'([^']*)'\s*//) |
---|
30 | { |
---|
31 | my $e = $1; |
---|
32 | $e =~ s/\\([\(\)])/$1/g; |
---|
33 | $e =~ s/\\(\d)/\$$1/g; |
---|
34 | $str .= "$e;\n"; |
---|
35 | } |
---|
36 | $str .= "}\n"; |
---|
37 | |
---|
38 | eval $str; |
---|
39 | |
---|
40 | die "$str:$@" if $@; |
---|
41 | |
---|
42 | open(H,">$file.new") || die "Cannot open $file.new:$!"; |
---|
43 | binmode H; # no CRs (which cause a spurious rebuild) |
---|
44 | while (<SH>) |
---|
45 | { |
---|
46 | last if /^$term$/o; |
---|
47 | s/\$([\w_]+)/Config($1)/eg; |
---|
48 | s/`([^\`]*)`/BackTick($1)/eg; |
---|
49 | munge(); |
---|
50 | s/\\\$/\$/g; |
---|
51 | s#/[ *\*]*\*/#/**/#; |
---|
52 | if (/^\s*#define\s+(PRIVLIB|SITELIB|VENDORLIB)_EXP/) |
---|
53 | { |
---|
54 | $_ = "#define ". $1 . "_EXP (win32_get_". lc($1) . "($patchlevel))\t/**/\n"; |
---|
55 | } |
---|
56 | # incpush() handles archlibs, so disable them |
---|
57 | elsif (/^\s*#define\s+(ARCHLIB|SITEARCH|VENDORARCH)_EXP/) |
---|
58 | { |
---|
59 | $_ = "/*#define ". $1 . "_EXP \"\"\t/**/\n"; |
---|
60 | } |
---|
61 | print H; |
---|
62 | } |
---|
63 | close(H); |
---|
64 | close(SH); |
---|
65 | |
---|
66 | |
---|
67 | chmod(0666,"../lib/CORE/config.h"); |
---|
68 | copy("$file.new","../lib/CORE/config.h") || die "Cannot copy:$!"; |
---|
69 | chmod(0444,"../lib/CORE/config.h"); |
---|
70 | |
---|
71 | if (!$OBJ && compare("$file.new",$file)) |
---|
72 | { |
---|
73 | warn "$file has changed\n"; |
---|
74 | chmod(0666,$file); |
---|
75 | unlink($file); |
---|
76 | rename("$file.new",$file); |
---|
77 | #chmod(0444,$file); |
---|
78 | exit(1); |
---|
79 | } |
---|
80 | else |
---|
81 | { |
---|
82 | unlink ("$file.new"); |
---|
83 | exit(0); |
---|
84 | } |
---|
85 | |
---|
86 | sub Config |
---|
87 | { |
---|
88 | my $var = shift; |
---|
89 | my $val = $Config{$var}; |
---|
90 | $val = 'undef' unless defined $val; |
---|
91 | $val =~ s/\\/\\\\/g; |
---|
92 | return $val; |
---|
93 | } |
---|
94 | |
---|
95 | sub BackTick |
---|
96 | { |
---|
97 | my $cmd = shift; |
---|
98 | if ($cmd =~ /^echo\s+(.*?)\s*\|\s+sed\s+'(.*)'\s*$/) |
---|
99 | { |
---|
100 | local ($data,$pat) = ($1,$2); |
---|
101 | $data =~ s/\s+/ /g; |
---|
102 | eval "\$data =~ $pat"; |
---|
103 | return $data; |
---|
104 | } |
---|
105 | else |
---|
106 | { |
---|
107 | die "Cannot handle \`$cmd\`"; |
---|
108 | } |
---|
109 | return $cmd; |
---|
110 | } |
---|