Commit | Line | Data |
adfe19db |
1 | ################################################################################ |
2 | ## |
bfc37ff7 |
3 | ## $Revision: 51 $ |
adfe19db |
4 | ## $Author: mhx $ |
bfc37ff7 |
5 | ## $Date: 2010/03/07 13:15:48 +0100 $ |
adfe19db |
6 | ## |
7 | ################################################################################ |
8 | ## |
bfc37ff7 |
9 | ## Version 3.x, Copyright (C) 2004-2010, Marcus Holland-Moritz. |
adfe19db |
10 | ## Version 2.x, Copyright (C) 2001, Paul Marquess. |
11 | ## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. |
12 | ## |
13 | ## This program is free software; you can redistribute it and/or |
14 | ## modify it under the same terms as Perl itself. |
15 | ## |
16 | ################################################################################ |
17 | |
18 | =provides |
19 | |
20 | =implementation |
21 | |
adfe19db |
22 | use strict; |
23 | |
c83e6f19 |
24 | # Disable broken TRIE-optimization |
25 | BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } |
26 | |
78b4ff79 |
27 | my $VERSION = __VERSION__; |
28 | |
adfe19db |
29 | my %opt = ( |
30 | quiet => 0, |
31 | diag => 1, |
32 | hints => 1, |
33 | changes => 1, |
34 | cplusplus => 0, |
4a582685 |
35 | filter => 1, |
0d0f8426 |
36 | strip => 0, |
78b4ff79 |
37 | version => 0, |
adfe19db |
38 | ); |
39 | |
40 | my($ppport) = $0 =~ /([\w.]+)$/; |
41 | my $LF = '(?:\r\n|[\r\n])'; # line feed |
42 | my $HS = "[ \t]"; # horizontal whitespace |
43 | |
c83e6f19 |
44 | # Never use C comments in this file! |
45 | my $ccs = '/'.'*'; |
46 | my $cce = '*'.'/'; |
47 | my $rccs = quotemeta $ccs; |
48 | my $rcce = quotemeta $cce; |
49 | |
adfe19db |
50 | eval { |
51 | require Getopt::Long; |
52 | Getopt::Long::GetOptions(\%opt, qw( |
78b4ff79 |
53 | help quiet diag! filter! hints! changes! cplusplus strip version |
adfe19db |
54 | patch=s copy=s diff=s compat-version=s |
04fc8b94 |
55 | list-provided list-unsupported api-info=s |
adfe19db |
56 | )) or usage(); |
57 | }; |
58 | |
59 | if ($@ and grep /^-/, @ARGV) { |
60 | usage() if "@ARGV" =~ /^--?h(?:elp)?$/; |
61 | die "Getopt::Long not found. Please don't use any options.\n"; |
62 | } |
63 | |
78b4ff79 |
64 | if ($opt{version}) { |
65 | print "This is $0 $VERSION.\n"; |
66 | exit 0; |
67 | } |
68 | |
adfe19db |
69 | usage() if $opt{help}; |
0d0f8426 |
70 | strip() if $opt{strip}; |
adfe19db |
71 | |
72 | if (exists $opt{'compat-version'}) { |
73 | my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; |
74 | if ($@) { |
75 | die "Invalid version number format: '$opt{'compat-version'}'\n"; |
76 | } |
77 | die "Only Perl 5 is supported\n" if $r != 5; |
4a582685 |
78 | die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; |
adfe19db |
79 | $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; |
80 | } |
81 | else { |
82 | $opt{'compat-version'} = 5; |
83 | } |
84 | |
adfe19db |
85 | my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ |
4a582685 |
86 | ? ( $1 => { |
adfe19db |
87 | ($2 ? ( base => $2 ) : ()), |
88 | ($3 ? ( todo => $3 ) : ()), |
89 | (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), |
90 | (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), |
91 | (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), |
92 | } ) |
93 | : die "invalid spec: $_" } qw( |
94 | __PERL_API__ |
95 | ); |
96 | |
97 | if (exists $opt{'list-unsupported'}) { |
98 | my $f; |
99 | for $f (sort { lc $a cmp lc $b } keys %API) { |
100 | next unless $API{$f}{todo}; |
101 | print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; |
102 | } |
103 | exit 0; |
104 | } |
105 | |
106 | # Scan for possible replacement candidates |
107 | |
679ad62d |
108 | my(%replace, %need, %hints, %warnings, %depends); |
adfe19db |
109 | my $replace = 0; |
679ad62d |
110 | my($hint, $define, $function); |
adfe19db |
111 | |
af36fda7 |
112 | sub find_api |
113 | { |
114 | my $code = shift; |
115 | $code =~ s{ |
c83e6f19 |
116 | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) |
117 | | "[^"\\]*(?:\\.[^"\\]*)*" |
118 | | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; |
af36fda7 |
119 | grep { exists $API{$_} } $code =~ /(\w+)/mg; |
120 | } |
121 | |
adfe19db |
122 | while (<DATA>) { |
123 | if ($hint) { |
679ad62d |
124 | my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; |
adfe19db |
125 | if (m{^\s*\*\s(.*?)\s*$}) { |
679ad62d |
126 | for (@{$hint->[1]}) { |
127 | $h->{$_} ||= ''; # suppress warning with older perls |
128 | $h->{$_} .= "$1\n"; |
129 | } |
130 | } |
c83e6f19 |
131 | else { undef $hint } |
679ad62d |
132 | } |
133 | |
c83e6f19 |
134 | $hint = [$1, [split /,?\s+/, $2]] |
135 | if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; |
679ad62d |
136 | |
137 | if ($define) { |
138 | if ($define->[1] =~ /\\$/) { |
139 | $define->[1] .= $_; |
140 | } |
141 | else { |
142 | if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { |
af36fda7 |
143 | my @n = find_api($define->[1]); |
679ad62d |
144 | push @{$depends{$define->[0]}}, @n if @n |
145 | } |
146 | undef $define; |
147 | } |
148 | } |
149 | |
150 | $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; |
151 | |
152 | if ($function) { |
153 | if (/^}/) { |
154 | if (exists $API{$function->[0]}) { |
af36fda7 |
155 | my @n = find_api($function->[1]); |
679ad62d |
156 | push @{$depends{$function->[0]}}, @n if @n |
157 | } |
c1a049cb |
158 | undef $function; |
adfe19db |
159 | } |
160 | else { |
679ad62d |
161 | $function->[1] .= $_; |
adfe19db |
162 | } |
163 | } |
679ad62d |
164 | |
165 | $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; |
adfe19db |
166 | |
167 | $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; |
168 | $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; |
169 | $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; |
170 | $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; |
171 | |
c01be2ce |
172 | if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { |
173 | my @deps = map { s/\s+//g; $_ } split /,/, $3; |
174 | my $d; |
175 | for $d (map { s/\s+//g; $_ } split /,/, $1) { |
176 | push @{$depends{$d}}, @deps; |
177 | } |
adfe19db |
178 | } |
179 | |
180 | $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; |
181 | } |
182 | |
679ad62d |
183 | for (values %depends) { |
184 | my %s; |
185 | $_ = [sort grep !$s{$_}++, @$_]; |
186 | } |
187 | |
04fc8b94 |
188 | if (exists $opt{'api-info'}) { |
189 | my $f; |
190 | my $count = 0; |
9132e1a3 |
191 | my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; |
04fc8b94 |
192 | for $f (sort { lc $a cmp lc $b } keys %API) { |
9132e1a3 |
193 | next unless $f =~ /$match/; |
04fc8b94 |
194 | print "\n=== $f ===\n\n"; |
195 | my $info = 0; |
196 | if ($API{$f}{base} || $API{$f}{todo}) { |
197 | my $base = format_version($API{$f}{base} || $API{$f}{todo}); |
9132e1a3 |
198 | print "Supported at least starting from perl-$base.\n"; |
04fc8b94 |
199 | $info++; |
200 | } |
201 | if ($API{$f}{provided}) { |
202 | my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "__MIN_PERL__"; |
9132e1a3 |
203 | print "Support by $ppport provided back to perl-$todo.\n"; |
04fc8b94 |
204 | print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; |
205 | print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; |
679ad62d |
206 | print "\n$hints{$f}" if exists $hints{$f}; |
207 | print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; |
04fc8b94 |
208 | $info++; |
209 | } |
c83e6f19 |
210 | print "No portability information available.\n" unless $info; |
04fc8b94 |
211 | $count++; |
212 | } |
c83e6f19 |
213 | $count or print "Found no API matching '$opt{'api-info'}'."; |
214 | print "\n"; |
04fc8b94 |
215 | exit 0; |
216 | } |
217 | |
adfe19db |
218 | if (exists $opt{'list-provided'}) { |
219 | my $f; |
220 | for $f (sort { lc $a cmp lc $b } keys %API) { |
221 | next unless $API{$f}{provided}; |
222 | my @flags; |
223 | push @flags, 'explicit' if exists $need{$f}; |
224 | push @flags, 'depend' if exists $depends{$f}; |
225 | push @flags, 'hint' if exists $hints{$f}; |
679ad62d |
226 | push @flags, 'warning' if exists $warnings{$f}; |
adfe19db |
227 | my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; |
228 | print "$f$flags\n"; |
229 | } |
230 | exit 0; |
231 | } |
232 | |
4a582685 |
233 | my @files; |
679ad62d |
234 | my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); |
235 | my $srcext = join '|', map { quotemeta $_ } @srcext; |
4a582685 |
236 | |
237 | if (@ARGV) { |
238 | my %seen; |
679ad62d |
239 | for (@ARGV) { |
240 | if (-e) { |
241 | if (-f) { |
242 | push @files, $_ unless $seen{$_}++; |
243 | } |
244 | else { warn "'$_' is not a file.\n" } |
245 | } |
246 | else { |
247 | my @new = grep { -f } glob $_ |
248 | or warn "'$_' does not exist.\n"; |
249 | push @files, grep { !$seen{$_}++ } @new; |
250 | } |
251 | } |
4a582685 |
252 | } |
253 | else { |
254 | eval { |
255 | require File::Find; |
256 | File::Find::find(sub { |
679ad62d |
257 | $File::Find::name =~ /($srcext)$/i |
4a582685 |
258 | and push @files, $File::Find::name; |
259 | }, '.'); |
260 | }; |
261 | if ($@) { |
679ad62d |
262 | @files = map { glob "*$_" } @srcext; |
4a582685 |
263 | } |
264 | } |
265 | |
266 | if (!@ARGV || $opt{filter}) { |
267 | my(@in, @out); |
268 | my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; |
269 | for (@files) { |
679ad62d |
270 | my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; |
4a582685 |
271 | push @{ $out ? \@out : \@in }, $_; |
272 | } |
273 | if (@ARGV && @out) { |
274 | warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); |
275 | } |
276 | @files = @in; |
277 | } |
278 | |
c83e6f19 |
279 | die "No input files given!\n" unless @files; |
4a582685 |
280 | |
adfe19db |
281 | my(%files, %global, %revreplace); |
282 | %revreplace = reverse %replace; |
283 | my $filename; |
284 | my $patch_opened = 0; |
285 | |
286 | for $filename (@files) { |
287 | unless (open IN, "<$filename") { |
288 | warn "Unable to read from $filename: $!\n"; |
289 | next; |
290 | } |
291 | |
292 | info("Scanning $filename ..."); |
293 | |
294 | my $c = do { local $/; <IN> }; |
295 | close IN; |
296 | |
297 | my %file = (orig => $c, changes => 0); |
298 | |
c83e6f19 |
299 | # Temporarily remove C/XS comments and strings from the code |
adfe19db |
300 | my @ccom; |
c83e6f19 |
301 | |
adfe19db |
302 | $c =~ s{ |
c83e6f19 |
303 | ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* |
304 | | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) |
305 | | ( ^$HS*\#[^\r\n]* |
306 | | "[^"\\]*(?:\\.[^"\\]*)*" |
307 | | '[^'\\]*(?:\\.[^'\\]*)*' |
308 | | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) |
af36fda7 |
309 | }{ defined $2 and push @ccom, $2; |
c83e6f19 |
310 | defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; |
adfe19db |
311 | |
312 | $file{ccom} = \@ccom; |
313 | $file{code} = $c; |
c83e6f19 |
314 | $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; |
adfe19db |
315 | |
316 | my $func; |
317 | |
318 | for $func (keys %API) { |
319 | my $match = $func; |
320 | $match .= "|$revreplace{$func}" if exists $revreplace{$func}; |
321 | if ($c =~ /\b(?:Perl_)?($match)\b/) { |
322 | $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; |
323 | $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; |
324 | if (exists $API{$func}{provided}) { |
679ad62d |
325 | $file{uses_provided}{$func}++; |
adfe19db |
326 | if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { |
327 | $file{uses}{$func}++; |
adfe19db |
328 | my @deps = rec_depend($func); |
329 | if (@deps) { |
330 | $file{uses_deps}{$func} = \@deps; |
331 | for (@deps) { |
332 | $file{uses}{$_} = 0 unless exists $file{uses}{$_}; |
adfe19db |
333 | } |
334 | } |
335 | for ($func, @deps) { |
c83e6f19 |
336 | $file{needs}{$_} = 'static' if exists $need{$_}; |
adfe19db |
337 | } |
338 | } |
339 | } |
340 | if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { |
341 | if ($c =~ /\b$func\b/) { |
342 | $file{uses_todo}{$func}++; |
adfe19db |
343 | } |
344 | } |
345 | } |
346 | } |
347 | |
348 | while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { |
349 | if (exists $need{$2}) { |
350 | $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; |
adfe19db |
351 | } |
c83e6f19 |
352 | else { warning("Possibly wrong #define $1 in $filename") } |
adfe19db |
353 | } |
354 | |
96ad942f |
355 | for (qw(uses needs uses_todo needed_global needed_static)) { |
356 | for $func (keys %{$file{$_}}) { |
357 | push @{$global{$_}{$func}}, $filename; |
358 | } |
359 | } |
360 | |
adfe19db |
361 | $files{$filename} = \%file; |
362 | } |
363 | |
364 | # Globally resolve NEED_'s |
365 | my $need; |
366 | for $need (keys %{$global{needs}}) { |
367 | if (@{$global{needs}{$need}} > 1) { |
368 | my @targets = @{$global{needs}{$need}}; |
369 | my @t = grep $files{$_}{needed_global}{$need}, @targets; |
370 | @targets = @t if @t; |
371 | @t = grep /\.xs$/i, @targets; |
372 | @targets = @t if @t; |
373 | my $target = shift @targets; |
374 | $files{$target}{needs}{$need} = 'global'; |
375 | for (@{$global{needs}{$need}}) { |
376 | $files{$_}{needs}{$need} = 'extern' if $_ ne $target; |
377 | } |
378 | } |
379 | } |
380 | |
381 | for $filename (@files) { |
382 | exists $files{$filename} or next; |
383 | |
384 | info("=== Analyzing $filename ==="); |
385 | |
386 | my %file = %{$files{$filename}}; |
387 | my $func; |
388 | my $c = $file{code}; |
679ad62d |
389 | my $warnings = 0; |
adfe19db |
390 | |
391 | for $func (sort keys %{$file{uses_Perl}}) { |
392 | if ($API{$func}{varargs}) { |
aab9a3b6 |
393 | unless ($API{$func}{nothxarg}) { |
394 | my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} |
395 | { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); |
396 | if ($changes) { |
397 | warning("Doesn't pass interpreter argument aTHX to Perl_$func"); |
398 | $file{changes} += $changes; |
399 | } |
adfe19db |
400 | } |
401 | } |
402 | else { |
403 | warning("Uses Perl_$func instead of $func"); |
404 | $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} |
405 | {$func$1(}g); |
406 | } |
407 | } |
408 | |
409 | for $func (sort keys %{$file{uses_replace}}) { |
410 | warning("Uses $func instead of $replace{$func}"); |
411 | $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); |
412 | } |
413 | |
679ad62d |
414 | for $func (sort keys %{$file{uses_provided}}) { |
415 | if ($file{uses}{$func}) { |
416 | if (exists $file{uses_deps}{$func}) { |
417 | diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); |
418 | } |
419 | else { |
420 | diag("Uses $func"); |
421 | } |
adfe19db |
422 | } |
679ad62d |
423 | $warnings += hint($func); |
adfe19db |
424 | } |
425 | |
679ad62d |
426 | unless ($opt{quiet}) { |
427 | for $func (sort keys %{$file{uses_todo}}) { |
428 | print "*** WARNING: Uses $func, which may not be portable below perl ", |
429 | format_version($API{$func}{todo}), ", even with '$ppport'\n"; |
430 | $warnings++; |
431 | } |
adfe19db |
432 | } |
433 | |
434 | for $func (sort keys %{$file{needed_static}}) { |
435 | my $message = ''; |
436 | if (not exists $file{uses}{$func}) { |
437 | $message = "No need to define NEED_$func if $func is never used"; |
438 | } |
439 | elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { |
440 | $message = "No need to define NEED_$func when already needed globally"; |
441 | } |
442 | if ($message) { |
443 | diag($message); |
444 | $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); |
445 | } |
446 | } |
447 | |
448 | for $func (sort keys %{$file{needed_global}}) { |
449 | my $message = ''; |
450 | if (not exists $global{uses}{$func}) { |
451 | $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; |
452 | } |
453 | elsif (exists $file{needs}{$func}) { |
454 | if ($file{needs}{$func} eq 'extern') { |
455 | $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; |
456 | } |
457 | elsif ($file{needs}{$func} eq 'static') { |
458 | $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; |
459 | } |
460 | } |
461 | if ($message) { |
462 | diag($message); |
463 | $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); |
464 | } |
465 | } |
466 | |
467 | $file{needs_inc_ppport} = keys %{$file{uses}}; |
468 | |
469 | if ($file{needs_inc_ppport}) { |
470 | my $pp = ''; |
471 | |
472 | for $func (sort keys %{$file{needs}}) { |
473 | my $type = $file{needs}{$func}; |
474 | next if $type eq 'extern'; |
475 | my $suffix = $type eq 'global' ? '_GLOBAL' : ''; |
476 | unless (exists $file{"needed_$type"}{$func}) { |
477 | if ($type eq 'global') { |
478 | diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); |
479 | } |
480 | else { |
481 | diag("File needs $func, adding static request"); |
482 | } |
483 | $pp .= "#define NEED_$func$suffix\n"; |
484 | } |
485 | } |
486 | |
487 | if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { |
488 | $pp = ''; |
489 | $file{changes}++; |
490 | } |
491 | |
492 | unless ($file{has_inc_ppport}) { |
493 | diag("Needs to include '$ppport'"); |
494 | $pp .= qq(#include "$ppport"\n) |
495 | } |
496 | |
497 | if ($pp) { |
498 | $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) |
499 | || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) |
500 | || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) |
501 | || ($c =~ s/^/$pp/); |
502 | } |
503 | } |
504 | else { |
505 | if ($file{has_inc_ppport}) { |
506 | diag("No need to include '$ppport'"); |
507 | $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); |
508 | } |
509 | } |
510 | |
511 | # put back in our C comments |
512 | my $ix; |
513 | my $cppc = 0; |
514 | my @ccom = @{$file{ccom}}; |
515 | for $ix (0 .. $#ccom) { |
516 | if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { |
517 | $cppc++; |
518 | $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; |
519 | } |
520 | else { |
521 | $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; |
522 | } |
523 | } |
524 | |
525 | if ($cppc) { |
526 | my $s = $cppc != 1 ? 's' : ''; |
527 | warning("Uses $cppc C++ style comment$s, which is not portable"); |
528 | } |
529 | |
679ad62d |
530 | my $s = $warnings != 1 ? 's' : ''; |
531 | my $warn = $warnings ? " ($warnings warning$s)" : ''; |
532 | info("Analysis completed$warn"); |
533 | |
adfe19db |
534 | if ($file{changes}) { |
535 | if (exists $opt{copy}) { |
536 | my $newfile = "$filename$opt{copy}"; |
537 | if (-e $newfile) { |
538 | error("'$newfile' already exists, refusing to write copy of '$filename'"); |
539 | } |
540 | else { |
541 | local *F; |
542 | if (open F, ">$newfile") { |
543 | info("Writing copy of '$filename' with changes to '$newfile'"); |
544 | print F $c; |
545 | close F; |
546 | } |
547 | else { |
548 | error("Cannot open '$newfile' for writing: $!"); |
549 | } |
550 | } |
551 | } |
552 | elsif (exists $opt{patch} || $opt{changes}) { |
553 | if (exists $opt{patch}) { |
554 | unless ($patch_opened) { |
555 | if (open PATCH, ">$opt{patch}") { |
556 | $patch_opened = 1; |
557 | } |
558 | else { |
559 | error("Cannot open '$opt{patch}' for writing: $!"); |
560 | delete $opt{patch}; |
561 | $opt{changes} = 1; |
562 | goto fallback; |
563 | } |
564 | } |
565 | mydiff(\*PATCH, $filename, $c); |
566 | } |
567 | else { |
568 | fallback: |
569 | info("Suggested changes:"); |
570 | mydiff(\*STDOUT, $filename, $c); |
571 | } |
572 | } |
573 | else { |
574 | my $s = $file{changes} == 1 ? '' : 's'; |
575 | info("$file{changes} potentially required change$s detected"); |
576 | } |
577 | } |
578 | else { |
579 | info("Looks good"); |
580 | } |
581 | } |
582 | |
583 | close PATCH if $patch_opened; |
584 | |
585 | exit 0; |
586 | |
587 | ####################################################################### |
588 | |
c83e6f19 |
589 | sub try_use { eval "use @_;"; return $@ eq '' } |
590 | |
adfe19db |
591 | sub mydiff |
592 | { |
593 | local *F = shift; |
594 | my($file, $str) = @_; |
595 | my $diff; |
596 | |
597 | if (exists $opt{diff}) { |
598 | $diff = run_diff($opt{diff}, $file, $str); |
599 | } |
600 | |
c83e6f19 |
601 | if (!defined $diff and try_use('Text::Diff')) { |
adfe19db |
602 | $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); |
603 | $diff = <<HEADER . $diff; |
604 | --- $file |
605 | +++ $file.patched |
606 | HEADER |
607 | } |
608 | |
609 | if (!defined $diff) { |
610 | $diff = run_diff('diff -u', $file, $str); |
611 | } |
612 | |
613 | if (!defined $diff) { |
614 | $diff = run_diff('diff', $file, $str); |
615 | } |
616 | |
617 | if (!defined $diff) { |
618 | error("Cannot generate a diff. Please install Text::Diff or use --copy."); |
619 | return; |
620 | } |
621 | |
622 | print F $diff; |
adfe19db |
623 | } |
624 | |
625 | sub run_diff |
626 | { |
627 | my($prog, $file, $str) = @_; |
628 | my $tmp = 'dppptemp'; |
629 | my $suf = 'aaa'; |
630 | my $diff = ''; |
631 | local *F; |
632 | |
633 | while (-e "$tmp.$suf") { $suf++ } |
634 | $tmp = "$tmp.$suf"; |
635 | |
636 | if (open F, ">$tmp") { |
637 | print F $str; |
638 | close F; |
639 | |
640 | if (open F, "$prog $file $tmp |") { |
641 | while (<F>) { |
642 | s/\Q$tmp\E/$file.patched/; |
643 | $diff .= $_; |
644 | } |
645 | close F; |
646 | unlink $tmp; |
647 | return $diff; |
648 | } |
649 | |
650 | unlink $tmp; |
651 | } |
652 | else { |
653 | error("Cannot open '$tmp' for writing: $!"); |
654 | } |
655 | |
656 | return undef; |
657 | } |
658 | |
adfe19db |
659 | sub rec_depend |
660 | { |
af36fda7 |
661 | my($func, $seen) = @_; |
adfe19db |
662 | return () unless exists $depends{$func}; |
af36fda7 |
663 | $seen = {%{$seen||{}}}; |
664 | return () if $seen->{$func}++; |
665 | my %s; |
666 | grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; |
adfe19db |
667 | } |
668 | |
669 | sub parse_version |
670 | { |
671 | my $ver = shift; |
672 | |
673 | if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { |
674 | return ($1, $2, $3); |
675 | } |
676 | elsif ($ver !~ /^\d+\.[\d_]+$/) { |
677 | die "cannot parse version '$ver'\n"; |
678 | } |
679 | |
680 | $ver =~ s/_//g; |
681 | $ver =~ s/$/000000/; |
682 | |
683 | my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; |
684 | |
685 | $v = int $v; |
686 | $s = int $s; |
687 | |
688 | if ($r < 5 || ($r == 5 && $v < 6)) { |
689 | if ($s % 10) { |
690 | die "cannot parse version '$ver'\n"; |
691 | } |
692 | } |
693 | |
694 | return ($r, $v, $s); |
695 | } |
696 | |
697 | sub format_version |
698 | { |
699 | my $ver = shift; |
700 | |
701 | $ver =~ s/$/000000/; |
702 | my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; |
703 | |
704 | $v = int $v; |
705 | $s = int $s; |
706 | |
707 | if ($r < 5 || ($r == 5 && $v < 6)) { |
708 | if ($s % 10) { |
709 | die "invalid version '$ver'\n"; |
710 | } |
711 | $s /= 10; |
712 | |
713 | $ver = sprintf "%d.%03d", $r, $v; |
714 | $s > 0 and $ver .= sprintf "_%02d", $s; |
715 | |
716 | return $ver; |
717 | } |
718 | |
719 | return sprintf "%d.%d.%d", $r, $v, $s; |
720 | } |
721 | |
722 | sub info |
723 | { |
724 | $opt{quiet} and return; |
725 | print @_, "\n"; |
726 | } |
727 | |
728 | sub diag |
729 | { |
730 | $opt{quiet} and return; |
731 | $opt{diag} and print @_, "\n"; |
732 | } |
733 | |
734 | sub warning |
735 | { |
736 | $opt{quiet} and return; |
737 | print "*** ", @_, "\n"; |
738 | } |
739 | |
740 | sub error |
741 | { |
742 | print "*** ERROR: ", @_, "\n"; |
743 | } |
744 | |
745 | my %given_hints; |
679ad62d |
746 | my %given_warnings; |
adfe19db |
747 | sub hint |
748 | { |
749 | $opt{quiet} and return; |
adfe19db |
750 | my $func = shift; |
679ad62d |
751 | my $rv = 0; |
752 | if (exists $warnings{$func} && !$given_warnings{$func}++) { |
753 | my $warn = $warnings{$func}; |
754 | $warn =~ s!^!*** !mg; |
755 | print "*** WARNING: $func\n", $warn; |
756 | $rv++; |
757 | } |
758 | if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { |
759 | my $hint = $hints{$func}; |
760 | $hint =~ s/^/ /mg; |
761 | print " --- hint for $func ---\n", $hint; |
762 | } |
763 | $rv; |
adfe19db |
764 | } |
765 | |
766 | sub usage |
767 | { |
768 | my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; |
769 | my %M = ( 'I' => '*' ); |
770 | $usage =~ s/^\s*perl\s+\S+/$^X $0/; |
771 | $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; |
772 | |
773 | print <<ENDUSAGE; |
774 | |
775 | Usage: $usage |
776 | |
777 | See perldoc $0 for details. |
778 | |
779 | ENDUSAGE |
780 | |
781 | exit 2; |
782 | } |
0d0f8426 |
783 | |
784 | sub strip |
785 | { |
786 | my $self = do { local(@ARGV,$/)=($0); <> }; |
78b4ff79 |
787 | my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; |
788 | $copy =~ s/^(?=\S+)/ /gms; |
789 | $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; |
0d0f8426 |
790 | $self =~ s/^SKIP.*(?=^__DATA__)/SKIP |
791 | if (\@ARGV && \$ARGV[0] eq '--unstrip') { |
792 | eval { require Devel::PPPort }; |
793 | \$@ and die "Cannot require Devel::PPPort, please install.\\n"; |
51d6c659 |
794 | if (eval \$Devel::PPPort::VERSION < $VERSION) { |
78b4ff79 |
795 | die "$0 was originally generated with Devel::PPPort $VERSION.\\n" |
796 | . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" |
797 | . "Please install a newer version, or --unstrip will not work.\\n"; |
798 | } |
0d0f8426 |
799 | Devel::PPPort::WriteFile(\$0); |
800 | exit 0; |
801 | } |
802 | print <<END; |
803 | |
804 | Sorry, but this is a stripped version of \$0. |
805 | |
806 | To be able to use its original script and doc functionality, |
807 | please try to regenerate this file using: |
808 | |
809 | \$^X \$0 --unstrip |
810 | |
811 | END |
812 | /ms; |
c83e6f19 |
813 | my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms; |
814 | $c =~ s{ |
815 | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) |
816 | | ( "[^"\\]*(?:\\.[^"\\]*)*" |
817 | | '[^'\\]*(?:\\.[^'\\]*)*' ) |
818 | | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex; |
819 | $c =~ s!\s+$!!mg; |
820 | $c =~ s!^$LF!!mg; |
821 | $c =~ s!^\s*#\s*!#!mg; |
822 | $c =~ s!^\s+!!mg; |
0d0f8426 |
823 | |
824 | open OUT, ">$0" or die "cannot strip $0: $!\n"; |
c83e6f19 |
825 | print OUT "$pl$c\n"; |
0d0f8426 |
826 | |
827 | exit 0; |
828 | } |