use strict qw(refs vars subs);

# 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 $function;
  }
  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*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
  my @deps = map { s/\s+//g; $_ } split /,/, $3;
  my $d;
  for $d (map { s/\s+//g; $_ } split /,/, $1) {
    push @{$depends{$d}}, @deps;
  }
}

$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) } @files; #warn "\@files=",@files,"\%xsc=",join ",",keys %xsc; for (@files) { if (/^(.*)\.xs$/) { $xsc{"$1.cc"} = 1; } 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}}));
    }
    else {
      diag("Uses $func");
    }
  }
  $warnings += hint($func);
}

unless ($opt{quiet}) {
  for $func (sort keys %{$file{uses_todo}}) {
    print "*** WARNING: Uses $func, which may not be portable below perl ",
          format_version($API{$func}{todo}), ", even with '$ppport'\n";
    $warnings++;
  }
}

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

my $s = $warnings != 1 ? 's' : '';
my $warn = $warnings ? " ($warnings warning$s)" : '';
info("Analysis completed$warn");

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 try_use { eval "use @_;"; return $@ eq '' }

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 try_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 rec_depend { my($func, $seen) = @_; return () unless exists $depends{$func}; $seen = {%{$seen||{}}}; return () if $seen->{$func}++; my %s; grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$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; my %given_warnings; sub hint { $opt{quiet} and return; my $func = shift; my $rv = 0; if (exists $warnings{$func} && !$given_warnings{$func}++) { my $warn = $warnings{$func}; $warn =~ s!^!*** !mg; print "*** WARNING: $func\n", $warn; $rv++; } if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } $rv; }

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 (eval \$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; my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms; $c =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | ( "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' ) | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex; $c =~ s!\s+$!!mg; $c =~ s!^$LF!!mg; $c =~ s!^\s*#\s*!#!mg; $c =~ s!^\s+!!mg;

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

exit 0;
}

cpanm Devel::PPPort

perl -MCPAN -e shell
install Devel::PPPort