ext/Devel/PPPort/parts/inc/ppphbin

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