[p5sagit/p5-mst-13.2.git] / ext / Devel / PPPort / parts / inc / ppphbin

################################################################################
##
##  $Revision: 34 $
##  $Author: mhx $
##  $Date: 2006/07/03 10:21:54 +0200 $
##
################################################################################
##
##  Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
##  Version 2.x, Copyright (C) 2001, Paul Marquess.
##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
##
##  This program is free software; you can redistribute it and/or
##  modify it under the same terms as Perl itself.
##
################################################################################

=provides

=implementation

use strict;

my $VERSION = __VERSION__;

my %opt = (
  quiet     => 0,
  diag      => 1,
  hints     => 1,
  changes   => 1,
  cplusplus => 0,
  filter    => 1,
  strip     => 0,
  version   => 0,
);

my($ppport) = $0 =~ /([\w.]+)$/;
my $LF = '(?:\r\n|[\r\n])';   # line feed
my $HS = "[ \t]";             # horizontal whitespace

eval {
  require Getopt::Long;
  Getopt::Long::GetOptions(\%opt, qw(
    help quiet diag! filter! hints! changes! cplusplus strip version
    patch=s copy=s diff=s compat-version=s
    list-provided list-unsupported api-info=s
  )) or usage();
};

if ($@ and grep /^-/, @ARGV) {
  usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
  die "Getopt::Long not found. Please don't use any options.\n";
}

if ($opt{version}) {
  print "This is $0 $VERSION.\n";
  exit 0;
}

usage() if $opt{help};
strip() if $opt{strip};

if (exists $opt{'compat-version'}) {
  my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
  if ($@) {
    die "Invalid version number format: '$opt{'compat-version'}'\n";
  }
  die "Only Perl 5 is supported\n" if $r != 5;
  die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
  $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
}
else {
  $opt{'compat-version'} = 5;
}

# Never use C comments in this file!!!!!
my $ccs  = '/'.'*';
my $cce  = '*'.'/';
my $rccs = quotemeta $ccs;
my $rcce = quotemeta $cce;

my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
                ? ( $1 => {
                      ($2                  ? ( base     => $2 ) : ()),
                      ($3                  ? ( todo     => $3 ) : ()),
                      (index($4, 'v') >= 0 ? ( varargs  => 1  ) : ()),
                      (index($4, 'p') >= 0 ? ( provided => 1  ) : ()),
                      (index($4, 'n') >= 0 ? ( nothxarg => 1  ) : ()),
                    } )
                : die "invalid spec: $_" } qw(
__PERL_API__
);

if (exists $opt{'list-unsupported'}) {
  my $f;
  for $f (sort { lc $a cmp lc $b } keys %API) {
    next unless $API{$f}{todo};
    print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
  }
  exit 0;
}

# Scan for possible replacement candidates

my(%replace, %need, %hints, %depends);
my $replace = 0;
my $hint = '';

while (<DATA>) {
  if ($hint) {
    if (m{^\s*\*\s(.*?)\s*$}) {
      $hints{$hint} ||= '';  # suppress warning with older perls
      $hints{$hint} .= "$1\n";
    }
    else {
      $hint = '';
    }
  }
  $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$};

  $replace     = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
  $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
  $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
  $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};

  if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
    push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2;
  }

  $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
}

if (exists $opt{'api-info'}) {
  my $f;
  my $count = 0;
  my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
  for $f (sort { lc $a cmp lc $b } keys %API) {
    next unless $f =~ /$match/;
    print "\n=== $f ===\n\n";
    my $info = 0;
    if ($API{$f}{base} || $API{$f}{todo}) {
      my $base = format_version($API{$f}{base} || $API{$f}{todo});
      print "Supported at least starting from perl-$base.\n";
      $info++;
    }
    if ($API{$f}{provided}) {
      my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "__MIN_PERL__";
      print "Support by $ppport provided back to perl-$todo.\n";
      print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
      print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
      print "$hints{$f}" if exists $hints{$f};
      $info++;
    }
    unless ($info) {
      print "No portability information available.\n";
    }
    $count++;
  }
  if ($count > 0) {
    print "\n";
  }
  else {
    print "Found no API matching '$opt{'api-info'}'.\n";
  }
  exit 0;
}

