#!/usr/bin/perl

##############################################################################
#  Copyright (C) 2007, 2008 Paulo Cesar Pereira de Andrade.  All Rights Reserved.
#
#  This is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This software is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  Authors:
#	Paulo Cesar Pereira de Andrade <pcpa@mandriva.com.br>
##############################################################################

use Cwd;
use File::Basename;
use Getopt::Std;

use strict;

my %servers;
my %modules;
my @objects;
my %types;
my %weaks;
my %bases;
my %undefs;
my %hiddens;
my %exports;
my %clashes;
my %loaders;
my %dynamics;
my %libraries;
my %options;


my @ignore = ("___tls_get_addr",

	      "__div64",
	      "__divdf3",
	      "__divsf3",
	      "__divsi3",
	      "__modsi3",
	      "__mul64",
	      "__muldf3",
	      "__mulsf3",
	      "__mulsi3",
	      "__udivsi3",
	      "__umodsi3",

	      "__gmon_start__",

	      "__libc_enable_secure",
	      "__libc_stack_end",

	      "__pthread_key_create",
	      "__pthread_once",
	      "__pthread_getspecific",
	      "__pthread_setspecific",

	      "__resp",

	      "_rtld_global",
	      "_rtld_global_ro",

	      "_IO_stdin_used",
	      "_Jv_RegisterClasses",

	      "_dl_allocate_tls",
	      "_dl_allocate_tls_init",
	      "_dl_argv",
	      "_dl_deallocate_tls",
	      "_dl_get_tls_static_info",
	      "_dl_make_stack_executable",
	      "_dl_rtld_di_serinfo",
	      "_dl_starting_up",
	      "_dl_tls_get_addr_soft",

	      "_fini",
	      "_init",

	      "errno",
	      "h_errno",

	      "w__div64",
	      "w__divdf3",
	      "w__divsf3",
	      "w__divsi3",
	      "w__modsi3",
	      "w__mul64",
	      "w__muldf3",
	      "w__mulsf3",
	      "w__mulsi3",
	      "w__udivsi3",
	      "w__umodsi3",
	      "w_IO_stdin_used",
	      "w_Jv_RegisterClasses",
	      "w_dl_starting_up",
	      "w__gmon_start__",
	      "w__pthread_getspecific",
	      "w__pthread_key_create",

	      "w__pthread_mutex_lock",
	      "w__pthread_mutex_unlock",

	      "w__pthread_once",
	      "w__pthread_setspecific",
	      "wpthread_cancel",
	      "wpthread_once");

Getopt::Std::getopts("p:m:aefxsh?", \%options);
if ($options{'h'} or $options{'?'}) {
    print("Usage:\n",
	  File::Basename::basename($0), " [options ...]\n",
	  " -a      Don't ignore symbols in \`\`\@ignore'' list.\n",
	  " -p path Use path prefix instead of xorg-git.dest-dir\n",
	  "         Try /usr for \"standard\" install files.\n",
	  " -m path Use given module path\n",
	  "         use \":\" to specify multiple module paths.\n",
	  " -e      Don't warn about not referenced exported symbols.\n",
	  " -f      Prints full paths of binaries.\n",
	  " -x      Don't warn about symbols found in the X Server.\n",
	  " -s      Inherit library symbols for modules (the X Server still inherits).\n",
	  " -h, -?  Prints this message and quits.\n");
    exit(0);
}

##############################################################################
# From xorg-build.pl
##############################################################################
# User configuration
sub git_config {
    my ($option) = @_;

    $option = `git-config --global --get $option`;
    $option =~ s/^\s+//;
    $option =~ s/\s+$//;

    return $option;
};

my $libname = git_config("xorg-git.lib-name");
if ($libname eq "") {
    $libname = `uname -m`;
    $libname = $libname =~ m/64/ ? "lib64" : "lib";
}

my $prefix = $options{'p'};
unless (defined($prefix)) {
    $prefix = git_config("xorg-git.dest-dir");
    $prefix = "$ENV{HOME}/anongit.freedesktop.org/build"
	if ($prefix eq "" or not -d $prefix);
    $prefix = "/usr"
	if ($prefix eq "");
}

my $module_path = $options{'m'};
my $module_path = "$prefix/$libname/xorg/modules"
    unless (defined($module_path));

$ENV{LD_LIBRARY_PATH} = "$prefix/$libname:$ENV{LD_LIBRARY_PATH}";
##############################################################################
# End from xorg-build.pl
##############################################################################


print("\n>>> Building X Servers list...\n");
foreach (split("\n", `find $prefix/bin -perm /a+x -a -type f -a -name X\\*`)) {
    $servers{$_} = Cwd::realpath($_);
    # Only know about Xorg as a loader capable X Server
    if ($servers{$_} =~ /Xorg/) {
	$loaders{$servers{$_}} = 1;
    }
}

