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