ppphbin

source of perl for linux application,

################################################################################
##
##  $Revision: 45 $
##  $Author: mhx $
##  $Date: 2007/09/11 23:18:31 +0200 $
##
################################################################################
##
##  Version 3.x, Copyright (C) 2004-2007, 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;

# Disable broken TRIE-optimization
BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 }

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

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

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;
}

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, %warnings, %depends);
my $replace = 0;
my($hint, $define, $function);

sub find_api
{
  my $code = shift;
  $code =~ s{
    / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
  | "[^"\\]*(?:\\.[^"\\]*)*"
  | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx;
  grep { exists $API{$_} } $code =~ /(\w+)/mg;
}

while (<DATA>) {
  if ($hint) {
    my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings;
    if (m{^\s*\*\s(.*?)\s*$}) {
      for (@{$hint->[1]}) {
        $h->{$_} ||= '';  # suppress warning with older perls
        $h->{$_} .= "$1\n";
      }
    }
    else { undef $hint }
  }

  $hint = [$1, [split /,?\s+/, $2]]
      if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$};

  if ($define) {
    if ($define->[1] =~ /\\$/) {
      $define->[1] .= $_;
    }
    else {
      if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) {
        my @n = find_api($define->[1]);
        push @{$depends{$define->[0]}}, @n if @n
      }
      undef $define;
    }
  }

  $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)};

  if ($function) {
    if (/^}/) {
      if (exists $API{$function->[0]}) {
        my @n = find_api($function->[1]);
        push @{$depends{$function->[0]}}, @n if @n
      }
      undef $define;
    }
    else {
      $function->[1] .= $_;
    }
  }

  $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)};

  $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)?\)};
}

for (values %depends) {
  my %s;
  $_ = [sort grep !$s{$_}++, @$_];
}

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 "\n$hints{$f}" if exists $hints{$f};
      print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f};
      $info++;
    }
    print "No portability information available.\n" unless $info;
    $count++;
  }
  $count or print "Found no API matching '$opt{'api-info'}'.";
  print "\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};
    push @flags, 'warning'  if exists $warnings{$f};
    my $flags = @flags ? '  ['.join(', ', @flags).']' : '';
    print "$f$flags\n";
  }
  exit 0;
}

my @files;
my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
my $srcext = join '|', map { quotemeta $_ } @srcext;

if (@ARGV) {
  my %seen;
  for (@ARGV) {
    if (-e) {
      if (-f) {
        push @files, $_ unless $seen{$_}++;
      }
      else { warn "'$_' is not a file.\n" }
    }
    else {
      my @new = grep { -f } glob $_
          or warn "'$_' does not exist.\n";
      push @files, grep { !$seen{$_}++ } @new;
    }
  }
}
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;
}

die "No input files given!\n" unless @files;

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/XS comments and strings from the code
  my @ccom;

  $c =~ s{
    ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]*
    | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* )
  | ( ^$HS*\#[^\r\n]*
    | "[^"\\]*(?:\\.[^"\\]*)*"
    | '[^'\\]*(?:\\.[^'\\]*)*'
    | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) )
  }{ defined $2 and push @ccom, $2;
     defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex;

  $file{ccom} = \@ccom;
  $file{code} = $c;
  $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m;

  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}) {
        $file{uses_provided}{$func}++;
        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) {
            $file{needs}{$_} = 'static' if exists $need{$_};
          }
        }
      }
      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};
  my $warnings = 0;

  for $func (sort keys %{$file{uses_Perl}}) {
    if ($API{$func}{varargs}) {
      unless ($API{$func}{nothxarg}) {
        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_provided}}) {
    if ($file{uses}{$func}) {
      if (exists $file{uses_deps}{$func}) {
        diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));