ppphbin revision 1.1.1.1
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 16use strict; 17 18# Disable broken TRIE-optimization 19BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } 20 21my $VERSION = __VERSION__; 22 23my %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 34my($ppport) = $0 =~ /([\w.]+)$/; 35my $LF = '(?:\r\n|[\r\n])'; # line feed 36my $HS = "[ \t]"; # horizontal whitespace 37 38# Never use C comments in this file! 39my $ccs = '/'.'*'; 40my $cce = '*'.'/'; 41my $rccs = quotemeta $ccs; 42my $rcce = quotemeta $cce; 43 44eval { 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 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 58if ($opt{version}) { 59 print "This is $0 $VERSION.\n"; 60 exit 0; 61} 62 63usage() if $opt{help}; 64strip() if $opt{strip}; 65 66if (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} 75else { 76 $opt{'compat-version'} = 5; 77} 78 79my %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 91if (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 102my(%replace, %need, %hints, %warnings, %depends); 103my $replace = 0; 104my($hint, $define, $function); 105 106sub 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 116while (<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 177for (values %depends) { 178 my %s; 179 $_ = [sort grep !$s{$_}++, @$_]; 180} 181 182if (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 212if (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 227my @files; 228my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); 229my $srcext = join '|', map { quotemeta $_ } @srcext; 230 231if (@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} 247else { 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 260if (!@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 273die "No input files given!\n" unless @files; 274 275my(%files, %global, %revreplace); 276%revreplace = reverse %replace; 277my $filename; 278my $patch_opened = 0; 279 280for $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 359my $need; 360for $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 375for $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 { 562fallback: 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 577close PATCH if $patch_opened; 578 579exit 0; 580 581####################################################################### 582 583sub try_use { eval "use @_;"; return $@ eq '' } 584 585sub 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 600HEADER 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 619sub 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 653sub 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 663sub parse_version 664{ 665 my $ver = shift; 666 667 if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { 668 return ($1, $2, $3); 669 } 670 elsif ($ver !~ /^\d+\.[\d_]+$/) { 671 die "cannot parse version '$ver'\n"; 672 } 673 674 $ver =~ s/_//g; 675 $ver =~ s/$/000000/; 676 677 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; 678 679 $v = int $v; 680 $s = int $s; 681 682 if ($r < 5 || ($r == 5 && $v < 6)) { 683 if ($s % 10) { 684 die "cannot parse version '$ver'\n"; 685 } 686 } 687 688 return ($r, $v, $s); 689} 690 691sub format_version 692{ 693 my $ver = shift; 694 695 $ver =~ s/$/000000/; 696 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; 697 698 $v = int $v; 699 $s = int $s; 700 701 if ($r < 5 || ($r == 5 && $v < 6)) { 702 if ($s % 10) { 703 die "invalid version '$ver'\n"; 704 } 705 $s /= 10; 706 707 $ver = sprintf "%d.%03d", $r, $v; 708 $s > 0 and $ver .= sprintf "_%02d", $s; 709 710 return $ver; 711 } 712 713 return sprintf "%d.%d.%d", $r, $v, $s; 714} 715 716sub info 717{ 718 $opt{quiet} and return; 719 print @_, "\n"; 720} 721 722sub diag 723{ 724 $opt{quiet} and return; 725 $opt{diag} and print @_, "\n"; 726} 727 728sub warning 729{ 730 $opt{quiet} and return; 731 print "*** ", @_, "\n"; 732} 733 734sub error 735{ 736 print "*** ERROR: ", @_, "\n"; 737} 738 739my %given_hints; 740my %given_warnings; 741sub hint 742{ 743 $opt{quiet} and return; 744 my $func = shift; 745 my $rv = 0; 746 if (exists $warnings{$func} && !$given_warnings{$func}++) { 747 my $warn = $warnings{$func}; 748 $warn =~ s!^!*** !mg; 749 print "*** WARNING: $func\n", $warn; 750 $rv++; 751 } 752 if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { 753 my $hint = $hints{$func}; 754 $hint =~ s/^/ /mg; 755 print " --- hint for $func ---\n", $hint; 756 } 757 $rv; 758} 759 760sub usage 761{ 762 my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; 763 my %M = ( 'I' => '*' ); 764 $usage =~ s/^\s*perl\s+\S+/$^X $0/; 765 $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; 766 767 print <<ENDUSAGE; 768 769Usage: $usage 770 771See perldoc $0 for details. 772 773ENDUSAGE 774 775 exit 2; 776} 777 778sub strip 779{ 780 my $self = do { local(@ARGV,$/)=($0); <> }; 781 my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; 782 $copy =~ s/^(?=\S+)/ /gms; 783 $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; 784 $self =~ s/^SKIP.*(?=^__DATA__)/SKIP 785if (\@ARGV && \$ARGV[0] eq '--unstrip') { 786 eval { require Devel::PPPort }; 787 \$@ and die "Cannot require Devel::PPPort, please install.\\n"; 788 if (eval \$Devel::PPPort::VERSION < $VERSION) { 789 die "$0 was originally generated with Devel::PPPort $VERSION.\\n" 790 . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" 791 . "Please install a newer version, or --unstrip will not work.\\n"; 792 } 793 Devel::PPPort::WriteFile(\$0); 794 exit 0; 795} 796print <<END; 797 798Sorry, but this is a stripped version of \$0. 799 800To be able to use its original script and doc functionality, 801please try to regenerate this file using: 802 803 \$^X \$0 --unstrip 804 805END 806/ms; 807 my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms; 808 $c =~ s{ 809 / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) 810 | ( "[^"\\]*(?:\\.[^"\\]*)*" 811 | '[^'\\]*(?:\\.[^'\\]*)*' ) 812 | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex; 813 $c =~ s!\s+$!!mg; 814 $c =~ s!^$LF!!mg; 815 $c =~ s!^\s*#\s*!#!mg; 816 $c =~ s!^\s+!!mg; 817 818 open OUT, ">$0" or die "cannot strip $0: $!\n"; 819 print OUT "$pl$c\n"; 820 821 exit 0; 822} 823