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