ext/Devel/PPPort/parts/inc/ppphbin

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