print("\n>>> Building modules list...\n");
foreach my $path (split(":", $module_path)) {
    foreach (split("\n", `find $path -type f -a -name \\*.so`)) {
	$modules{$_} = Cwd::realpath($_);
    }
}


##############################################################################
sub pathname {
    my ($path) = @_;

    return $options{'f'} ? $path : File::Basename::basename($path);
};


##############################################################################
sub build_dep {
    my ($binary) = @_;

    my ($kind, $type, $hidden, $symbol, $und, $where);

    open(OBJ, "objdump -t -T -w --demangle $binary |") or die("objdump");
    while (<OBJ>) {
	last if /SYMBOL TABLE:/;
    }

    while (<OBJ>) {
	last if /DYNAMIC SYMBOL TABLE:/;

	# remove 8 hex digits and spaces
	s/\S+\s+//;

	# check for known type
	if (s/(\S)\s+(F|O)\s+//) {
	    $kind = $1;
	    $type = $2;
	    s/\S+\s+//;
	}
	# unknown type
	elsif (s/(\S)(\s+)?\*UND\*\s+//) {
	    $kind = $1;
	    $type = "";
	}
	# not interesting, debug info, etc
	else {
	    next;
	}

	# remove 8 hex digits and spaces
	s/\S+\s+//;

	# check for hidden symbol
	if (s/(\.hidden)\s+//) {
	    $hidden = 1;
	}
	else {
	    $hidden = 0;
	}
	
	# symbol name
	if (/(\S+)/) {
	    $symbol = $1;
	}
	else {
	    next;
	    # parse error??
	}

	# symbols to ignore
	next if (not $options{'a'} and grep($_ eq $symbol, @ignore));

	if ($hidden != 0) {
	    $hiddens{$binary}{$symbol} = 1;
	}
	$types{$binary}{$symbol} = $type;
	$weaks{$binary}{$symbol} = $kind if ($kind eq "w");
    }

    while (<OBJ>) {
	# remove 8 hex digits and spaces
	s/\S+\s+//;

	if (s/D(O|F)?\s+\*UND\*//) {
	    $type = $1;
	    $und = 1;
	    $kind = undef;
	}
	elsif (s/w\s+D\s+(\*UND\*)?//) {
	    $type = "";
	    $und = 1;
	    $kind = "w";
	}
	elsif (s/g\s+D(O|F)?\s+\S+//) {
	    $type = $1;
	    $und = 0;
	    $kind = undef;
	}
	# weak symbol
	elsif (s/w\s+D(O|F)\s+\S+//) {
	    $type = $1;
	    $und = 0;
	    $kind = "w";
	}
	else {
	    # *ABS* or parse error??
	    next;
	}

	# remove spaces and 8 hex digits and spaces
	s/\s+\S+\s+//;

	if (/(\S+)\s+(\S+)/) {
	    $where = $1;
	    $symbol = $2;
	}
	elsif (/(\S+)/) {
	    $symbol = $1;
	    $where = undef;
	}
	else {
	    # parse error?
	    next;
	}

	# symbols to ignore
	next if (not $options{'a'} and grep($_ eq $symbol, @ignore));

	if ($where) {
	    $bases{$binary}{$symbol} = $where;
	}

	if ($und != 0) {
	    $undefs{$binary}{$symbol} = 1;
	}
	elsif ($type ne "") {
	    # Set value to 0, to also use as a counter for external
	    # references, if applicable
	    $exports{$binary}{$symbol} = 0;
	    $dynamics{$binary}{$symbol} = $type;
	}

	$weaks{$binary}{$symbol} = $kind if ($kind eq "w");
    }
    close OBJ;
}
##############################################################################


##############################################################################
sub merge_dep {
    my ($binary, $object) = @_;
    
    foreach (keys %{$types{$object}}) {
	$types{$binary}{$_} = $types{$object}{$_}
	    unless defined($types{$binary}{$_});
    }
    foreach (keys %{$exports{$object}}) {
	if ($undefs{$binary}{$_}) {
	    delete($undefs{$binary}{$_});
	}
	$exports{$binary}{$_} = $exports{$object}{$_}
	    unless defined($exports{$binary}{$_});
    }
    foreach (keys %{$undefs{$object}}) {
	$undefs{$binary}{$_} = $undefs{$object}{$_}
	    unless defined($exports{$binary}{$_});
    }

    # Don't provide symbols of libraries to modules if option -s is used
    if (not $options{'s'} or $servers{$binary}) {
	foreach (keys %{$dynamics{$object}}) {
						# Dont store type information
						# or code bellow will not
						# know where it defined.
	    $dynamics{$binary}{$_} = ""		# $dynamics{$object}{$_}
		unless defined($dynamics{$binary}{$_});
	}
    }
}
##############################################################################


