ext/Devel/PPPort/parts/inc/ppphbin

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