if (exists $opt{'list-provided'}) {
  my $f;
  for $f (sort { lc $a cmp lc $b } keys %API) {
    next unless $API{$f}{provided};
    my @flags;
    push @flags, 'explicit' if exists $need{$f};
    push @flags, 'depend'   if exists $depends{$f};
    push @flags, 'hint'     if exists $hints{$f};
    my $flags = @flags ? '  ['.join(', ', @flags).']' : '';
    print "$f$flags\n";
  }
  exit 0;
}

my @files;
my @srcext = qw( xs c h cc cpp );
my $srcext = join '|', @srcext;

if (@ARGV) {
  my %seen;
  @files = grep { -f && !exists $seen{$_} } map { glob $_ } @ARGV;
}
else {
  eval {
    require File::Find;
    File::Find::find(sub {
      $File::Find::name =~ /\.($srcext)$/i
          and push @files, $File::Find::name;
    }, '.');
  };
  if ($@) {
    @files = map { glob "*.$_" } @srcext;
  }
}

if (!@ARGV || $opt{filter}) {
  my(@in, @out);
  my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
  for (@files) {
    my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/\.($srcext)$/i;
    push @{ $out ? \@out : \@in }, $_;
  }
  if (@ARGV && @out) {
    warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
  }
  @files = @in;
}

unless (@files) {
  die "No input files given!\n";
}

my(%files, %global, %revreplace);
%revreplace = reverse %replace;
my $filename;
my $patch_opened = 0;

for $filename (@files) {
  unless (open IN, "<$filename") {
    warn "Unable to read from $filename: $!\n";
    next;
  }

  info("Scanning $filename ...");

  my $c = do { local $/; <IN> };
  close IN;

  my %file = (orig => $c, changes => 0);

  # temporarily remove C comments from the code
  my @ccom;
  $c =~ s{
    (
        [^"'/]+
      |
        (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+
      |
        (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+
    )
  |
    (/ (?:
        \*[^*]*\*+(?:[^$ccs][^*]*\*+)* /
        |
        /[^\r\n]*
      ))
  }{
    defined $2 and push @ccom, $2;
    defined $1 ? $1 : "$ccs$#ccom$cce";
  }egsx;

  $file{ccom} = \@ccom;
  $file{code} = $c;
  $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/);

  my $func;

  for $func (keys %API) {
    my $match = $func;
    $match .= "|$revreplace{$func}" if exists $revreplace{$func};
    if ($c =~ /\b(?:Perl_)?($match)\b/) {
      $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
      $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
      if (exists $API{$func}{provided}) {
        if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
          $file{uses}{$func}++;
          my @deps = rec_depend($func);
          if (@deps) {
            $file{uses_deps}{$func} = \@deps;
            for (@deps) {
              $file{uses}{$_} = 0 unless exists $file{uses}{$_};
            }
          }
          for ($func, @deps) {
            if (exists $need{$_}) {
              $file{needs}{$_} = 'static';
            }
          }
        }
      }
      if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
        if ($c =~ /\b$func\b/) {
          $file{uses_todo}{$func}++;
        }
      }
    }
  }

  while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
    if (exists $need{$2}) {
      $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
    }
    else {
      warning("Possibly wrong #define $1 in $filename");
    }
  }

  for (qw(uses needs uses_todo needed_global needed_static)) {
    for $func (keys %{$file{$_}}) {
      push @{$global{$_}{$func}}, $filename;
    }
  }

  $files{$filename} = \%file;
}

# Globally resolve NEED_'s
my $need;
for $need (keys %{$global{needs}}) {
  if (@{$global{needs}{$need}} > 1) {
    my @targets = @{$global{needs}{$need}};
    my @t = grep $files{$_}{needed_global}{$need}, @targets;
    @targets = @t if @t;
    @t = grep /\.xs$/i, @targets;
    @targets = @t if @t;
    my $target = shift @targets;
    $files{$target}{needs}{$need} = 'global';
    for (@{$global{needs}{$need}}) {
      $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
    }
  }
}

