| 1 | #!/usr/bin/perl -ws |
| 2 | |
| 3 | # |
| 4 | # findrfuncs: find reentrant variants of functions used in an executable. |
| 5 | # |
| 6 | # Requires a functional "nm -u". Searches headers in /usr/include |
| 7 | # to find available *_r functions and looks for non-reentrant |
| 8 | # variants used in the supplied executable. |
| 9 | # |
| 10 | # Requires debug info in the shared libraries/executables. |
| 11 | # |
| 12 | # Gurusamy Sarathy |
| 13 | # gsar@ActiveState.com |
| 14 | # |
| 15 | # Hacked to automatically find the executable and shared objects. |
| 16 | # --jhi |
| 17 | |
| 18 | use strict; |
| 19 | use File::Find; |
| 20 | |
| 21 | my @EXES; |
| 22 | my $NMU = 'nm -u'; |
| 23 | my @INCDIRS = qw(/usr/include); |
| 24 | my $SO = 'so'; |
| 25 | my $EXE = ''; |
| 26 | |
| 27 | if (open(CONFIG, "config.sh")) { |
| 28 | local $/; |
| 29 | my $CONFIG = <CONFIG>; |
| 30 | $SO = $1 if $CONFIG =~ /^so='(\w+)'/m; |
| 31 | $EXE = $1 if $CONFIG =~ /^_exe='\.(\w+)'/m; |
| 32 | close(CONFIG); |
| 33 | } |
| 34 | |
| 35 | push @EXES, "perl$EXE"; |
| 36 | |
| 37 | find(sub {push @EXES, $File::Find::name if /\.$SO$/}, '.' ); |
| 38 | |
| 39 | push @EXES, @ARGV; |
| 40 | |
| 41 | if ($^O eq 'dec_osf') { |
| 42 | $NMU = 'nm -Bu'; |
| 43 | } elsif ($^O eq 'irix') { |
| 44 | $NMU = 'nm -pu'; |
| 45 | } |
| 46 | |
| 47 | my %rfuncs; |
| 48 | my @syms; |
| 49 | find(sub { |
| 50 | return unless -f $File::Find::name; |
| 51 | local *F; |
| 52 | open F, "<$File::Find::name" |
| 53 | or die "Can't open $File::Find::name: $!"; |
| 54 | my $line; |
| 55 | while (defined ($line = <F>)) { |
| 56 | if ($line =~ /\b(\w+_r)\b/) { |
| 57 | #warn "$1 => $File::Find::name\n"; |
| 58 | $rfuncs{$1}->{$File::Find::name}++; |
| 59 | } |
| 60 | } |
| 61 | close F; |
| 62 | }, @INCDIRS); |
| 63 | |
| 64 | # delete bogus symbols grepped out of comments and such |
| 65 | delete $rfuncs{setlocale_r} if $^O eq 'linux'; |
| 66 | |
| 67 | # delete obsolete (as promised by man pages) symbols |
| 68 | my $netdb_r_obsolete; |
| 69 | if ($^O eq 'hpux') { |
| 70 | delete $rfuncs{crypt_r}; |
| 71 | delete $rfuncs{drand48_r}; |
| 72 | delete $rfuncs{endgrent_r}; |
| 73 | delete $rfuncs{endpwent_r}; |
| 74 | delete $rfuncs{getgrent_r}; |
| 75 | delete $rfuncs{getpwent_r}; |
| 76 | delete $rfuncs{setlocale_r}; |
| 77 | delete $rfuncs{srand48_r}; |
| 78 | delete $rfuncs{strerror_r}; |
| 79 | $netdb_r_obsolete = 1; |
| 80 | } elsif ($^O eq 'dec_osf') { |
| 81 | delete $rfuncs{crypt_r}; |
| 82 | delete $rfuncs{strerror_r}; |
| 83 | $netdb_r_obsolete = 1; |
| 84 | } |
| 85 | if ($netdb_r_obsolete) { |
| 86 | delete @rfuncs{qw(endhostent_r |
| 87 | endnetent_r |
| 88 | endprotoent_r |
| 89 | endservent_r |
| 90 | gethostbyaddr_r |
| 91 | gethostbyname_r |
| 92 | gethostent_r |
| 93 | getnetbyaddr_r |
| 94 | getnetbyname_r |
| 95 | getnetent_r |
| 96 | getprotobyname_r |
| 97 | getprotobynumber_r |
| 98 | getprotoent_r |
| 99 | getservbyname_r |
| 100 | getservbyport_r |
| 101 | getservent_r |
| 102 | sethostent_r |
| 103 | setnetent_r |
| 104 | setprotoent_r |
| 105 | setservent_r)}; |
| 106 | } |
| 107 | |
| 108 | my %syms; |
| 109 | |
| 110 | for my $exe (@EXES) { |
| 111 | # warn "#--- $exe\n"; |
| 112 | for my $sym (`$NMU $exe 2>/dev/null`) { |
| 113 | chomp $sym; |
| 114 | $sym =~ s/^\s+//; |
| 115 | $sym =~ s/^([0-9A-Fa-f]+\s+)?[Uu]\s+//; |
| 116 | $sym =~ s/\s+[Uu]\s+-$//; |
| 117 | next if $sym =~ /\s/; |
| 118 | $sym =~ s/\@.*\z//; # remove @@GLIBC_2.0 etc |
| 119 | # warn "#### $sym\n"; |
| 120 | if (exists $rfuncs{"${sym}_r"} && ! $syms{"$sym:$exe"}++) { |
| 121 | push @syms, $sym; |
| 122 | } |
| 123 | } |
| 124 | |
| 125 | if (@syms) { |
| 126 | print "\nFollowing symbols in $exe have reentrant versions:\n"; |
| 127 | for my $sym (@syms) { |
| 128 | my @f = sort keys %{$rfuncs{$sym . '_r'}}; |
| 129 | print "$sym => $sym" . "_r (@f)\n"; |
| 130 | } |
| 131 | } |
| 132 | @syms = (); |
| 133 | } |