Commit | Line | Data |
25f0751f |
1 | package MakeUtil ; |
2 | package main ; |
3 | |
4 | use strict ; |
5 | |
6 | use Config qw(%Config); |
7 | use File::Copy; |
8 | |
9 | |
10 | BEGIN |
11 | { |
12 | eval { require File::Spec::Functions ; File::Spec::Functions->import() } ; |
13 | if ($@) |
14 | { |
15 | *catfile = sub { return "$_[0]/$_[1]" } |
16 | } |
17 | } |
18 | |
19 | require VMS::Filespec if $^O eq 'VMS'; |
20 | |
21 | |
22 | unless($ENV{PERL_CORE}) { |
23 | $ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV; |
24 | } |
25 | |
26 | $ENV{SKIP_FOR_CORE} = 1 if $ENV{PERL_CORE} || $ENV{MY_PERL_CORE} ; |
27 | |
28 | |
29 | |
30 | sub MY::libscan |
31 | { |
32 | my $self = shift; |
33 | my $path = shift; |
34 | |
35 | return undef |
36 | if $path =~ /(~|\.bak|_bak)$/ || |
37 | $path =~ /\..*\.sw(o|p)$/ || |
38 | $path =~ /\B\.svn\b/; |
39 | |
40 | return $path; |
41 | } |
42 | |
43 | sub MY::postamble |
44 | { |
45 | return '' |
46 | if $ENV{PERL_CORE} ; |
47 | |
48 | my @files = getPerlFiles('MANIFEST'); |
49 | |
50 | my $postamble = ' |
51 | |
52 | MyTrebleCheck: |
53 | @echo Checking for $$^W in files: '. "@files" . ' |
54 | @perl -ne \' \ |
55 | exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/; \ |
56 | \' ' . " @files || " . ' \ |
57 | (echo found unexpected $$^W ; exit 1) |
58 | @echo All is ok. |
59 | |
60 | '; |
61 | |
62 | return $postamble; |
63 | } |
64 | |
65 | sub getPerlFiles |
66 | { |
67 | my @manifests = @_ ; |
68 | |
69 | my @files = (); |
70 | |
71 | for my $manifest (@manifests) |
72 | { |
73 | my $prefix = './'; |
74 | |
75 | $prefix = $1 |
76 | if $manifest =~ m#^(.*/)#; |
77 | |
78 | open M, "<$manifest" |
79 | or die "Cannot open '$manifest': $!\n"; |
80 | while (<M>) |
81 | { |
82 | chomp ; |
83 | next if /^\s*#/ || /^\s*$/ ; |
84 | |
85 | s/^\s+//; |
86 | s/\s+$//; |
87 | |
88 | /^(\S+)\s*(.*)$/; |
89 | |
90 | my ($file, $rest) = ($1, $2); |
91 | |
92 | if ($file =~ /\.(pm|pl|t)$/ and $file !~ /MakeUtil.pm/) |
93 | { |
94 | push @files, "$prefix$file"; |
95 | } |
96 | elsif ($rest =~ /perl/i) |
97 | { |
98 | push @files, "$prefix$file"; |
99 | } |
100 | |
101 | } |
102 | close M; |
103 | } |
104 | |
105 | return @files; |
106 | } |
107 | |
108 | sub UpDowngrade |
109 | { |
110 | return if defined $ENV{TipTop}; |
111 | |
112 | my @files = @_ ; |
113 | |
114 | # our and use bytes/utf8 is stable from 5.6.0 onward |
115 | # warnings is stable from 5.6.1 onward |
116 | |
117 | # Note: this code assumes that each statement it modifies is not |
118 | # split across multiple lines. |
119 | |
120 | |
121 | my $warn_sub = ''; |
122 | my $our_sub = '' ; |
123 | |
124 | my $upgrade ; |
125 | my $downgrade ; |
126 | |
127 | my $caller = (caller(1))[3] || ''; |
128 | |
129 | if ($caller =~ /downgrade/) |
130 | { |
131 | $downgrade = 1; |
132 | } |
133 | elsif ($caller =~ /upgrade/) |
134 | { |
135 | $upgrade = 1; |
136 | } |
137 | # else |
138 | # { |
139 | # my $opt = shift @ARGV || '' ; |
140 | # $upgrade = ($opt =~ /^-upgrade/i); |
141 | # $downgrade = ($opt =~ /^-downgrade/i); |
142 | # push @ARGV, $opt unless $downgrade || $upgrade; |
143 | # } |
144 | |
145 | if ($downgrade) { |
146 | # From: use|no warnings "blah" |
147 | # To: local ($^W) = 1; # use|no warnings "blah" |
148 | $warn_sub = sub { |
149 | s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ; |
150 | s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ; |
151 | }; |
152 | } |
153 | elsif ($] >= 5.006001 || $upgrade) { |
154 | # From: local ($^W) = 1; # use|no warnings "blah" |
155 | # To: use|no warnings "blah" |
156 | $warn_sub = sub { |
157 | s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ; |
158 | }; |
159 | } |
160 | |
161 | if ($downgrade) { |
162 | $our_sub = sub { |
163 | if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) { |
164 | my $indent = $1; |
165 | my $vars = join ' ', split /\s*,\s*/, $2; |
166 | $_ = "${indent}use vars qw($vars);\n"; |
167 | } |
168 | elsif ( /^(\s*)((use|no)\s+(bytes|utf8)\s*;.*)$/) |
169 | { |
170 | $_ = "$1# $2\n"; |
171 | } |
172 | }; |
173 | } |
174 | elsif ($] >= 5.006000 || $upgrade) { |
175 | $our_sub = sub { |
176 | if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) { |
177 | my $indent = $1; |
178 | my $vars = join ', ', split ' ', $2; |
179 | $_ = "${indent}our ($vars);\n"; |
180 | } |
181 | elsif ( /^(\s*)#\s*((use|no)\s+(bytes|utf8)\s*;.*)$/) |
182 | { |
183 | $_ = "$1$2\n"; |
184 | } |
185 | }; |
186 | } |
187 | |
188 | if (! $our_sub && ! $warn_sub) { |
189 | warn "Up/Downgrade not needed.\n"; |
190 | if ($upgrade || $downgrade) |
191 | { exit 0 } |
192 | else |
193 | { return } |
194 | } |
195 | |
196 | foreach (@files) { |
197 | #if (-l $_ ) |
198 | { doUpDown($our_sub, $warn_sub, $_) } |
199 | #else |
200 | #{ doUpDownViaCopy($our_sub, $warn_sub, $_) } |
201 | } |
202 | |
203 | warn "Up/Downgrade complete.\n" ; |
204 | exit 0 if $upgrade || $downgrade; |
205 | |
206 | } |
207 | |
208 | |
209 | sub doUpDown |
210 | { |
211 | my $our_sub = shift; |
212 | my $warn_sub = shift; |
213 | |
214 | return if -d $_[0]; |
215 | |
216 | local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak"; |
217 | local (@ARGV) = shift; |
218 | |
219 | while (<>) |
220 | { |
221 | print, last if /^__(END|DATA)__/ ; |
222 | |
223 | &{ $our_sub }() if $our_sub ; |
224 | &{ $warn_sub }() if $warn_sub ; |
225 | print ; |
226 | } |
227 | |
228 | return if eof ; |
229 | |
230 | while (<>) |
231 | { print } |
232 | } |
233 | |
234 | sub doUpDownViaCopy |
235 | { |
236 | my $our_sub = shift; |
237 | my $warn_sub = shift; |
238 | my $file = shift ; |
239 | |
240 | use File::Copy ; |
241 | |
242 | return if -d $file ; |
243 | |
244 | my $backup = $file . ($^O eq 'VMS') ? "_bak" : ".bak"; |
245 | |
246 | copy($file, $backup) |
247 | or die "Cannot copy $file to $backup: $!"; |
248 | |
249 | my @keep = (); |
250 | |
251 | { |
252 | open F, "<$file" |
253 | or die "Cannot open $file: $!\n" ; |
254 | while (<F>) |
255 | { |
256 | if (/^__(END|DATA)__/) |
257 | { |
258 | push @keep, $_; |
259 | last ; |
260 | } |
261 | |
262 | &{ $our_sub }() if $our_sub ; |
263 | &{ $warn_sub }() if $warn_sub ; |
264 | push @keep, $_; |
265 | } |
266 | |
267 | if (! eof F) |
268 | { |
269 | while (<F>) |
270 | { push @keep, $_ } |
271 | } |
272 | close F; |
273 | } |
274 | |
275 | { |
276 | open F, ">$file" |
277 | or die "Cannot open $file: $!\n"; |
278 | print F @keep ; |
279 | close F; |
280 | } |
281 | } |
282 | |
283 | package MakeUtil ; |
284 | |
285 | 1; |
286 | |
287 | |