for $filename (@files) {
  exists $files{$filename} or next;

  info("=== Analyzing $filename ===");

  my %file = %{$files{$filename}};
  my $func;
  my $c = $file{code};

  for $func (sort keys %{$file{uses_Perl}}) {
    if ($API{$func}{varargs}) {
      my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
                            { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
      if ($changes) {
        warning("Doesn't pass interpreter argument aTHX to Perl_$func");
        $file{changes} += $changes;
      }
    }
    else {
      warning("Uses Perl_$func instead of $func");
      $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
                                {$func$1(}g);
    }
  }

  for $func (sort keys %{$file{uses_replace}}) {
    warning("Uses $func instead of $replace{$func}");
    $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
  }

  for $func (sort keys %{$file{uses}}) {
    next unless $file{uses}{$func};   # if it's only a dependency
    if (exists $file{uses_deps}{$func}) {
      diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
    }
    elsif (exists $replace{$func}) {
      warning("Uses $func instead of $replace{$func}");
      $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
    }
    else {
      diag("Uses $func");
    }
    hint($func);
  }

  for $func (sort keys %{$file{uses_todo}}) {
    warning("Uses $func, which may not be portable below perl ",
            format_version($API{$func}{todo}));
  }

  for $func (sort keys %{$file{needed_static}}) {
    my $message = '';
    if (not exists $file{uses}{$func}) {
      $message = "No need to define NEED_$func if $func is never used";
    }
    elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
      $message = "No need to define NEED_$func when already needed globally";
    }
    if ($message) {
      diag($message);
      $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
    }
  }

  for $func (sort keys %{$file{needed_global}}) {
    my $message = '';
    if (not exists $global{uses}{$func}) {
      $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
    }
    elsif (exists $file{needs}{$func}) {
      if ($file{needs}{$func} eq 'extern') {
        $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
      }
      elsif ($file{needs}{$func} eq 'static') {
        $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
      }
    }
    if ($message) {
      diag($message);
      $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
    }
  }

  $file{needs_inc_ppport} = keys %{$file{uses}};

  if ($file{needs_inc_ppport}) {
    my $pp = '';

    for $func (sort keys %{$file{needs}}) {
      my $type = $file{needs}{$func};
      next if $type eq 'extern';
      my $suffix = $type eq 'global' ? '_GLOBAL' : '';
      unless (exists $file{"needed_$type"}{$func}) {
        if ($type eq 'global') {
          diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
        }
        else {
          diag("File needs $func, adding static request");
        }
        $pp .= "#define NEED_$func$suffix\n";
      }
    }

    if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
      $pp = '';
      $file{changes}++;
    }

    unless ($file{has_inc_ppport}) {
      diag("Needs to include '$ppport'");
      $pp .= qq(#include "$ppport"\n)
    }

    if ($pp) {
      $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
                     || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
                     || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
                     || ($c =~ s/^/$pp/);
    }
  }
  else {
    if ($file{has_inc_ppport}) {
      diag("No need to include '$ppport'");
      $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
    }
  }

  # put back in our C comments
  my $ix;
  my $cppc = 0;
  my @ccom = @{$file{ccom}};
  for $ix (0 .. $#ccom) {
    if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
      $cppc++;
      $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
    }
    else {
      $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
    }
  }

  if ($cppc) {
    my $s = $cppc != 1 ? 's' : '';
    warning("Uses $cppc C++ style comment$s, which is not portable");
  }

  if ($file{changes}) {
    if (exists $opt{copy}) {
      my $newfile = "$filename$opt{copy}";
      if (-e $newfile) {
        error("'$newfile' already exists, refusing to write copy of '$filename'");
      }
      else {
        local *F;
        if (open F, ">$newfile") {
          info("Writing copy of '$filename' with changes to '$newfile'");
          print F $c;
          close F;
        }
        else {
          error("Cannot open '$newfile' for writing: $!");
        }
      }
    }
    elsif (exists $opt{patch} || $opt{changes}) {
      if (exists $opt{patch}) {
        unless ($patch_opened) {
          if (open PATCH, ">$opt{patch}") {
            $patch_opened = 1;
          }
          else {
            error("Cannot open '$opt{patch}' for writing: $!");
            delete $opt{patch};
            $opt{changes} = 1;
            goto fallback;
          }
        }
        mydiff(\*PATCH, $filename, $c);
      }
      else {
fallback:
        info("Suggested changes:");
        mydiff(\*STDOUT, $filename, $c);
      }
    }
    else {
      my $s = $file{changes} == 1 ? '' : 's';
      info("$file{changes} potentially required change$s detected");
    }
  }
  else {
    info("Looks good");
  }
}

close PATCH if $patch_opened;

exit 0;

#######################################################################

