dist/Devel-PPPort/parts/inc/ppphbin

   1 ################################################################################
   2 ##
   3 ##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
   4 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
   5 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
   6 ##
   7 ##  This program is free software; you can redistribute it and/or
   8 ##  modify it under the same terms as Perl itself.
   9 ##
  10 ################################################################################
  11
  12 =provides
  13
  14 =implementation
  15
  16 use strict;
  17
  18 BEGIN { require warnings if "$]" > '5.006' }
  19
  20 # Disable broken TRIE-optimization
  21 BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if "$]" >= "5.009004" && "$]" <= "5.009005"}
  22
  23 my $VERSION = __VERSION__;
  24
  25 my %opt = (
  26   quiet     => 0,
  27   diag      => 1,
  28   hints     => 1,
  29   changes   => 1,
  30   cplusplus => 0,
  31   filter    => 1,
  32   strip     => 0,
  33   version   => 0,
  34 );
  35
  36 my($ppport) = $0 =~ /([\w.]+)$/;
  37 my $LF = '(?:\r\n|[\r\n])';   # line feed
  38 my $HS = "[ \t]";             # horizontal whitespace
  39
  40 # Never use C comments in this file!
  41 my $ccs  = '/'.'*';
  42 my $cce  = '*'.'/';
  43 my $rccs = quotemeta $ccs;
  44 my $rcce = quotemeta $cce;
  45
  46 eval {
  47   require Getopt::Long;
  48   Getopt::Long::GetOptions(\%opt, qw(
  49     help quiet diag! filter! hints! changes! cplusplus strip version
  50     patch=s copy=s diff=s compat-version=s
  51     list-provided list-unsupported api-info=s
  52   )) or usage();
  53 };
  54
  55 if ($@ and grep /^-/, @ARGV) {
  56   usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
  57   die "Getopt::Long not found. Please don't use any options.\n";
  58 }
  59
  60 if ($opt{version}) {
  61   print "This is $0 $VERSION.\n";
  62   exit 0;
  63 }
  64
  65 usage() if $opt{help};
  66 strip() if $opt{strip};
  67
  68 $opt{'compat-version'} = __MIN_PERL__ unless exists $opt{'compat-version'};
  69 $opt{'compat-version'} = int_parse_version($opt{'compat-version'});
  70
  71 my $int_min_perl = int_parse_version(__MIN_PERL__);
  72
  73 # Each element of this hash looks something like:
  74 # 'Poison' => {
  75 #                         'base' => '5.008000',
  76 #                         'provided' => 1,
  77 #                         'todo' => '5.003007'
  78 #             },
  79 my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
  80                 ? ( $1 => {
  81                       ($2                  ? ( base     => $2 ) : ()),
  82                       ($3                  ? ( todo     => $3 ) : ()),
  83                       (index($4, 'v') >= 0 ? ( varargs  => 1  ) : ()),
  84                       (index($4, 'p') >= 0 ? ( provided => 1  ) : ()),
  85                       (index($4, 'n') >= 0 ? ( noTHXarg => 1  ) : ()),
  86                       (index($4, 'c') >= 0 ? ( core_only    => 1  ) : ()),
  87                       (index($4, 'd') >= 0 ? ( deprecated   => 1  ) : ()),
  88                       (index($4, 'i') >= 0 ? ( inaccessible => 1  ) : ()),
  89                       (index($4, 'x') >= 0 ? ( experimental => 1  ) : ()),
  90                       (index($4, 'u') >= 0 ? ( undocumented => 1  ) : ()),
  91                       (index($4, 'o') >= 0 ? ( ppport_fnc => 1  ) : ()),
  92                       (index($4, 'V') >= 0 ? ( unverified => 1  ) : ()),
  93                     } )
  94                 : die "invalid spec: $_" } qw(
  95 __ALL_ELEMENTS__
  96 );
  97
  98 if (exists $opt{'list-unsupported'}) {
  99   my $f;
 100   for $f (sort dictionary_order keys %API) {
 101     next if $API{$f}{core_only};
 102     next if $API{$f}{beyond_depr};
 103     next if $API{$f}{inaccessible};
 104     next if $API{$f}{experimental};
 105     next unless $API{$f}{todo};
 106     next if int_parse_version($API{$f}{todo}) <= $int_min_perl;
 107     my $repeat = 40 - length($f);
 108     $repeat = 0 if $repeat < 0;
 109     print "$f ", '.'x $repeat, " ", format_version($API{$f}{todo}), "\n";
 110   }
 111   exit 0;
 112 }
 113
 114 # Scan for hints, possible replacement candidates, etc.
 115
 116 my(%replace, %need, %hints, %warnings, %depends);
 117 my $replace = 0;
 118 my($hint, $define, $function);
 119
 120 sub find_api
 121 {
 122   BEGIN { 'warnings'->unimport('uninitialized') if "$]" > '5.006' }
 123   my $code = shift;
 124   $code =~ s{
 125     / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
 126   | "[^"\\]*(?:\\.[^"\\]*)*"
 127   | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx;
 128   grep { exists $API{$_} } $code =~ /(\w+)/mg;
 129 }
 130
 131 while (<DATA>) {
 132   if ($hint) {
 133
 134     # Here, we are in the middle of accumulating a hint or warning.
 135     my $end_of_hint = 0;
 136
 137     # A line containing a comment end marker closes the hint.  Remove that
 138     # marker for processing below.
 139     if (s/\s*$rcce(.*?)\s*$//) {
 140         die "Nothing can follow the end of comment in '$_'\n" if length $1 > 0;
 141         $end_of_hint = 1;
 142     }
 143
 144     # Set $h to the hash of which type.
 145     my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings;
 146
 147     # Ignore any leading and trailing white space, and an optional star comment
 148     # continuation marker, then place the meat of the line into $1
 149     m/^\s*(?:\*\s*)?(.*?)\s*$/;
 150
 151     # Add the meat of this line to the hash value of each API element it
 152     # applies to
 153     for (@{$hint->[1]}) {
 154       $h->{$_} ||= '';  # avoid the warning older perls generate
 155       $h->{$_} .= "$1\n";
 156     }
 157
 158     # If the line had a comment close, we are through with this hint
 159     undef $hint if $end_of_hint;
 160
 161     next;
 162   }
 163
 164   # Set up $hint if this is the beginning of a Hint: or Warning:
 165   # These are from a multi-line C comment in the file, with the first line
 166   # looking like (a space has been inserted because this file can't have C
 167   # comment markers in it):
 168   #   / * Warning: PL_expect, PL_copline, PL_rsfp
 169   #
 170   # $hint becomes
 171   #     [
 172   #      'Warning',
 173   #                [
 174   #                  'PL_expect',
 175   #                  'PL_copline',
 176   #                  'PL_rsfp',
 177   #                ],
 178   #     ]
 179   if (m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}) {
 180       $hint = [$1, [split /,?\s+/, $2]];
 181       next;
 182   }
 183
 184   if ($define) { # If in the middle of a definition...
 185
 186     # append a continuation line ending with backslash.
 187     if ($define->[1] =~ /\\$/) {
 188       $define->[1] .= $_;
 189     }
 190     else {  # Otherwise this line ends the definition, make foo depend on bar
 191             # (and what bar depends on) if its not one of ppp's own constructs
 192       if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) {
 193         my @n = find_api($define->[1]);
 194         push @{$depends{$define->[0]}}, @n if @n
 195       }
 196       undef $define;
 197     }
 198   }
 199
 200   # For '#define foo bar' or '#define foo(a,b,c) bar', $define becomes a
 201   # reference to [ foo, bar ]
 202   $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)};
 203
 204   if ($function) {
 205     if (/^}/) {
 206       if (exists $API{$function->[0]}) {
 207         my @n = find_api($function->[1]);
 208         push @{$depends{$function->[0]}}, @n if @n
 209       }
 210       undef $function;
 211     }
 212     else {
 213       $function->[1] .= $_;
 214     }
 215   }
 216
 217   $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)};
 218
 219   # Set $replace to the number given for lines that look like
 220   # / * Replace: \d+ * /
 221   # Thus setting it to 1 starts a region where replacements are automatically
 222   # done, and setting it to 0 ends that region.
 223   $replace     = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
 224
 225   # Add bar => foo to %replace  for lines like '#define foo bar in a region
 226   # where $replace is non-zero
 227   $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
 228
 229   # Add bar => foo to %replace for lines like '#define foo bar  / * Replace * /
 230   $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
 231
 232   # Add foo => bar to %replace for lines like / * Replace foo with bar * /
 233   $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+.*?)\s+$rcce\s*$};
 234
 235   # For lines like / * foo, bar depends on baz, bat * /
 236   # create a list of the elements on the rhs, and make that list apply to each
 237   # element in the lhs, which becomes a key in \%depends.
 238   if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
 239     my @deps = map { s/\s+//g; $_ } split /,/, $3;
 240     my $d;
 241     for $d (map { s/\s+//g; $_ } split /,/, $1) {
 242       push @{$depends{$d}}, @deps;
 243     }
 244   }
 245
 246   $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
 247 }
 248
 249 for (values %depends) {
 250   my %seen;
 251   $_ = [sort dictionary_order grep !$seen{$_}++, @$_];
 252 }
 253
 254 if (exists $opt{'api-info'}) {
 255   my $f;
 256   my $count = 0;
 257   my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
 258
 259   # Sort the names, and split into two classes; one for things that are part of
 260   # the API; a second for things that aren't.
 261   my @ok_to_use;
 262   my @shouldnt_use;
 263   for $f (sort dictionary_order keys %API) {
 264     next unless $f =~ /$match/;
 265     my $base = int_parse_version($API{$f}{base}) if $API{$f}{base};
 266     if ($base && ! $API{$f}{inaccessible} && ! $API{$f}{core_only}) {
 267         push @ok_to_use, $f;
 268     }
 269     else {
 270         push @shouldnt_use, $f;
 271     }
 272   }
 273
 274   # We normally suppress non-API items.  But if the search matched no API
 275   # items, output the non-ones.  This allows someone to get the info for an
 276   # item if they ask for it specifically enough, but doesn't normally clutter
 277   # the output with irrelevant results.
 278   @ok_to_use = @shouldnt_use unless @ok_to_use;
 279
 280   for $f (@ok_to_use) {
 281     print "\n=== $f ===\n";
 282     my $info = 0;
 283     my $base;
 284     $base = int_parse_version($API{$f}{base}) if $API{$f}{base};
 285     my $todo;
 286     $todo = int_parse_version($API{$f}{todo}) if $API{$f}{todo};
 287
 288     # Output information
 289     if ($base) {
 290         my $with_or= "";
 291         if (    $base <= $int_min_perl
 292             || (   (! $API{$f}{provided} && ! $todo)
 293                 || ($todo && $todo >= $base)))
 294         {
 295             $with_or= " with or";
 296         }
 297
 298         my $Supported = ($API{$f}{undocumented}) ? 'Available' : 'Supported';
 299         print "\n$Supported at least since perl-",
 300               format_version($base), ",$with_or without $ppport.";
 301         if ($API{$f}{unverified}) {
 302             print "\nThis information is based on inspection of the source code",
 303                   " and has not been\n",
 304                   "verified by successful compilation.";
 305         }
 306         print "\n";
 307         $info++;
 308      }
 309      if ($API{$f}{provided} || $todo) {
 310         print "\nThis is only supported by $ppport, and NOT by perl versions going forward.\n" unless $base;
 311         if ($todo) {
 312             if (! $base || $todo < $base) {
 313                 my $additionally = "";
 314                 $additionally .= " additionally" if $base;
 315                 print "$ppport$additionally provides support at least back to perl-",
 316                     format_version($todo),
 317                     ".\n";
 318             }
 319         }
 320         elsif (! $base || $base > $int_min_perl) {
 321             if (exists $depends{$f}) {
 322                 my $max = 0;
 323                 for (@{$depends{$f}}) {
 324                     $max = int_parse_version($API{$_}{todo}) if $API{$_}{todo} && $API{$_}{todo} > $max;
 325                     # XXX What to assume unspecified values are?  This effectively makes them MIN_PERL
 326                 }
 327                 $todo = $max if $max;
 328             }
 329             print "\n$ppport provides support for this, but ironically, does not",
 330                   " currently know,\n",
 331                   "for this report, the minimum version it supports for this";
 332             if ($API{$f}{undocumented}) {
 333                 print " and many things\n",
 334                       "it provides that are implemented as macros and aren't",
 335                       " documented.  You can\n",
 336                       "help by submitting a documentation patch";
 337             }
 338             print ".\n";
 339             if ($todo) {
 340                 if ($todo <= $int_min_perl) {
 341                     print "It may very well be supported all the way back to ",
 342                           format_version(__MIN_PERL__), ".\n";
 343                 }
 344                 else {
 345                     print "But given the things $f depends on, it's a good",
 346                           " guess that it isn't\n",
 347                           "supported prior to ", format_version($todo), ".\n";
 348                 }
 349             }
 350         }
 351     }
 352     if ($API{$f}{provided}) {
 353       print "Support needs to be explicitly requested by #define NEED_$f\n",
 354             "(or #define NEED_${f}_GLOBAL).\n"              if exists $need{$f};
 355       $info++;
 356     }
 357
 358     if ($base || ! $API{$f}{ppport_fnc}) {
 359       my $email = "Send email to perl5-porters\@perl.org if you need to have this functionality.\n";
 360       if ($API{$f}{inaccessible}) {
 361         print "\nThis is not part of the public API, and may not even be accessible to XS code.\n";
 362         $info++;
 363       }
 364       elsif ($API{$f}{core_only}) {
 365         print "\nThis is not part of the public API, and should not be used by XS code.\n";
 366         $info++;
 367       }
 368       elsif ($API{$f}{deprecated}) {
 369         print "\nThis is deprecated and should not be used.  Convert existing uses.\n";
 370         $info++;
 371       }
 372       elsif ($API{$f}{experimental}) {
 373         print "\nThe API for this is unstable and should not be used by XS code.\n", $email;
 374         $info++;
 375       }
 376       elsif ($API{$f}{undocumented}) {
 377         print "\nSince this is undocumented, the API should be considered unstable.\n";
 378         if ($API{$f}{provided}) {
 379             print "Consider bringing this up on the list: perl5-porters\@perl.org.\n";
 380         }
 381         else {
 382             print "It may be that this is not intended for XS use, or it may just be\n",
 383                   "that no one has gotten around to documenting it.\n", $email;
 384         }
 385         $info++;
 386       }
 387       unless ($info) {
 388         print "No portability information available.  Check your spelling; or",
 389               " this could be\na bug in Devel::PPPort.  To report an issue:\n",
 390               "https://github.com/Dual-Life/Devel-PPPort/issues/new\n";
 391       }
 392     }
 393
 394     print "\nDepends on: ", join(', ', @{$depends{$f}}), ".\n"
 395                                                          if exists $depends{$f};
 396     if (exists $hints{$f} || exists $warnings{$f}) {
 397       print "\n$hints{$f}" if exists $hints{$f};
 398       print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f};
 399       $info++;
 400     }
 401     $count++;
 402   }
 403
 404   $count or print "\nFound no API matching '$opt{'api-info'}'.";
 405   print "\n";
 406   exit 0;
 407 }
 408
 409 if (exists $opt{'list-provided'}) {
 410   my $f;
 411   for $f (sort dictionary_order keys %API) {
 412     next unless $API{$f}{provided};
 413     my @flags;
 414     push @flags, 'explicit' if exists $need{$f};
 415     push @flags, 'depend'   if exists $depends{$f};
 416     push @flags, 'hint'     if exists $hints{$f};
 417     push @flags, 'warning'  if exists $warnings{$f};
 418     my $flags = @flags ? '  ['.join(', ', @flags).']' : '';
 419     print "$f$flags\n";
 420   }
 421   exit 0;
 422 }
 423
 424 my @files;
 425 my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
 426 my $srcext = join '|', map { quotemeta $_ } @srcext;
 427
 428 if (@ARGV) {
 429   my %seen;
 430   for (@ARGV) {
 431     if (-e) {
 432       if (-f) {
 433         push @files, $_ unless $seen{$_}++;
 434       }
 435       else { warn "'$_' is not a file.\n" }
 436     }
 437     else {
 438       my @new = grep { -f } glob $_
 439           or warn "'$_' does not exist.\n";
 440       push @files, grep { !$seen{$_}++ } @new;
 441     }
 442   }
 443 }
 444 else {
 445   eval {
 446     require File::Find;
 447     File::Find::find(sub {
 448       $File::Find::name =~ /($srcext)$/i
 449           and push @files, $File::Find::name;
 450     }, '.');
 451   };
 452   if ($@) {
 453     @files = map { glob "*$_" } @srcext;
 454   }
 455 }
 456
 457 if (!@ARGV || $opt{filter}) {
 458   my(@in, @out);
 459   my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
 460   for (@files) {
 461     my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i;
 462     push @{ $out ? \@out : \@in }, $_;
 463   }
 464   if (@ARGV && @out) {
 465     warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
 466   }
 467   @files = @in;
 468 }
 469
 470 die "No input files given!\n" unless @files;
 471
 472 my(%files, %global, %revreplace);
 473 %revreplace = reverse %replace;
 474 my $filename;
 475 my $patch_opened = 0;
 476
 477 for $filename (@files) {
 478   unless (open IN, "<$filename") {
 479     warn "Unable to read from $filename: $!\n";
 480     next;
 481   }
 482
 483   info("Scanning $filename ...");
 484
 485   my $c = do { local $/; <IN> };
 486   close IN;
 487
 488   my %file = (orig => $c, changes => 0);
 489
 490   # Temporarily remove C/XS comments and strings from the code
 491   my @ccom;
 492
 493   $c =~ s{
 494     ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]*
 495     | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* )
 496   | ( ^$HS*\#[^\r\n]*
 497     | "[^"\\]*(?:\\.[^"\\]*)*"
 498     | '[^'\\]*(?:\\.[^'\\]*)*'
 499     | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) )
 500   }{ defined $2 and push @ccom, $2;
 501      defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex;
 502
 503   $file{ccom} = \@ccom;
 504   $file{code} = $c;
 505   $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m;
 506
 507   my $func;
 508
 509   for $func (keys %API) {
 510     my $match = $func;
 511     $match .= "|$revreplace{$func}" if exists $revreplace{$func};
 512     if ($c =~ /\b(?:Perl_)?($match)\b/) {
 513       $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
 514       $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
 515       if (exists $API{$func}{provided}) {
 516         $file{uses_provided}{$func}++;
 517         if ( ! exists $API{$func}{base}
 518             || int_parse_version($API{$func}{base}) > $opt{'compat-version'})
 519         {
 520           $file{uses}{$func}++;
 521           my @deps = rec_depend($func);
 522           if (@deps) {
 523             $file{uses_deps}{$func} = \@deps;
 524             for (@deps) {
 525               $file{uses}{$_} = 0 unless exists $file{uses}{$_};
 526             }
 527           }
 528           for ($func, @deps) {
 529             $file{needs}{$_} = 'static' if exists $need{$_};
 530           }
 531         }
 532       }
 533       if (   exists $API{$func}{todo}
 534           && int_parse_version($API{$func}{todo}) > $opt{'compat-version'})
 535       {
 536         if ($c =~ /\b$func\b/) {
 537           $file{uses_todo}{$func}++;
 538         }
 539       }
 540     }
 541   }
 542
 543   while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
 544     if (exists $need{$2}) {
 545       $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
 546     }
 547     else { warning("Possibly wrong #define $1 in $filename") }
 548   }
 549
 550   for (qw(uses needs uses_todo needed_global needed_static)) {
 551     for $func (keys %{$file{$_}}) {
 552       push @{$global{$_}{$func}}, $filename;
 553     }
 554   }
 555
 556   $files{$filename} = \%file;
 557 }
 558
 559 # Globally resolve NEED_'s
 560 my $need;
 561 for $need (keys %{$global{needs}}) {
 562   if (@{$global{needs}{$need}} > 1) {
 563     my @targets = @{$global{needs}{$need}};
 564     my @t = grep $files{$_}{needed_global}{$need}, @targets;
 565     @targets = @t if @t;
 566     @t = grep /\.xs$/i, @targets;
 567     @targets = @t if @t;
 568     my $target = shift @targets;
 569     $files{$target}{needs}{$need} = 'global';
 570     for (@{$global{needs}{$need}}) {
 571       $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
 572     }
 573   }
 574 }
 575
 576 for $filename (@files) {
 577   exists $files{$filename} or next;
 578
 579   info("=== Analyzing $filename ===");
 580
 581   my %file = %{$files{$filename}};
 582   my $func;
 583   my $c = $file{code};
 584   my $warnings = 0;
 585
 586   for $func (sort dictionary_order keys %{$file{uses_Perl}}) {
 587     if ($API{$func}{varargs}) {
 588       unless ($API{$func}{noTHXarg}) {
 589         my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
 590                               { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
 591         if ($changes) {
 592           warning("Doesn't pass interpreter argument aTHX to Perl_$func");
 593           $file{changes} += $changes;
 594         }
 595       }
 596     }
 597     else {
 598       warning("Uses Perl_$func instead of $func");
 599       $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
 600                                 {$func$1(}g);
 601     }
 602   }
 603
 604   for $func (sort dictionary_order keys %{$file{uses_replace}}) {
 605     warning("Uses $func instead of $replace{$func}");
 606     $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
 607   }
 608
 609   for $func (sort dictionary_order keys %{$file{uses_provided}}) {
 610     if ($file{uses}{$func}) {
 611       if (exists $file{uses_deps}{$func}) {
 612         diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
 613       }
 614       else {
 615         diag("Uses $func");
 616       }
 617     }
 618     $warnings += (hint($func) || 0);
 619   }
 620
 621   unless ($opt{quiet}) {
 622     for $func (sort dictionary_order keys %{$file{uses_todo}}) {
 623       next if int_parse_version($API{$func}{todo}) <= $int_min_perl;
 624       print "*** WARNING: Uses $func, which may not be portable below perl ",
 625             format_version($API{$func}{todo}), ", even with '$ppport'\n";
 626       $warnings++;
 627     }
 628   }
 629
 630   for $func (sort dictionary_order keys %{$file{needed_static}}) {
 631     my $message = '';
 632     if (not exists $file{uses}{$func}) {
 633       $message = "No need to define NEED_$func if $func is never used";
 634     }
 635     elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
 636       $message = "No need to define NEED_$func when already needed globally";
 637     }
 638     if ($message) {
 639       diag($message);
 640       $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
 641     }
 642   }
 643
 644   for $func (sort dictionary_order keys %{$file{needed_global}}) {
 645     my $message = '';
 646     if (not exists $global{uses}{$func}) {
 647       $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
 648     }
 649     elsif (exists $file{needs}{$func}) {
 650       if ($file{needs}{$func} eq 'extern') {
 651         $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
 652       }
 653       elsif ($file{needs}{$func} eq 'static') {
 654         $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
 655       }
 656     }
 657     if ($message) {
 658       diag($message);
 659       $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
 660     }
 661   }
 662
 663   $file{needs_inc_ppport} = keys %{$file{uses}};
 664
 665   if ($file{needs_inc_ppport}) {
 666     my $pp = '';
 667
 668     for $func (sort dictionary_order keys %{$file{needs}}) {
 669       my $type = $file{needs}{$func};
 670       next if $type eq 'extern';
 671       my $suffix = $type eq 'global' ? '_GLOBAL' : '';
 672       unless (exists $file{"needed_$type"}{$func}) {
 673         if ($type eq 'global') {
 674           diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
 675         }
 676         else {
 677           diag("File needs $func, adding static request");
 678         }
 679         $pp .= "#define NEED_$func$suffix\n";
 680       }
 681     }
 682
 683     if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
 684       $pp = '';
 685       $file{changes}++;
 686     }
 687
 688     unless ($file{has_inc_ppport}) {
 689       diag("Needs to include '$ppport'");
 690       $pp .= qq(#include "$ppport"\n)
 691     }
 692
 693     if ($pp) {
 694       $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
 695                      || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
 696                      || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
 697                      || ($c =~ s/^/$pp/);
 698     }
 699   }
 700   else {
 701     if ($file{has_inc_ppport}) {
 702       diag("No need to include '$ppport'");
 703       $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
 704     }
 705   }
 706
 707   # put back in our C comments
 708   my $ix;
 709   my $cppc = 0;
 710   my @ccom = @{$file{ccom}};
 711   for $ix (0 .. $#ccom) {
 712     if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
 713       $cppc++;
 714       $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
 715     }
 716     else {
 717       $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
 718     }
 719   }
 720
 721   if ($cppc) {
 722     my $s = $cppc != 1 ? 's' : '';
 723     warning("Uses $cppc C++ style comment$s, which is not portable");
 724   }
 725
 726   my $s = $warnings != 1 ? 's' : '';
 727   my $warn = $warnings ? " ($warnings warning$s)" : '';
 728   info("Analysis completed$warn");
 729
 730   if ($file{changes}) {
 731     if (exists $opt{copy}) {
 732       my $newfile = "$filename$opt{copy}";
 733       if (-e $newfile) {
 734         error("'$newfile' already exists, refusing to write copy of '$filename'");
 735       }
 736       else {
 737         local *F;
 738         if (open F, ">$newfile") {
 739           info("Writing copy of '$filename' with changes to '$newfile'");
 740           print F $c;
 741           close F;
 742         }
 743         else {
 744           error("Cannot open '$newfile' for writing: $!");
 745         }
 746       }
 747     }
 748     elsif (exists $opt{patch} || $opt{changes}) {
 749       if (exists $opt{patch}) {
 750         unless ($patch_opened) {
 751           if (open PATCH, ">$opt{patch}") {
 752             $patch_opened = 1;
 753           }
 754           else {
 755             error("Cannot open '$opt{patch}' for writing: $!");
 756             delete $opt{patch};
 757             $opt{changes} = 1;
 758             goto fallback;
 759           }
 760         }
 761         mydiff(\*PATCH, $filename, $c);
 762       }
 763       else {
 764 fallback:
 765         info("Suggested changes:");
 766         mydiff(\*STDOUT, $filename, $c);
 767       }
 768     }
 769     else {
 770       my $s = $file{changes} == 1 ? '' : 's';
 771       info("$file{changes} potentially required change$s detected");
 772     }
 773   }
 774   else {
 775     info("Looks good");
 776   }
 777 }
 778
 779 close PATCH if $patch_opened;
 780
 781 exit 0;
 782
 783 #######################################################################
 784
 785 sub try_use { eval "use @_;"; return $@ eq '' }
 786
 787 sub mydiff
 788 {
 789   local *F = shift;
 790   my($file, $str) = @_;
 791   my $diff;
 792
 793   if (exists $opt{diff}) {
 794     $diff = run_diff($opt{diff}, $file, $str);
 795   }
 796
 797   if (!defined $diff and try_use('Text::Diff')) {
 798     $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
 799     $diff = <<HEADER . $diff;
 800 --- $file
 801 +++ $file.patched
 802 HEADER
 803   }
 804
 805   if (!defined $diff) {
 806     $diff = run_diff('diff -u', $file, $str);
 807   }
 808
 809   if (!defined $diff) {
 810     $diff = run_diff('diff', $file, $str);
 811   }
 812
 813   if (!defined $diff) {
 814     error("Cannot generate a diff. Please install Text::Diff or use --copy.");
 815     return;
 816   }
 817
 818   print F $diff;
 819 }
 820
 821 sub run_diff
 822 {
 823   my($prog, $file, $str) = @_;
 824   my $tmp = 'dppptemp';
 825   my $suf = 'aaa';
 826   my $diff = '';
 827   local *F;
 828
 829   while (-e "$tmp.$suf") { $suf++ }
 830   $tmp = "$tmp.$suf";
 831
 832   if (open F, ">$tmp") {
 833     print F $str;
 834     close F;
 835
 836     if (open F, "$prog $file $tmp |") {
 837       while (<F>) {
 838         s/\Q$tmp\E/$file.patched/;
 839         $diff .= $_;
 840       }
 841       close F;
 842       unlink $tmp;
 843       return $diff;
 844     }
 845
 846     unlink $tmp;
 847   }
 848   else {
 849     error("Cannot open '$tmp' for writing: $!");
 850   }
 851
 852   return undef;
 853 }
 854
 855 sub rec_depend
 856 {
 857   my($func, $seen) = @_;
 858   return () unless exists $depends{$func};
 859   $seen = {%{$seen||{}}};
 860   return () if $seen->{$func}++;
 861   my %s;
 862   grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}};
 863 }
 864
 865 sub info
 866 {
 867   $opt{quiet} and return;
 868   print @_, "\n";
 869 }
 870
 871 sub diag
 872 {
 873   $opt{quiet} and return;
 874   $opt{diag} and print @_, "\n";
 875 }
 876
 877 sub warning
 878 {
 879   $opt{quiet} and return;
 880   print "*** ", @_, "\n";
 881 }
 882
 883 sub error
 884 {
 885   print "*** ERROR: ", @_, "\n";
 886 }
 887
 888 my %given_hints;
 889 my %given_warnings;
 890 sub hint
 891 {
 892   $opt{quiet} and return;
 893   my $func = shift;
 894   my $rv = 0;
 895   if (exists $warnings{$func} && !$given_warnings{$func}++) {
 896     my $warn = $warnings{$func};
 897     $warn =~ s!^!*** !mg;
 898     print "*** WARNING: $func\n", $warn;
 899     $rv++;
 900   }
 901   if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) {
 902     my $hint = $hints{$func};
 903     $hint =~ s/^/   /mg;
 904     print "   --- hint for $func ---\n", $hint;
 905   }
 906   $rv || 0;
 907 }
 908
 909 sub usage
 910 {
 911   my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
 912   my %M = ( 'I' => '*' );
 913   $usage =~ s/^\s*perl\s+\S+/$^X $0/;
 914   $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
 915
 916   print <<ENDUSAGE;
 917
 918 Usage: $usage
 919
 920 See perldoc $0 for details.
 921
 922 ENDUSAGE
 923
 924   exit 2;
 925 }
 926
 927 sub strip
 928 {
 929   my $self = do { local(@ARGV,$/)=($0); <> };
 930   my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
 931   $copy =~ s/^(?=\S+)/    /gms;
 932   $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
 933   $self =~ s/^SKIP.*(?=^__DATA__)/SKIP
 934 if (\@ARGV && \$ARGV[0] eq '--unstrip') {
 935   eval { require Devel::PPPort };
 936   \$@ and die "Cannot require Devel::PPPort, please install.\\n";
 937   if (eval \$Devel::PPPort::VERSION < $VERSION) {
 938     die "$0 was originally generated with Devel::PPPort $VERSION.\\n"
 939       . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n"
 940       . "Please install a newer version, or --unstrip will not work.\\n";
 941   }
 942   Devel::PPPort::WriteFile(\$0);
 943   exit 0;
 944 }
 945 print <<END;
 946
 947 Sorry, but this is a stripped version of \$0.
 948
 949 To be able to use its original script and doc functionality,
 950 please try to regenerate this file using:
 951
 952   \$^X \$0 --unstrip
 953
 954 END
 955 /ms;
 956   my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms;
 957   $c =~ s{
 958     / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
 959   | ( "[^"\\]*(?:\\.[^"\\]*)*"
 960     | '[^'\\]*(?:\\.[^'\\]*)*' )
 961   | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex;
 962   $c =~ s!\s+$!!mg;
 963   $c =~ s!^$LF!!mg;
 964   $c =~ s!^\s*#\s*!#!mg;
 965   $c =~ s!^\s+!!mg;
 966
 967   open OUT, ">$0" or die "cannot strip $0: $!\n";
 968   print OUT "$pl$c\n";
 969
 970   exit 0;
 971 }