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
16use strict;
17
18BEGIN { require warnings if "$]" > '5.006' }
19
20# Disable broken TRIE-optimization
21BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if "$]" >= "5.009004" && "$]" <= "5.009005"}
22
23my $VERSION = __VERSION__;
24
25my %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
36my($ppport) = $0 =~ /([\w.]+)$/;
37my $LF = '(?:\r\n|[\r\n])';   # line feed
38my $HS = "[ \t]";             # horizontal whitespace
39
40# Never use C comments in this file!
41my $ccs  = '/'.'*';
42my $cce  = '*'.'/';
43my $rccs = quotemeta $ccs;
44my $rcce = quotemeta $cce;
45
46eval {
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
55if ($@ and grep /^-/, @ARGV) {
56  usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
57  die "Getopt::Long not found. Please don't use any options.\n";
58}
59
60if ($opt{version}) {
61  print "This is $0 $VERSION.\n";
62  exit 0;
63}
64
65usage() if $opt{help};
66strip() 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
71my $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#             },
79my %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
98if (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
116my(%replace, %need, %hints, %warnings, %depends);
117my $replace = 0;
118my($hint, $define, $function);
119
120sub 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
131while (<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
249for (values %depends) {
250  my %seen;
251  $_ = [sort dictionary_order grep !$seen{$_}++, @$_];
252}
253
254if (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
409if (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
424my @files;
425my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
426my $srcext = join '|', map { quotemeta $_ } @srcext;
427
428if (@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}
444else {
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
457if (!@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
470die "No input files given!\n" unless @files;
471
472my(%files, %global, %revreplace);
473%revreplace = reverse %replace;
474my $filename;
475my $patch_opened = 0;
476
477for $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
560my $need;
561for $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
576for $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 {
764fallback:
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
779close PATCH if $patch_opened;
780
781exit 0;
782
783#######################################################################
784
785sub try_use { eval "use @_;"; return $@ eq '' }
786
787sub 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
802HEADER
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
821sub 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
855sub 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
865sub info
866{
867  $opt{quiet} and return;
868  print @_, "\n";
869}
870
871sub diag
872{
873  $opt{quiet} and return;
874  $opt{diag} and print @_, "\n";
875}
876
877sub warning
878{
879  $opt{quiet} and return;
880  print "*** ", @_, "\n";
881}
882
883sub error
884{
885  print "*** ERROR: ", @_, "\n";
886}
887
888my %given_hints;
889my %given_warnings;
890sub 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
909sub 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
918Usage: $usage
919
920See perldoc $0 for details.
921
922ENDUSAGE
923
924  exit 2;
925}
926
927sub 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
934if (\@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}
945print <<END;
946
947Sorry, but this is a stripped version of \$0.
948
949To be able to use its original script and doc functionality,
950please try to regenerate this file using:
951
952  \$^X \$0 --unstrip
953
954END
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}
972