sub mydiff
{
  local *F = shift;
  my($file, $str) = @_;
  my $diff;

  if (exists $opt{diff}) {
    $diff = run_diff($opt{diff}, $file, $str);
  }

  if (!defined $diff and can_use('Text::Diff')) {
    $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
    $diff = <<HEADER . $diff;
--- $file
+++ $file.patched
HEADER
  }

  if (!defined $diff) {
    $diff = run_diff('diff -u', $file, $str);
  }

  if (!defined $diff) {
    $diff = run_diff('diff', $file, $str);
  }

  if (!defined $diff) {
    error("Cannot generate a diff. Please install Text::Diff or use --copy.");
    return;
  }

  print F $diff;

}

sub run_diff
{
  my($prog, $file, $str) = @_;
  my $tmp = 'dppptemp';
  my $suf = 'aaa';
  my $diff = '';
  local *F;

  while (-e "$tmp.$suf") { $suf++ }
  $tmp = "$tmp.$suf";

  if (open F, ">$tmp") {
    print F $str;
    close F;

    if (open F, "$prog $file $tmp |") {
      while (<F>) {
        s/\Q$tmp\E/$file.patched/;
        $diff .= $_;
      }
      close F;
      unlink $tmp;
      return $diff;
    }

    unlink $tmp;
  }
  else {
    error("Cannot open '$tmp' for writing: $!");
  }

  return undef;
}

sub can_use
{
  eval "use @_;";
  return $@ eq '';
}

sub rec_depend
{
  my $func = shift;
  my %seen;
  return () unless exists $depends{$func};
  grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}};
}

sub parse_version
{
  my $ver = shift;

  if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
    return ($1, $2, $3);
  }
  elsif ($ver !~ /^\d+\.[\d_]+$/) {
    die "cannot parse version '$ver'\n";
  }

  $ver =~ s/_//g;
  $ver =~ s/$/000000/;

  my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;

  $v = int $v;
  $s = int $s;

  if ($r < 5 || ($r == 5 && $v < 6)) {
    if ($s % 10) {
      die "cannot parse version '$ver'\n";
    }
  }

  return ($r, $v, $s);
}

sub format_version
{
  my $ver = shift;

  $ver =~ s/$/000000/;
  my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;

  $v = int $v;
  $s = int $s;

  if ($r < 5 || ($r == 5 && $v < 6)) {
    if ($s % 10) {
      die "invalid version '$ver'\n";
    }
    $s /= 10;

    $ver = sprintf "%d.%03d", $r, $v;
    $s > 0 and $ver .= sprintf "_%02d", $s;

    return $ver;
  }

  return sprintf "%d.%d.%d", $r, $v, $s;
}

sub info
{
  $opt{quiet} and return;
  print @_, "\n";
}

sub diag
{
  $opt{quiet} and return;
  $opt{diag} and print @_, "\n";
}

sub warning
{
  $opt{quiet} and return;
  print "*** ", @_, "\n";
}

sub error
{
  print "*** ERROR: ", @_, "\n";
}

my %given_hints;
sub hint
{
  $opt{quiet} and return;
  $opt{hints} or return;
  my $func = shift;
  exists $hints{$func} or return;
  $given_hints{$func}++ and return;
  my $hint = $hints{$func};
  $hint =~ s/^/   /mg;
  print "   --- hint for $func ---\n", $hint;
}

sub usage
{
  my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
  my %M = ( 'I' => '*' );
  $usage =~ s/^\s*perl\s+\S+/$^X $0/;
  $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;

  print <<ENDUSAGE;

Usage: $usage

See perldoc $0 for details.

ENDUSAGE

  exit 2;
}

sub strip
{
  my $self = do { local(@ARGV,$/)=($0); <> };
  my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
  $copy =~ s/^(?=\S+)/    /gms;
  $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
  $self =~ s/^SKIP.*(?=^__DATA__)/SKIP
if (\@ARGV && \$ARGV[0] eq '--unstrip') {
  eval { require Devel::PPPort };
  \$@ and die "Cannot require Devel::PPPort, please install.\\n";
  if (\$Devel::PPPort::VERSION < $VERSION) {
    die "$0 was originally generated with Devel::PPPort $VERSION.\\n"
      . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n"
      . "Please install a newer version, or --unstrip will not work.\\n";
  }
  Devel::PPPort::WriteFile(\$0);
  exit 0;
}
print <<END;

Sorry, but this is a stripped version of \$0.

To be able to use its original script and doc functionality,
please try to regenerate this file using:

  \$^X \$0 --unstrip

END
/ms;

  open OUT, ">$0" or die "cannot strip $0: $!\n";
  print OUT $self;

  exit 0;
}
Commit	Line	Data
adfe19db	1	################################################################################
adfe19db	2	##
78b4ff79	3	## $Revision: 34 $
adfe19db	4	## $Author: mhx $
78b4ff79	5	## $Date: 2006/07/03 10:21:54 +0200 $
adfe19db	6	##
	7	################################################################################
	8	##
