openbsd-ports/infrastructure/package/check-lib-depends

#!/usr/bin/perl

# $OpenBSD: check-lib-depends,v 1.15 2008/02/20 07:04:25 espie Exp $
# Copyright (c) 2004 Marc Espie <espie@openbsd.org>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

# check all packages in the current directory, and report library issues

use strict;
use warnings;

use File::Find;
use File::Spec;
use File::Path;
use File::Basename;
use OpenBSD::PackageLocator;
use OpenBSD::PackageInfo;
use OpenBSD::PackingList;
use OpenBSD::SharedLibs;
use File::Temp;
use Getopt::Std;

our ($opt_o, $opt_d, $opt_f, $opt_F, $opt_B, $opt_s, $opt_O);
my $errors = 0;


# FileSource: where we get the files to analyze
package FileSource;

# FakeFileSource : file system
package FakeFileSource;
our @ISA=(qw(FileSource));
sub new
{
	my ($class, $location) = @_;
	bless {location => $location }, $class
}

sub retrieve
{
	my ($self, $item) = @_;
	return $self->{location}.$item->fullname;
}

sub skip
{
}

sub clean
{
}

# RealFileSource: package archive
package RealFileSource;
our @ISA=(qw(FileSource));
sub new
{
	my ($class, $handle, $location) = @_;
	bless {handle => $handle, location => $location }, $class;
}

sub prepare_to_extract
{
	my ($self, $item) = @_;
	require OpenBSD::ArcCheck;
	my $o = $self->{handle}->next;
	$o->{cwd} = $item->cwd;
	if (!$o->check_name($item)) {
		die "Error checking name for $o->{name} vs. $item->{name}\n";
	}
	$o->{name} = $item->fullname;
	$o->{destdir} = $self->{location};
	return $o;
}

sub extracted_name
{
	my ($self, $item) = @_;
	return $self->{location}.$item->fullname;
}
sub retrieve
{
	my ($self, $item) = @_;
	my $o = $self->prepare_to_extract($item);
	$o->create;
	return $self->extracted_name($item);
}

sub skip
{
	my ($self, $item) = @_;
	my $o = $self->prepare_to_extract($item);
	$self->{handle}->skip;
}

sub clean
{
	my ($self, $item) = @_;
	unlink($self->extracted_name($item));
}

# Recorder: how we keep track of which binary uses which library
package Recorder;
sub new
{
	my $class = shift;
	return bless {}, $class;
}

sub reduce_libname
{
	my ($self, $lib) = @_;
	$lib =~ s/^(.*\/)?lib(.*)\.so\.(\d+)\.\d+$/$2.$3/;
	return $lib;
}

sub libs
{
	my $self = shift;
	return keys %$self;
}

sub record_rpath
{
}

# SimpleRecorder: remember one single binary for each library
package SimpleRecorder;
our @ISA=(qw(Recorder));
sub record
{
	my ($self, $lib, $filename) = @_;
	$self->{$self->reduce_libname($lib)} = $filename;
}

sub binary
{
	my ($self, $lib) = @_;
	return $self->{$lib};
}

# AllRecorder: remember all binaries for each library
package AllRecorder;
our @ISA=(qw(Recorder));
sub record
{
	my ($self, $lib, $filename) = @_;
	push(@{$self->{$self->reduce_libname($lib)}}, $filename);
}

sub binaries
{
	my ($self, $lib) = @_;
	return @{$self->{$lib}};
}
sub binary
{
	my ($self, $lib) = @_;
	return $self->{$lib}->[0];
}

sub dump
{
	my ($self, $fh) = @_;
	for my $lib (sort $self->libs) {
		print $fh "$lib:\t\n";
		for my $binary (sort $self->binaries($lib)) {
			print $fh "\t$binary\n";
		}
	}
}

package DumpRecorder;
our @ISA=(qw(Recorder));
sub record
{
	my ($self, $lib, $filename) = @_;
	push(@{$self->{$filename}->{libs}}, $lib);
}

sub record_rpath
{
	my ($self, $path, $filename) = @_;
	push(@{$self->{$filename}->{rpath}}, $path);
}

sub dump
{
	my ($self, $fh) = @_;
	while (my ($binary, $v) = each %$self) {
		print $fh $binary;
		if (defined $v->{rpath}) {
			print $fh "(", join(':', @{$v->{rpath}}), ")";
		}
		print $fh ": ", join(',', @{$v->{libs}}), "\n";
	}
}

