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