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