# shared-libs -- lintian check script -*- perl -*-

# Copyright (C) 1998 Christian Schwarz
#
# 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, you can find it on the World Wide
# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.

package Lintian::shared_libs;
use strict;

use File::Basename;

use Lintian::Data;
use Dep;
use Tags;
use Util;

sub run {

# Libraries that should only be used in the presence of certain capabilities
# may be located in subdirectories of the standard ldconfig search path with
# one of the following names.
my %hwcap_dir = map { $_ => 1 }
    qw( i486 i586 i686 cmov tls );

# The following architectures should always have a STACK setting in shared
# libraries to disable executable stack.  Other architectures don't always add
# this section and therefore can't be checked.
my %stack_arches = map { $_ => 1 }
    qw( alpha
	amd64
	i386
	m68k
	powerpc
	s390
	sparc
      );

my $ldconfig_dirs = Lintian::Data->new('shared-libs/ldconfig-dirs');
my $file;
my $must_call_ldconfig;
my $postrm = "control/postrm";
my $postinst = "control/postinst";
my $preinst = "control/preinst";
my $prerm = "control/prerm";
my $shlibs_control_file = "control/shlibs";
my $symbols_control_file = "control/symbols";
my %SONAME;
my %INTERP;
my %STACK;
my %TEXTREL;
my %objsomething;
my %sharedobject;
my %index_info;
my %link_info;
my @shlibs;
my @words;

# ---end-of-configuration-part---

my $pkg = shift;
my $type = shift;

# 1st step: get info about shared libraries installed by this package
open(IN, '<', "objdump-info")
    or fail("cannot find objdump-info for $type package $pkg");
while (<IN>) {
    chop;

    #skip blank lines
    next if m/^\s*$/o;

    if (m/^-- (\S+)\s*$/o) {
	$file = $1;
	$file =~ s,^(\./)?,,;
    } elsif (m/^\s*SONAME\s+(\S+)/o) {
	$SONAME{$file} = $1;
    } elsif (m/^\s*TEXTREL\s/o) {
        $TEXTREL{$file} = 1;
    } elsif (m/^\s*INTERP\s/) {
	$INTERP{$file} = 1;
    } elsif (m/^\s*STACK\s/) {
	$STACK{$file} = 0;
    } else {
        if (defined $STACK{$file} and $STACK{$file} eq 0) {
	    m/\sflags\s+(\S+)/o;
	    $STACK{$file} = $1;
	}
	else {
	    $objsomething{$file} = 1;
	}
    }
}
close(IN);

open (IN, '<', "file-info")
    or fail("cannot find file-info for $type package $pkg");
while (<IN>) {
    chomp;
    # with file names containing colons and spaces, we're fucked.
    m/^(?:\.\/)?(.+?):\s+(.*)$/o or fail("unrecognized file(1) output: $_");
    my ($file,$info) = ($1,$2);
    if ($info =~ m/^[^,]*\bELF\b/ && $info =~ m/shared object/) {
	$sharedobject{$file} = 1;
    }
}
close(IN);

# 2nd step: read package contents
my %files;
open(IN, '<', "index") or fail("cannot open index file index: $!");
while (<IN>) {
    chop;
    @words = split(/\s+/o, $_, 6);
    my $perm = $words[0];
    my $cur_file = $words[5];
    $cur_file =~ s,^(\./),,;
    $cur_file =~ s/ link to .*//;

    if ($perm =~ m/^l/) {
	my $link;
	($cur_file, $link) = split(' -> ', $cur_file);
	$link_info{$cur_file} = $link;
    }
    $index_info{$cur_file} = 1;
    $files{$cur_file} = $perm;
}

for (keys %files) {
    my ($cur_file, $perm) = ($_, $files{$_});

    # shared library?
    if (exists $SONAME{$cur_file} or 
	($link_info{$cur_file} and exists $SONAME{abs_path(dirname($cur_file)."/".$link_info{$cur_file})})) {
	# yes!!

	my ($real_file, $real_perm);
	if ($SONAME{$cur_file}) {
	    $real_file = $cur_file;
	    $real_perm = $perm;
	} else {
	    $real_file = abs_path(dirname($cur_file)."/".$link_info{$cur_file});
	    $real_perm = $files{$real_file} || $perm;
	}

	# Now that we're sure this is really a shared library, report on
	# non-PIC problems.
        if ($cur_file eq $real_file and $TEXTREL{$cur_file}) {
            tag "shlib-with-non-pic-code", "$cur_file";
        }

        # don't apply the permission checks to links
        # since this only results in doubled messages
        if ($cur_file eq $real_file) { 
            # executable?
            if ($real_perm =~ m/x/) {
                # yes.  But if the library has an INTERP section, it's designed
                # to do something useful when executed, so don't report an error.
                tag "shlib-with-executable-bit", $cur_file, sprintf("%04o",perm2oct($real_perm))
                    unless $INTERP{$real_file};
            } elsif ($real_perm ne '-rw-r--r--') {
                # bad permissions
                tag "shlib-with-bad-permissions", $cur_file, sprintf("%04o",perm2oct($real_perm));
            }
        }

	# Installed in a directory controlled by the dynamic linker?  We have
	# to strip off directories named for hardware capabilities.
	my $dirname = dirname($cur_file);
	my $last;
	do {
	    $dirname =~ s%/([^/]+)$%%;
	    $last = $1;
	} while ($last && $hwcap_dir{$last});
	$dirname .= "/$last" if $last;
	if ($ldconfig_dirs->known($dirname)) {
	    # yes! so postinst must call ldconfig
	    $must_call_ldconfig = $real_file;
	}

	# executable stack.  We can only warn about a missing section on some
	# architectures.  Only warn if there's an Architecture field; if
	# that's missing, we'll already be complaining elsewhere.
	if (exists $objsomething{$cur_file}) {
	    if (not defined $STACK{$cur_file}) {
		if (open(FH, '<', "fields/architecture")) {
		    my $arch = <FH>;
		    close FH;
		    chomp $arch;
		    tag "shlib-without-PT_GNU_STACK-section", $cur_file
			if $stack_arches{$arch};
		}
	    } elsif ($STACK{$cur_file} ne "rw-") {
		tag "shlib-with-executable-stack", $cur_file;
	    }
	}
    } elsif (exists $objsomething{$cur_file}
	     && $ldconfig_dirs->known(dirname($cur_file))
	     && exists $sharedobject{$cur_file}) {
	tag "sharedobject-in-library-directory-missing-soname", "$cur_file";
    }
}

close(IN);

# 3rd step: check if shlib symlinks are present and in correct order
for my $shlib_file (keys %SONAME) {
    # file found?
    if (not exists $index_info{$shlib_file}) {
	fail("shlib $shlib_file not found in package (should not happen!)");
    }

    my ($dir, $shlib_name) = $shlib_file =~ m,(.*)/([^/]+)$,;

    # not a public shared library, skip it
    next unless $ldconfig_dirs->known($dir);

    # symlink found?
    my $link_file = "$dir/$SONAME{$shlib_file}";
    if (not exists $index_info{$link_file}) {
	tag "ldconfig-symlink-missing-for-shlib", "$link_file $shlib_file $SONAME{$shlib_file}";
    } else {
	# $link_file really another file?
	if ($link_file eq $shlib_file) {
	    # the library file uses its SONAME, this is ok...
	} else {
	    # $link_file really a symlink?
	    if (exists $link_info{$link_file}) {
		# yes.

		# $link_file pointing to correct file?
		if ($link_info{$link_file} eq $shlib_name) {
		    # ok.
		} else {
		    tag "ldconfig-symlink-referencing-wrong-file", "$link_file -> $link_info{$link_file} instead of $shlib_name";
		}
	    } else {
		tag "ldconfig-symlink-is-not-a-symlink", "$shlib_file $link_file";
	    }

	    # symlink after shlib?
	    if ($index_info{$link_file} < $index_info{$shlib_file}) {
		tag "ldconfig-symlink-before-shlib-in-deb", "$link_file";
	    }
	}
    }

    # determine shlib link name (w/o version)
    $link_file =~ s/\.so.*$/.so/o;

    # -dev package?
    if ($pkg =~ m/\-dev$/o) {
	# yes!!

	# need shlib symlink
	if (not exists $index_info{$link_file}) {
	    tag "dev-pkg-without-shlib-symlink", "$shlib_file $link_file";
	}
    } else {
	# no.

	# shlib symlink may not exist.
	# if shlib doesn't _have_ a version, then $link_file and $shlib_file will
	# be equal, and it's not a development link, so don't complain.
	if (exists $index_info{$link_file} and $link_file ne $shlib_file) {
	    tag "non-dev-pkg-with-shlib-symlink", "$shlib_file $link_file";
	}
    }
}

# 4th step: check shlibs control file
my $version;
if (open (VERSION, '<', 'fields/version')) {
    $version = <VERSION>;
    close VERSION;
    chomp $version;
}
my $provides = $pkg . "( = $version)";
if (open (PROVIDES, '<', 'fields/provides')) {
    my $line = <PROVIDES>;
    close PROVIDES;
    chomp $line;
    $provides .= ", $line";
}
$provides = Dep::parse($provides);

my %shlibs_control;
my %symbols_control;

@shlibs = grep { !m,^lib/libnss_[^.]+\.so(\.[0-9]+)$, } keys %SONAME;
if ($#shlibs == -1) {
    # no shared libraries included in package, thus shlibs control file should
    # not be present
    if (-f $shlibs_control_file) {
	tag "pkg-has-shlibs-control-file-but-no-actual-shared-libs", "";
    }
} else {
    # shared libraries included, thus shlibs control file has to exist
    if (not -f $shlibs_control_file) {
	if ($type ne 'udeb') {
	    for my $shlib (@shlibs) {
		# skip it if it's not a public shared library
		next unless $ldconfig_dirs->known(dirname($shlib));
		tag "no-shlibs-control-file", "$shlib";
	    }
	}
    } else {
	my %shlibs_control_used;
	my @shlibs_depends;
	open(SHLIBS, '<', $shlibs_control_file)
	    or fail("cannot open shlibs control file $shlibs_control_file for reading: $!");
	while (<SHLIBS>) {
	    chop;
	    next if m/^\s*$/ or /^#/;

	    # We exclude udebs from the checks for correct shared library
	    # dependencies, since packages may contain dependencies on
	    # other udeb packages.
	    my $udeb="";
	    $udeb = "udeb: " if s/^udeb:\s+//o;
	    @words = split(/\s+/o,$_);
	    my $shlibs_string = $udeb.$words[0].' '.$words[1];
	    if ($shlibs_control{$shlibs_string}) {
		tag "duplicate-entry-in-shlibs-control-file", $shlibs_string;
	    } else {
		$shlibs_control{$shlibs_string} = 1;
		push (@shlibs_depends, join (' ', @words[2 .. $#words]))
		    unless $udeb;
	    }
	}
	close(SHLIBS);
	my $shlib_name;
	for my $shlib (@shlibs) {
	    $shlib_name = $SONAME{$shlib};
	    $shlib_name = format_soname($shlib_name);
	    $shlibs_control_used{$shlib_name} = 1;
	    $shlibs_control_used{"udeb: ".$shlib_name} = 1;
	    unless (exists $shlibs_control{$shlib_name}) {
		# skip it if it's not a public shared library
 		next unless $ldconfig_dirs->known(dirname($shlib));
		# no!!
		tag "shlib-missing-in-control-file", $shlib_name, 'for', $shlib;
	    }
	}
	for $shlib_name (keys %shlibs_control) {
	    tag "unused-shlib-entry-in-control-file", $shlib_name
		unless $shlibs_control_used{$shlib_name};
	}

	# Check that all of the packages listed as dependencies in the shlibs
	# file are satisfied by the current package or its Provides.
	# Normally, packages should only declare dependencies in their shlibs
	# that they themselves can satisfy.
	#
	# Deduplicate the list of dependencies before warning so that we don't
	# dupliate warnings.
	my %seen;
	@shlibs_depends = grep { !$seen{$_}++ } @shlibs_depends;
	for my $depend (@shlibs_depends) {
	    unless (Dep::implies($provides, Dep::parse($depend))) {
		tag "shlibs-declares-dependency-on-other-package", $depend;
	    }
	}
    }
}

# 5th step: check symbols control file
if ($#shlibs == -1) {
    # no shared libraries included in package, thus symbols control file should
    # not be present
    if (-f $symbols_control_file) {
        tag "pkg-has-symbols-control-file-but-no-shared-libs", "";
    }
} elsif (not -f $symbols_control_file) {
    if ($type ne 'udeb') {
	for my $shlib (@shlibs) {
	    # skip it if it's not a public shared library
	    next unless $ldconfig_dirs->known(dirname($shlib));
	    tag "no-symbols-control-file", "$shlib";
	}
    }
} elsif (open(IN, '<', $symbols_control_file)) {
    my $version_wo_rev = $version;
    $version_wo_rev =~ s/^(.+)-([^-]+)$/$1/;
    my ($full_version_count, $full_version_sym) = (0, undef);
    my ($debian_revision_count, $debian_revision_sym) = (0, undef);
    my ($soname, $dep_package, $dep);
    my %symbols_control_used;
    my @symbols_depends;
    my $dep_templates = 0;
    my $meta_info_seen = 0;

    while (<IN>) {
	chomp;
	next if m/^\s*$/ or /^#/;

	if (m/^([^\s|*]\S+)\s(\S+)(?:\s(\S+))?/) {
	    # soname, main dependency template

	    ($soname, $dep_package, $dep) = ($1, $2, $3);
	    $dep ||= '';
	    $soname = format_soname($soname);

	    if ($symbols_control{$soname}) {
		tag "duplicate-entry-in-symbols-control-file", $soname;
	    } else {
		$symbols_control{$soname} = 1;
		push @symbols_depends, $dep_package . ' ' . $dep;
	    }

	    $dep_templates = 0;
	    $meta_info_seen = 0;
	} elsif (m/^\|\s+(\S+)\s(\S+(\s\S+)?)$/) {
	    # alternative dependency template

	    if ($meta_info_seen or not defined $soname) {
		tag "syntax-error-in-symbols-file", $.;
	    }

	    ($dep_package, $dep) = ($1, $2);
	    push @symbols_depends, $dep_package . ' ' . $dep;
	    $dep_templates++;
	} elsif (m/^\*\s(\S+):\s(\S+)/) {
	    # meta-information

	    # This should probably be in a hash, but there's
	    # only one supported value currently
	    tag "unknown-meta-field-in-symbols-file", "$1, line $."
		unless $1 eq 'Build-Depends-Package';
	    tag "syntax-error-in-symbols-file", $.
		if $dep_templates > 0;

	    $meta_info_seen = 1;
	} elsif (m/^\s+(\S+)\s(\S+)(?:\s(\S+(\s\S+)?))?$/) {
	    # Symbol definition

	    tag "syntax-error-in-symbols-file", $.
		unless defined $soname;

	    my ($sym, $v, $dep_order) = ($1, $2, $3);
	    $dep_order ||= '';

	    if (($v eq $version) and ($version =~ /-/)) {
		$full_version_sym ||= $sym;
		$full_version_count++;
	    }
	    if (($v =~ /-/) and (not $v =~ /~$/) and ($v ne $version_wo_rev)) {
		$debian_revision_sym ||= $sym;
		$debian_revision_count++;
	    }

	    if (length $dep_order) {
		if ($dep_order !~ /^\d+$/ or $dep_order > $dep_templates) {
		    tag "invalid-template-id-in-symbols-file", $.;
		}
	    }
	} else {
	    # Unparseable line

	    tag "syntax-error-in-symbols-file", $.;
	}
    }
    close IN;
    if ($full_version_count) {
	$full_version_count--;
	my $others = '';
	if ($full_version_count > 0) {
	    $others = " and $full_version_count others";
	}
	tag "symbols-file-contains-current-version-with-debian-revision",
	    "on symbol $full_version_sym$others";
    }
    if ($debian_revision_count) {
	$debian_revision_count--;
	my $others = '';
	if ($debian_revision_count > 0) {
	    $others = " and $debian_revision_count others";
	}
	tag "symbols-file-contains-debian-revision",
	    "on symbol $debian_revision_sym$others";
    }
    my $shlib_name;
    for my $shlib (@shlibs) {
	$shlib_name = $SONAME{$shlib};
	$shlib_name = format_soname($shlib_name);
	$symbols_control_used{$shlib_name} = 1;
	$symbols_control_used{"udeb: ".$shlib_name} = 1;
	unless (exists $symbols_control{$shlib_name}) {
	    # skip it if it's not a public shared library
	    next unless $ldconfig_dirs->known(dirname($shlib));
	    tag "shlib-missing-in-symbols-control-file", $shlib_name, 'for', $shlib;
	}
    }
    for $shlib_name (keys %symbols_control) {
	tag "unused-shlib-entry-in-symbols-control-file", $shlib_name
	    unless $symbols_control_used{$shlib_name};
    }

    # Check that all of the packages listed as dependencies in the symbols
    # file are satisfied by the current package or its Provides.
    # Normally, packages should only declare dependencies in their symbols
    # files that they themselves can satisfy.
    #
    # Deduplicate the list of dependencies before warning so that we don't
    # dupliate warnings.
    my %seen;
    @symbols_depends = grep { !$seen{$_}++ } @symbols_depends;
    for my $depend (@symbols_depends) {
	unless (Dep::implies($provides, Dep::parse($depend))) {
	    tag "symbols-declares-dependency-on-other-package", $depend;
	}
    } 
}

# Compare the contents of the shlibs and symbols control files
if (keys %shlibs_control and keys %symbols_control) {
    for my $key (keys %symbols_control) {
	unless (exists $shlibs_control{$key}) {
	    tag "symbols-declared-but-not-shlib", $key;
	}
    }
}

# 6th step: check pre- and post- control files
if (-f $preinst) {
    local $_ = slurp_entire_file($preinst);
    if (/^[^\#]*\bldconfig\b/m) {
	tag "preinst-calls-ldconfig", ""
    }
}

my $we_call_postinst=0;
if (-f $postinst) {
    local $_ = slurp_entire_file($postinst);

    # Decide if we call ldconfig
    if (/^[^\#]*\bldconfig\b/m) {
	$we_call_postinst=1;
    }
}

if ($type eq 'udeb') {
    tag "udeb-postinst-must-not-call-ldconfig"
	if $we_call_postinst;
} else {
    tag "postinst-has-useless-call-to-ldconfig", ""
	if $we_call_postinst and not $must_call_ldconfig;
    tag "postinst-must-call-ldconfig", "$must_call_ldconfig"
	if not $we_call_postinst and $must_call_ldconfig;
}

if (-f $prerm) {
    local $_ = slurp_entire_file($prerm);
    if (/^[^\#]*\bldconfig\b/m) {
	tag "prerm-calls-ldconfig", "";
    }
}

if (-f $postrm) {
    local $_ = slurp_entire_file($postrm);

    # Decide if we call ldconfig
    if (/^[^\#]*\bldconfig\b/m) {
	tag "postrm-has-useless-call-to-ldconfig", ""
	    unless $must_call_ldconfig;
    } else {
	tag "postrm-should-call-ldconfig", "$must_call_ldconfig"
	    if $must_call_ldconfig;
    }

    # Decide if we do it safely
    s/\bldconfig\b/BldconfigB/g;
    s/[ \t]//g;
    # this one matches code from debhelper
    s/^if\["\$1"=.?remove.?\];?\n*then\n*BldconfigB//gm;
    # variations...
    s/^if\[.?remove.?="\$1"\];?\n*then\n*BldconfigB//gm;
    s/^\["\$1"=.?remove.?\]\&&BldconfigB//gm;
    s/^\[.?remove.?="\$1"\]&&BldconfigB//gm;
    s/remove(?:\|[^)]+)*\).*?BldconfigB.*?(;;|esac)//s;

    if (/^[^\#]*BldconfigB/m) {
        tag "postrm-unsafe-ldconfig", "";
    }
}

}

# make /tmp/baz/baz.txt from /tmp/foo/../bar/../baz/baz.txt
sub abs_path {
    my $path = shift;
    while($path =~ s!/[^/]*/\.\./!/!g){1};
    return $path;
}

sub format_soname {
    my $soname = shift;

    # libfoo.so.X.X
    if ($soname =~ m/(.+)\.so\.(.*)$/) {
	$soname = "$1 $2";
    # libfoo-X.X.so
    } elsif ($soname =~ m/(.+)\-(\w[\w\.]*)\.so$/) {
	$soname = "$1 $2";
    }

    return $soname
}

1;

# Local Variables:
# indent-tabs-mode: t
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 ts=8