ext/Devel/PPPort/parts/inc/ppphbin

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