#!/usr/bin/perl
#
#  dpkg-shlibdeps - Alternative implementation for non-native binaries
#  Copyright (C) 1997-2000  Roman Hodek <roman@hodek.net>
#  Copyright (C) 2004  Nikita Youshchenko <yoush@cs.msu.su>
#  Copyright (C) 2004  Raphael Bossek <bossekr@debian.org>
#  Copyright (c) 2007  Neil Williams <codehelp@debian.org>
#
#  This program 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 program 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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
#

use Debian::DpkgCross;
use Debian::DpkgCross qw(dpkgcross_application detect_arch get_tool convert_ld_library_path);
use POSIX;
use POSIX qw(:errno_h :signal_h);
use warnings;
use strict;
use vars qw( $stdout $varlistfile $fh $lf $varnameprefix @crosslib64formats $shlibsoverride $crossroot $shlibsdefault $shlibslocal $shlibsppext $shlibsppdir %depstrength $dependencyfield @depfields $conffile @libname @libsoname @libpath @libf $objdump $crosslib $crosslib64 @crosslibs $config $crossinc $crossdir @exec @execf %libpathadded @safelibpaths @needtoscan %pathpackages @packages %predefdepfdep %unkdepfdone %unkdepf %defdepf $nthisldd );
my $dpkglibdir= "/usr/lib/dpkg";
push(@INC,$dpkglibdir);
require 'controllib.pl';

&dpkgcross_application();

# Sometimes libraries should be looked for in $crosslib64 instead of $crosslib
# To detect that cases, we will check "file format" line in objdump output and
# check if the result is in the following list.
@crosslib64formats = ("elf64-sparc", "elf64-s390", "elf64-x86-64", "elf64-powerpc");

$dpkglibdir= "/usr/lib/dpkg";

&read_config();
&setup();

$config = &get_config;
$crossinc = $$config{'crossinc'};
$crossdir = $$config{'crossdir'};
$crosslib = $$config{'crosslib'};
$crosslib64 = $$config{'crosslib64'};
$crossroot = $$config{'crossroot'} ? $$config{'crossroot'} : '';
$shlibsoverride= "$crossroot/etc/dpkg/shlibs.override";
$shlibsdefault= "$crossroot/etc/dpkg/shlibs.default";
$shlibslocal= $ENV{"SHLIBSLOCALFILE"} || 'debian/shlibs.local';
$shlibsppdir= "$crossroot/var/lib/dpkg/info";
$shlibsppext= '.shlibs';
$varnameprefix= 'shlibs';
$dependencyfield= 'Depends';
$varlistfile= $ENV{"SUBSTVARSFILE"} || 'debian/substvars';
@depfields= qw(Suggests Recommends Depends Pre-Depends);

sub usage {
	# print original message
	system "dpkg-shlibdeps.orig -h";
	# and our comments...
	print STDERR <<'EOF';

dpkg-cross cross-compiling extension: Recognizes non-native binaries (on which
ldd fails) and treats them differently to extract shlibs information.
EOF
}

my $i = 0;
grep( $depstrength{$_} = ++$i, @depfields );

