ext/Devel/PPPort/parts/inc/ppphbin

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