Commit | Line | Data |
---|---|---|
adfe19db MHM |
1 | ################################################################################ |
2 | ## | |
b2049988 | 3 | ## Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz. |
adfe19db MHM |
4 | ## Version 2.x, Copyright (C) 2001, Paul Marquess. |
5 | ## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. | |
6 | ## | |
7 | ## This program is free software; you can redistribute it and/or | |
8 | ## modify it under the same terms as Perl itself. | |
9 | ## | |
10 | ################################################################################ | |
11 | ||
12 | =provides | |
13 | ||
14 | =implementation | |
15 | ||
adfe19db MHM |
16 | use strict; |
17 | ||
8f62b02f CBW |
18 | BEGIN { require warnings if "$]" > '5.006' } |
19 | ||
c83e6f19 | 20 | # Disable broken TRIE-optimization |
c8799aff | 21 | BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if "$]" >= "5.009004" && "$]" <= "5.009005"} |
c83e6f19 | 22 | |
78b4ff79 MHM |
23 | my $VERSION = __VERSION__; |
24 | ||
adfe19db MHM |
25 | my %opt = ( |
26 | quiet => 0, | |
27 | diag => 1, | |
28 | hints => 1, | |
29 | changes => 1, | |
30 | cplusplus => 0, | |
4a582685 | 31 | filter => 1, |
0d0f8426 | 32 | strip => 0, |
78b4ff79 | 33 | version => 0, |
adfe19db MHM |
34 | ); |
35 | ||
36 | my($ppport) = $0 =~ /([\w.]+)$/; | |
37 | my $LF = '(?:\r\n|[\r\n])'; # line feed | |
38 | my $HS = "[ \t]"; # horizontal whitespace | |
39 | ||
c83e6f19 MHM |
40 | # Never use C comments in this file! |
41 | my $ccs = '/'.'*'; | |
42 | my $cce = '*'.'/'; | |
43 | my $rccs = quotemeta $ccs; | |
44 | my $rcce = quotemeta $cce; | |
45 | ||
adfe19db MHM |
46 | eval { |
47 | require Getopt::Long; | |
48 | Getopt::Long::GetOptions(\%opt, qw( | |
78b4ff79 | 49 | help quiet diag! filter! hints! changes! cplusplus strip version |
adfe19db | 50 | patch=s copy=s diff=s compat-version=s |
04fc8b94 | 51 | list-provided list-unsupported api-info=s |
adfe19db MHM |
52 | )) or usage(); |
53 | }; | |
54 | ||
55 | if ($@ and grep /^-/, @ARGV) { | |
56 | usage() if "@ARGV" =~ /^--?h(?:elp)?$/; | |
57 | die "Getopt::Long not found. Please don't use any options.\n"; | |
58 | } | |
59 | ||
78b4ff79 MHM |
60 | if ($opt{version}) { |
61 | print "This is $0 $VERSION.\n"; | |
62 | exit 0; | |
63 | } | |
64 | ||
adfe19db | 65 | usage() if $opt{help}; |
0d0f8426 | 66 | strip() if $opt{strip}; |
adfe19db | 67 | |
f7074f41 KW |
68 | $opt{'compat-version'} = __MIN_PERL__ unless exists $opt{'compat-version'}; |
69 | $opt{'compat-version'} = int_parse_version($opt{'compat-version'}); | |
adfe19db | 70 | |
42f01a88 KW |
71 | my $int_min_perl = int_parse_version(__MIN_PERL__); |
72 | ||
3e4f8f97 KW |
73 | # Each element of this hash looks something like: |
74 | # 'Poison' => { | |
75 | # 'base' => '5.008000', | |
76 | # 'provided' => 1, | |
77 | # 'todo' => '5.003007' | |
78 | # }, | |
adfe19db | 79 | my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ |
4a582685 | 80 | ? ( $1 => { |
adfe19db MHM |
81 | ($2 ? ( base => $2 ) : ()), |
82 | ($3 ? ( todo => $3 ) : ()), | |
83 | (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), | |
84 | (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), | |
16289599 | 85 | (index($4, 'n') >= 0 ? ( noTHXarg => 1 ) : ()), |
bf9610ae KW |
86 | (index($4, 'c') >= 0 ? ( core_only => 1 ) : ()), |
87 | (index($4, 'd') >= 0 ? ( deprecated => 1 ) : ()), | |
88 | (index($4, 'i') >= 0 ? ( inaccessible => 1 ) : ()), | |
89 | (index($4, 'x') >= 0 ? ( experimental => 1 ) : ()), | |
90 | (index($4, 'u') >= 0 ? ( undocumented => 1 ) : ()), | |
7d0cbfba | 91 | (index($4, 'o') >= 0 ? ( ppport_fnc => 1 ) : ()), |
12d2b8fd | 92 | (index($4, 'V') >= 0 ? ( unverified => 1 ) : ()), |
adfe19db MHM |
93 | } ) |
94 | : die "invalid spec: $_" } qw( | |
c8799aff | 95 | __ALL_ELEMENTS__ |
adfe19db MHM |
96 | ); |
97 | ||
98 | if (exists $opt{'list-unsupported'}) { | |
99 | my $f; | |
55179e46 | 100 | for $f (sort dictionary_order keys %API) { |
b151b75a KW |
101 | next if $API{$f}{core_only}; |
102 | next if $API{$f}{beyond_depr}; | |
103 | next if $API{$f}{inaccessible}; | |
104 | next if $API{$f}{experimental}; | |
adfe19db | 105 | next unless $API{$f}{todo}; |
42f01a88 | 106 | next if int_parse_version($API{$f}{todo}) <= $int_min_perl; |
c8799aff N |
107 | my $repeat = 40 - length($f); |
108 | $repeat = 0 if $repeat < 0; | |
109 | print "$f ", '.'x $repeat, " ", format_version($API{$f}{todo}), "\n"; | |
adfe19db MHM |
110 | } |
111 | exit 0; | |
112 | } | |
113 | ||
3e4f8f97 | 114 | # Scan for hints, possible replacement candidates, etc. |
adfe19db | 115 | |
679ad62d | 116 | my(%replace, %need, %hints, %warnings, %depends); |
adfe19db | 117 | my $replace = 0; |
679ad62d | 118 | my($hint, $define, $function); |
adfe19db | 119 | |
af36fda7 MHM |
120 | sub find_api |
121 | { | |
c8799aff | 122 | BEGIN { 'warnings'->unimport('uninitialized') if "$]" > '5.006' } |
af36fda7 MHM |
123 | my $code = shift; |
124 | $code =~ s{ | |
c83e6f19 MHM |
125 | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) |
126 | | "[^"\\]*(?:\\.[^"\\]*)*" | |
127 | | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; | |
af36fda7 MHM |
128 | grep { exists $API{$_} } $code =~ /(\w+)/mg; |
129 | } | |
130 | ||
adfe19db MHM |
131 | while (<DATA>) { |
132 | if ($hint) { | |
2b5a6a7e KW |
133 | |
134 | # Here, we are in the middle of accumulating a hint or warning. | |
135 | my $end_of_hint = 0; | |
136 | ||
137 | # A line containing a comment end marker closes the hint. Remove that | |
138 | # marker for processing below. | |
139 | if (s/\s*$rcce(.*?)\s*$//) { | |
140 | die "Nothing can follow the end of comment in '$_'\n" if length $1 > 0; | |
141 | $end_of_hint = 1; | |
142 | } | |
143 | ||
144 | # Set $h to the hash of which type. | |
679ad62d | 145 | my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; |
2b5a6a7e KW |
146 | |
147 | # Ignore any leading and trailing white space, and an optional star comment | |
148 | # continuation marker, then place the meat of the line into $1 | |
149 | m/^\s*(?:\*\s*)?(.*?)\s*$/; | |
150 | ||
151 | # Add the meat of this line to the hash value of each API element it | |
152 | # applies to | |
153 | for (@{$hint->[1]}) { | |
154 | $h->{$_} ||= ''; # avoid the warning older perls generate | |
155 | $h->{$_} .= "$1\n"; | |
679ad62d | 156 | } |
2b5a6a7e KW |
157 | |
158 | # If the line had a comment close, we are through with this hint | |
159 | undef $hint if $end_of_hint; | |
160 | ||
161 | next; | |
679ad62d MHM |
162 | } |
163 | ||
2b5a6a7e KW |
164 | # Set up $hint if this is the beginning of a Hint: or Warning: |
165 | # These are from a multi-line C comment in the file, with the first line | |
166 | # looking like (a space has been inserted because this file can't have C | |
167 | # comment markers in it): | |
168 | # / * Warning: PL_expect, PL_copline, PL_rsfp | |
169 | # | |
170 | # $hint becomes | |
171 | # [ | |
172 | # 'Warning', | |
173 | # [ | |
174 | # 'PL_expect', | |
175 | # 'PL_copline', | |
176 | # 'PL_rsfp', | |
177 | # ], | |
178 | # ] | |
179 | if (m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}) { | |
180 | $hint = [$1, [split /,?\s+/, $2]]; | |
181 | next; | |
182 | } | |
679ad62d | 183 | |
3e4f8f97 KW |
184 | if ($define) { # If in the middle of a definition... |
185 | ||
186 | # append a continuation line ending with backslash. | |
679ad62d MHM |
187 | if ($define->[1] =~ /\\$/) { |
188 | $define->[1] .= $_; | |
189 | } | |
3e4f8f97 KW |
190 | else { # Otherwise this line ends the definition, make foo depend on bar |
191 | # (and what bar depends on) if its not one of ppp's own constructs | |
679ad62d | 192 | if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { |
af36fda7 | 193 | my @n = find_api($define->[1]); |
679ad62d MHM |
194 | push @{$depends{$define->[0]}}, @n if @n |
195 | } | |
196 | undef $define; | |
197 | } | |
198 | } | |
199 | ||
3e4f8f97 KW |
200 | # For '#define foo bar' or '#define foo(a,b,c) bar', $define becomes a |
201 | # reference to [ foo, bar ] | |
679ad62d MHM |
202 | $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; |
203 | ||
204 | if ($function) { | |
205 | if (/^}/) { | |
206 | if (exists $API{$function->[0]}) { | |
af36fda7 | 207 | my @n = find_api($function->[1]); |
679ad62d MHM |
208 | push @{$depends{$function->[0]}}, @n if @n |
209 | } | |
c1a049cb | 210 | undef $function; |
adfe19db MHM |
211 | } |
212 | else { | |
679ad62d | 213 | $function->[1] .= $_; |
adfe19db MHM |
214 | } |
215 | } | |
679ad62d MHM |
216 | |
217 | $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; | |
adfe19db | 218 | |
3e4f8f97 KW |
219 | # Set $replace to the number given for lines that look like |
220 | # / * Replace: \d+ * / | |
3e4f8f97 KW |
221 | # Thus setting it to 1 starts a region where replacements are automatically |
222 | # done, and setting it to 0 ends that region. | |
adfe19db | 223 | $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; |
3e4f8f97 KW |
224 | |
225 | # Add bar => foo to %replace for lines like '#define foo bar in a region | |
226 | # where $replace is non-zero | |
adfe19db | 227 | $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; |
3e4f8f97 KW |
228 | |
229 | # Add bar => foo to %replace for lines like '#define foo bar / * Replace * / | |
adfe19db | 230 | $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; |
3e4f8f97 KW |
231 | |
232 | # Add foo => bar to %replace for lines like / * Replace foo with bar * / | |
c8799aff | 233 | $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+.*?)\s+$rcce\s*$}; |
adfe19db | 234 | |
3e4f8f97 KW |
235 | # For lines like / * foo, bar depends on baz, bat * / |
236 | # create a list of the elements on the rhs, and make that list apply to each | |
237 | # element in the lhs, which becomes a key in \%depends. | |
c01be2ce MHM |
238 | if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { |
239 | my @deps = map { s/\s+//g; $_ } split /,/, $3; | |
240 | my $d; | |
241 | for $d (map { s/\s+//g; $_ } split /,/, $1) { | |
242 | push @{$depends{$d}}, @deps; | |
243 | } | |
adfe19db MHM |
244 | } |
245 | ||
246 | $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; | |
247 | } | |
248 | ||
679ad62d | 249 | for (values %depends) { |
2a3ad345 KW |
250 | my %seen; |
251 | $_ = [sort dictionary_order grep !$seen{$_}++, @$_]; | |
679ad62d MHM |
252 | } |
253 | ||
04fc8b94 MHM |
254 | if (exists $opt{'api-info'}) { |
255 | my $f; | |
256 | my $count = 0; | |
9132e1a3 | 257 | my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; |
c8799aff N |
258 | |
259 | # Sort the names, and split into two classes; one for things that are part of | |
260 | # the API; a second for things that aren't. | |
261 | my @ok_to_use; | |
262 | my @shouldnt_use; | |
55179e46 | 263 | for $f (sort dictionary_order keys %API) { |
9132e1a3 | 264 | next unless $f =~ /$match/; |
c8799aff N |
265 | my $base = int_parse_version($API{$f}{base}) if $API{$f}{base}; |
266 | if ($base && ! $API{$f}{inaccessible} && ! $API{$f}{core_only}) { | |
267 | push @ok_to_use, $f; | |
268 | } | |
269 | else { | |
270 | push @shouldnt_use, $f; | |
271 | } | |
272 | } | |
273 | ||
274 | # We normally suppress non-API items. But if the search matched no API | |
275 | # items, output the non-ones. This allows someone to get the info for an | |
276 | # item if they ask for it specifically enough, but doesn't normally clutter | |
277 | # the output with irrelevant results. | |
278 | @ok_to_use = @shouldnt_use unless @ok_to_use; | |
279 | ||
280 | for $f (@ok_to_use) { | |
b3cf09c1 | 281 | print "\n=== $f ===\n"; |
04fc8b94 | 282 | my $info = 0; |
b3cf09c1 KW |
283 | my $base; |
284 | $base = int_parse_version($API{$f}{base}) if $API{$f}{base}; | |
285 | my $todo; | |
286 | $todo = int_parse_version($API{$f}{todo}) if $API{$f}{todo}; | |
287 | ||
c8799aff N |
288 | # Output information |
289 | if ($base) { | |
b3cf09c1 KW |
290 | my $with_or= ""; |
291 | if ( $base <= $int_min_perl | |
292 | || ( (! $API{$f}{provided} && ! $todo) | |
293 | || ($todo && $todo >= $base))) | |
294 | { | |
295 | $with_or= " with or"; | |
296 | } | |
c8799aff N |
297 | |
298 | my $Supported = ($API{$f}{undocumented}) ? 'Available' : 'Supported'; | |
299 | print "\n$Supported at least since perl-", | |
b3cf09c1 KW |
300 | format_version($base), ",$with_or without $ppport."; |
301 | if ($API{$f}{unverified}) { | |
302 | print "\nThis information is based on inspection of the source code", | |
303 | " and has not been\n", | |
304 | "verified by successful compilation."; | |
305 | } | |
306 | print "\n"; | |
307 | $info++; | |
308 | } | |
309 | if ($API{$f}{provided} || $todo) { | |
310 | print "\nThis is only supported by $ppport, and NOT by perl versions going forward.\n" unless $base; | |
311 | if ($todo) { | |
312 | if (! $base || $todo < $base) { | |
313 | my $additionally = ""; | |
314 | $additionally .= " additionally" if $base; | |
315 | print "$ppport$additionally provides support at least back to perl-", | |
316 | format_version($todo), | |
317 | ".\n"; | |
318 | } | |
319 | } | |
320 | elsif (! $base || $base > $int_min_perl) { | |
18c37bcd KW |
321 | if (exists $depends{$f}) { |
322 | my $max = 0; | |
323 | for (@{$depends{$f}}) { | |
324 | $max = int_parse_version($API{$_}{todo}) if $API{$_}{todo} && $API{$_}{todo} > $max; | |
325 | # XXX What to assume unspecified values are? This effectively makes them MIN_PERL | |
326 | } | |
327 | $todo = $max if $max; | |
328 | } | |
b3cf09c1 KW |
329 | print "\n$ppport provides support for this, but ironically, does not", |
330 | " currently know,\n", | |
331 | "for this report, the minimum version it supports for this"; | |
332 | if ($API{$f}{undocumented}) { | |
333 | print " and many things\n", | |
334 | "it provides that are implemented as macros and aren't", | |
335 | " documented. You can\n", | |
336 | "help by submitting a documentation patch"; | |
337 | } | |
338 | print ".\n"; | |
18c37bcd KW |
339 | if ($todo) { |
340 | if ($todo <= $int_min_perl) { | |
341 | print "It may very well be supported all the way back to ", | |
342 | format_version(__MIN_PERL__), ".\n"; | |
343 | } | |
344 | else { | |
345 | print "But given the things $f depends on, it's a good", | |
346 | " guess that it isn't\n", | |
347 | "supported prior to ", format_version($todo), ".\n"; | |
348 | } | |
349 | } | |
b3cf09c1 | 350 | } |
04fc8b94 MHM |
351 | } |
352 | if ($API{$f}{provided}) { | |
7db2b3f7 KW |
353 | print "Support needs to be explicitly requested by #define NEED_$f\n", |
354 | "(or #define NEED_${f}_GLOBAL).\n" if exists $need{$f}; | |
04fc8b94 MHM |
355 | $info++; |
356 | } | |
bf9610ae | 357 | |
b3cf09c1 | 358 | if ($base || ! $API{$f}{ppport_fnc}) { |
bf9610ae KW |
359 | my $email = "Send email to perl5-porters\@perl.org if you need to have this functionality.\n"; |
360 | if ($API{$f}{inaccessible}) { | |
361 | print "\nThis is not part of the public API, and may not even be accessible to XS code.\n"; | |
362 | $info++; | |
363 | } | |
364 | elsif ($API{$f}{core_only}) { | |
365 | print "\nThis is not part of the public API, and should not be used by XS code.\n"; | |
366 | $info++; | |
367 | } | |
368 | elsif ($API{$f}{deprecated}) { | |
369 | print "\nThis is deprecated and should not be used. Convert existing uses.\n"; | |
370 | $info++; | |
371 | } | |
372 | elsif ($API{$f}{experimental}) { | |
373 | print "\nThe API for this is unstable and should not be used by XS code.\n", $email; | |
374 | $info++; | |
375 | } | |
376 | elsif ($API{$f}{undocumented}) { | |
377 | print "\nSince this is undocumented, the API should be considered unstable.\n"; | |
378 | if ($API{$f}{provided}) { | |
379 | print "Consider bringing this up on the list: perl5-porters\@perl.org.\n"; | |
380 | } | |
381 | else { | |
382 | print "It may be that this is not intended for XS use, or it may just be\n", | |
383 | "that no one has gotten around to documenting it.\n", $email; | |
384 | } | |
385 | $info++; | |
386 | } | |
387 | unless ($info) { | |
388 | print "No portability information available. Check your spelling; or", | |
389 | " this could be\na bug in Devel::PPPort. To report an issue:\n", | |
390 | "https://github.com/Dual-Life/Devel-PPPort/issues/new\n"; | |
391 | } | |
7d0cbfba | 392 | } |
c7957769 KW |
393 | |
394 | print "\nDepends on: ", join(', ', @{$depends{$f}}), ".\n" | |
395 | if exists $depends{$f}; | |
396 | if (exists $hints{$f} || exists $warnings{$f}) { | |
397 | print "\n$hints{$f}" if exists $hints{$f}; | |
398 | print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; | |
399 | $info++; | |
400 | } | |
04fc8b94 MHM |
401 | $count++; |
402 | } | |
7d0cbfba | 403 | |
bf9610ae | 404 | $count or print "\nFound no API matching '$opt{'api-info'}'."; |
c83e6f19 | 405 | print "\n"; |
04fc8b94 MHM |
406 | exit 0; |
407 | } | |
408 | ||
adfe19db MHM |
409 | if (exists $opt{'list-provided'}) { |
410 | my $f; | |
55179e46 | 411 | for $f (sort dictionary_order keys %API) { |
adfe19db MHM |
412 | next unless $API{$f}{provided}; |
413 | my @flags; | |
414 | push @flags, 'explicit' if exists $need{$f}; | |
415 | push @flags, 'depend' if exists $depends{$f}; | |
416 | push @flags, 'hint' if exists $hints{$f}; | |
679ad62d | 417 | push @flags, 'warning' if exists $warnings{$f}; |
adfe19db MHM |
418 | my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; |
419 | print "$f$flags\n"; | |
420 | } | |
421 | exit 0; | |
422 | } | |
423 | ||
4a582685 | 424 | my @files; |
679ad62d MHM |
425 | my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); |
426 | my $srcext = join '|', map { quotemeta $_ } @srcext; | |
4a582685 NC |
427 | |
428 | if (@ARGV) { | |
429 | my %seen; | |
679ad62d MHM |
430 | for (@ARGV) { |
431 | if (-e) { | |
432 | if (-f) { | |
433 | push @files, $_ unless $seen{$_}++; | |
434 | } | |
435 | else { warn "'$_' is not a file.\n" } | |
436 | } | |
437 | else { | |
438 | my @new = grep { -f } glob $_ | |
439 | or warn "'$_' does not exist.\n"; | |
440 | push @files, grep { !$seen{$_}++ } @new; | |
441 | } | |
442 | } | |
4a582685 NC |
443 | } |
444 | else { | |
445 | eval { | |
446 | require File::Find; | |
447 | File::Find::find(sub { | |
679ad62d | 448 | $File::Find::name =~ /($srcext)$/i |
4a582685 NC |
449 | and push @files, $File::Find::name; |
450 | }, '.'); | |
451 | }; | |
452 | if ($@) { | |
679ad62d | 453 | @files = map { glob "*$_" } @srcext; |
4a582685 NC |
454 | } |
455 | } | |
456 | ||
457 | if (!@ARGV || $opt{filter}) { | |
458 | my(@in, @out); | |
459 | my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; | |
460 | for (@files) { | |
679ad62d | 461 | my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; |
4a582685 NC |
462 | push @{ $out ? \@out : \@in }, $_; |
463 | } | |
464 | if (@ARGV && @out) { | |
465 | warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); | |
466 | } | |
467 | @files = @in; | |
468 | } | |
469 | ||
c83e6f19 | 470 | die "No input files given!\n" unless @files; |
4a582685 | 471 | |
adfe19db MHM |
472 | my(%files, %global, %revreplace); |
473 | %revreplace = reverse %replace; | |
474 | my $filename; | |
475 | my $patch_opened = 0; | |
476 | ||
477 | for $filename (@files) { | |
478 | unless (open IN, "<$filename") { | |
479 | warn "Unable to read from $filename: $!\n"; | |
480 | next; | |
481 | } | |
482 | ||
483 | info("Scanning $filename ..."); | |
484 | ||
485 | my $c = do { local $/; <IN> }; | |
486 | close IN; | |
487 | ||
488 | my %file = (orig => $c, changes => 0); | |
489 | ||
c83e6f19 | 490 | # Temporarily remove C/XS comments and strings from the code |
adfe19db | 491 | my @ccom; |
c83e6f19 | 492 | |
adfe19db | 493 | $c =~ s{ |
c83e6f19 MHM |
494 | ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* |
495 | | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) | |
496 | | ( ^$HS*\#[^\r\n]* | |
497 | | "[^"\\]*(?:\\.[^"\\]*)*" | |
498 | | '[^'\\]*(?:\\.[^'\\]*)*' | |
499 | | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) | |
af36fda7 | 500 | }{ defined $2 and push @ccom, $2; |
c83e6f19 | 501 | defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; |
adfe19db MHM |
502 | |
503 | $file{ccom} = \@ccom; | |
504 | $file{code} = $c; | |
c83e6f19 | 505 | $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; |
adfe19db MHM |
506 | |
507 | my $func; | |
508 | ||
509 | for $func (keys %API) { | |
510 | my $match = $func; | |
511 | $match .= "|$revreplace{$func}" if exists $revreplace{$func}; | |
512 | if ($c =~ /\b(?:Perl_)?($match)\b/) { | |
513 | $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; | |
514 | $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; | |
515 | if (exists $API{$func}{provided}) { | |
679ad62d | 516 | $file{uses_provided}{$func}++; |
f7074f41 KW |
517 | if ( ! exists $API{$func}{base} |
518 | || int_parse_version($API{$func}{base}) > $opt{'compat-version'}) | |
519 | { | |
adfe19db | 520 | $file{uses}{$func}++; |
adfe19db MHM |
521 | my @deps = rec_depend($func); |
522 | if (@deps) { | |
523 | $file{uses_deps}{$func} = \@deps; | |
524 | for (@deps) { | |
525 | $file{uses}{$_} = 0 unless exists $file{uses}{$_}; | |
adfe19db MHM |
526 | } |
527 | } | |
528 | for ($func, @deps) { | |
c83e6f19 | 529 | $file{needs}{$_} = 'static' if exists $need{$_}; |
adfe19db MHM |
530 | } |
531 | } | |
532 | } | |
f7074f41 KW |
533 | if ( exists $API{$func}{todo} |
534 | && int_parse_version($API{$func}{todo}) > $opt{'compat-version'}) | |
535 | { | |
adfe19db MHM |
536 | if ($c =~ /\b$func\b/) { |
537 | $file{uses_todo}{$func}++; | |
adfe19db MHM |
538 | } |
539 | } | |
540 | } | |
541 | } | |
542 | ||
543 | while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { | |
544 | if (exists $need{$2}) { | |
545 | $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; | |
adfe19db | 546 | } |
c83e6f19 | 547 | else { warning("Possibly wrong #define $1 in $filename") } |
adfe19db MHM |
548 | } |
549 | ||
96ad942f MHM |
550 | for (qw(uses needs uses_todo needed_global needed_static)) { |
551 | for $func (keys %{$file{$_}}) { | |
552 | push @{$global{$_}{$func}}, $filename; | |
553 | } | |
554 | } | |
555 | ||
adfe19db MHM |
556 | $files{$filename} = \%file; |
557 | } | |
558 | ||
559 | # Globally resolve NEED_'s | |
560 | my $need; | |
561 | for $need (keys %{$global{needs}}) { | |
562 | if (@{$global{needs}{$need}} > 1) { | |
563 | my @targets = @{$global{needs}{$need}}; | |
564 | my @t = grep $files{$_}{needed_global}{$need}, @targets; | |
565 | @targets = @t if @t; | |
566 | @t = grep /\.xs$/i, @targets; | |
567 | @targets = @t if @t; | |
568 | my $target = shift @targets; | |
569 | $files{$target}{needs}{$need} = 'global'; | |
570 | for (@{$global{needs}{$need}}) { | |
571 | $files{$_}{needs}{$need} = 'extern' if $_ ne $target; | |
572 | } | |
573 | } | |
574 | } | |
575 | ||
576 | for $filename (@files) { | |
577 | exists $files{$filename} or next; | |
578 | ||
579 | info("=== Analyzing $filename ==="); | |
580 | ||
581 | my %file = %{$files{$filename}}; | |
582 | my $func; | |
583 | my $c = $file{code}; | |
679ad62d | 584 | my $warnings = 0; |
adfe19db | 585 | |
55179e46 | 586 | for $func (sort dictionary_order keys %{$file{uses_Perl}}) { |
adfe19db | 587 | if ($API{$func}{varargs}) { |
16289599 | 588 | unless ($API{$func}{noTHXarg}) { |
aab9a3b6 MHM |
589 | my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} |
590 | { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); | |
591 | if ($changes) { | |
592 | warning("Doesn't pass interpreter argument aTHX to Perl_$func"); | |
593 | $file{changes} += $changes; | |
594 | } | |
adfe19db MHM |
595 | } |
596 | } | |
597 | else { | |
598 | warning("Uses Perl_$func instead of $func"); | |
599 | $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} | |
600 | {$func$1(}g); | |
601 | } | |
602 | } | |
603 | ||
55179e46 | 604 | for $func (sort dictionary_order keys %{$file{uses_replace}}) { |
adfe19db MHM |
605 | warning("Uses $func instead of $replace{$func}"); |
606 | $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); | |
607 | } | |
608 | ||
55179e46 | 609 | for $func (sort dictionary_order keys %{$file{uses_provided}}) { |
679ad62d MHM |
610 | if ($file{uses}{$func}) { |
611 | if (exists $file{uses_deps}{$func}) { | |
612 | diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); | |
613 | } | |
614 | else { | |
615 | diag("Uses $func"); | |
616 | } | |
adfe19db | 617 | } |
190ae7ea | 618 | $warnings += (hint($func) || 0); |
adfe19db MHM |
619 | } |
620 | ||
679ad62d | 621 | unless ($opt{quiet}) { |
55179e46 | 622 | for $func (sort dictionary_order keys %{$file{uses_todo}}) { |
abf1601f | 623 | next if int_parse_version($API{$func}{todo}) <= $int_min_perl; |
679ad62d MHM |
624 | print "*** WARNING: Uses $func, which may not be portable below perl ", |
625 | format_version($API{$func}{todo}), ", even with '$ppport'\n"; | |
626 | $warnings++; | |
627 | } | |
adfe19db MHM |
628 | } |
629 | ||
55179e46 | 630 | for $func (sort dictionary_order keys %{$file{needed_static}}) { |
adfe19db MHM |
631 | my $message = ''; |
632 | if (not exists $file{uses}{$func}) { | |
633 | $message = "No need to define NEED_$func if $func is never used"; | |
634 | } | |
635 | elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { | |
636 | $message = "No need to define NEED_$func when already needed globally"; | |
637 | } | |
638 | if ($message) { | |
639 | diag($message); | |
640 | $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); | |
641 | } | |
642 | } | |
643 | ||
55179e46 | 644 | for $func (sort dictionary_order keys %{$file{needed_global}}) { |
adfe19db MHM |
645 | my $message = ''; |
646 | if (not exists $global{uses}{$func}) { | |
647 | $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; | |
648 | } | |
649 | elsif (exists $file{needs}{$func}) { | |
650 | if ($file{needs}{$func} eq 'extern') { | |
651 | $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; | |
652 | } | |
653 | elsif ($file{needs}{$func} eq 'static') { | |
654 | $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; | |
655 | } | |
656 | } | |
657 | if ($message) { | |
658 | diag($message); | |
659 | $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); | |
660 | } | |
661 | } | |
662 | ||
663 | $file{needs_inc_ppport} = keys %{$file{uses}}; | |
664 | ||
665 | if ($file{needs_inc_ppport}) { | |
666 | my $pp = ''; | |
667 | ||
55179e46 | 668 | for $func (sort dictionary_order keys %{$file{needs}}) { |
adfe19db MHM |
669 | my $type = $file{needs}{$func}; |
670 | next if $type eq 'extern'; | |
671 | my $suffix = $type eq 'global' ? '_GLOBAL' : ''; | |
672 | unless (exists $file{"needed_$type"}{$func}) { | |
673 | if ($type eq 'global') { | |
674 | diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); | |
675 | } | |
676 | else { | |
677 | diag("File needs $func, adding static request"); | |
678 | } | |
679 | $pp .= "#define NEED_$func$suffix\n"; | |
680 | } | |
681 | } | |
682 | ||
683 | if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { | |
684 | $pp = ''; | |
685 | $file{changes}++; | |
686 | } | |
687 | ||
688 | unless ($file{has_inc_ppport}) { | |
689 | diag("Needs to include '$ppport'"); | |
690 | $pp .= qq(#include "$ppport"\n) | |
691 | } | |
692 | ||
693 | if ($pp) { | |
694 | $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) | |
695 | || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) | |
696 | || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) | |
697 | || ($c =~ s/^/$pp/); | |
698 | } | |
699 | } | |
700 | else { | |
701 | if ($file{has_inc_ppport}) { | |
702 | diag("No need to include '$ppport'"); | |
703 | $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); | |
704 | } | |
705 | } | |
706 | ||
707 | # put back in our C comments | |
708 | my $ix; | |
709 | my $cppc = 0; | |
710 | my @ccom = @{$file{ccom}}; | |
711 | for $ix (0 .. $#ccom) { | |
712 | if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { | |
713 | $cppc++; | |
714 | $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; | |
715 | } | |
716 | else { | |
717 | $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; | |
718 | } | |
719 | } | |
720 | ||
721 | if ($cppc) { | |
722 | my $s = $cppc != 1 ? 's' : ''; | |
723 | warning("Uses $cppc C++ style comment$s, which is not portable"); | |
724 | } | |
725 | ||
679ad62d MHM |
726 | my $s = $warnings != 1 ? 's' : ''; |
727 | my $warn = $warnings ? " ($warnings warning$s)" : ''; | |
728 | info("Analysis completed$warn"); | |
729 | ||
adfe19db MHM |
730 | if ($file{changes}) { |
731 | if (exists $opt{copy}) { | |
732 | my $newfile = "$filename$opt{copy}"; | |
733 | if (-e $newfile) { | |
734 | error("'$newfile' already exists, refusing to write copy of '$filename'"); | |
735 | } | |
736 | else { | |
737 | local *F; | |
738 | if (open F, ">$newfile") { | |
739 | info("Writing copy of '$filename' with changes to '$newfile'"); | |
740 | print F $c; | |
741 | close F; | |
742 | } | |
743 | else { | |
744 | error("Cannot open '$newfile' for writing: $!"); | |
745 | } | |
746 | } | |
747 | } | |
748 | elsif (exists $opt{patch} || $opt{changes}) { | |
749 | if (exists $opt{patch}) { | |
750 | unless ($patch_opened) { | |
751 | if (open PATCH, ">$opt{patch}") { | |
752 | $patch_opened = 1; | |
753 | } | |
754 | else { | |
755 | error("Cannot open '$opt{patch}' for writing: $!"); | |
756 | delete $opt{patch}; | |
757 | $opt{changes} = 1; | |
758 | goto fallback; | |
759 | } | |
760 | } | |
761 | mydiff(\*PATCH, $filename, $c); | |
762 | } | |
763 | else { | |
764 | fallback: | |
765 | info("Suggested changes:"); | |
766 | mydiff(\*STDOUT, $filename, $c); | |
767 | } | |
768 | } | |
769 | else { | |
770 | my $s = $file{changes} == 1 ? '' : 's'; | |
771 | info("$file{changes} potentially required change$s detected"); | |
772 | } | |
773 | } | |
774 | else { | |
775 | info("Looks good"); | |
776 | } | |
777 | } | |
778 | ||
779 | close PATCH if $patch_opened; | |
780 | ||
781 | exit 0; | |
782 | ||
783 | ####################################################################### | |
784 | ||
c83e6f19 MHM |
785 | sub try_use { eval "use @_;"; return $@ eq '' } |
786 | ||
adfe19db MHM |
787 | sub mydiff |
788 | { | |
789 | local *F = shift; | |
790 | my($file, $str) = @_; | |
791 | my $diff; | |
792 | ||
793 | if (exists $opt{diff}) { | |
794 | $diff = run_diff($opt{diff}, $file, $str); | |
795 | } | |
796 | ||
c83e6f19 | 797 | if (!defined $diff and try_use('Text::Diff')) { |
adfe19db MHM |
798 | $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); |
799 | $diff = <<HEADER . $diff; | |
800 | --- $file | |
801 | +++ $file.patched | |
802 | HEADER | |
803 | } | |
804 | ||
805 | if (!defined $diff) { | |
806 | $diff = run_diff('diff -u', $file, $str); | |
807 | } | |
808 | ||
809 | if (!defined $diff) { | |
810 | $diff = run_diff('diff', $file, $str); | |
811 | } | |
812 | ||
813 | if (!defined $diff) { | |
814 | error("Cannot generate a diff. Please install Text::Diff or use --copy."); | |
815 | return; | |
816 | } | |
817 | ||
818 | print F $diff; | |
adfe19db MHM |
819 | } |
820 | ||
821 | sub run_diff | |
822 | { | |
823 | my($prog, $file, $str) = @_; | |
824 | my $tmp = 'dppptemp'; | |
825 | my $suf = 'aaa'; | |
826 | my $diff = ''; | |
827 | local *F; | |
828 | ||
829 | while (-e "$tmp.$suf") { $suf++ } | |
830 | $tmp = "$tmp.$suf"; | |
831 | ||
832 | if (open F, ">$tmp") { | |
833 | print F $str; | |
834 | close F; | |
835 | ||
836 | if (open F, "$prog $file $tmp |") { | |
837 | while (<F>) { | |
838 | s/\Q$tmp\E/$file.patched/; | |
839 | $diff .= $_; | |
840 | } | |
841 | close F; | |
842 | unlink $tmp; | |
843 | return $diff; | |
844 | } | |
845 | ||
846 | unlink $tmp; | |
847 | } | |
848 | else { | |
849 | error("Cannot open '$tmp' for writing: $!"); | |
850 | } | |
851 | ||
852 | return undef; | |
853 | } | |
854 | ||
adfe19db MHM |
855 | sub rec_depend |
856 | { | |
af36fda7 | 857 | my($func, $seen) = @_; |
adfe19db | 858 | return () unless exists $depends{$func}; |
af36fda7 MHM |
859 | $seen = {%{$seen||{}}}; |
860 | return () if $seen->{$func}++; | |
861 | my %s; | |
862 | grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; | |
adfe19db MHM |
863 | } |
864 | ||
adfe19db MHM |
865 | sub info |
866 | { | |
867 | $opt{quiet} and return; | |
868 | print @_, "\n"; | |
869 | } | |
870 | ||
871 | sub diag | |
872 | { | |
873 | $opt{quiet} and return; | |
874 | $opt{diag} and print @_, "\n"; | |
875 | } | |
876 | ||
877 | sub warning | |
878 | { | |
879 | $opt{quiet} and return; | |
880 | print "*** ", @_, "\n"; | |
881 | } | |
882 | ||
883 | sub error | |
884 | { | |
885 | print "*** ERROR: ", @_, "\n"; | |
886 | } | |
887 | ||
888 | my %given_hints; | |
679ad62d | 889 | my %given_warnings; |
adfe19db MHM |
890 | sub hint |
891 | { | |
892 | $opt{quiet} and return; | |
adfe19db | 893 | my $func = shift; |
679ad62d MHM |
894 | my $rv = 0; |
895 | if (exists $warnings{$func} && !$given_warnings{$func}++) { | |
896 | my $warn = $warnings{$func}; | |
897 | $warn =~ s!^!*** !mg; | |
898 | print "*** WARNING: $func\n", $warn; | |
899 | $rv++; | |
900 | } | |
901 | if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { | |
902 | my $hint = $hints{$func}; | |
903 | $hint =~ s/^/ /mg; | |
904 | print " --- hint for $func ---\n", $hint; | |
905 | } | |
190ae7ea | 906 | $rv || 0; |
adfe19db MHM |
907 | } |
908 | ||
909 | sub usage | |
910 | { | |
911 | my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; | |
912 | my %M = ( 'I' => '*' ); | |
913 | $usage =~ s/^\s*perl\s+\S+/$^X $0/; | |
914 | $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; | |
915 | ||
916 | print <<ENDUSAGE; | |
917 | ||
918 | Usage: $usage | |
919 | ||
920 | See perldoc $0 for details. | |
921 | ||
922 | ENDUSAGE | |
923 | ||
924 | exit 2; | |
925 | } | |
0d0f8426 MHM |
926 | |
927 | sub strip | |
928 | { | |
929 | my $self = do { local(@ARGV,$/)=($0); <> }; | |
78b4ff79 MHM |
930 | my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; |
931 | $copy =~ s/^(?=\S+)/ /gms; | |
932 | $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; | |
0d0f8426 MHM |
933 | $self =~ s/^SKIP.*(?=^__DATA__)/SKIP |
934 | if (\@ARGV && \$ARGV[0] eq '--unstrip') { | |
935 | eval { require Devel::PPPort }; | |
936 | \$@ and die "Cannot require Devel::PPPort, please install.\\n"; | |
51d6c659 | 937 | if (eval \$Devel::PPPort::VERSION < $VERSION) { |
78b4ff79 MHM |
938 | die "$0 was originally generated with Devel::PPPort $VERSION.\\n" |
939 | . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" | |
940 | . "Please install a newer version, or --unstrip will not work.\\n"; | |
941 | } | |
0d0f8426 MHM |
942 | Devel::PPPort::WriteFile(\$0); |
943 | exit 0; | |
944 | } | |
945 | print <<END; | |
946 | ||
947 | Sorry, but this is a stripped version of \$0. | |
948 | ||
949 | To be able to use its original script and doc functionality, | |
950 | please try to regenerate this file using: | |
951 | ||
952 | \$^X \$0 --unstrip | |
953 | ||
954 | END | |
955 | /ms; | |
c83e6f19 MHM |
956 | my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms; |
957 | $c =~ s{ | |
958 | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | |
959 | | ( "[^"\\]*(?:\\.[^"\\]*)*" | |
960 | | '[^'\\]*(?:\\.[^'\\]*)*' ) | |
961 | | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex; | |
962 | $c =~ s!\s+$!!mg; | |
963 | $c =~ s!^$LF!!mg; | |
964 | $c =~ s!^\s*#\s*!#!mg; | |
965 | $c =~ s!^\s+!!mg; | |
0d0f8426 MHM |
966 | |
967 | open OUT, ">$0" or die "cannot strip $0: $!\n"; | |
c83e6f19 | 968 | print OUT "$pl$c\n"; |
0d0f8426 MHM |
969 | |
970 | exit 0; | |
971 | } |