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 | |
be714331 |
9 | my $VERSION = '1.0'; |
10 | |
25f0751f |
11 | |
12 | BEGIN |
13 | { |
14 | eval { require File::Spec::Functions ; File::Spec::Functions->import() } ; |
15 | if ($@) |
16 | { |
17 | *catfile = sub { return "$_[0]/$_[1]" } |
18 | } |
19 | } |
20 | |
21 | require VMS::Filespec if $^O eq 'VMS'; |
22 | |
23 | |
24 | unless($ENV{PERL_CORE}) { |
25 | $ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV; |
26 | } |
27 | |
28 | $ENV{SKIP_FOR_CORE} = 1 if $ENV{PERL_CORE} || $ENV{MY_PERL_CORE} ; |
29 | |
30 | |
31 | |
32 | sub MY::libscan |
33 | { |
34 | my $self = shift; |
35 | my $path = shift; |
36 | |
37 | return undef |
38 | if $path =~ /(~|\.bak|_bak)$/ || |
39 | $path =~ /\..*\.sw(o|p)$/ || |
40 | $path =~ /\B\.svn\b/; |
41 | |
42 | return $path; |
43 | } |
44 | |
45 | sub MY::postamble |
46 | { |
47 | return '' |
48 | if $ENV{PERL_CORE} ; |
49 | |
50 | my @files = getPerlFiles('MANIFEST'); |
51 | |
e11a3f9e |
52 | # Note: Once you remove all the layers of shell/makefile escaping |
53 | # the regular expression below reads |
54 | # |
55 | # /^\s*local\s*\(\s*\$^W\s*\)/ |
56 | # |
25f0751f |
57 | my $postamble = ' |
58 | |
59 | MyTrebleCheck: |
60 | @echo Checking for $$^W in files: '. "@files" . ' |
61 | @perl -ne \' \ |
62 | exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/; \ |
63 | \' ' . " @files || " . ' \ |
64 | (echo found unexpected $$^W ; exit 1) |
65 | @echo All is ok. |
66 | |
67 | '; |
68 | |
69 | return $postamble; |
70 | } |
71 | |
72 | sub getPerlFiles |
73 | { |
74 | my @manifests = @_ ; |
75 | |
76 | my @files = (); |
77 | |
78 | for my $manifest (@manifests) |
79 | { |
80 | my $prefix = './'; |
81 | |
82 | $prefix = $1 |
83 | if $manifest =~ m#^(.*/)#; |
84 | |
85 | open M, "<$manifest" |
86 | or die "Cannot open '$manifest': $!\n"; |
87 | while (<M>) |
88 | { |
89 | chomp ; |
90 | next if /^\s*#/ || /^\s*$/ ; |
91 | |
92 | s/^\s+//; |
93 | s/\s+$//; |
94 | |
95 | /^(\S+)\s*(.*)$/; |
96 | |
97 | my ($file, $rest) = ($1, $2); |
98 | |
99 | if ($file =~ /\.(pm|pl|t)$/ and $file !~ /MakeUtil.pm/) |
100 | { |
101 | push @files, "$prefix$file"; |
102 | } |
103 | elsif ($rest =~ /perl/i) |
104 | { |
105 | push @files, "$prefix$file"; |
106 | } |
107 | |
108 | } |
109 | close M; |
110 | } |
111 | |
112 | return @files; |
113 | } |
114 | |
115 | sub UpDowngrade |
116 | { |
117 | return if defined $ENV{TipTop}; |
118 | |
119 | my @files = @_ ; |
120 | |
121 | # our and use bytes/utf8 is stable from 5.6.0 onward |
122 | # warnings is stable from 5.6.1 onward |
123 | |
124 | # Note: this code assumes that each statement it modifies is not |
125 | # split across multiple lines. |
126 | |
127 | |
128 | my $warn_sub = ''; |
129 | my $our_sub = '' ; |
130 | |
131 | my $upgrade ; |
132 | my $downgrade ; |
258133d1 |
133 | my $do_downgrade ; |
25f0751f |
134 | |
135 | my $caller = (caller(1))[3] || ''; |
136 | |
137 | if ($caller =~ /downgrade/) |
138 | { |
139 | $downgrade = 1; |
140 | } |
141 | elsif ($caller =~ /upgrade/) |
142 | { |
143 | $upgrade = 1; |
144 | } |
258133d1 |
145 | else |
146 | { |
147 | $do_downgrade = 1 |
148 | if $] < 5.006001 ; |
149 | } |
150 | |
25f0751f |
151 | # else |
152 | # { |
153 | # my $opt = shift @ARGV || '' ; |
154 | # $upgrade = ($opt =~ /^-upgrade/i); |
155 | # $downgrade = ($opt =~ /^-downgrade/i); |
156 | # push @ARGV, $opt unless $downgrade || $upgrade; |
157 | # } |
158 | |
258133d1 |
159 | |
160 | if ($downgrade || $do_downgrade) { |
25f0751f |
161 | # From: use|no warnings "blah" |
162 | # To: local ($^W) = 1; # use|no warnings "blah" |
163 | $warn_sub = sub { |
164 | s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ; |
165 | s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ; |
166 | }; |
167 | } |
258133d1 |
168 | #elsif ($] >= 5.006001 || $upgrade) { |
169 | elsif ($upgrade) { |
25f0751f |
170 | # From: local ($^W) = 1; # use|no warnings "blah" |
171 | # To: use|no warnings "blah" |
172 | $warn_sub = sub { |
173 | s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ; |
174 | }; |
175 | } |
176 | |
258133d1 |
177 | if ($downgrade || $do_downgrade) { |
25f0751f |
178 | $our_sub = sub { |
179 | if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) { |
180 | my $indent = $1; |
181 | my $vars = join ' ', split /\s*,\s*/, $2; |
182 | $_ = "${indent}use vars qw($vars);\n"; |
183 | } |
184 | elsif ( /^(\s*)((use|no)\s+(bytes|utf8)\s*;.*)$/) |
185 | { |
186 | $_ = "$1# $2\n"; |
187 | } |
188 | }; |
189 | } |
258133d1 |
190 | #elsif ($] >= 5.006000 || $upgrade) { |
191 | elsif ($upgrade) { |
25f0751f |
192 | $our_sub = sub { |
193 | if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) { |
194 | my $indent = $1; |
195 | my $vars = join ', ', split ' ', $2; |
196 | $_ = "${indent}our ($vars);\n"; |
197 | } |
198 | elsif ( /^(\s*)#\s*((use|no)\s+(bytes|utf8)\s*;.*)$/) |
199 | { |
200 | $_ = "$1$2\n"; |
201 | } |
202 | }; |
203 | } |
204 | |
205 | if (! $our_sub && ! $warn_sub) { |
206 | warn "Up/Downgrade not needed.\n"; |
207 | if ($upgrade || $downgrade) |
208 | { exit 0 } |
209 | else |
210 | { return } |
211 | } |
212 | |
213 | foreach (@files) { |
214 | #if (-l $_ ) |
215 | { doUpDown($our_sub, $warn_sub, $_) } |
216 | #else |
217 | #{ doUpDownViaCopy($our_sub, $warn_sub, $_) } |
218 | } |
219 | |
220 | warn "Up/Downgrade complete.\n" ; |
221 | exit 0 if $upgrade || $downgrade; |
222 | |
223 | } |
224 | |
225 | |
226 | sub doUpDown |
227 | { |
228 | my $our_sub = shift; |
229 | my $warn_sub = shift; |
230 | |
231 | return if -d $_[0]; |
232 | |
233 | local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak"; |
234 | local (@ARGV) = shift; |
235 | |
236 | while (<>) |
237 | { |
238 | print, last if /^__(END|DATA)__/ ; |
239 | |
240 | &{ $our_sub }() if $our_sub ; |
241 | &{ $warn_sub }() if $warn_sub ; |
242 | print ; |
243 | } |
244 | |
245 | return if eof ; |
246 | |
247 | while (<>) |
248 | { print } |
249 | } |
250 | |
251 | sub doUpDownViaCopy |
252 | { |
253 | my $our_sub = shift; |
254 | my $warn_sub = shift; |
255 | my $file = shift ; |
256 | |
257 | use File::Copy ; |
258 | |
259 | return if -d $file ; |
260 | |
261 | my $backup = $file . ($^O eq 'VMS') ? "_bak" : ".bak"; |
262 | |
263 | copy($file, $backup) |
264 | or die "Cannot copy $file to $backup: $!"; |
265 | |
266 | my @keep = (); |
267 | |
268 | { |
269 | open F, "<$file" |
270 | or die "Cannot open $file: $!\n" ; |
271 | while (<F>) |
272 | { |
273 | if (/^__(END|DATA)__/) |
274 | { |
275 | push @keep, $_; |
276 | last ; |
277 | } |
278 | |
279 | &{ $our_sub }() if $our_sub ; |
280 | &{ $warn_sub }() if $warn_sub ; |
281 | push @keep, $_; |
282 | } |
283 | |
284 | if (! eof F) |
285 | { |
286 | while (<F>) |
287 | { push @keep, $_ } |
288 | } |
289 | close F; |
290 | } |
291 | |
292 | { |
293 | open F, ">$file" |
294 | or die "Cannot open $file: $!\n"; |
295 | print F @keep ; |
296 | close F; |
297 | } |
298 | } |
299 | |
9253672d |
300 | |
301 | sub FindBrokenDependencies |
302 | { |
303 | my $version = shift ; |
304 | my %thisModule = map { $_ => 1} @_; |
305 | |
306 | my @modules = qw( |
307 | IO::Compress::Base |
308 | IO::Compress::Base::Common |
309 | IO::Uncompress::Base |
310 | |
311 | Compress::Raw::Zlib |
312 | Compress::Raw::Bzip2 |
313 | |
314 | IO::Compress::RawDeflate |
315 | IO::Uncompress::RawInflate |
316 | IO::Compress::Deflate |
317 | IO::Uncompress::Inflate |
318 | IO::Compress::Gzip |
319 | IO::Compress::Gzip::Constants |
320 | IO::Uncompress::Gunzip |
321 | IO::Compress::Zip |
322 | IO::Uncompress::Unzip |
323 | |
324 | IO::Compress::Bzip2 |
325 | IO::Uncompress::Bunzip2 |
326 | |
327 | IO::Compress::Lzf |
328 | IO::Uncompress::UnLzf |
329 | |
330 | IO::Compress::Lzop |
331 | IO::Uncompress::UnLzop |
332 | |
333 | Compress::Zlib |
334 | ); |
335 | |
336 | my @broken = (); |
337 | |
338 | foreach my $module ( grep { ! $thisModule{$_} } @modules) |
339 | { |
340 | my $hasVersion = getInstalledVersion($module); |
341 | |
342 | # No need to upgrade if the module isn't installed at all |
343 | next |
344 | if ! defined $hasVersion; |
345 | |
346 | # If already have C::Z version 1, then an upgrade to any of the |
347 | # IO::Compress modules will not break it. |
348 | next |
349 | if $module eq 'Compress::Zlib' && $hasVersion < 2; |
350 | |
351 | if ($hasVersion < $version) |
352 | { |
353 | push @broken, $module |
354 | } |
355 | } |
356 | |
357 | return @broken; |
358 | } |
359 | |
360 | sub getInstalledVersion |
361 | { |
362 | my $module = shift; |
363 | my $version; |
364 | |
365 | eval " require $module; "; |
366 | |
367 | if ($@ eq '') |
368 | { |
369 | no strict 'refs'; |
370 | $version = ${ $module . "::VERSION" }; |
371 | $version = 0 |
372 | } |
373 | |
374 | return $version; |
375 | } |
376 | |
25f0751f |
377 | package MakeUtil ; |
378 | |
379 | 1; |
380 | |
381 | |