sub retrieve
{
	my ($self, $filename) = @_;
	open(my $fh, '<', $filename) or die "Can't read $filename: $!";
	local $_;
	while (<$fh>) {
		chomp;
		if (m/^(.*?)\:\s(.*)$/) {
			my ($binary, $libs) = ($1, $2);
			if ($binary =~ m/^(.*)\(.*\)$/) {
				$binary = $1;
			}
			my @libs = split(/,/, $libs);
			$self->{$binary}= \@libs;
		} else {
			print "Can't parse $_\n";
		}
	}
	close $fh;
}

# Issue: intermediate objects that record problems with libraries
package Issue;
sub new
{
	my ($class, $lib, $binary, @packages) = @_;
	bless { lib => $lib, binary => $binary, packages => \@packages }, 
		$class;
}

sub stringize
{
	my $self = shift;
	my $string = $self->{lib};
	if (@{$self->{packages}} > 0) {
		$string.=" from ".join(',', @{$self->{packages}});
	}
	return $string." ($self->{binary})";
}

sub do_record_wantlib
{
	my ($self, $h) = @_;
	my $want = $self->{lib};
	$want =~ s/\.\d+$//;
	$h->{$want} = 1;
}

sub record_wantlib
{
}

sub print_error_not_reachable
{
	return 0;
}

package Issue::system_lib;
our @ISA=(qw(Issue));
sub print
{
	my $self = shift;
	print "WANTLIB:       ", $self->stringize, " (system lib)\n";
}

sub record_wantlib
{
	&Issue::do_record_wantlib;
}
package Issue::direct_dependency;
our @ISA=(qw(Issue));
sub print
{
	my $self = shift;
	print "LIB_DEPENDS:   ", $self->stringize, "\n";
}

package Issue::indirect_dependency;
our @ISA=(qw(Issue));
sub print
{
	my $self = shift;
	print "WANTLIB:       ", $self->stringize, "\n";
}

sub record_wantlib
{
	&Issue::do_record_wantlib;
}

package Issue::not_reachable;
our @ISA=(qw(Issue));
sub print
{
	my $self = shift;
	print "Missing lib:   ", $self->stringize, " (NOT REACHABLE)\n";
}

sub print_error_not_reachable
{
	my $self = shift;
	print "Bogus WANTLIB: ", $self->stringize, " (NOT REACHABLE)\n";
	return 1;
}

package MyFile;
our @ISA=(qw(OpenBSD::PackingElement::FileBase));

sub fullname
{
	my $self = shift;
	return $self->{name};
}

package OpenBSD::PackingElement;
sub record_needed_libs
{
}

sub find_libs
{
}

sub register_libs
{
}

sub depwalk
{
}

package OpenBSD::PackingElement::Wantlib;
sub register_libs
{
	my ($item, $t) = @_;
	my $name = $item->{name};
	$name =~ s/^(.*\/)?(.*)\.(\d+)\.\d+$/$2.$3/;
	$t->{$name} = 1;
}

package OpenBSD::PackingElement::Lib;

sub register_libs
{
	my ($item, $t) = @_;
	if ($item->fullname =~ m/^(.*\/)?lib(.*)\.so\.(\d+)\.\d+$/) {
		$t->{"$2.$3"} = 2;
	}
}

package OpenBSD::PackingElement::FileBase;
use File::Basename;
sub find_libs
{
	my ($item, $dest, $special) = @_;
	my $fullname = $item->fullname;
	if (defined $special->{$fullname}) {
		for my $lib (@{$special->{$fullname}}) {
			$dest->record($lib, $fullname);
		}
	}
}

sub record_needed_libs
{
	my ($item, $dest, $source) = @_;
	my $fullname = File::Spec->canonpath($item->fullname);

	my $linux_bin = 0;
	my $freebsd_bin = 0;
	if ($fullname =~ m,^/usr/local/emul/redhat/,) {
		$linux_bin = 1;
	}
	if ($fullname =~ m,^/usr/local/emul/freebsd/,) {
		$freebsd_bin = 1;
	}
	if ($linux_bin || $freebsd_bin || $item->{symlink} || $item->{link}) {
		$source->skip($item);
		return;
	}
	my $n = $source->retrieve($item);
	my $cmd;
	if ($main::opt_o) {
		open($cmd, "-|", "ldd", "-f", "NEEDED lib%o.so.%m.%n\n", $n) or die "open: $!";
	} else {
		unless (open($cmd, '-|')) {
			open(STDERR, '>', '/dev/null');
			exec('objdump', '-p', $n) or die "exec: $!";
		}
	}
	my @l;
	while(my $line = <$cmd>) {
		if ($line =~ m/^\s+NEEDED\s+(.*?)\s*$/) {
			my $lib = $1;
			push(@l, $lib);
			# detect linux binaries
			if ($lib eq 'libc.so.6') {
				$linux_bin = 1;
			}
		} elsif ($line =~ m/^\s+RPATH\s+(.*)\s*$/) {
			my $p = {};
			for my $path (split /\:/, $1) {
				next if $path eq '/usr/local/lib';
				next if $path eq '/usr/X11R6/lib';
				next if $path eq '/usr/lib';
				$p->{$path} = 1;
			}
			for my $path (keys %$p) {
				$dest->record_rpath($path, $fullname);
			}
		}
	}
	close($cmd);
	# okay, we are not OpenBSD, we don't have sensible names
	unless ($linux_bin or $freebsd_bin) {
		for my $lib (@l) {
			# don't look for modules
			next if $lib =~ m/\.so$/;
			$dest->record($lib, $fullname);
		}
	}
	$source->clean($item);
}

