appcert/scripts/symreport.pl

#!/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
#
#
# Copyright (c) 1996-2000 by Sun Microsystems, Inc.
# All rights reserved.
#
#ident  "%Z%%M% %I% %E% SMI"
#

#
# This utility program reads the symcheck output of each binary and
# creates additional output for then and an overall report.
#

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_report_dir
    $misc_check_databases_loaded_ok
    %result_list_hash
    %result_msg
    %warnings_found
);

set_clean_up_exit_routine(\&clean_up_exit);

import_vars_from_environment();

signals('on', \&interrupted);

set_working_dir();

generate_reports();

clean_up();

exit 0;

#
# working_dir has been imported by import_vars_from_environment()
# 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));
    }
}

#
# Called when interrupted by user.
#
sub interrupted
{
    $SIG{$_[0]} = 'DEFAULT';
    signals('off');
    clean_up_exit(1);
}

#
# Does the cleanup and then exit with return code $rc.  Note: The
# utility routine exiter() will call this routine.
#
sub clean_up_exit
{
    my ($rc) = @_;
    $rc = 0 unless ($rc);

    clean_up();
    exit $rc;
}

#
# General cleanup activities are placed here. There may not be an
# immediate exit after this cleanup.
#
sub clean_up
{
    if (defined($tmp_report_dir) && -d $tmp_report_dir) {
        rmtree($tmp_report_dir);
    }
}

#
# Top level routine for generating the additional reports.
#
sub generate_reports
{
    # Make a tmp dir for the reporting work.
    $tmp_report_dir = create_tmp_dir($tmp_dir);

    if (! -d $tmp_report_dir) {
        exiter(nocreatedir($tmp_report_dir, $!));
    }

    pmsg("\n");
    print_line();

    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 be placed down in $dir, e.g. "$dir/report"
    #

    while (defined($dir = next_dir_name())) {

        # Map object output dir to actual path of the object:
        $path_to_object = dir_name_to_path($dir);

        # Make a report for it:
        report_object($path_to_object, $dir);
    }

    my $type;
    foreach $type (keys(%result_list_hash)) {
        $result_list_hash{$type} =~ s/\|+$//;
    }

    print_report();
    my $tout;
    $tout = gettext(
        "Additional output regarding private symbols usage and other\n" .
        "data is in the directory:\n");

    $tout .= "\n   $working_dir\n\n";

    $tout .= gettext(
        "see the appcert documentation for more information.\n");

    pmsg("%s", $tout);

    clean_up(); # Remove any tmp directories and files.
}