##############################################################################
# Check ldd output for extra libraries, and also "cache" the information
print("\n>>> Loading symbol information...\n");
foreach my $binary (keys %servers, keys %modules) {
    print("--> ", pathname($binary), "\n");
    if (grep($_ eq $binary, @objects)) {
	print("**** Parsing $binary twice!\n");
	next;
    }
    push(@objects, $binary);
    build_dep($binary);
    foreach (`ldd $binary`) {
        if (/\s+\S+\s+=>\s+(\S+)\s+\S+/ or /^\s+(\S+)\s+\S+$/) {
	    my $library = Cwd::realpath($1);
	    print("     ", pathname($library));
	    unless (grep($_ eq $library, @objects)) {
		build_dep($library);
	    }
	    else {
		print(" (cached)");
	    }
	    print("\n");
	    push(@objects, $library);
	    $libraries{$binary}{$library} = 1;
	}
    }
}


##############################################################################
# Check for clashes, possibly with library symbols
print("\n>>> Checking symbol clashes...\n");
foreach my $object (keys %servers) {
    foreach my $other (keys %exports) {
	# If a library linked agains't the binary, or a loader capable
	# Xserver and checking a module
	if ($libraries{$object}{$other} or
	    ($loaders{$object} and $modules{$other})) {
	    foreach my $symbol (keys %{$exports{$object}}) {
		if (defined($exports{$other}{$symbol}) and
		    not defined($weaks{$other}{$symbol})) {
		    $clashes{$symbol}{$object} = 1;
		    $clashes{$symbol}{$other} = 1;
		}
	    }
	}
    }
}


##############################################################################
# Print information about clashes
foreach my $symbol (keys %clashes) {
    my $found = 0;
    print(" ** $symbol: ");
    foreach my $object (keys %{$clashes{$symbol}}) {
	if (++$found > 1) {
	    print(", ");
	}
	print(pathname($object));
    }
    print("\n");
}


##############################################################################
# Process ldd output again, this time to "augment" symbol list of
# objects/binaries with the ones in the required libraries
print("\n>>> Checking library dependencies...\n");
foreach my $binary (keys %servers, keys %modules) {
    foreach (`ldd $binary`) {
        if (/\s+\S+\s+=>\s+(\S+)\s+\S+/ or /^\s+(\S+)\s+\S+$/) {
	    merge_dep($binary, Cwd::realpath($1));
	}
    }
}

##############################################################################
# Check shared objects
print("\n>>> Checking undefined symbols...\n");
foreach my $object (keys %servers, keys %modules) {
    print("--> ", pathname($object), "\n");
    foreach my $undefined (keys %{$undefs{$object}}) {
	my $found = 0;
	foreach my $other (keys %dynamics) {
	    # use defined($dynamics{$other}{$undefined}) to also match
	    # inherited symbols from libraries
	    if (defined($dynamics{$other}{$undefined}) and
		($loaders{$other} or $modules{$other})) {
		if (not $dynamics{$other}{$undefined} or
		    not $options{'x'} or
		    not $loaders{$other}) {
		    print("    Symbol $undefined found: ");
		    # check if defined in more than one object
		    # if it is being exporting it from a library
		    foreach (keys %dynamics) {
			if ($dynamics{$_}{$undefined}) {
			    if (++$found > 1) {
				print(", ");
			    }
			    print(pathname($_));
			}
		    }
		    print("\n");
		}
		# Don't print warning if not checking symbols defined
		# in the X Server
		elsif ($dynamics{$other}{$undefined}) {
		    ++$found;
		}
		++$exports{$other}{$undefined};
		goto found;
	    }
	}
	# Check if symbol is in the list of hidden symbols
	# of some shared object
	foreach my $other (keys %hiddens) {
	    if ($hiddens{$object}{$undefined}) {
		print(" ** Hidden symbol $undefined in binary ",
		      pathname($object),
		      " is required by:\n");
		foreach my $key (keys %undefs) {
		    if ($undefs{$key}{$undefined}) {
			print("\t", pathname($key), "\n");
		    }
		}
	    }
	}
	found:
	if ($found == 0) {
	    print(" ** Undefined symbol $undefined\n");
	}
    }
}


##############################################################################
unless ($options{'e'}) {
    print("\n>>> Checking exported symbols not ",
	  "(directly) used in other modules...\n");
    foreach my $object (keys %exports) {
    print "--> ", pathname($object), "\n";
	if ($loaders{$object} or $modules{$object}) {
	    foreach my $symbol (keys %{$exports{$object}}) {
		if ($exports{$object}{$symbol} == 0 and
		    $dynamics{$object}{$symbol}) {
		    print "  $dynamics{$object}{$symbol} $symbol\n";
		}
	    }
	}
    }
}