0d0f8426	9	## Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
adfe19db	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
adfe19db	22	use strict;
adfe19db	23
78b4ff79	24	my $VERSION = __VERSION__;
78b4ff79	25
adfe19db	26	my %opt = (
	27	quiet => 0,
	28	diag => 1,
	29	hints => 1,
	30	changes => 1,
	31	cplusplus => 0,
4a582685	32	filter => 1,
0d0f8426	33	strip => 0,
78b4ff79	34	version => 0,
adfe19db	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(
78b4ff79	44	help quiet diag! filter! hints! changes! cplusplus strip version
adfe19db	45	patch=s copy=s diff=s compat-version=s
04fc8b94	46	list-provided list-unsupported api-info=s
adfe19db	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
78b4ff79	55	if ($opt{version}) {
	56	print "This is $0 $VERSION.\n";
	57	exit 0;
	58	}
	59
adfe19db	60	usage() if $opt{help};
0d0f8426	61	strip() if $opt{strip};
adfe19db	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;
4a582685	69	die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 \|\| $s >= 1000;
adfe19db	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
adfe19db	82	my %API = map { /^(\w+)\\|([^\|])\\|([^\|])\\|(\w*)$/
4a582685	83	? ( $1 => {
adfe19db	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#\sdefine\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
	123	$replace{$2} = $1 if m{^\s#\sdefine\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
04fc8b94	133	if (exists $opt{'api-info'}) {
	134	my $f;
	135	my $count = 0;
9132e1a3	136	my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
04fc8b94	137	for $f (sort { lc $a cmp lc $b } keys %API) {
9132e1a3	138	next unless $f =~ /$match/;
04fc8b94	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});
9132e1a3	143	print "Supported at least starting from perl-$base.\n";
04fc8b94	144	$info++;
	145	}
	146	if ($API{$f}{provided}) {
	147	my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "__MIN_PERL__";
9132e1a3	148	print "Support by $ppport provided back to perl-$todo.\n";
04fc8b94	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 {
9132e1a3	163	print "Found no API matching '$opt{'api-info'}'.\n";
04fc8b94	164	}
	165	exit 0;
	166	}
	167
adfe19db	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
4a582685	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
adfe19db	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}++;
adfe19db	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}{$_};
adfe19db	279	}
	280	}
	281	for ($func, @deps) {
	282	if (exists $need{$_}) {
	283	$file{needs}{$_} = 'static';
adfe19db	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}++;
adfe19db	291	}
	292	}
	293	}
	294	}
	295
	296	while ($c =~ /^$HS#$HSdefine$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
	297	if (exists $need{$2}) {
	298	$file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
adfe19db	299	}
	300	else {
	301	warning("Possibly wrong #define $1 in $filename");
	302	}
	303	}
	304
96ad942f	305	for (qw(uses needs uses_todo needed_global needed_static)) {
	306	for $func (keys %{$file{$_}}) {
	307	push @{$global{$_}{$func}}, $filename;
	308	}
	309	}
	310
adfe19db	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)\((\saTHX_?)?\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#$HSdefine$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#$HSdefine$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#$HSdefine$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#$HSdefine$HS+NEED_\w+.*?)^/$1$pp/ms)
446	\|\| ($c =~ s/^(?=$HS#$HSinclude.*\Q$ppport\E)/$pp/m)
447	\|\| ($c =~ s/^($HS#$HSinclude.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?#$HSinclude.\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;
96ad942f	610	my %seen;
adfe19db	611	return () unless exists $depends{$func};
96ad942f	612	grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}};
adfe19db	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	}
0d0f8426	721
	722	sub strip
	723	{
	724	my $self = do { local(@ARGV,$/)=($0); <> };
78b4ff79	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;
0d0f8426	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";
78b4ff79	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	}
0d0f8426	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	}