#!/usr/perl5/bin/perl -w
#
# CDDL HEADER START
#
# The contents of this file are subject to the terms of the
# Common Development and Distribution License, Version 1.0 only
# (the "License"). You may not use this file except in compliance
# with the License.
#
# You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
# or http://www.opensolaris.org/os/licensing.
# See the License for the specific language governing permissions
# and limitations under the License.
#
# When distributing Covered Code, include this CDDL HEADER in each
# file and include the License file at usr/src/OPENSOLARIS.LICENSE.
# If applicable, add the following below this CDDL HEADER, with the
# fields enclosed by brackets "[]" replaced with your own identifying
# information: Portions Copyright [yyyy] [name of copyright owner]
#
# CDDL HEADER END
#
#
# ident "%Z%%M% %I% %E% SMI"
#
# Copyright 2004 Sun Microsystems, Inc. All rights reserved.
# Use is subject to license terms.
#
#
# This utility program creates the profiles of the binaries to be
# checked.
#
# The dynamic profiling is done by running ldd -r on the binary with
# LD_DEBUG=files,bindings and parsing the linker debug output.
#
# The static profiling (gathering of .text symbols) is done by calling
# the utility program static_prof.
#
require 5.005;
use strict;
use locale;
use POSIX qw(locale_h);
use Sun::Solaris::Utils qw(textdomain gettext);
use File::Basename;
use File::Path;
use lib qw(/usr/lib/abi/appcert);
use AppcertUtil;
setlocale(LC_ALL, "");
textdomain(TEXT_DOMAIN);
use vars qw(
$tmp_prof_dir
);
set_clean_up_exit_routine(\&clean_up_exit);
import_vars_from_environment();
signals('on', \&interrupted);
set_working_dir();
profile_objects();
clean_up();
exit 0;
#
# working_dir has been imported by import_vars_from_environment() from
# appcert. A sanity check is performed here to make sure it exists.
#
sub set_working_dir
{
if (! defined($working_dir) || ! -d $working_dir) {
exiter("$command_name: " . sprintf(gettext(
"cannot locate working directory: %s\n"), $working_dir));
}
}
#
# Routine called when interrupted by user (e.g. SIGINT).
#
sub interrupted
{
$SIG{$_[0]} = 'DEFAULT';
signals('off');
clean_up_exit(1);
}
#
# Does the cleanup then exits with return code $rc. Note: The utility
# routine exiter() calls this routine.
#
sub clean_up_exit
{
my ($rc) = @_;
$rc = 0 unless ($rc);
clean_up();
exit $rc;
}
#
# General cleanup activities.
#
sub clean_up
{
if (defined($tmp_prof_dir) && -d $tmp_prof_dir) {
rmtree($tmp_prof_dir);
}
}
#
# Top level routine to loop over the objects and call the profiling
# routines on each.
#
sub profile_objects
{
# Make a tmp directory for the profiling work.
$tmp_prof_dir = create_tmp_dir($tmp_dir);
if (! -d $tmp_prof_dir) {
exiter(nocreatedir($tmp_prof_dir, $!));
}
my ($dir, $path_to_object);
#
# Loop over each object item in the working_dir.
# - $dir will be each one of these object directories.
# - $path_to_object will be the corresponding actual path
# to the the binary to be profiled.
# Output will usually be placed down in $dir, e.g. "$dir/profile.static"
#
my $cnt = -1;
my $last_i;
while (defined($dir = next_dir_name())) {
$cnt++;
if ($block_max ne '') {
next if ($cnt < $block_min || $cnt >= $block_max);
}
$last_i = $cnt;
# Map object output directory to actual path of the object:
$path_to_object = dir_name_to_path($dir);
if (! -f $path_to_object) {
exiter(nopathexist($path_to_object, $!));
}
# Profile it:
emsg(gettext("profiling: %s\n"), $path_to_object);
static_profile($path_to_object, $dir);
dynamic_profile($path_to_object, $dir);
}
# Only try this after everything has been initially profiled.
if (! $block_max || $last_i >= $binary_count - 1) {
redo_unbound_profile();
}
clean_up(); # Remove any tmp dirs and files.
}
#
# Runs utility program static_prof on the object and places results in
# output directory.
#
sub static_profile($$)
{
my ($object, $output_dir) = @_;
# This is the location of static_prof's output file:
my $outfile = "$output_dir/profile.static";
# It is consumed by static_check_object() in symcheck.
#
# Do not run on *completely* statically linked objects. This
# case will be caught and noted in the dynamic profiling and
# checking.
#
my $skip_it;
if (is_statically_linked($object)) {
$skip_it = "STATICALLY_LINKED";
} elsif (! is_elf($object)) {
$skip_it = "NON_ELF";
}
my $static_prof_fh = do { local *FH; *FH };
if (defined($skip_it)) {
open($static_prof_fh, ">$outfile") ||
exiter(nofile($outfile, $!));
print $static_prof_fh "#SKIPPED_TEST: $skip_it\n";
close($static_prof_fh);
return;
}
#
# system() when run in the following manner will prevent the
# shell from expanding any strange characters in $object. Quotes
# around '$object' would be almost as safe. since excluded
# earlier the cases where it contains the ' character.
#
system("$appcert_lib_dir/static_prof", '-p', '-s', '-o', $outfile,
$object);
if ($? != 0) {
open($static_prof_fh, ">$outfile") ||
exiter(nofile($outfile, $!));
#
# For completeness, we'll use elfdump to record the
# static profile for 64 bit binaries, although the
# static linking problems only occur for 32-bit
# applications.
#
my ($prof, $sym);
$prof = '';
my $elfdump_fh = do { local *FH; *FH };
if (open($elfdump_fh, "$cmd_elfdump -s -N .dynsym '$object' " .
" 2>/dev/null |")) {
while (<$elfdump_fh>) {
chomp;
if (/\s\.text\s+(\S+)$/) {
$sym = $1;
if (! /\bFUNC\b/) {
next;
}
if (/\bGLOB\b/) {
$prof .= "$object|TEXT|GLOB|" .
"FUNC|$sym\n";
} else {
$prof .= "$object|TEXT|WEAK|" .
"FUNC|$sym\n";
}
}
}
close($elfdump_fh);
}
if ($prof ne '') {
my $line;
print $static_prof_fh "#generated by symprof/elfdump\n";
print $static_prof_fh "#dtneeded:";
foreach $line (split(/\n/, cmd_output_dump($object))) {
if ($line =~ /\bNEEDED\s+(\S+)/) {
print $static_prof_fh " $1";
}
}
print $static_prof_fh "\n";
print $static_prof_fh $prof;
} else {
print $static_prof_fh "#SKIPPED_TEST: " .
"PROFILER_PROGRAM_static_prof_RETURNED:$?\n";
}
close($static_prof_fh);
return;
}
# Also store the dtneededs from the static profile output.
my $dtneeded = "$output_dir/info.dtneeded";
my $dtneeded_fh = do { local *FH; *FH };
open($dtneeded_fh, ">$dtneeded") ||
exiter(nofile($dtneeded, $!));
open($static_prof_fh, "<$outfile") ||
exiter(nofile($outfile, $!));
my $lib;
while (<$static_prof_fh>) {
next unless (/^\s*#/);
if (/^\s*#\s*dtneeded:\s*(\S.*)$/) {
foreach $lib (split(/\s+/, $1)) {
next if ($lib eq '');
print $dtneeded_fh "$lib\n";
}
last;
}
}
close($dtneeded_fh);
close($static_prof_fh);
}
#
# Top level subroutine for doing a dynamic profile of an object. It
# calls get_dynamic_profile() which handles the details of the actual
# profiling and returns the newline separated "preprocessed format" to
# this subroutine.
#
# The records are then processed and placed in the output directory.
#
sub dynamic_profile
{
my ($object, $output_dir) = @_;
my ($profile, $line, $tmp);
# This is the profile output file.
my $outfile = "$output_dir/profile.dynamic";
$profile = get_dynamic_profile($object);
if ($profile =~ /^ERROR:\s*(.*)$/) {
# There was some problem obtaining the dynamic profile
my $msg = $1;
my $errfile = "$output_dir/profile.dynamic.errors";
my $profile_error_fh = do { local *FH; *FH };
open($profile_error_fh, ">>$errfile") ||
exiter(nofile($errfile, $!));
$msg =~ s/\n/ /g;
$msg =~ s/;/,/g;
print $profile_error_fh $msg, "\n";
close($profile_error_fh);
# Write a comment to the profile file as well:
my $profile_fh = do { local *FH; *FH };
open($profile_fh, ">$outfile") ||
exiter(nofile($outfile, $!));
print $profile_fh "#NO_BINDINGS_FOUND $msg\n";
close($profile_fh);
return;
}
my ($filter, $filtee, $from, $to, $sym);
my ($type, $saw_bindings, $all_needed);
my (%filter_map, %symlink_map);
# Resolve the symlink of the object, if any.
$symlink_map{$object} = follow_symlink($object);
#
# Collect the filter or static linking info first. Since the
# filter info may be used to alias libraries, it is safest to do
# it before any bindings processing. that is why we iterate
# through $profile twice.
#
my @dynamic_profile_array = split(/\n/, $profile);
foreach $line (@dynamic_profile_array) {
if ($line =~ /^FILTER_AUX:(.*)$/) {
#
# Here is the basic example of an auxiliary filter:
#
# FILTER: /usr/lib/libc.so.1
# FILTEE: /usr/platform/sun4u/lib/libc_psr.so.1
#
# The app links against symbol memcpy() in
# libc.so.1 at build time. Now, at run time IF
# memcpy() is provided by libc_psr.so.1 then
# that "code" is used, otherwise it backs off to
# use the memcpy()in libc.so.1. The
# libc_psr.so.1 doesn't even have to exist.
#
# The dynamic linker happily informs us that it
# has found (and will bind to) memcpy() in
# /usr/platform/sun4u/lib/libc_psr.so.1. We
# want to alias libc_psr.so.1 => libc.so.1.
# Why?
# - less models to maintain. Note the symlink
# situation in /usr/platform.
# - libc_psr.so.1 is versioned, but we would be
# incorrect since it has memcpy() as SUNWprivate
#
# Therefore we record this aliasing in the hash
# %filter_map. This will be used below to
# replace occurrences of the FILTEE string by
# the FILTER string. Never the other way round.
#
($filter, $filtee) = split(/\|/, $1, 2);
$filter_map{$filtee} = $filter;
# Map the basenames too:
$filter = basename($filter);
$filtee = basename($filtee);
$filter_map{$filtee} = $filter;
} elsif ($line =~ /^FILTER_STD:(.*)$/) {
#
# Here is the basic example(s) of a standard filter:
#
# FILTER: /usr/lib/libsys.so.1
# FILTEE: /usr/lib/libc.so.1
#
# Here is another:
#
# FILTER: /usr/lib/libw.so.1
# FILTEE: /usr/lib/libc.so.1
#
# Here is a more perverse one, libxnet.so.1 has 3
# filtees:
#
# FILTER: /usr/lib/libxnet.so.1
# FILTEE: /usr/lib/{libsocket.so.1,libnsl.so.1,libc.so.1}
#
# The important point to note about standard
# filters is that they contain NO CODE AT ALL.
# All of the symbols in the filter MUST be found
# in (and bound to) the filtee(s) or there is a
# relocation error.
#
# The app links against symbol getwc() in
# libw.so.1 at build time. Now, at run time
# getwc() is actually provided by libc.so.1.
#
# The dynamic linker happily informs us that it
# has found (and will bind to) getwc() in
# libc.so.1. IT NEVER DIRECTLY TELLS US getwc was
# actually referred to in libw.so.1
#
# So, unless we open a model file while
# PROFILING, we cannot figure out which ones
# come from libw.so.1 and which ones come from
# libc.so.1. In one sense this is too bad: the
# libw.so.1 structure is lost.
#
# The bottom line is we should not alias
# libc.so.1 => libw.so.1 (FILTEE => FILTER) as
# we did above with FILTER_AUX. That would be a
# disaster. (would say EVERYTHING in libc came
# from libw!)
#
# So we DO NOT store the alias in this case, this
# leads to:
# - more models to maintain.
#
# Thus we basically skip this info.
# EXCEPT for one case, libdl.so.1, see below.
#
($filter, $filtee) = split(/\|/, $1, 2);
#
# The dlopen(), ... family of functions in
# libdl.so.1 is implemented as a filter for
# ld.so.1. We DO NOT want to consider a symbol
# model for ld.so.1. So in this case alone we
# want to alias ld.so.1 => libdl.so.1
#
#
# We only need to substitute the standard filter
# libdl.so.n. Record the alias in that case.
#
if ($filter =~ /\blibdl\.so\.\d+/) {
$filter_map{$filtee} = $filter;
# Map basenames too:
$filter = basename($filter);
$filtee = basename($filtee);
$filter_map{$filtee} = $filter;
}
} elsif ($line =~ /^DYNAMIC_PROFILE_SKIPPED_NOT_ELF/ ||
$line =~ /^STATICALLY_LINKED:/) {
#
# This info will go as a COMMENT into the
# output. n.b.: there is no checking whether
# this piece of info is consistent with the rest
# of the profile output.
#
# The $message string will come right after the
# header, and before the bindings (if any). See
# below where we write to the PROF filehandle.
#
my $profile_msg_fh = do { local *FH; *FH };
open($profile_msg_fh, ">>$outfile") ||
exiter(nofile($outfile, $!));
print $profile_msg_fh "#$line\n";
close($profile_msg_fh);
} elsif ($line =~ /^NEEDED_FOUND:(.*)$/) {
#
# These libraries are basically information
# contained in the ldd "libfoo.so.1 =>
# /usr/lib/libfoo.so.1" output lines. It is the
# closure of the neededs (not just the directly
# needed ones).
#
$all_needed .= $1 . "\n";
}
}
#
# Now collect the bindings info:
#
# Each BINDING record refers to 1 symbol. After manipulation
# here it will go into 1 record into the profile output.
#
# What sort of manipulations? Looking below reveals:
#
# - we apply the library FILTER_AUX aliases in %filter_map
# - for shared objects we resolve symbolic links to the actual
# files they point to.
# - we may be in a mode where we do not store full paths of
# the shared objects, e.g. /usr/lib/libc.so.1, but rather
# just their basename "libc.so.1"
#
# There are exactly four(4) types of bindings that will be
# returned to us by get_dynamic_profile(). See
# get_dynamic_profile() and Get_ldd_Profile() for more details.
#
# Here are the 4 types:
#
# BINDING_DIRECT:from|to|sym
# The object being profiled is the "from" here!
# It directly calls "sym" in library "to".
#
# BINDING_INDIRECT:from|to|sym
# The object being profiled is NOT the "from" here.
# "from" is a shared object, and "from" calls "sym" in
# library "to".
#
# BINDING_REVERSE:from|to|sym
# The shared object "from" makes a reverse binding
# all the way back to the object being profiled! We call
# this *REVERSE*. "to" is the object being profiled.
#
# BINDING_UNBOUND:from|sym
# object "from" wants to call "sym", but "sym" was
# not found! We didn't find the "to", and so no
# "to" is passed to us.
#
my $put_DIRECT_in_the_UNBOUND_record;
$saw_bindings = 0;
#
# Start the sorting pipeline that appends to the output file.
# It will be written to in the following loop.
#
# Tracing back $outfile to $outdir to $working_dir, one sees $outfile
# should have no single-quote characters. We double check it does not
# before running the command.
#
if ($outfile =~ /'/) {
exiter(norunprog("|$cmd_sort -t'|' +1 | $cmd_uniq >> '$outfile'"));
}
my $prof_fh = do { local *FH; *FH };
open($prof_fh, "|$cmd_sort -t'|' +1 | $cmd_uniq >> '$outfile'") ||
exiter(norunprog("|$cmd_sort -t'|' +1 | $cmd_uniq >> '$outfile'",
$!));
local($SIG{'PIPE'}) = sub {
exiter(norunprog(
"|$cmd_sort -t'|' +1 | $cmd_uniq >> '$outfile'", $!));
};
foreach $line (@dynamic_profile_array) {
if ($line =~ /^BINDING_([^:]+):(.*)$/) {
$type = $1;
if ($type eq 'UNBOUND') {
#
# If the symbol was unbound, there is no
# "to" library. We make an empty "to"
# value so as to avoid special casing
# "to" all through the code that
# follows. It is easy to verify no
# matter what happens with the $to
# variable, it will NOT be printed to the
# profile output file in the UNBOUND
# case.
#
($from, $sym) = split(/\|/, $2, 2);
$to = '';
} else {
# Otherwise, we have the full triple:
($from, $to, $sym) = split(/\|/, $2, 3);
}
#
# We record here information to be used in
# writing out UNBOUND records, namely if the
# "from" happened to also be the object being
# profiled. In that case The string "*DIRECT*"
# will be placed in the "*UNBOUND*" record,
# otherwise the "from" will stand as is in the
# "*UNBOUND*" record. We do this check here
# before the filter_map is applied. The chances
# of it making a difference is small, but we had
# best to do it here.
#
if (files_equal($from, $object)) {
#
# Switch to indicate placing *DIRECT* in
# the *UNBOUND* line, etc.
#
$put_DIRECT_in_the_UNBOUND_record = 1;
} else {
$put_DIRECT_in_the_UNBOUND_record = 0;
}
#
# See if there is a filter name that "aliases"
# either of the "from" or "to" libraries, if so
# then rename it.
#
if ($to ne '' && $filter_map{$to}) {
$to = $filter_map{$to};
}
if ($type ne 'DIRECT' && $filter_map{$from}) {
$from = $filter_map{$from};
}
#
# Record symlink information.
#
# Note that follow_symlink returns the file
# name itself when the file is not a symlink.
#
# Work out if either "from" or "to" are
# symlinks. For efficiency we keep them in the
# %symlink_map hash. Recall that we are in a
# loop here, so why do libc.so.1 200 times?
#
if ($from ne '') {
if (! exists($symlink_map{$from})) {
$symlink_map{$from} =
follow_symlink($from);
}
}
if ($to ne '') {
if (! exists($symlink_map{$to})) {
$symlink_map{$to} =
follow_symlink($to);
}
}
#
# Now make the actual profile output line. Construct
# it in $tmp and then append it to $prof_fh pipeline.
#
$tmp = '';
if ($type eq "DIRECT") {
$tmp = "$object|*DIRECT*|$to|$sym";
} elsif ($type eq "INDIRECT") {
$tmp = "$object|$from|$to|$sym";
} elsif ($type eq "REVERSE") {
$tmp = "$object|*REVERSE*|$from|$sym";
} elsif ($type eq "UNBOUND") {
if ($put_DIRECT_in_the_UNBOUND_record) {
$tmp =
"$object|*DIRECT*|*UNBOUND*|$sym";
} else {
$tmp = "$object|$from|*UNBOUND*|$sym";
}
} else {
exiter("$command_name: " . sprintf(gettext(
"unrecognized ldd(1) LD_DEBUG " .
"bindings line: %s\n"), $line));
}
# write it to the sorting pipeline:
print $prof_fh $tmp, "\n";
$saw_bindings = 1;
} elsif ($line =~ /^DYNAMIC_PROFILE_SKIPPED_NOT_ELF/) {
# ignore no bindings warning for non-ELF
$saw_bindings = 1;
}
}
if (! $saw_bindings) {
print $prof_fh "#NO_BINDINGS_FOUND\n";
}
close($prof_fh);
if ($? != 0) {
exiter(norunprog(
"|$cmd_sort -t'|' +1 | $cmd_uniq >> '$outfile'", $!));
}
# Print out the library location and symlink info.
$outfile = "$output_dir/profile.dynamic.objects";
my $objects_fh = do { local *FH; *FH };
open($objects_fh, ">$outfile") || exiter(nofile($outfile, $!));
my ($var, $val);
while (($var, $val) = each(%ENV)) {
if ($var =~ /^LD_/) {
print $objects_fh "#info: $var=$val\n";
}
}
my $obj;
foreach $obj (sort(keys(%symlink_map))) {
next if ($obj eq '');
print $objects_fh "$obj => $symlink_map{$obj}\n";
}
close($objects_fh);
# Print out ldd shared object resolution.
$outfile = "$output_dir/profile.dynamic.ldd";
my $ldd_prof_fh = do { local *FH; *FH };
open($ldd_prof_fh, ">$outfile") || exiter(nofile($outfile, $!));
if (defined($all_needed)) {
print $ldd_prof_fh $all_needed;
}
close($ldd_prof_fh);
}
#
# If the users environment is not the same when running symprof as when
# running their application, the dynamic linker cannot resolve all of
# the dynamic bindings and we get "unbound symbols".
# redo_unbound_profile attempts to alleviate this somewhat. In
# particular, for shared objects that do not have all of their
# dependencies recorded, it attempts to use binding information in the
# other *executables* under test to supplement the binding information
# for the shared object with unbound symbols. This is not the whole
# story (e.g. dlopen(3L)), but it often helps considerably.
#
sub redo_unbound_profile
{
my ($dir, $path_to_object);
my ($profile, $total, $count);
my (%unbound_bins);
#
# Find the objects with unbound symbols. Put them in the list
# %unbound_bins.
#
$total = 0;
while (defined($dir = next_dir_name())) {
$profile = "$dir/profile.dynamic";
my $profile_fh = do { local *FH; *FH };
if (! -f $profile || ! open($profile_fh, "<$profile")) {
next;
}
$count = 0;
while (<$profile_fh>) {
next if (/^\s*#/);
$count++ if (/\|\*UNBOUND\*\|/);
}
close($profile_fh);
$unbound_bins{$dir} = $count if ($count);
$total += $count;
}
# we are done if no unbounds are detected.
return unless (%unbound_bins);
return if ($total == 0);
my (%dtneededs_lookup_full, %dtneededs_lookup_base);
# Read in *ALL* objects dt_neededs.
my ($soname, $base, $full);
while (defined($dir = next_dir_name())) {
$profile = "$dir/profile.dynamic.ldd";
my $all_neededs_fh = do { local *FH; *FH };
if (! open($all_neededs_fh, "<$profile")) {
# this is a heuristic, so we skip on to the next
next;
}
while (<$all_neededs_fh>) {
chop;
next if (/^\s*#/);
# save the dtneeded info:
($soname, $full) = split(/\s+=>\s+/, $_);
if ($full !~ /not found|\)/) {
$dtneededs_lookup_full{$full}{$dir} = 1;
}
if ($soname !~ /not found|\)/) {
$base = basename($soname);
$dtneededs_lookup_base{$base}{$dir} = 1;
}
}
close($all_neededs_fh);
}
emsg("\n" . gettext(
"re-profiling binary objects with unbound symbols") . " ...\n");
# Now combine the above info with each object having unbounds:
my $uref = \%unbound_bins;
foreach $dir (keys(%unbound_bins)) {
# Map object output directory to the actual path of the object:
$path_to_object = dir_name_to_path($dir);
#
# Here is the algorithm:
#
# 1) binary with unbounds must be a shared object.
#
# 2) check if it is in the dtneeded of other product binaries.
# if so, use the dynamic profile of those binaries
# to augment the bindings of the binary with unbounds
#
if (! -f $path_to_object) {
exiter(nopathexist($path_to_object, $!));
}
# only consider shared objects (e.g. with no DTNEEDED recorded)
if (! is_shared_object($path_to_object)) {
next;
}
$base = basename($path_to_object);
my (@dirlist);
my $result = 0;
if (defined($dtneededs_lookup_base{$base})) {
# the basename is on another's dtneededs:
@dirlist = keys(%{$dtneededs_lookup_base{$base}});
# try using the bindings of these executables:
$result =
try_executables_bindings($dir, $uref, @dirlist);
}
if ($result) {
# we achieved some improvements and so are done:
next;
}
# Otherwise, try objects that have our full path in their
# dtneededs:
@dirlist = ();
foreach $full (keys(%dtneededs_lookup_full)) {
if (! files_equal($path_to_object, $full)) {
next;
}
push(@dirlist, keys(%{$dtneededs_lookup_full{$full}}));
}
if (@dirlist) {
$result =
try_executables_bindings($dir, $uref, @dirlist);
}
}
emsg("\n");
}
#
# We are trying to reduce unbound symbols of shared objects/libraries
# under test that *have not* recorded their dependencies (i.e.
# DTNEEDED's). So we look for Executables being checked that have *this*
# binary ($path_to_object, a shared object) on *its* DTNEEDED. If we
# find one, we use those bindings.
#
sub try_executables_bindings
{
my ($dir, $uref, @dirlist) = @_;
my $path_to_object = dir_name_to_path($dir);
#
# N.B. The word "try" here means for a binary (a shared library,
# actually) that had unbound symbols, "try" to use OTHER
# executables binding info to resolve those unbound symbols.
#
# At least one executable needs this library; we select the one
# with minimal number of its own unbounds.
#
my (%sorting_list);
my (@executables_to_try);
my ($dir2, $cnt);
foreach $dir2 (@dirlist) {
next if (! defined($dir2));
next if ($dir2 eq $dir);
if (exists($uref->{$dir2})) {
$cnt = $uref->{$dir2};
} else {
#
# This binary is not on the unbounds list, so
# give it the highest priority.
#
$cnt = 0;
}
$sorting_list{"$dir2 $cnt"} = $dir2;
}
foreach my $key (reverse(sort_on_count(keys %sorting_list))) {
push(@executables_to_try, $sorting_list{$key});
}
my ($my_new_count, $my_new_profile, %my_new_symbols);
my ($object, $caller, $callee, $sym, $profile);
my $reprofiled = 0;
my ($line, $path2);
foreach $dir2 (@executables_to_try) {
$path2 = dir_name_to_path($dir2);
emsg(gettext(
"re-profiling: %s\n" .
"using: %s\n"), $path_to_object, $path2);
# read the other binary's profile
$profile = "$dir2/profile.dynamic";
if (! -f $profile) {
next;
}
my $prof_try_fh = do { local *FH; *FH };
open($prof_try_fh, "<$profile") ||
exiter(nofile($profile, $!));
# initialize for the next try:
$my_new_profile = '';
$my_new_count = 0;
%my_new_symbols = ();
# try to find bindings that involve us ($dir)
while (<$prof_try_fh>) {
chop($line = $_);
next if (/^\s*#/);
next if (/^\s*$/);
($object, $caller, $callee, $sym) =
split(/\|/, $line, 4);
if ($caller eq '*REVERSE*') {
next if ($callee =~ /^\*.*\*$/);
if (! files_equal($callee, $path_to_object)) {
next;
}
$my_new_profile .=
"$callee|*DIRECT*|REVERSE_TO:" .
"$object|$sym\n";
$my_new_symbols{$sym}++;
$my_new_count++;
} elsif (files_equal($caller, $path_to_object)) {
$my_new_profile .=
"$caller|*DIRECT*|$callee|$sym\n";
$my_new_symbols{$sym}++;
$my_new_count++;
}
}
close($prof_try_fh);
next if (! $my_new_count);
# modify our profile with the new information:
$profile = "$dir/profile.dynamic";
if (! rename($profile, "$profile.0") || ! -f "$profile.0") {
return 0;
}
my $prof_orig_fh = do { local *FH; *FH };
if (! open($prof_orig_fh, "<$profile.0")) {
rename("$profile.0", $profile);
return 0;
}
my $prof_fh = do { local *FH; *FH };
if (! open($prof_fh, ">$profile")) {
rename("$profile.0", $profile);
return 0;
}
my $resolved_from = dir_name_to_path($dir2);
print $prof_fh "# REDUCING_UNBOUNDS_VIA_PROFILE_FROM: " .
"$resolved_from\n";
while (<$prof_orig_fh>) {
if (/^\s*#/) {
print $prof_fh $_;
next;
}
chop($line = $_);
($object, $caller, $callee, $sym) =
split(/\|/, $line, 4);
if (! exists($my_new_symbols{$sym})) {
print $prof_fh $_;
next;
}
print $prof_fh "# RESOLVED_FROM=$resolved_from: $_";
}
close($prof_orig_fh);
print $prof_fh "# NEW_PROFILE:\n" . $my_new_profile;
close($prof_fh);
$reprofiled = 1;
last;
}
return $reprofiled;
}
#
# This routine calls get_ldd_output on the object and parses the
# LD_DEBUG output. Returns a string containing the information in
# standard form.
#
sub get_dynamic_profile
{
my ($object) = @_;
# Check if the object is statically linked:
my $str;
if (! is_elf($object)) {
return "DYNAMIC_PROFILE_SKIPPED_NOT_ELF";
} elsif (is_statically_linked($object)) {
$str = cmd_output_file($object);
return "STATICALLY_LINKED: $str";
}
# Get the raw ldd output:
my $ldd_output = get_ldd_output($object);
if ($ldd_output =~ /^ERROR:/) {
# some problem occurred, pass the error upward:
return $ldd_output;
}
# variables for manipulating the output:
my ($line, $filters, $neededs, $rest);
my ($tmp, $tmp2, @bindings);
# Now parse it:
foreach $line (split(/\n/, $ldd_output)) {
if ($line =~ /^\d+:\s*(.*)$/) {
# LD_DEBUG profile line, starts with "NNNNN:"
$tmp = $1;
next if ($tmp eq '');
if ($tmp =~ /^binding (.*)$/) {
#
# First look for:
# binding file=/bin/pagesize to \
# file=/usr/lib/libc.so.1: symbol `exit'
#
$tmp = $1;
push(@bindings, ldd_binding_line($1, $object));
} elsif ($tmp =~ /^file=\S+\s+(.*)$/) {
#
# Next look for:
# file=/usr/platform/SUNW,Ultra-1/\
# lib/libc_psr.so.1; filtered by /usr...
# file=libdl.so.1; needed by /usr/lib/libc.so.1
#
$rest = trim($1);
if ($rest =~ /^filtered by /) {
$filters .=
ldd_filter_line($tmp);
} elsif ($rest =~ /^needed by /) {
$neededs .=
ldd_needed_line($tmp, $object);
}
}
} elsif ($line =~ /^stdout:(.*)$/) {
# LD_DEBUG stdout line:
$tmp = trim($1);
next if ($tmp eq '');
if ($tmp =~ /\s+=>\s+/) {
#
# First look for standard dependency
# resolution lines:
#
# libsocket.so.1 => /usr/lib/libsocket.so.1
#
# Note that these are *all* of the
# needed shared objects, not just the
# directly needed ones.
#
$tmp =~ s/\s+/ /g;
$neededs .= "NEEDED_FOUND:$tmp" . "\n";
} elsif ($tmp =~ /symbol not found: (.*)$/) {
#
# Next look for unbound symbols:
# symbol not found: gethz (/usr/\
# local/bin/gethz)
#
$tmp = trim($1);
($tmp, $tmp2) = split(/\s+/, $tmp, 2);
$tmp2 =~ s/[\(\)]//g; # trim off ().
# $tmp is the symbol, $tmp2 is the
# calling object.
push(@bindings,
"BINDING_UNBOUND:$tmp2|$tmp" . "\n"
);
}
}
}
# Return the output:
my $ret = '';
$ret .= $filters if (defined($filters));
$ret .= $neededs if (defined($neededs));
$ret .= join('', @bindings);
return $ret;
}
#
# Routine used to parse a LD_DEBUG "binding" line.
#
# Returns "preprocessed format line" if line is ok, or
# null string otherwise.
#
sub ldd_binding_line
{
my ($line, $object) = @_;
my ($from, $to, $sym);
my ($t1, $t2, $t3); # tmp vars for regex output
#
# Working on a line like:
#
# binding file=/bin/pagesize to file=/usr/lib/libc.so.1: symbol `exit'
#
# (with the leading "binding " removed).
#
if ($line =~ /^file=(\S+)\s+to file=(\S+)\s+symbol(.*)$/) {
#
# The following trim off spaces, ', `, ;, and :, from
# the edges so if the filename had those there could
# be a problem.
#
$from = $1;
$to = $2;
$sym = $3;
#
# guard against future changes to the LD_DEBUG output
# (i.e. information appended to the end)
#
$sym =~ s/'\s+.*$//;
$to =~ s/:$//;
$sym =~ s/[\s:;`']*$//;
$sym =~ s/^[\s:;`']*//;
} elsif ($line =~ /^file=(.+) to file=(.+): symbol (.*)$/) {
# This will catch spaces, but is less robust.
$t1 = $1;
$t2 = $2;
$t3 = $3;
#
# guard against future changes to the LD_DEBUG output
# (i.e. information appended to the end)
#
$t3 =~ s/'\s+.*$//;
$from = wclean($t1, 1);
$to = wclean($t2, 1);
$sym = wclean($t3);
} else {
return '';
}
if ($from eq '' || $to eq '' || $sym eq '') {
return '';
}
#
# OK, we have 3 files: $from, $to, $object
# Which, if any, are the same file?
#
# Note that we have not yet done the Filter library
# substitutions yet. So one cannot be too trusting of the file
# comparisons done here.
#
if (files_equal($from, $to, 0)) {
#
# We skip the "from" = "to" case
# (could call this: BINDING_SELF).
#
return '';
} elsif (files_equal($object, $from, 0)) {
# DIRECT CASE (object calls library):
return "BINDING_DIRECT:$from|$to|$sym" . "\n";
} elsif (files_equal($object, $to, 0)) {
# REVERSE CASE (library calls object):
return "BINDING_REVERSE:$from|$to|$sym" . "\n";
} else {
#
# INDIRECT CASE (needed library calls library):
# (this will not be a library calling itself because
# we skip $from eq $to above).
#
return "BINDING_INDIRECT:$from|$to|$sym" . "\n";
}
}
#
# Routine used to parse a LD_DEBUG "filtered by" line.
#
# Returns "preprocessed format line" if line is ok, or null string
# otherwise.
#
sub ldd_filter_line
{
my ($line) = @_;
my ($filter, $filtee);
#
# Working on a line like:
#
# file=/usr/platform/SUNW,Ultra-1/lib/libc_psr.so.1; \
# filtered by /usr/lib/libc.so.1
#
my ($t1, $t2); # tmp vars for regex output
if ($line =~ /file=(\S+)\s+filtered by\s+(\S.*)$/) {
$t1 = $1;
$t2 = $2;
$filtee = wclean($t1);
$filter = wclean($t2);
} elsif ($line =~ /file=(.+); filtered by (.*)$/) {
$t1 = $1;
$t2 = $2;
$filtee = wclean($t1, 1);
$filter = wclean($t2, 1);
} else {
return '';
}
if ($filtee eq '' || $filter eq '') {
return '';
}
#
# What kind of filter is $filter?
# STANDARD (contains no "real code", e.g. libxnet.so.1), or
# AUXILIARY (provides "code" if needed, but
# prefers to pass filtee's "code", e.g. libc.so.1)
#
# LD_DEBUG output does not indicate this, so dump -Lv is run on it
# in filter_lib_type:
#
my $type = 'unknown';
$type = filter_lib_type($filter);
if ($type eq 'STD') {
return "FILTER_STD:$filter|$filtee" . "\n";
} elsif ($type eq 'AUX') {
return "FILTER_AUX:$filter|$filtee" . "\n";
} else {
return '';
}
}
#
# Routine used to parse a LD_DEBUG "needed by" line.
#
# Returns "preprocessed format line" if line is ok, or the null string
# otherwise.
#
sub ldd_needed_line
{
my ($line, $object) = @_;
my ($thing_needed, $file);
my ($t1, $t2); # tmp variables for regex output.
#
# Working on a line like:
#
# file=libdl.so.1; needed by /usr/lib/libc.so.1
#
if ($line =~ /file=(\S+)\s+needed by\s+(\S.*)$/) {
$t1 = $1;
$t2 = $2;
$thing_needed = wclean($t1);
$file = wclean($t2);
} elsif ($line =~ /file=(.+); needed by (.*)$/) {
$t1 = $1;
$t2 = $2;
$thing_needed = wclean($t1, 1);
$file = wclean($t2, 1);
} else {
return '';
}
if ($thing_needed eq '' || $file eq '') {
return '';
}
#
# Note that $thing_needed is not a path to a file, just the
# short name unresolved, e.g. "libc.so.1". The next line of the
# LD_DEBUG output would tell us where $thing_needed is resolved
# to.
#
if (files_equal($object, $file)) {
return "NEEDED_DIRECT:$thing_needed|$file" . "\n";
} else {
return "NEEDED_INDIRECT:$thing_needed|$file" . "\n";
}
}
#
# Routine to clean up a "word" string from ldd output.
#
# This is specialized for removing the stuff surrounding files and
# symbols in the LD_DEBUG output. It is usually a file name or symbol
# name.
#
sub wclean
{
my ($w, $keep_space) = @_;
if (! $keep_space) {
# make sure leading/trailing spaces are gone.
$w =~ s/[\s:;`']*$//; # get rid of : ; ' and `
$w =~ s/^[\s:;`']*//;
} else {
$w =~ s/[:;`']*$//; # get rid of : ; ' and `
$w =~ s/^[:;`']*//;
}
return $w;
}
#
# This routine runs ldd -r on the object file with LD_DEBUG flags turned
# on. It collects the stdout and the LD_DEBUG profile data for the
# object (it must skip the LD_DEBUG profile data for /usr/bin/ldd
# /bin/sh, or any other extraneous processes).
#
# It returns the profile data as a single string with \n separated
# records. Records starting with "stdout: " are the stdout lines,
# Records starting with "NNNNN: " are the LD_DEBUG lines. Our caller
# must split and parse those lines.
#
# If there is some non-fatal error, it returns a 1-line string like:
# ERROR: <error-message>
#
sub get_ldd_output
{
my ($object) = @_;
my ($tmpdir, $outfile, $errfile);
if (! -f $object) {
exiter(nopathexist($object));
}
# We use the tmp_dir for our work:
$tmpdir = $tmp_prof_dir;
# Clean out the tmpdir.
if ($tmpdir !~ m,^/*$,) {
unlink(<$tmpdir/*>);
#
# The following puts xgettext(1) back on track. It is
# confused and believes it is inside a C-style /* comment */
#
my $unused = "*/";
}
# Output files for collecting output of the ldd -r command:
$errfile = "$tmpdir/stderr";
$outfile = "$tmpdir/stdout";
my ($rc, $msg, $child, $result);
#
# This forking method should have 2 LD_DEBUG bind.<PID> files
# one for ldd and the other for $object. system() could have
# another from the shell.
#
# Fork off a child:
$child = fork();
#
# Note: the file "/tmp/.../bind.$child" should be the "ldd"
# profile, but we do not want to depend upon that.
#
if (! defined($child)) {
# Problem forking:
exiter(sprintf(gettext(
"cannot fork for command: ldd -r %s: %s\n"), $object, $!));
} elsif ($child == 0) {
# Reopen std output to the desired output files:
open(STDOUT, ">$outfile") ||
exiter(nofile($outfile, $!));
open(STDERR, ">$errfile") ||
exiter(nofile($errfile, $!));
#
# Set the env to turn on debugging from the linker:
#
$ENV{'LD_DEBUG'} = "files,bindings";
$ENV{'LD_DEBUG_OUTPUT'} = "$tmpdir/bind";
#
# Set LD_NOAUXFLTR to avoid auxiliary filters (e.g. libc_psr)
# since they are not of interest to the public/private
# symbol status and confuse things more than anything else.
#
$ENV{'LD_NOAUXFLTR'} = "1";
# Run ldd -r:
c_locale(1);
exec($cmd_ldd, '-r', $object);
exit 1; # only reached if exec fails.
} else {
wait; # Wait for children to finish.
$rc = $?; # Record exit status.
$msg = $!;
}
# Check the exit status:
if ($rc != 0) {
if (-s $errfile) {
my $tmp;
my $errfile_fh = do { local *FH; *FH };
if (open($errfile_fh, "<$errfile")) {
while (<$errfile_fh>) {
if (/ldd:/) {
$tmp = $_;
last;
}
}
close($errfile_fh);
}
if (defined($tmp)) {
chomp($tmp);
if ($tmp =~ /ldd:\s*(\S.*)$/) {
$tmp = $1;
}
if ($tmp =~ /^[^:]+:\s*(\S.*)$/) {
my $t = $1;
if ($t !~ /^\s*$/) {
$tmp = $t;
}
}
$msg = $tmp if ($tmp !~ /^\s*$/);
}
}
emsg("%s", norunprog("$cmd_ldd -r $object", "$msg\n"));
$msg =~ s/\n/ /g;
$msg =~ s/;/,/g;
$msg = sprintf("ERROR: " . gettext(
"Error running: ldd -r LD_DEBUG: %s"), $msg);
return $msg;
}
#
# We now have all the output files created. We read them and
# merge them into one long string to return to whoever called
# us. The caller will parse it, not us. Our goal here is to
# just return the correct LD_DEBUG profile data.
#
if (-f "$tmpdir/stdout") {
my $out_fh = do { local *FH; *FH };
if (! open($out_fh, "<$tmpdir/stdout")) {
exiter(nofile("$tmpdir/stdout", $!));
}
while (<$out_fh>) {
# Add the special prefix for STDOUT:
$result .= "stdout: $_";
}
close($out_fh);
}
my ($file, $count, $goodone, $ok, $aok, @file);
$count = 0;
my $prevline;
# Loop over each "bind.NNNNN" file in the tmp directory:
foreach $file (<$tmpdir/bind.*>) {
# Open it for reading:
my $ldd_file_fh = do { local *FH; *FH };
if (! open($ldd_file_fh, "<$file")) {
exiter(nofile($file, $!));
}
#
# ok = 1 means this file we are reading the profile file
# corresponding to $object. We set ok = 0 as soon as we
# discover otherwise.
#
$ok = 1;
#
# $aok = 1 means always OK. I.e. we are definitely in the
# correct profile.
#
$aok = 0;
#
# this variable will hold the previous line so that we
# can skip adjacent duplicates.
#
$prevline = '';
my $idx;
while (<$ldd_file_fh>) {
#
# This check is done to perform a simple
# uniq'ing of the output. Non-PIC objects have
# lots of duplicates, many of them right after
# each other.
#
next if ($_ eq $prevline);
$prevline = $_;
#
# Check to see if this is the wrong profile
# file: The ones we know about are "ldd" and
# "sh". If the object under test is ever "ldd"
# or "sh" this will fail.
#
if ($aok) {
;
} elsif ($ok) {
#
# checks line:
# file=ldd; analyzing [ RTLD_GLOBAL RTLD_LAZY ]
#
if (/\bfile=\S+\b(ldd|sh)\b/) {
$ok = 0;
} else {
$idx =
index($_, " file=$object; analyzing");
$aok = 1 if ($idx != -1);
}
}
# We can skip this file as soon as we see $ok = 0.
last unless ($ok);
# Gather the profile output into a string:
$file[$count] .= $_;
}
#
# Note that this one is the desired profile
# (i.e. if $ok is still true):
#
$goodone .= "$count," if ($ok);
# On to the next $file:
close($ldd_file_fh);
$count++;
}
if (defined($goodone)) {
$goodone =~ s/,$//; # Trim the last comma off.
}
# If we have none or more than one "good one" we are in trouble:
if (! defined($goodone) || ($goodone !~ /^\d+$/) || ($goodone =~ /,/)) {
#
# Note that this is the first point at which we would detect
# a problem with the checking of SUID/SGID objects, although
# in theory we could have skipped these objects earlier.
# We prefer to let the linker, ld.so.1, indicate this failure
# and then we catch it and diagnose it here.
#
my $suid = is_suid($object);
if ($suid == 1) {
$result = "ERROR: " . gettext(
"SUID - ldd(1) LD_DEBUG profile failed");
} elsif ($suid == 2) {
$result = "ERROR: " . gettext(
"SGID - ldd(1) LD_DEBUG profile failed");
} else {
$result = "ERROR: " . gettext(
"could not get ldd(1) LD_DEBUG profile output");
}
} else {
# Append the correct profile to the result and return it:
$result .= $file[$goodone];
}
# Tidy up our mess by cleaning out the tmpdir.
unlink(<$tmpdir/*>) if ($tmpdir !~ m,^/*$,);
return $result;
}