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