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