mirror of
https://github.com/Perl/perl5.git
synced 2026-01-26 08:38:23 +00:00
ff906f87ce
When porting/makerel runs, all files copied into the directory for the tarball have the executable bit stripped and then only a specific set of files have the executable bit restored. There are many files in the repo that have the executable bit set in the repo that will be stripped. So that the state of files in the repo is as close as possible to the state of files in the release tarball, the executable bit has been stripped from such files. In one recent case, a file added from a dual-life module needed the executable bit set. Because it had the bit in the repo but was not listed in makerel to get an executable bit, tests using it passed in the repo and failed in the tarball. This commit refactors the list into a new file, Porting/exec-bit.txt and add tests to detect a mismatch between files listed there and actual executable bits in the repo.
134 lines
3.1 KiB
Perl
Executable File
134 lines
3.1 KiB
Perl
Executable File
#!/usr/bin/perl -ws
|
|
|
|
#
|
|
# findrfuncs: find reentrant variants of functions used in an executable.
|
|
#
|
|
# Requires a functional "nm -u". Searches headers in /usr/include
|
|
# to find available *_r functions and looks for non-reentrant
|
|
# variants used in the supplied executable.
|
|
#
|
|
# Requires debug info in the shared libraries/executables.
|
|
#
|
|
# Gurusamy Sarathy
|
|
# gsar@ActiveState.com
|
|
#
|
|
# Hacked to automatically find the executable and shared objects.
|
|
# --jhi
|
|
|
|
use strict;
|
|
use File::Find;
|
|
|
|
my @EXES;
|
|
my $NMU = 'nm -u';
|
|
my @INCDIRS = qw(/usr/include);
|
|
my $SO = 'so';
|
|
my $EXE = '';
|
|
|
|
if (open(CONFIG, "config.sh")) {
|
|
local $/;
|
|
my $CONFIG = <CONFIG>;
|
|
$SO = $1 if $CONFIG =~ /^so='(\w+)'/m;
|
|
$EXE = $1 if $CONFIG =~ /^_exe='\.(\w+)'/m;
|
|
close(CONFIG);
|
|
}
|
|
|
|
push @EXES, "perl$EXE";
|
|
|
|
find(sub {push @EXES, $File::Find::name if /\.$SO$/}, '.' );
|
|
|
|
push @EXES, @ARGV;
|
|
|
|
if ($^O eq 'dec_osf') {
|
|
$NMU = 'nm -Bu';
|
|
} elsif ($^O eq 'irix') {
|
|
$NMU = 'nm -pu';
|
|
}
|
|
|
|
my %rfuncs;
|
|
my @syms;
|
|
find(sub {
|
|
return unless -f $File::Find::name;
|
|
local *F;
|
|
open F, "<$File::Find::name"
|
|
or die "Can't open $File::Find::name: $!";
|
|
my $line;
|
|
while (defined ($line = <F>)) {
|
|
if ($line =~ /\b(\w+_r)\b/) {
|
|
#warn "$1 => $File::Find::name\n";
|
|
$rfuncs{$1}->{$File::Find::name}++;
|
|
}
|
|
}
|
|
close F;
|
|
}, @INCDIRS);
|
|
|
|
# delete bogus symbols grepped out of comments and such
|
|
delete $rfuncs{setlocale_r} if $^O eq 'linux';
|
|
|
|
# delete obsolete (as promised by man pages) symbols
|
|
my $netdb_r_obsolete;
|
|
if ($^O eq 'hpux') {
|
|
delete $rfuncs{crypt_r};
|
|
delete $rfuncs{drand48_r};
|
|
delete $rfuncs{endgrent_r};
|
|
delete $rfuncs{endpwent_r};
|
|
delete $rfuncs{getgrent_r};
|
|
delete $rfuncs{getpwent_r};
|
|
delete $rfuncs{setlocale_r};
|
|
delete $rfuncs{srand48_r};
|
|
delete $rfuncs{strerror_r};
|
|
$netdb_r_obsolete = 1;
|
|
} elsif ($^O eq 'dec_osf') {
|
|
delete $rfuncs{crypt_r};
|
|
delete $rfuncs{strerror_r};
|
|
$netdb_r_obsolete = 1;
|
|
}
|
|
if ($netdb_r_obsolete) {
|
|
delete @rfuncs{qw(endhostent_r
|
|
endnetent_r
|
|
endprotoent_r
|
|
endservent_r
|
|
gethostbyaddr_r
|
|
gethostbyname_r
|
|
gethostent_r
|
|
getnetbyaddr_r
|
|
getnetbyname_r
|
|
getnetent_r
|
|
getprotobyname_r
|
|
getprotobynumber_r
|
|
getprotoent_r
|
|
getservbyname_r
|
|
getservbyport_r
|
|
getservent_r
|
|
sethostent_r
|
|
setnetent_r
|
|
setprotoent_r
|
|
setservent_r)};
|
|
}
|
|
|
|
my %syms;
|
|
|
|
for my $exe (@EXES) {
|
|
# warn "#--- $exe\n";
|
|
for my $sym (`$NMU $exe 2>/dev/null`) {
|
|
chomp $sym;
|
|
$sym =~ s/^\s+//;
|
|
$sym =~ s/^([0-9A-Fa-f]+\s+)?[Uu]\s+//;
|
|
$sym =~ s/\s+[Uu]\s+-$//;
|
|
next if $sym =~ /\s/;
|
|
$sym =~ s/\@.*\z//; # remove @@GLIBC_2.0 etc
|
|
# warn "#### $sym\n";
|
|
if (exists $rfuncs{"${sym}_r"} && ! $syms{"$sym:$exe"}++) {
|
|
push @syms, $sym;
|
|
}
|
|
}
|
|
|
|
if (@syms) {
|
|
print "\nFollowing symbols in $exe have reentrant versions:\n";
|
|
for my $sym (@syms) {
|
|
my @f = sort keys %{$rfuncs{$sym . '_r'}};
|
|
print "$sym => $sym" . "_r (@f)\n";
|
|
}
|
|
}
|
|
@syms = ();
|
|
}
|