package OpenBSD::PackingElement::Dependency;

sub depwalk
{
	my ($self, $h) = @_;
	$h->{$self->{def}} = $self->{pkgpath};
}

package main;

getopts('od:f:B:F:s:O:');

my $dependencies = {};

sub register_dependencies
{
	my $plist = shift;
	my $pkgname = $plist->pkgname;
	my $h = {};
	$dependencies->{$pkgname} = $h;
	$plist->depwalk($h);
}

sub get_plist
{
	my ($pkgname, $pkgpath) = @_;

	# try physical package
	if (defined $opt_d) {
		my $location = "$opt_d/$pkgname.tgz";

		my $true_package = OpenBSD::PackageLocator->find($location);
		if ($true_package) {
			my $dir = $true_package->info;
			if (-d $dir) {
				my $plist = OpenBSD::PackingList->fromfile($dir.CONTENTS);
				$true_package->close;
				rmtree($dir);
				return $plist;
			}
		}
	}
	# ask the ports tree
	print "Asking ports for dependency $pkgname($pkgpath)\n";
	my $portsdir = $ENV{PORTSDIR} || "/usr/ports";
	my $make = $ENV{MAKE} || "make";
	open my $fh, "cd $portsdir && env -i SUBDIR=$pkgpath ECHO_MSG=: make print-plist-with-depends |" or return undef;
	my $plist = OpenBSD::PackingList->read($fh);
	close $fh;
	return $plist;
}

sub handle_dependency
{
	my ($pkgname, $pkgpath) = @_;
	my $plist = get_plist($pkgname, $pkgpath);

	if (!defined $plist || !defined $plist->pkgname) {
		print "Error: can't solve dependency for $pkgname/$pkgpath\n";
		return;
	}

	if ($plist->pkgname ne $pkgname) {
		delete $dependencies->{$pkgname};
		for my $p (keys %$dependencies) {
			if ($dependencies->{$p}->{$pkgname}) {
				$dependencies->{$p}->{$plist->pkgname} =
				    $dependencies->{$p}->{$pkgname};
				delete $dependencies->{$p}->{$pkgname};
			}
		}
	}

	register_dependencies($plist);
	OpenBSD::SharedLibs::add_libs_from_plist($plist);

	return $plist->pkgname;
}

sub report_lib_issue
{
	my ($plist, $lib, $binary) = @_;

	OpenBSD::SharedLibs::add_libs_from_system('/');
	my $libspec = "$lib.0";
	my $want = $lib;
	$want =~ s/\.\d+$//;
	for my $dir (qw(/usr /usr/X11R6)) {
		my @r = OpenBSD::SharedLibs::lookup_libspec($dir, $libspec);
		if (grep { $_ eq 'system' } @r) {
			return Issue::system_lib->new($lib, $binary);
		}
	}

	while (my ($p, $pkgpath) = each %{$dependencies->{$plist->pkgname}}) {
		next if defined $dependencies->{$p};
		handle_dependency($p, $pkgpath);
	}

	my @r = OpenBSD::SharedLibs::lookup_libspec('/usr/local', $libspec);
	if (@r > 0) {
		for my $p (@r) {
			if (defined $dependencies->{$plist->pkgname}->{$p}) {
				return Issue::direct_dependency->new($lib, $binary, $p);
			}
		}
	}
	# okay, let's walk for WANTLIB
	my @todo = %{$dependencies->{$plist->pkgname}};
	my $done = {};
	while (@todo >= 2) {
		my $path = pop @todo;
		my $dep = pop @todo;
		next if $done->{$dep};
		$done->{$dep} = 1;
		$dep = handle_dependency($dep, $path)
		    	unless defined $dependencies->{$dep};
		next if !defined $dep;
		$done->{$dep} = 1;
		push(@todo, %{$dependencies->{$dep}});
	}
	@r = OpenBSD::SharedLibs::lookup_libspec('/usr/local', $libspec);
	for my $p (@r) {
		if (defined $done->{$p}) {
			return Issue::indirect_dependency->new($lib, $binary, $p);
		}
	}
	return Issue::not_reachable->new($lib,, $binary, @r);
}