#
# Examines the symcheck output for a given binary object recording and
# reporting and problems found.  Generates additional reports and
# summaries.
#
sub report_object
{
    my ($object, $dir) = @_;

    my (%problems);

    my $problems_file = "$dir/check.problems";

    my $problems_fh = do { local *FH; *FH };
    open($problems_fh, "<$problems_file") ||
        exiter(nofile($problems_file, $!));

    # We need the "warning" msgs and text from the Misc Checks loaded:
    if (! defined($misc_check_databases_loaded_ok)) {
        $misc_check_databases_loaded_ok = load_misc_check_databases();
    }

    my ($prob, $incomp, $c, $w);
    my $problem_count = 0;
    my $incomplete_count = 0;
    my $line_count = 0;

    while (<$problems_fh>) {
        chomp;
        $prob = 1;
        $incomp = 0;
        $line_count++;

        if (/^DYNAMIC: PRIVATE_SYMBOL_USE\s+(\d*)/) {
            $problems{'private_syms'} += $1;
        } elsif (/^DYNAMIC: UNBOUND_SYMBOL_USE\s+(\d*)/) {
            $problems{'unbound_syms'} += $1;
            $incomp = 1;
        } elsif (/^DYNAMIC: UNRECOGNIZED_SYMBOL_USE\s+(\d*)/) {
            $problems{'unrecognized_syms'} += $1;
            $incomp = 1;
        } elsif (/^DYNAMIC: NO_DYNAMIC_BINDINGS_FOUND\s*(.*)$/) {
            $problems{'no_dynamic_bindings'} .= "$1, ";
            $incomp = 1;
        } elsif (/^STATIC: LINKED_ARCHIVE\s+(.*)$/) {
            $problems{'static_linking'} .= "$1, ";
        } elsif (/^STATIC: COMPLETELY_STATIC/) {
            $problems{'completely_static'}++;
        } elsif (/^MISC: REMOVED_SCOPED_SYMBOLS:\s+(.*)$/) {
            $problems{'scoped_symbols'} .= "$1, ";
        } elsif (/^MISC: WARNING:\s+(INCOMPLETE\S+)/) {
            $problems{'warnings'} .= "$1|";
            $incomp = 1;
        } elsif (/^MISC: WARNING:\s+(.*)$/) {
            $problems{'warnings'} .= "$1|";
        } else {
            $prob = 0;
        }
        $problem_count += $prob;
        $incomplete_count += $incomp;
    }
    close($problems_fh);

    if ($line_count == 0) {
        # No problems at all, leave a comment message:
        open($problems_fh, ">$problems_file") ||
            exiter(nofile($problems_file, $!));
        print $problems_fh "# NO_PROBLEMS_DETECTED\n";
        close($problems_fh);
    }

    if ($problem_count == 0) {
        $result_list_hash{'passed'} .= "$object|";
        return;
    }

    if ($incomplete_count == $problem_count) {
        $result_list_hash{'incomplete'} .= "$object|";
    } else {
        $result_list_hash{'failed'} .= "$object|";
    }

    my $m;

    if ($m = $problems{'private_syms'}) {
        $result_list_hash{'private_syms'} .= "$object|";
        $result_msg{$object} .= "$m " .
            gettext("private symbols") . "; ";
    }

    if ($m = $problems{'unbound_syms'}) {
        $result_list_hash{'unbound_syms'} .= "$object|";
        $result_msg{$object} .= "$m " .
            gettext("unbound symbols") . "; ";

        # add this case to the warnings output at end of report.
        my $tag  = 'unbound symbols';
        $warnings_found{$tag} .= "$object|";

        if (! exists($warnings_desc{$tag})) {
            my $desc = gettext("unbound symbols");
            $warnings_desc{$tag} = $desc;
        }
    }

    if ($m = $problems{'unrecognized_syms'}) {
        $result_list_hash{'unrecognized_syms'} .= "$object|";
        $result_msg{$object} .= "$m " .
            gettext("unrecognized symbols") . "; ";

        # Add this case to the warnings output at end of report.
        my $tag  = 'unrecognized symbols';
        $warnings_found{$tag} .= "$object|";

        if (! exists($warnings_desc{$tag})) {
            my $desc = gettext("unrecognized symbols");
            $warnings_desc{$tag} = $desc;
        }
    }

    if ($m = $problems{'static_linking'}) {
        $result_list_hash{'static_linking'} .= "$object|";
        $m =~ s/,\s*$//;
        $result_msg{$object} .= sprintf(gettext(
            "statically linked with %s"), $m) . "; ";

        # Add this case to the warnings output at end of report.
        my $tag  = 'statically linked';
        $warnings_found{$tag} .= "$object|";

        if (! exists($warnings_desc{$tag})) {
            my $desc =
                gettext("static linking of Solaris libraries");
            $warnings_desc{$tag} = $desc;
        }
    }

    if ($problems{'completely_static'}) {
        $result_list_hash{'completely_static'} .= "$object|";
        $result_msg{$object} .=
            gettext("completely statically linked") . "; ";

        # Add this case to the warnings output.
        my $tag  = gettext("completely statically linked");
        $warnings_found{$tag} .= "$object|";

        my $desc =
            gettext("complete static linking of Solaris libraries");
        if (! exists($warnings_desc{$tag})) {
            $warnings_desc{$tag} = $desc;
        }

    } elsif ($m = $problems{'no_dynamic_bindings'}) {
        #
        # Note we skip this error if it is completely static.
        # The app could technically be SUID as well.
        #

        $result_list_hash{'no_dynamic_bindings'} .= "$object|";
        $m =~ s/,\s*$//;
        $m = " : $m";
        $m =~ s/ : NO_SYMBOL_BINDINGS_FOUND//;
        $m =~ s/^ :/:/;
        $result_msg{$object} .=
            gettext("no bindings found") . "$m; ";
    }

    if ($m = $problems{'scoped_symbols'}) {
        $m =~ s/[,\s]*$//;
        $result_list_hash{'scoped_symbols'} .= "$object|";
        $c = scalar(my @a = split(' ', $m));

        $result_msg{$object} .= "$c " .
            gettext("demoted (removed) private symbols") . ": $m; ";

        # Add this case to the warnings output.
        my $tag  = 'scoped symbols';
        $warnings_found{$tag} .= "$object|";

        my $desc = gettext(
            "dependency on demoted (removed) private Solaris symbols");
        if (! exists($warnings_desc{$tag})) {
            $warnings_desc{$tag} = $desc;
        }
    }

    if ($m = $problems{'warnings'}) {
        foreach $w (split(/\|/, $m)) {
            next if ($w =~ /^\s*$/);

            $c = $w;
            if (defined($warnings_desc{$c})) {
                $c = $warnings_desc{$c};
                $c = gettext($c);
            }
            $c =~ s/;//g;
            $result_msg{$object} .= "$c; ";
            $warnings_found{$w} .= "$object|";
        }
    }

    $result_msg{$object} =~ s/;\s+$//;
}