# parse options
while (@ARGV) {
	$_ = shift(@ARGV);
	if (m/^-T/) {
		$varlistfile = $';#'##
	}
	elsif (m/^-p(\w[-:0-9A-Za-z]*)$/) {
		$varnameprefix = $1;
	}
	elsif (m/^-L/) {
		$shlibslocal = $';#'##
	}
	elsif (m/^-O$/) {
		$stdout = 1;
	}
	elsif (m/^-h$/) {
		&usage();
		exit 0;
	}
	elsif (m/^-c/) {
		$conffile = $';#'##
	}
	elsif (m/^-d/) {
		$dependencyfield = capit($');#'##
		defined($depstrength{$dependencyfield}) ||
			warn("unrecognised dependency field '$dependencyfield'\n");
	}
	elsif (m/^-e/) {
		push( @exec, $' );#'##
		push( @execf, $dependencyfield );
	}
	elsif (m/^-/) {
		&usageerr( "unknown option \`$_'" );
	}
	else {
		push( @exec, $_ );
		push( @execf, $dependencyfield );
	}
}
@exec || usageerr( "need at least one executable" );

# Remove most of LD_LIBRARY_PATH. We don't use it, and it can
# lead to attempts to link non-native libraries into tools that
# we call. At least cross-building of zlib was affected by this.
&convert_ld_library_path();

# Look at all given executables and try to extract the names of linked shared
# libraries. For multiple executables one and the same library can be referenced
# more then once. Only one the first library will be remembered. In other words,
# the list of libraries is unique.
@libname = @libsoname = @libpath = @libf = qw();
for( $i = 0; $i <= $#exec; $i++ ) {
	# Use detect_arch() to find out architecture of $exec[$i] (and if
	# it is executable or not).
	my $arch = &detect_arch($exec[$i]);
	next unless $arch; # Skip unknown files
	$objdump = &get_tool($arch, "objdump", $ENV{"DPKGCROSSMODE"});
	# Look for NEEDED entries in the .dynamic section of an ELF
	# executable. There all needed libraries are listed (without a
	# path, but that should always be $crosslib for our purposes).
	open( PIPE, "LC_ALL=C $objdump --private-headers -- $exec[$i] 2>&1 |" )
		|| syserr( "cannot exec $objdump" );

	# Counts how many library references exists for this executable.
	$nthisldd = 0;
	my $thiscrosslib = $crosslib;
	while( <PIPE> ) {
		chomp;
		my ($libname_, $libsoname_, $p);
		if (/^\s*\S+:\s*file\s+format\s+(\S+)\s*$/) {
			if (grep {$_ eq $1} @crosslib64formats) {
				$thiscrosslib = $crosslib64;
			}
			next;
		}
		elsif (/^\s*NEEDED\s+(lib\S+)\.so\.(\S+)$/) {
			$libname_ = $1;
			$libsoname_ = $2;
			$p = "$thiscrosslib/$1.so.$2";
		}
		# Alternate form: used e.g. for libdb2.4 with 'libdb-4.2.so' soname
		elsif (/^\s*NEEDED\s+(lib[^-]+)-(.+)\.so$/) {
			$libname_ = $1;
			$libsoname_ = $2;
			$p = "$thiscrosslib/$1-$2.so";
		}
		else {
			# No library reference found so continue with the next line.
			next;
		}

		# An another library found. Check if we know already the library. If not,
		# continue with storing additional information for future post-proceeding.
		$nthisldd++;
		$p =~ s/^\Q$crossroot\E// if $crossroot;
		if (!$libpathadded{$p}++) {
			push( @libname, $libname_ );
			push( @libsoname, $libsoname_ );
			push( @libpath, $p );
			push( @libf, $execf[$i] );
			push( @crosslibs, $thiscrosslib ); # used for diagnostic only
		}
	}
	close( PIPE );
	$? && subprocerr( "$objdump on \`$exec[$i]'" );
	$nthisldd || warn( "no library references found in '$exec[$i]'\n" );
}

# A library may be a part of package being built.
# In this case, dpkg --search will not find it (unless an earlier version
# of the package is installed).
# So we should not pass to dpkg paths to any libs defined in shlibs.local
# and shlibs.override
for( $i = 0; $i <= $#libname; $i++ ) {
	&scanshlibsfile( $shlibslocal, $libname[$i], $libsoname[$i], $libf[$i] ) && next;
	&scanshlibsfile( $shlibsoverride, $libname[$i], $libsoname[$i], $libf[$i] ) && next;
	push( @safelibpaths, $libpath[$i] );
	$needtoscan[$i] = 1;
}

# use of $# is deprecated (output format of printed numbers) in perl.
if ($#safelibpaths >= 0) {
#	grep(s/\[\?\*/\\$&/g, @safelibpaths);
	my $c;
	defined($c = open(P,"-|")) || syserr("cannot fork for dpkg --search");
	if (!$c) {
		$ENV{'LC_ALL'} = 'C';
		my @args = ("dpkg", "--search");
		push( @args, "--root=$crossroot" ) if $crossroot;
		push( @args, "--", @safelibpaths );
		exec(@args);
#		syserr("cannot exec dpkg") if system(@args);
	}
	while (<P>) {
		chomp;
		if (m/^local diversion |^diversion by/) {
			warn("diversions involved - output may be incorrect.\n");
			print(STDERR " $_\n") || syserr("write diversion info to stderr");
		} elsif (m/^(\S+(, \S+)*): (\/.+)$/) {
			$pathpackages{$+}= $1;
		} else {
			warn("unknown output from dpkg --search: '$_'\n");
		}
	}
	close(P);
	$? && subprocerr("dpkg --search");
}

LIB: for( $i = 0; $i <= $#libname; $i++ ) {

	$needtoscan[$i] || next;

	if (!defined($pathpackages{$libpath[$i]})) {
		warn("could not find any packages for $crossroot$libpath[$i]".
			" ($libname[$i].so.$libsoname[$i])\n");
	} else {
	@packages= split(/, /,$pathpackages{$libpath[$i]});
	for my $p (@packages) {
		&scanshlibsfile("$shlibsppdir/$p$shlibsppext", $libname[$i],$libsoname[$i],$libf[$i])
				&& next LIB;
		}
	}
	&scanshlibsfile( $shlibsdefault, $libname[$i], $libsoname[$i], $libf[$i] ) && next;

	warn("unable to find dependency information for ".
		"shared library $libname[$i] (soname $libsoname[$i], path ".
		($crossroot ? $crossroot : $crosslibs[$i])."/$libpath[$i], ".
		"dependency field $libf[$i])\n");
}

sub scanshlibsfile {
	my( $fn, $ln, $lsn, $lf ) = @_;
	my( $da, $dv, $dk );

	$fn= "./$fn" if $fn =~ m/^\s/;
	if (!open( SLF,"< $fn" )) {
		$! == ENOENT || syserr( "unable to open shared libs info file '$fn'");
		return 0;
	}
	while (<SLF>) {
		s/\s*\n$//;
		next if m/^\#/;

		if (!m/^\s*(\S+)\s+(\S+)/) {
			warn( "shared libs info file '$fn' line $.: bad line '$_'\n" );
			next;
		}
		next if $1 ne $ln || $2 ne $lsn;
		$da= $';#'##
		for $dv (split(/,/,$da)) {
			$dv =~ s/^\s+//; $dv =~ s/\s+$//;
			if (defined($depstrength{$lf})) {
				if (!defined($predefdepfdep{$dv}) ||
					$depstrength{$predefdepfdep{$dv}} < $depstrength{$lf}) {
					$predefdepfdep{$dv}= $lf;
				}
			} else {
				$dk= "$lf: $dv";
				if (!defined($unkdepfdone{$dk})) {
					$unkdepfdone{$dk}= 1;
					$unkdepf{$lf}.= ', ' if length($unkdepf{$lf});
					$unkdepf{$lf}.= $dv;
				}
			}
		}
		return 1;
	}
	close(SLF);
	return 0;
}

if (!$stdout) {
	$varlistfile = "./$varlistfile" if $varlistfile =~ m/^\s/;

	open( Y, "> $varlistfile.new" ) ||
		syserr( "open new substvars file \`$varlistfile.new'" );
	my @fowner = getfowner();
	chown( @fowner, "$varlistfile.new" ) ||
		syserr( "chown of \`$varlistfile.new'" );

	if (open( X, "<$varlistfile" )) {
		while( <X> ) {
			s/\n$//;
			next if m/^(\w[-:0-9A-Za-z]*):/ && $1 eq $varnameprefix;
			print( Y "$_\n" ) ||
				syserr( "copy old entry to new varlist ".
					"file \`$varlistfile.new'" );
		}
	}
	elsif ($! != ENOENT) {
		syserr( "open old varlist file \`$varlistfile' for reading" );
	}
	$fh= 'Y';
	}
else {
	$fh= 'STDOUT';
}

for my $dv (sort keys %predefdepfdep) {
	$lf = $predefdepfdep{$dv};
	next if (!defined($defdepf{$lf}));
	$defdepf{$lf} .= ', ' if length($defdepf{$lf});
	$defdepf{$lf} .= $dv;
}
for $lf (reverse @depfields) {
	next unless defined($defdepf{$lf});
	print( $fh "$varnameprefix:$lf=$defdepf{$lf}\n" )
		|| syserr( "write output entry" );
}
for $lf (sort keys %unkdepf) {
	print( $fh "$varnameprefix:$lf=$unkdepf{$lf}\n" )
		|| syserr( "write userdef output entry" );
}
close($fh) || syserr( "close output" );
if (!$stdout) {
	rename( "$varlistfile.new",$varlistfile ) ||
		syserr( "install new varlist file \`$varlistfile'" );
}