sub print_list
{
	my ($head, $h) = @_;

	my $line = "";
	for my $k (sort keys %$h) {
		if (length $line > 50) {
			print $head, $line, "\n";
			$line = "";
		}
		$line .= ' '.$k;
	}
	if ($line ne '') {
		print $head, $line, "\n";
	}
}

sub analyze 
{
	my ($plist, $source, @l) = @_;

	my $pkgname = $plist->pkgname;
	my $needed_libs = $opt_f ? AllRecorder->new : SimpleRecorder->new;
	my $has_libs = {};
	if ($opt_s) {
		my $special =  DumpRecorder->new;
		$special->retrieve($opt_s);
		$plist->find_libs($needed_libs, $special);
	} else {
		$plist->record_needed_libs($needed_libs, $source, @l);
	}
	$plist->register_libs($has_libs);

	if (!defined $dependencies->{$pkgname}) {
		register_dependencies($plist);
		OpenBSD::SharedLibs::add_libs_from_plist($plist);
	}
	my $r = { wantlib => {}, libdepends => {}, wantlib2 => {} };
	for my $lib (sort $needed_libs->libs) {
		my $fullname = $needed_libs->binary($lib);
		if (!defined $has_libs->{$lib}) {
			my $issue = report_lib_issue($plist, $lib, $fullname);
			$issue->print;
			$errors++;
			$issue->record_wantlib($r->{wantlib});
		} elsif ($has_libs->{$lib} == 1) {
			my $issue = report_lib_issue($plist, $lib, $fullname);
			if ($issue->print_error_not_reachable) {
				$errors++;
			}
		}
		$has_libs->{$lib} = 2;
	}
	for my $k (sort keys %$has_libs) {
		my $v = $has_libs->{$k};
		next if $v == 2;
		print "Extra:         $k\n";
	}
	print_list("\tWANTLIB +=", $r->{wantlib});
	if ($opt_f) {
	    $needed_libs->dump(\*STDOUT);
	}
}

sub do_pkg
{
	my $pkgname = shift;

	print "\n$pkgname:\n";
	my $true_package = OpenBSD::PackageLocator->find($pkgname);
	return 0 unless $true_package;
	my $dir = $true_package->info;
	# twice read
	return 0 unless -d $dir;
	my $plist = OpenBSD::PackingList->fromfile($dir.CONTENTS);
	if ($opt_B) {
		analyze($plist, FakeFileSource->new($opt_B));
	} else {
		my $temp = File::Temp::mkdtemp("/tmp/zoinx.XXXXXXXXXX");
		analyze($plist, RealFileSource->new($true_package, $temp));
		rmtree($temp);
	}
	$true_package->close;
	$true_package->wipe_info;
	$plist->forget;
	return 1;
}

sub do_plist
{
	my $plist = OpenBSD::PackingList->read(\*STDIN);
	if (!defined $plist->{name}) {
		print STDERR "Error reading plist\n";
		$errors++;
	} else {
		my $pkgname = $plist->pkgname;
		print "\n$pkgname:\n";
		analyze($plist, FakeFileSource->new($opt_B));
	}
}

if ($opt_F) {
	my $recorder = DumpRecorder->new;
	my $cwd = $opt_F;
	my $source = FakeFileSource->new($opt_F);
	File::Find::find({
		wanted => sub {
		    return unless -f $_;
		    my $name = $_;
		    $name =~ s/^\Q$opt_F\E//;
		    # XXX hack FileBase object;
		    my $i = bless {name => $name}, "MyFile";
		    $i->record_needed_libs($recorder, $source);
		},
		no_chdir => 1 }, $opt_F);
	if ($opt_O) {
		open my $fh, '>', $opt_O or die "Can't write to $opt_O: $!";
		$recorder->dump($fh);
		close $fh;
	} else {
		$recorder->dump(\*STDOUT);
	}
	exit(0);
}
if (@ARGV == 0 && defined $opt_B) {
	do_plist();
} else {
    for my $pkgname (@ARGV) {
	    do_pkg($pkgname);
    }
}

exit($errors ? 1 : 0);