#
# Create the top level roll-up report.
#
sub print_report
{
    # Count the number of passed, failed and total binary objects:
    my(@a);
    my($r_passed, $r_incomp, $r_failed);
    if (exists($result_list_hash{'passed'})) {
        $r_passed = $result_list_hash{'passed'};
    } else {
        $r_passed = '';
    }
    if (exists($result_list_hash{'incomplete'})) {
        $r_incomp = $result_list_hash{'incomplete'};
    } else {
        $r_incomp = '';
    }
    if (exists($result_list_hash{'failed'})) {
        $r_failed = $result_list_hash{'failed'};
    } else {
        $r_failed = '';
    }
    my $n_passed = scalar(@a = split(/\|/, $r_passed));
    my $n_incomp = scalar(@a = split(/\|/, $r_incomp));
    my $n_failed = scalar(@a = split(/\|/, $r_failed));
    my $n_checked = $n_passed + $n_incomp + $n_failed;

    my ($summary_result, $msg, $output, $object);


    if ($n_checked == 0) {
        $summary_result = $text{'Summary_Result_None_Checked'};
    } elsif ($n_failed > 0) {
        $summary_result = $text{'Summary_Result_Some_Failed'};
    } elsif ($n_incomp > 0) {
        $summary_result = $text{'Summary_Result_Some_Incomplete'};
    } else {
        $summary_result = $text{'Summary_Result_All_Passed'};
    }

    # place the info in problem count file:
    my $cnt_file = "$working_dir/ProblemCount";
    my $pcount_fh = do { local *FH; *FH };
    if (! open($pcount_fh, ">$cnt_file")) {
        exiter(nofile($cnt_file, $!));
    }

    print $pcount_fh "$n_failed / $n_checked binary_objects_had_problems\n";
    print $pcount_fh
        "$n_incomp / $n_checked could_not_be_completely_checked\n";

    print $pcount_fh "NO_PROBLEMS_LIST: $r_passed\n";
    print $pcount_fh "INCOMPLETE_LIST: $r_incomp\n";
    print $pcount_fh "PROBLEMS_LIST: $r_failed\n";
    close($pcount_fh);

    #
    # Set the overall result code.
    # This is used to communicate back to the appcert script to
    # indicate how it should exit(). The string must start with the
    # exit number, after which a message may follow.
    #

    if ($n_checked == 0) {
        overall_result_code("3 => nothing_checked");
    } elsif ($n_failed > 0) {
        overall_result_code("2 => some_problems_detected($n_failed)");
    } elsif ($n_incomp > 0) {
        overall_result_code("1 => " .
            "some_binaries_incompletely_checked($n_incomp)");
    } else {
        overall_result_code("0 => no_problems_detected");
    }

    my ($sp0, $sp, $sf, $si);   # PASS & FAIL spacing tags.
    $sp0 = '   ';
    if ($batch_report) {
        $sp = 'PASS ';
        $sf = 'FAIL ';
        $si = 'INC  ';
    } else {
        $sp = $sp0;
        $sf = $sp0;
        $si = $sp0;
    }


    $msg = sprintf(gettext("Summary: %s"), $summary_result) . "\n\n";
    my $format = gettext("A total of %d binary objects were examined.");
    $msg .= sprintf($format, $n_checked) . "\n\n\n";
    $output .= $msg;

    my $fmt1 = gettext(
        "The following (%d of %d) components had no problems detected:");

    if ($n_passed > 0) {
        $output .= sprintf($fmt1, $n_passed, $n_checked);
        $output .= "\n\n";

        foreach $object (split(/\|/, $r_passed)) {
            $output .= "${sp}$object\n";
        }
        $output .= "\n";
    }

    my $fmt2 = gettext(
        "The following (%d of %d) components had no problems detected,\n" .
        "   but could not be completely checked:");

    if ($n_incomp > 0) {
        $output .= sprintf($fmt2, $n_incomp, $n_checked);
        $output .= "\n\n";

        foreach $object (split(/\|/, $r_incomp)) {
            $msg = $result_msg{$object};
            $output .= "${si}$object\t($msg)\n";
        }
        $output .= "\n";
    }

    my $fmt3 = gettext(
        "The following (%d of %d) components have potential " .
        "stability problems:");
    if ($n_failed > 0) {
        $output .= sprintf($fmt3, $n_failed, $n_checked);
        $output .= "\n\n";

        foreach $object (split(/\|/, $r_failed)) {
            $msg = $result_msg{$object};
            $output .= "${sf}$object\t($msg)\n";
        }
        $output .= "\n";
    }

    $output .= "\n" . get_summary();

    $output .= "\n" . get_warnings();

    my $report_file = "$working_dir/Report";
    my $report_fh = do { local *FH; *FH };
    open($report_fh, ">$report_file") ||
        exiter(nofile($report_file, $!));

    print $report_fh $output;
    close($report_fh);
    system($cmd_more, $report_file);
}

