+++ /dev/null
-# 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
projects / maemian / blobdiff