#
# Collects all of the warnings issued for the binaries that were
# checked.  Returns the warning text that will go into the roll-up
# report.
#
sub get_warnings
{
    my ($w, $c, $output, $count);

    if (! %warnings_found) {
        return '';  # appends null string to output text
    }

    $output = gettext("Summary of various warnings:") . "\n\n";
    my(@a);
    foreach $w (keys(%warnings_found)) {
        $warnings_found{$w} =~ s/\|+$//;
        $count = scalar(@a = split(/\|/, $warnings_found{$w}));
        $c = $w;
        if (defined($warnings_desc{$c})) {
            $c = $warnings_desc{$c};
        }
        $c = gettext($c);
        $output .= " - $c  " . sprintf(gettext(
            "(%d binaries)\n"), $count);
        $output .= "\n";

    }
    $output .= "\n";

    return $output;
}

#
# Computes the summary information for each binary object that was
# checked.  Returns the text that will go into the roll-up report.
#
sub get_summary
{
    my ($dir, $file);
    my (%lib_private, %libsym_private);
    my (%libapp, %libapp_private);

    my ($bin, $arch, $direct, $lib, $class, $sym);

    while (defined($dir = next_dir_name())) {

        # This is where the public symbol list is:
        $file = "$dir/check.dynamic.public";

        my %app_public;
        my %app_sym_public;
        my %app_private;
        my %app_sym_private;

        if (-s $file) {
            my $publics_fh = do { local *FH; *FH };
            open($publics_fh, "<$file") ||
                exiter(nofile($file, $!));

            while (<$publics_fh>) {
                next if (/^\s*#/);
                chomp;
                ($bin, $arch, $direct, $lib, $class, $sym) =
                    split(/\|/, $_);

                $libapp{"$lib|$bin"}++;

                $app_public{$lib}++;
                $app_sym_public{"$lib|$sym"}++;
            }
            close($publics_fh);
        }

        # This is where the private symbol list is:
        $file = "$dir/check.dynamic.private";

        if (-s $file) {
            my $privates_fh = do { local *FH; *FH };
            open($privates_fh, "<$file") ||
                exiter(nofile($file, $!));

            while (<$privates_fh>) {
                next if (/^\s*#/);
                chomp;
                ($bin, $arch, $direct, $lib, $class, $sym) =
                    split(/\|/, $_);

                $lib_private{$lib}++;
                $libsym_private{"$lib|$sym"}++;
                $libapp_private{"$lib|$bin"}++;
                $libapp{"$lib|$bin"}++;

                $app_private{$lib}++;
                $app_sym_private{"$lib|$sym"}++;
            }
            close($privates_fh);
        }

        write_app_summary($dir, \%app_public, \%app_sym_public,
            \%app_private, \%app_sym_private);
    }

    my ($app_total, $app_private_total);
    my ($key, $lib2, $app2, $sym2);
    my $val;
    my $text;

    foreach $lib (sort(keys(%lib_private))) {

        $app_total = 0;
        foreach $key (keys(%libapp)) {
            ($lib2, $app2) = split(/\|/, $key);
            $app_total++ if ($lib eq $lib2);
        }

        $app_private_total = 0;
        foreach $key (keys(%libapp_private)) {
            ($lib2, $app2) = split(/\|/, $key);
            $app_private_total++ if ($lib eq $lib2);
        }

        my @list;
        while (($key, $val) =  each(%libsym_private)) {
            ($lib2, $sym2) = split(/\|/, $key);
            next unless ($lib eq $lib2);
            push(@list, "$sym2 $val");

        }

        $text .= private_format($lib, $app_total,
            $app_private_total, @list);
    }

    if (! defined($text)) {
        return '';  # appends null string to output report.
    }
    return $text;
}

#
# Given the symbols and counts of private symbols used by all binaries
# that were checked, returns a pretty-printed format table of the
# symbols. This text goes into the roll-up report and the summary.dynamic
# file.
#
sub private_format
{
    my ($lib, $tot, $priv, @list) = @_;

    my (@sorted) = sort_on_count(@list);
    my $formatted = list_format('  ', @sorted);

    my $text;
    my $libbase = basename($lib);

    $text = sprintf(gettext(
        "Summary of Private symbol use in %s\n"), $lib);
    my $fmt =
        gettext("%d binaries used %s, %d of these used private symbols");
    $text .= sprintf($fmt, $tot, $libbase, $priv);
    $text .= "\n\n$formatted\n";

    return $text;
}

#
# Given the public/private symbol and library usage information for a
# binary object, creates an output file with this information formatted
# in tables.
#
sub write_app_summary
{
    my ($dir, $public, $sym_public, $private, $sym_private) = @_;

    my $outfile = "$dir/summary.dynamic";

    my $summary_fh = do { local *FH; *FH };
    open($summary_fh, ">$outfile") ||
        exiter(nofile($outfile, $!));

    my $path_to_object = dir_name_to_path($dir);


    my ($tmp1, $tmp2, $tmp3);

    $tmp1 = gettext("ABI SYMBOL USAGE SUMMARY REPORT");
    $tmp2 = '*' x length($tmp1);

    print $summary_fh "$tmp2\n$tmp1\n$tmp2\n\n";

    print $summary_fh "  ", sprintf(gettext(
        "Binary Object: %s\n"), $path_to_object);

    my $uname_a = `$cmd_uname -a`;
    print $summary_fh "  ", sprintf(gettext("System: %s\n"), $uname_a);

    $tmp1 = gettext("References to shared objects in the Solaris ABI");
    $tmp2 = '*' x length($tmp1);

    print $summary_fh "$tmp2\n$tmp1\n$tmp2\n\n";


    my (%libs, $lib, $maxlen, $len);
    $maxlen = 0;

    foreach $lib (keys(%$public), keys(%$private)) {
        $len = length($lib);
        $maxlen = $len if ($len > $maxlen);
        $libs{$lib} = 1;
    }

    if (! %libs) {
        my $str = gettext(
        "  NONE FOUND. Possible explanations:\n" .
        "    - the dynamic profiling failed, see ldd(1), ld.so.1(1)\n" .
        "    - the object is SUID or SGID\n" .
        "    - the object is completely statically linked.\n"
        );
        print $summary_fh $str, "\n";
        close($summary_fh);
        return;
    }

    foreach $lib (sort(keys(%libs))) {
        print $summary_fh "  $lib\n";
    }
    print $summary_fh "\n";

    my ($len1, $len2, $len3);
    my $heading = '  ' . gettext("Library");
    $heading .= ' ' x ($maxlen + 6 - length($heading));
    $len1 = length($heading) - 2;
    my $public_str = gettext("Public");
    $len2 = length($public_str);
    my $private_str = gettext("Private");
    $len3 = length("  $private_str");
    $heading .= "$public_str  $private_str";
    $tmp3 = $heading;
    $tmp3 =~ s/\S/-/g;

    $tmp1 = gettext("Symbol usage statistics (summary by shared object)");
    $tmp2 = '*' x length($tmp1);

    print $summary_fh "$tmp2\n$tmp1\n$tmp2\n\n";
    print $summary_fh "$heading\n";
    print $summary_fh "$tmp3\n";

    my ($pub, $priv, $str);
    foreach $lib (sort(keys(%libs))) {
        $pub  = $public->{$lib};
        $priv = $private->{$lib};

        $pub = 0 if (! defined($pub));
        $priv = 0 if (! defined($priv));

        $str = '  ';
        $str .= sprintf("%-${len1}s", $lib);
        $str .= sprintf("%${len2}s", $pub);
        $str .= sprintf("%${len3}s", $priv);
        print $summary_fh $str, "\n";
    }
    print $summary_fh "\n";

    $tmp1 = gettext("Symbol usage (detailed inventory by shared object)");
    $tmp2 = '*' x length($tmp1);

    print $summary_fh "$tmp2\n$tmp1\n$tmp2\n\n";

    my (@pub, @priv, $lib2, $sym2, $text, $key);
    foreach $lib (sort(keys(%libs))) {
        @pub  = ();
        @priv = ();

        foreach $key (keys(%$sym_public)) {
            next unless (index($key, $lib) == 0);
            ($lib2, $sym2) = split(/\|/, $key, 2);
            next unless ($lib2 eq $lib);
            push(@pub, $sym2);
        }
        foreach $key (keys(%$sym_private)) {
            next unless (index($key, $lib) == 0);
            ($lib2, $sym2) = split(/\|/, $key, 2);
            next unless ($lib2 eq $lib);
            push(@priv, $sym2);
        }

        next if (! @pub && ! @priv);

        my $fmt = gettext("Symbols in %s Directly Referenced");
        $text = sprintf($fmt, $lib);

        if (@pub) {
            $lib2 = scalar(@pub);
            $text .= sprintf(gettext(
                "  %d public symbols are used:\n"), $lib2);
            $text .= list_format('    ', sort(@pub));
            $text .= "\n";
        }
        if (@priv) {
            $lib2 = scalar(@priv);
            $text .= sprintf(gettext(
                "  %d private symbols are used:\n"), $lib2);
            $text .= list_format('    ', sort(@priv));
            $text .= "\n";
        }

        print $summary_fh $text;
    }
    close($summary_fh);
}