Package: dpkg Version: 1.14.4 Please find attached a patch integrating my work on dpkg-shlibdeps in the current dpkg version. I've put my work in a git repository on git://git.debian.org/git/private/hertzog/dpkg (branch dpkg-shlibdeps)
It creates a set of modules in /usr/lib/dpkg/Dpkg/ as I need some shared code between dpkg-gensymbols and dpkg-shlibdeps. There's no documentation update yet, but I shall work on that once the code is integrated. I'll maintain that code over time and do any possible bugfixes and enhancements that may appear. I expect at least some enhancements in the way we handle the symbols files over the set of architectures (ie to share some information instead of having simply debian/package.symbols.arch). Any comments welcome. Please note that the code in the bzr branch is outdated now. I did substantial changes to put some code in modules. For reference, the following wiki page contains the initial spec that lead me in this work: http://wiki.debian.org/Projects/ImprovedDpkgShlibdeps Cheers, -- Raphaël Hertzog Premier livre français sur Debian GNU/Linux : http://www.ouaza.com/livre/admin-debian/
diff --git a/configure.ac b/configure.ac index a023b03..1b899ef 100644 --- a/configure.ac +++ b/configure.ac @@ -112,6 +112,7 @@ AC_CONFIG_FILES([ Makefile origins/Makefile po/Makefile.in scripts/Makefile + scripts/modules/Makefile scripts/po/Makefile.in src/Makefile utils/Makefile ]) diff --git a/debian/dpkg-dev.install b/debian/dpkg-dev.install index fda7604..d5e165c 100644 --- a/debian/dpkg-dev.install +++ b/debian/dpkg-dev.install @@ -8,6 +8,7 @@ usr/bin/dpkg-checkbuilddeps usr/bin/dpkg-distaddfile usr/bin/dpkg-genchanges usr/bin/dpkg-gencontrol +usr/bin/dpkg-gensymbols usr/bin/dpkg-name usr/bin/dpkg-parsechangelog usr/bin/dpkg-scanpackages @@ -15,6 +16,7 @@ usr/bin/dpkg-scansources usr/bin/dpkg-shlibdeps usr/bin/dpkg-source usr/lib/dpkg/controllib.pl +usr/lib/dpkg/Dpkg usr/lib/dpkg/parsechangelog usr/share/locale/*/LC_MESSAGES/dpkg-dev.mo usr/share/man/*/*/822-date.1 diff --git a/scripts/Makefile.am b/scripts/Makefile.am index b8b3643..45eaedf 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with automake to produce Makefile.in -SUBDIRS = po +SUBDIRS = po modules bin_SCRIPTS = \ 822-date \ @@ -10,6 +10,7 @@ bin_SCRIPTS = \ dpkg-distaddfile \ dpkg-genchanges \ dpkg-gencontrol \ + dpkg-gensymbols \ dpkg-name \ dpkg-parsechangelog \ dpkg-scanpackages \ @@ -36,6 +37,7 @@ EXTRA_DIST = \ dpkg-distaddfile.pl \ dpkg-genchanges.pl \ dpkg-gencontrol.pl \ + dpkg-gensymbols.pl \ dpkg-name.sh \ dpkg-parsechangelog.pl \ dpkg-scanpackages.pl \ diff --git a/scripts/dpkg-gensymbols.pl b/scripts/dpkg-gensymbols.pl new file mode 100755 index 0000000..c1066e0 --- /dev/null +++ b/scripts/dpkg-gensymbols.pl @@ -0,0 +1,235 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +our $version; +our $dpkglibdir; +BEGIN { + $version="1.14.4"; # This line modified by Makefile + $dpkglibdir="/usr/lib/dpkg"; # This line modified by Makefile + push(@INC,$dpkglibdir); +} +require 'controllib.pl'; + +use Dpkg::Version qw(compare_versions); +use Dpkg::Shlibs qw(@librarypaths); +use Dpkg::Shlibs::Objdump; +use Dpkg::Shlibs::SymbolFile; + +our $progname; +our (%f, %fi); +our %p2i; +our @librarypaths; + +our $host_arch= `dpkg-architecture -qDEB_HOST_ARCH`; +chomp $host_arch; + +require 'dpkg-gettext.pl'; +textdomain("dpkg-dev"); + +my $controlfile = 'debian/control'; +my $changelogfile = 'debian/changelog'; +my $packagebuilddir = 'debian/tmp'; + +my $sourceversion; +my $stdout; +my $oppackage; +my $compare = 1; # Bail on missing symbols by default +my $output; +my $debug = 0; + +sub version { + printf _g("Debian %s version %s.\n"), $progname, $version; + + printf _g(" +Copyright (C) 2007 Raphael Hertzog. +"); + + printf _g(" +This is free software; see the GNU General Public Licence version 2 or +later for copying conditions. There is NO warranty. +"); +} + +sub usage { + printf _g( +"Usage: %s [<option> ...] + +Options: + -p<package> generate symbols file for package. + -P<packagebuilddir> temporary build dir instead of debian/tmp. + -e<library> explicitely list libraries to scan. + -v<version> version of the packages (defaults to + version extracted from debian/changelog). + -c<level> compare generated symbols file with the + reference file in the debian directory. + Fails if difference are too important + (level goes from 0 for no check, to 4 + for all checks). By default checks at + level 1. + -O<file> write to <file>, not .../DEBIAN/symbols. + -O write to stdout, not .../DEBIAN/symbols. + -d display debug information during work. + -h, --help show this help message. + --version show the version. +"), $progname; +} + +my @files; +while (@ARGV) { + $_=shift(@ARGV); + if (m/^-p([-+0-9a-z.]+)$/) { + $oppackage= $1; + } elsif (m/^-c(\d)?$/) { + $compare = defined($1) ? $1 : 1; + } elsif (m/^-d$/) { + $debug = 1; + } elsif (m/^-v(.*)/) { + $sourceversion = $1; + } elsif (m/^-e(.*)/) { + my $file = $1; + if (-e $file) { + push @files, $file; + } else { + push @files, glob($file); + } + } elsif (m/^-p(.*)/) { + &error(sprintf(_g("Illegal package name \`%s'"), $1)); + } elsif (m/^-P(.*)$/) { + $packagebuilddir = $1; + $packagebuilddir =~ s{/+$}{}; + } elsif (m/^-O$/) { + $stdout= 1; + } elsif (m/^-O(.+)$/) { + $output= $1; + } elsif (m/^-(h|-help)$/) { + &usage; exit(0); + } elsif (m/^--version$/) { + &version; exit(0); + } else { + &usageerr(sprintf(_g("unknown option \`%s'"), $_)); + } +} + +if (not defined($sourceversion)) { + parsechangelog($changelogfile); + $sourceversion = $fi{"L Version"}; +} +if (not defined($oppackage)) { + parsecontrolfile($controlfile); + my @packages = grep(m/^C /, keys %p2i); + @packages==1 || + &error(sprintf(_g("must specify package since control info has many (%s)"), "@packages")); + $oppackage = $packages[0]; + $oppackage =~ s/^C //; +} + +my $symfile = Dpkg::Shlibs::SymbolFile->new(); +my $ref_symfile = Dpkg::Shlibs::SymbolFile->new(); +# Load source-provided symbol information +foreach my $file ($output, "debian/$oppackage.symbols.$host_arch", + "debian/symbols.$host_arch", "debian/$oppackage.symbols", + "debian/symbols") +{ + if (defined $file and -e $file) { + print "Using references symbols from $file\n" if $debug; + $symfile->load($file); + $ref_symfile->load($file) if $compare; + last; + } +} + +# Scan package build dir looking for libraries +if (not scalar @files) { + foreach my $path (@librarypaths) { + my $libdir = "$packagebuilddir$path"; + $libdir =~ s{/+}{/}g; + next if not -d $libdir; + opendir(DIR, "$libdir") || + syserr(sprintf(_g("Can't read directory %s: %s"), $libdir, $!)); + push @files, grep { + /(\.so\.|\.so$)/ && + Dpkg::Shlibs::Objdump::is_elf($_); + } map { "$libdir/$_" } readdir(DIR); + close(DIR); + } +} + +# Merge symbol information +my $od = Dpkg::Shlibs::Objdump->new(); +foreach my $file (@files) { + print "Scanning $file for symbol information\n" if $debug; + my $objid = $od->parse($file); + unless (defined($objid)) { + warning(sprintf(_g("Objdump couldn't parse %s\n"), $file)); + next; + } + my $object = $od->get_object($objid); + if ($object->{SONAME}) { # Objects without soname are of no interest + print "Merging symbols from $file as $object->{SONAME}\n" if $debug; + if (not $symfile->has_object($object->{SONAME})) { + $symfile->create_object($object->{SONAME}, "$oppackage #MINVER#"); + } + $symfile->merge_symbols($object, $sourceversion); + } else { + print "File $file doesn't have a soname. Ignoring.\n" if $debug; + } +} +$symfile->clear_except(keys %{$od->{objects}}); + +# Write out symbols files +if ($stdout) { + $output = "standard output"; + $symfile->save("-"); +} else { + unless (defined($output)) { + $output = "$packagebuilddir/DEBIAN/symbols"; + mkdir("$packagebuilddir/DEBIAN") if not -e "$packagebuilddir/DEBIAN"; + } + print "Storing symbols in $output.\n" if $debug; + $symfile->save($output); +} + +# Check if generated files differs from reference file +my $exitcode = 0; +if ($compare) { + use File::Temp; + use Digest::MD5; + # Compare + if ($symfile->has_new_libs($ref_symfile)) { + warning(_g("new libraries appeared in the symbols file.")); + $exitcode = 4 if ($compare >= 4); + } + if ($symfile->has_lost_libs($ref_symfile)) { + warning(_g("some libraries disappeared in the symbols file.")); + $exitcode = 3 if ($compare >= 3); + } + if ($symfile->has_new_symbols($ref_symfile)) { + warning(_g("some new symbols appeared in the symbols file.")); + $exitcode = 2 if ($compare >= 2); + } + if ($symfile->has_lost_symbols($ref_symfile)) { + warning(_g("some symbols disappeared in the symbols file.")); + $exitcode = 1 if ($compare >= 1); + } + # Output diffs between symbols files if needed + my $before = File::Temp->new(TEMPLATE=>'dpkg-gensymbolsXXXXXX'); + my $after = File::Temp->new(TEMPLATE=>'dpkg-gensymbolsXXXXXX'); + $ref_symfile->dump($before); $symfile->dump($after); + seek($before, 0, 0); seek($after, 0, 0); + my ($md5_before, $md5_after) = (Digest::MD5->new(), Digest::MD5->new()); + $md5_before->addfile($before); + $md5_after->addfile($after); + if ($md5_before->hexdigest() ne $md5_after->hexdigest()) { + if (defined($ref_symfile->{file})) { + warning(sprintf(_g("%s doesn't match completely %s\n"), + $output, $ref_symfile->{file})); + } else { + warning(sprintf(_g("no debian/symbols file used as basis for generating %s\n"), $output)); + } + my ($a, $b) = ($before->filename, $after->filename); + system("diff -u $a $b") if -x "/usr/bin/diff"; + } +} +exit($exitcode); diff --git a/scripts/dpkg-shlibdeps.pl b/scripts/dpkg-shlibdeps.pl index 67f45d5..0c2a048 100755 --- a/scripts/dpkg-shlibdeps.pl +++ b/scripts/dpkg-shlibdeps.pl @@ -1,41 +1,270 @@ -#! /usr/bin/perl -# -# dpkg-shlibdeps -# $Id$ +#!/usr/bin/perl -w use strict; use warnings; +use File::Find; + our $progname; -our $version = "1.4.1.19"; # This line modified by Makefile -our $dpkglibdir = "/usr/lib/dpkg"; +our $version; +our $dpkglibdir; my $admindir = "/var/lib/dpkg"; -use English; -use POSIX qw(:errno_h :signal_h); +BEGIN { + $version="1.14.4"; # This line modified by Makefile + $dpkglibdir="/usr/lib/dpkg"; # This line modified by Makefile + push(@INC,$dpkglibdir); +} + +use Dpkg::Version qw(compare_versions); +use Dpkg::Shlibs qw(find_library); +use Dpkg::Shlibs::Objdump; +use Dpkg::Shlibs::SymbolFile; + +our $host_arch= `dpkg-architecture -qDEB_HOST_ARCH`; +chomp $host_arch; + +my @depfields= qw(Suggests Recommends Depends Pre-Depends); # By increasing importance +my $i=0; my %depstrength = map { $_ => $i++ } @depfields; + +require 'controllib.pl'; +require 'dpkg-gettext.pl'; +textdomain("dpkg-dev"); my $shlibsoverride= '/etc/dpkg/shlibs.override'; my $shlibsdefault= '/etc/dpkg/shlibs.default'; my $shlibslocal= 'debian/shlibs.local'; -my $shlibsppdir; -my $shlibsppext= '.shlibs'; -my $varnameprefix= 'shlibs'; +my $packagetype= 'deb'; my $dependencyfield= 'Depends'; my $varlistfile= 'debian/substvars'; -my $packagetype= 'deb'; +my $varnameprefix= 'shlibs'; +my $debug= 0; + +my (@pkg_shlibs, @pkg_symbols); +if (-d "debian") { + find sub { + push @pkg_shlibs, $File::Find::name if ($File::Find::name =~ m{/DEBIAN/shlibs$}); + push @pkg_symbols, $File::Find::name if ($File::Find::name =~ m{/DEBIAN/symbols$}); + }, "debian"; +} + +my ($stdout, %exec); +foreach (@ARGV) { + if (m/^-T(.*)$/) { + $varlistfile= $1; + } elsif (m/^-p(\w[-:0-9A-Za-z]*)$/) { + $varnameprefix= $1; + } elsif (m/^-L(.*)$/) { + $shlibslocal= $1; + } elsif (m/^-O$/) { + $stdout= 1; + } elsif (m/^-(h|-help)$/) { + usage(); exit(0); + } elsif (m/^--version$/) { + version(); exit(0); + } elsif (m/^--admindir=(.*)$/) { + $admindir = $1; + -d $admindir || + error(sprintf(_g("administrative directory '%s' does not exist"), + $admindir)); + } elsif (m/^-d(.*)$/) { + $dependencyfield= capit($1); + defined($depstrength{$dependencyfield}) || + warning(sprintf(_g("unrecognised dependency field \`%s'"), $dependencyfield)); + } elsif (m/^-e(.*)$/) { + $exec{$1} = $dependencyfield; + } elsif (m/^-t(.*)$/) { + $packagetype = $1; + } elsif (m/-v$/) { + $debug = 1; + } elsif (m/^-/) { + usageerr(sprintf(_g("unknown option \`%s'"), $_)); + } else { + $exec{$_} = $dependencyfield; + } +} -my @depfields= qw(Suggests Recommends Depends Pre-Depends); -my %depstrength; -my $i=0; grep($depstrength{$_}= ++$i, @depfields); +scalar keys %exec || usageerr(_g("need at least one executable")); -push(@INC,$dpkglibdir); -require 'controllib.pl'; +my %dependencies; +my %shlibs; -require 'dpkg-gettext.pl'; -textdomain("dpkg-dev"); +my $cur_field; +foreach my $file (keys %exec) { + $cur_field = $exec{$file}; + print "Scanning $file (for $cur_field field)\n" if $debug; -#use strict; -#use warnings; + my $dump = Dpkg::Shlibs::Objdump->new(); + my $id = $dump->parse($file); + my $obj = $dump->get_object($id); + + # Load symbols files for all needed libraries (identified by SONAME) + my %libfiles; + foreach my $soname ($obj->get_needed_libraries) { + my $file = my_find_library($soname, $obj->{RPATH}, $obj->{format}); + warning("Couldn't find library $soname.") unless defined($file); + $libfiles{$file} = $soname if defined($file); + } + my $file2pkg = find_packages(keys %libfiles); + my $symfile = Dpkg::Shlibs::SymbolFile->new(); + my $dumplibs_wo_symfile = Dpkg::Shlibs::Objdump->new(); + my @soname_wo_symfile; + foreach my $file (keys %libfiles) { + my $soname = $libfiles{$file}; + if (not exists $file2pkg->{$file}) { + # If the library is not available in an installed package, + # it's because it's in the process of being built + # Empty package name will lead to consideration of symbols + # file from the package being built only + $file2pkg->{$file} = [""]; + } + + # Load symbols/shlibs files from packages providing libraries + foreach my $pkg (@{$file2pkg->{$file}}) { + my $dpkg_symfile; + if ($packagetype eq "deb") { + # Use fine-grained dependencies only on real deb + $dpkg_symfile = find_symbols_file($pkg, $soname); + } + if (defined $dpkg_symfile) { + # Load symbol information + print "Using symbols file $dpkg_symfile for $soname\n" if $debug; + $symfile->load($dpkg_symfile); + # Initialize dependencies as an unversioned dependency + my $dep = $symfile->get_dependency($soname); + foreach my $subdep (split /\s*,\s*/, $dep) { + if (not exists $dependencies{$cur_field}{$subdep}) { + $dependencies{$cur_field}{$subdep} = ''; + } + } + } else { + # No symbol file found, fall back to standard shlibs + $dumplibs_wo_symfile->parse($file); + push @soname_wo_symfile, $soname; + add_shlibs_dep($soname, $pkg); + } + } + } + + # Scan all undefined symbols of the binary and resolve to a + # dependency + my @sonames = $obj->get_needed_libraries; + my %used_sonames = map { $_ => 0 } @sonames; + foreach my $sym ($obj->get_undefined_dynamic_symbols()) { + my $name = $sym->{name}; + if ($sym->{version}) { + $name .= "[EMAIL PROTECTED]>{version}"; + } else { + $name .= "[EMAIL PROTECTED]"; + } + my $symdep = $symfile->lookup_symbol($name, [EMAIL PROTECTED]); + if (defined($symdep)) { + my ($d, $m) = ($symdep->{depends}, $symdep->{minver}); + $used_sonames{$symdep->{soname}}++; + foreach my $subdep (split /\s*,\s*/, $d) { + if (exists $dependencies{$cur_field}{$subdep} and + defined($dependencies{$cur_field}{$subdep})) + { + if ($dependencies{$cur_field}{$subdep} eq '' or + compare_versions($m, "gt", $dependencies{$cur_field}{$subdep})) + { + $dependencies{$cur_field}{$subdep} = $m; + } + } else { + $dependencies{$cur_field}{$subdep} = $m; + } + } + } else { + my $syminfo = $dumplibs_wo_symfile->locate_symbol($name); + if (not defined($syminfo)) { + my $print_name = $name; + $print_name =~ s/[EMAIL PROTECTED]//; # Drop the default suffix for readability + warning(sprintf( + _g("symbol %s used by %s found in none of the libraries."), + $print_name, $file)) unless $sym->{weak}; + } else { + $used_sonames{$syminfo->{soname}}++; + } + } + } + # Warn about un-NEEDED libraries + foreach my $soname (@sonames) { + unless ($used_sonames{$soname}) { + warning(sprintf( + _g("%s shouldn't be linked with %s (it uses none of its symbols)."), + $file, $soname)); + } + } +} + +# Open substvars file +my $fh; +if ($stdout) { + $fh = \*STDOUT; +} else { + open(NEW,"> $varlistfile.new") || + syserr(sprintf(_g("open new substvars file \`%s'"), "$varlistfile.new")); + if (-e $varlistfile) { + open(OLD,"< $varlistfile") || + syserr(sprintf(_g("open old varlist file \`%s' for reading"), $varlistfile)); + foreach my $entry (grep { not /^\Q$varnameprefix\E:/ } (<OLD>)) { + print(NEW $entry) || + syserr(sprintf(_g("copy old entry to new varlist file \`%s'"), "$varlistfile.new")); + } + } + $fh = \*NEW; +} + +# Write out the shlibs substvars +my %depseen; +foreach my $field (reverse @depfields) { + my $dep = ""; + if (exists $dependencies{$field} and scalar keys %{$dependencies{$field}}) { + $dep = join ", ", + map { + # Translate dependency templates into real dependencies + if ($dependencies{$field}{$_}) { + s/#MINVER#/(>= $dependencies{$field}{$_})/g; + } else { + s/#MINVER#//g; + } + s/\s+/ /g; + $_; + } grep { + # Don't include dependencies if they are already + # mentionned in a higher priority field + if (not defined($depseen{$_})) { + $depseen{$_} = $dependencies{$field}{$_}; + 1; + } else { + #Â Since dependencies can be versionned, we have to + # verify if the dependency is stronger than the + # previously seen one + if (compare_versions($depseen{$_}, "gt", + $dependencies{$field}{$_})) { + 0; + } else { + $depseen{$_} = $dependencies{$field}{$_}; + 1; + } + } + } keys %{$dependencies{$field}}; + } + if ($dep) { + print $fh "$varnameprefix:$field=$dep\n"; + } +} + +# Replace old file by new one +if (!$stdout) { + close($fh); + rename("$varlistfile.new",$varlistfile) || + syserr(sprintf(_g("install new varlist file \`%s'"), $varlistfile)); +} + +## +## Functions +## sub version { printf _g("Debian %s version %s.\n"), $progname, $version; @@ -43,7 +272,9 @@ sub version { printf _g(" Copyright (C) 1996 Ian Jackson. Copyright (C) 2000 Wichert Akkerman. -Copyright (C) 2006 Frank Lichtenheld."); +Copyright (C) 2006 Frank Lichtenheld. +Copyright (C) 2007 Raphael Hertzog. +"); printf _g(" This is free software; see the GNU General Public Licence version 2 or @@ -66,7 +297,6 @@ Options: -L<localshlibsfile> shlibs override file, not debian/shlibs.local. -T<varlistfile> update variables here, not debian/substvars. -t<type> set package type (default is deb). - --admindir=<directory> change the administrative directory. -h, --help show this help message. --version show the version. @@ -75,376 +305,117 @@ Dependency fields recognised are: "), $progname, join("/",@depfields); } -my ($stdout, @exec, @execfield); -foreach (@ARGV) { - if (m/^-T/) { - $varlistfile= $POSTMATCH; - } elsif (m/^-p(\w[-:0-9A-Za-z]*)$/) { - $varnameprefix= $1; - } elsif (m/^-L/) { - $shlibslocal= $POSTMATCH; - } elsif (m/^-O$/) { - $stdout= 1; - } elsif (m/^-(h|-help)$/) { - usage; exit(0); - } elsif (m/^--version$/) { - version; exit(0); - } elsif (m/^--admindir=/) { - $admindir = $POSTMATCH; - -d $admindir || - error(sprintf(_g("administrative directory '%s' does not exist"), - $admindir)); - } elsif (m/^-d/) { - $dependencyfield= capit($POSTMATCH); - defined($depstrength{$dependencyfield}) || - warning(sprintf(_g("unrecognised dependency field '%s'"), $dependencyfield)); - } elsif (m/^-e/) { - push(@exec,$POSTMATCH); push(@execfield,$dependencyfield); - } elsif (m/^-t/) { - $packagetype= $POSTMATCH; - } elsif (m/^-/) { - usageerr(sprintf(_g("unknown option \`%s'"), $_)); - } else { - push(@exec,$_); push(@execfield,$dependencyfield); +sub add_shlibs_dep { + my ($soname, $pkg) = @_; + foreach my $file ($shlibslocal, $shlibsoverride, @pkg_shlibs, + "$admindir/info/$pkg.shlibs") + { + next if not -e $file; + my $dep = extract_from_shlibs($soname, $file); + if (defined($dep)) { + foreach (split(/,\s*/, $dep)) { + $dependencies{$cur_field}{$_} = 1; + } + last; + } } } -$shlibsppdir = "$admindir/info"; - [EMAIL PROTECTED] || usageerr(_g("need at least one executable")); - -sub isbin { - open (F, $_[0]) || die(sprintf(_g("unable to open '%s' for test"), $_[0])); - my $d; - if (read (F, $d, 4) != 4) { - die (sprintf(_g("unable to read first four bytes of '%s' as magic number"), $_[0])); - } - if ($d =~ /^\177ELF$/) { # ELF binary - return 1; - } elsif (unpack ('N', $d) == 0x8086010B) { # obsd dyn bin - return 1; - } elsif (unpack ('N', $d) == 0x86010B) { # obsd stat bin - return 1; - } elsif ($d =~ /^\#\!..$/) { # shell script - return 0; - } elsif (unpack ('N', $d) == 0xcafebabe) { # JAVA binary - return 0; +sub extract_from_shlibs { + my ($soname, $shlibfile) = @_; + my ($libname, $libversion); + # Split soname in name/version + if ($soname =~ /^(.*)\.so\.(.*)$/) { + $libname = $1; $libversion = $2; + } elsif ($soname =~ /^(.*)-(.*)\.so$/) { + $libname = $1; $libversion = $2; } else { - die(sprintf(_g("unrecognized file type for '%s'"), $_[0])); - } -} - -my @librarypaths = qw( /lib /usr/lib /lib32 /usr/lib32 /lib64 /usr/lib64 - /emul/ia32-linux/lib /emul/ia32-linux/usr/lib ); -my %librarypaths = map { $_ => 'default' } @librarypaths; - -if ($ENV{LD_LIBRARY_PATH}) { - foreach (reverse split( /:/, $ENV{LD_LIBRARY_PATH} )) { - s,/+$,,; - unless (exists $librarypaths{$_}) { - $librarypaths{$_} = 'env'; - unshift @librarypaths, $_; - } + warning(sprintf(_g("Can't extract name and version from library name \`%s'"), $soname)); + return; } -} - -# Support system library directories. -my $ldconfigdir = '/lib/ldconfig'; -if (opendir(DIR, $ldconfigdir)) { - my @dirents = readdir(DIR); - closedir(DIR); - - for (@dirents) { - next if /^\./; - my $d = `readlink -f $ldconfigdir/$_`; - chomp $d; - unless (exists $librarypaths{$d}) { - $librarypaths{$d} = 'ldconfig'; - push @librarypaths, $d; + # Open shlibs file + $shlibfile = "./$shlibfile" if $shlibfile =~ m/^\s/; + open(SHLIBS, "< $shlibfile") || syserr(sprintf(_g("unable to open shared libs info file \`%s'"), $shlibfile)); + my $dep; + while (<SHLIBS>) { + s/\s*\n$//; next if m/^\#/; + if (!m/^\s*(?:(\S+):\s+)?(\S+)\s+(\S+)\s+(\S.*\S)\s*$/) { + warning(sprintf(_g("shared libs info file \`%s' line %d: bad line \`%s'"), $shlibfile, $., $_)); + next; + } + my $type = defined($1) ? $1 : "deb"; + next if $type ne $packagetype; + if (($libname eq $2) && ($libversion eq $3)) { + $dep = $4; + last; } } + close(SHLIBS); + return $dep; } -open CONF, '</etc/ld.so.conf' or - warning(sprintf(_g("couldn't open /etc/ld.so.conf: %s"), $!)); -while( <CONF> ) { - next if /^\s*$/; - chomp; - s,/+$,,; - unless (exists $librarypaths{$_}) { - $librarypaths{$_} = 'conf'; - push @librarypaths, $_; - } -} -close CONF; - -my (%rpaths, %format); -my (@libfiles, @libname, @libsoname, @libfield, @libexec); -for ($i=0;$i<=$#exec;$i++) { - if (!isbin ($exec[$i])) { next; } - - # Now we get the direct deps of the program - defined(my $c= open(P,"-|")) || syserr(_g("cannot fork for objdump")); - if (!$c) { - exec("objdump", "-p", "--", $exec[$i]) or - syserr(_g("cannot exec objdump")); - } - while (<P>) { - chomp; - if (/^\s*\S+:\s*file\s+format\s+(\S+)\s*$/) { - $format{$exec[$i]} = $1; - } elsif (m,^\s*NEEDED\s+,) { - if (m,^\s*NEEDED\s+((\S+)\.so\.(\S+))$,) { - push(@libname,$2); push(@libsoname,$3); - push(@libfield,$execfield[$i]); - push(@libfiles,$1); - push(@libexec,$exec[$i]); - } elsif (m,^\s*NEEDED\s+((\S+)-(\S+)\.so)$,) { - push(@libname,$2); push(@libsoname,$3); - push(@libfield,$execfield[$i]); - push(@libfiles,$1); - push(@libexec,$exec[$i]); - } else { - m,^\s*NEEDED\s+(\S+)$,; - warning(sprintf(_g("format of 'NEEDED %s' not recognized"), $1)); - } - } elsif (/^\s*RPATH\s+(\S+)\s*$/) { - push @{$rpaths{$exec[$i]}}, split(/:/, $1); +sub find_symbols_file { + my ($pkg, $soname) = @_; + foreach my $file (@pkg_symbols, + "/etc/dpkg/symbols/$pkg.symbols.$host_arch", + "/etc/dpkg/symbols/$pkg.symbols", + "$admindir/info/$pkg.symbols") + { + if (-e $file and symfile_has_soname($file, $soname)) { + return $file; } } - close(P) or subprocerr(sprintf(_g("objdump on \`%s'"), $exec[$i])); + return undef; } -# Now: See if it is in this package. See if it is in any other package. -my @curshlibs; -sub searchdir { - my $dir = shift; - if(opendir(DIR, $dir)) { - my @dirents = readdir(DIR); - closedir(DIR); - for (@dirents) { - if ( -f "$dir/$_/DEBIAN/shlibs" ) { - push(@curshlibs, "$dir/$_/DEBIAN/shlibs"); - next; - } elsif ( $_ !~ /^\./ && ! -e "$dir/$_/DEBIAN" && - -d "$dir/$_" && ! -l "$dir/$_" ) { - &searchdir("$dir/$_"); - } +sub symfile_has_soname { + my ($file, $soname) = @_; + open(SYM_FILE, "< $file") || syserr("can't open file $file"); + my $result = 0; + while (<SYM_FILE>) { + if (/^\Q$soname\E /) { + $result = 1; + last; } } + close(SYM_FILE); + return $result; } -my $searchdir = $exec[0]; -my $curpackdir = "debian/tmp"; -do { $searchdir =~ s,/[^/]*$,,; } while($searchdir =~ m,/, - && ! -d "$searchdir/DEBIAN"); -if ($searchdir =~ m,/,) { - $curpackdir = $searchdir; - $searchdir =~ s,/[^/]*,,; - &searchdir($searchdir); -} - -if (1 || $#curshlibs >= 0) { - PRELIB: - for ($i=0;$i<=$#libname;$i++) { - if(scanshlibsfile($shlibslocal,$libname[$i],$libsoname[$i],$libfield[$i]) - || scanshlibsfile($shlibsoverride,$libname[$i],$libsoname[$i],$libfield[$i])) { - splice(@libname, $i, 1); - splice(@libsoname, $i, 1); - splice(@libfield, $i, 1); - splice(@libfiles, $i, 1); - splice(@libexec, $i, 1); - $i--; - next PRELIB; - } - for my $shlibsfile (@curshlibs) { - if(scanshlibsfile($shlibsfile, $libname[$i], $libsoname[$i], $libfield[$i])) { - splice(@libname, $i, 1); - splice(@libsoname, $i, 1); - splice(@libfield, $i, 1); - splice(@libfiles, $i, 1); - splice(@libexec, $i, 1); - $i--; - next PRELIB; - } - } +# find_library ($soname, [EMAIL PROTECTED], $format) +sub my_find_library { + my ($lib, $rpath, $format) = @_; + my $file = find_library($lib, $rpath, $format, ""); + return $file if defined($file); + + # Look into the packages we're currently building (but only those + # that provides shlibs file...) + # TODO: we should probably replace that by a cleaner way to look into + # the various temporary build directories... + foreach my $builddir (map { s{/DEBIAN/shlibs$}{}; $_ } @pkg_shlibs) { + $file = find_library($lib, $rpath, $format, $builddir); + return $file if defined($file); } + return undef; } -my %pathpackages; -if ($#libfiles >= 0) { - grep(s/\[\?\*/\\$&/g, @libname); - defined(my $c= open(P,"-|")) || syserr(_g("cannot fork for dpkg --search")); - if (!$c) { - my %seen_libfiles; - my @uniq_libfiles = grep !$seen_libfiles{$_}++, @libfiles; - - close STDERR; # we don't need to see dpkg's errors - open STDERR, "> /dev/null"; - $ENV{LC_ALL} = "C"; - exec("dpkg", "--search", "--", @uniq_libfiles) or - syserr(_g("cannot exec dpkg")); - } - while (<P>) { - chomp; +sub find_packages { + my @files = (@_); + my $pkgmatch = {}; + open(DPKG, "dpkg --search -- @files 2>/dev/null |") || + syserr(sprintf(_g("Can't execute dpkg --search: %s"), $!)); + while(defined($_ = <DPKG>)) { + chomp($_); if (m/^local diversion |^diversion by/) { warning(_g("diversions involved - output may be incorrect")); print(STDERR " $_\n") || syserr(_g("write diversion info to stderr")); - } elsif (m=^(\S+(, \S+)*): (\S+)$=) { - push @{$pathpackages{$LAST_PAREN_MATCH}}, split(/, /, $1); + } elsif (m/^([^:]+): (\S+)$/) { + $pkgmatch->{$2} = [ split(/, /, $1) ]; } else { warning(sprintf(_g("unknown output from dpkg --search: '%s'"), $_)); } } - close(P); + close(DPKG); + return $pkgmatch; } - LIB: - for ($i=0;$i<=$#libname;$i++) { - my $file = $libfiles[$i]; - my @packages; - foreach my $rpath (@{$rpaths{$libexec[$i]}}) { - if (exists $pathpackages{"$rpath/$file"} - && format_matches($libexec[$i],"$rpath/$file")) { - push @packages, @{$pathpackages{"$rpath/$file"}}; - } - } - foreach my $path (@librarypaths) { - if (exists $pathpackages{"$path/$file"} - && format_matches($libexec[$i],"$path/$file")) { - push @packages, @{$pathpackages{"$path/$file"}}; - } - } - if ([EMAIL PROTECTED]) { - warning(sprintf(_g("could not find any packages for %s"), $libfiles[$i])); - } else { - for my $p (@packages) { - scanshlibsfile("$shlibsppdir/$p$shlibsppext", - $libname[$i],$libsoname[$i],$libfield[$i]) - && next LIB; - } - } - scanshlibsfile($shlibsdefault,$libname[$i],$libsoname[$i],$libfield[$i]) - && next; - warning(sprintf(_g("unable to find dependency information for ". - "shared library %s (soname %s, ". - "path %s, dependency field %s)"), - $libname[$i], $libsoname[$i], - $libfiles[$i], $libfield[$i])); - } - -sub format_matches { - my ($file1, $file2) = @_; - my ($format1, $format2) = (get_format($file1),get_format($file2)); - return $format1 eq $format2; -} - -sub get_format { - my ($file) = @_; - - if ($format{$file}) { - return $format{$file}; - } else { - defined(my $c= open(P,"-|")) || syserr(_g("cannot fork for objdump")); - if (!$c) { - exec("objdump", "-a", "--", $file) or - syserr(_g("cannot exec objdump")); - } - while (<P>) { - chomp; - if (/^\s*\S+:\s*file\s+format\s+(\S+)\s*$/) { - $format{$file} = $1; - return $format{$file}; - } - } - close(P) or subprocerr(sprintf(_g("objdump on \`%s'"), $file)); - } -} - -my (%predefdepfdep, %unkdepfdone, %unkdepf); -sub scanshlibsfile { - my ($fn,$ln,$lsn,$lf) = @_; - my ($da,$dk); - $fn= "./$fn" if $fn =~ m/^\s/; - if (!open(SLF,"< $fn")) { - $! == ENOENT || syserr(sprintf(_g("unable to open shared libs info file \`%s'"), $fn)); - return 0; - } - - while (<SLF>) { - s/\s*\n$//; next if m/^\#/; - if (!m/^\s*(?:(\S+):\s+)?(\S+)\s+(\S+)/) { - warning(sprintf(_g("shared libs info file '%s' line %d: bad line '%s'"), $fn, $., $_)); - next; - } - next if defined $1 && $1 ne $packagetype; - next if $2 ne $ln || $3 ne $lsn; - return 1 if $fn eq "$curpackdir/DEBIAN/shlibs"; - $da= $POSTMATCH; - last if defined $1; # exact match, otherwise keep looking - } - close(SLF); - - return 0 unless defined $da; - - for my $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 defined($unkdepf{$lf}); - $unkdepf{$lf}.= $dv; - } - } - } - return 1; -} - -my $fh; -if (!$stdout) { - open(Y,"> $varlistfile.new") || - syserr(sprintf(_g("open new substvars file \`%s'"), "$varlistfile.new")); - unless ($REAL_USER_ID) { - chown(getfowner(), "$varlistfile.new") || - syserr(sprintf(_g("chown of \`%s'"), "$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(sprintf(_g("copy old entry to new varlist file \`%s'"), "$varlistfile.new")); - } - } elsif ($! != ENOENT) { - syserr(sprintf(_g("open old varlist file \`%s' for reading"), $varlistfile)); - } - $fh = \*Y; -} else { - $fh = \*STDOUT; -} -my %defdepf; -for my $dv (sort keys %predefdepfdep) { - my $lf= $predefdepfdep{$dv}; - $defdepf{$lf} .= ', ' if defined($defdepf{$lf}); - $defdepf{$lf}.= $dv; -} -for my $lf (reverse @depfields) { - next unless defined($defdepf{$lf}); - print($fh "$varnameprefix:$lf=$defdepf{$lf}\n") - || syserr(_g("write output entry")); -} -for my $lf (sort keys %unkdepf) { - print($fh "$varnameprefix:$lf=$unkdepf{$lf}\n") - || syserr(_g("write userdef output entry")); -} -close($fh) || syserr(_g("close output")); -if (!$stdout) { - rename("$varlistfile.new",$varlistfile) || - syserr(sprintf(_g("install new varlist file \`%s'"), $varlistfile)); -} diff --git a/scripts/modules/Makefile.am b/scripts/modules/Makefile.am new file mode 100644 index 0000000..0b6f25f --- /dev/null +++ b/scripts/modules/Makefile.am @@ -0,0 +1,7 @@ + +shlibsmodulesdir=$(pkglibdir)/Dpkg/Shlibs +dpkgmodulesdir=$(pkglibdir)/Dpkg + +dist_shlibsmodules_DATA = Objdump.pm SymbolFile.pm +dist_dpkgmodules_DATA = Shlibs.pm Version.pm + diff --git a/scripts/modules/Objdump.pm b/scripts/modules/Objdump.pm new file mode 100644 index 0000000..da93f82 --- /dev/null +++ b/scripts/modules/Objdump.pm @@ -0,0 +1,235 @@ +package Dpkg::Shlibs::Objdump; + +require 'dpkg-gettext.pl'; + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = { 'objects' => {} }; + bless $self, $class; + return $self; +} + +sub parse { + my ($self, $file) = @_; + local $ENV{LC_ALL} = 'C'; + open(OBJDUMP, "objdump -w -p -T $file |") || syserr(sprintf(_g("Can't execute objdump: %s"), $!)); + my $obj = Dpkg::Shlibs::Objdump::Object->new($file); + my $section = "none"; + while (defined($_ = <OBJDUMP>)) { + chomp($_); + next if (/^\s*$/); + + if ($_ =~ /^DYNAMIC SYMBOL TABLE:/) { + $section = "dynsym"; + next; + } elsif ($_ =~ /^Dynamic Section:/) { + $section = "dyninfo"; + next; + } elsif ($_ =~ /^Program Header:/) { + $section = "header"; + next; + } elsif ($_ =~ /^Version definitions:/) { + $section = "verdef"; + next; + } elsif ($_ =~ /^Version References:/) { + $section = "verref"; + next; + } + + if ($section eq "dynsym") { + $self->parse_dynamic_symbol($_, $obj); + } elsif ($section eq "dyninfo") { + if ($_ =~ /^\s*NEEDED\s+(\S+)/) { + push @{$obj->{NEEDED}}, $1; + } elsif ($_ =~ /^\s*SONAME\s+(\S+)/) { + $obj->{SONAME} = $1; + } elsif ($_ =~ /^\s*HASH\s+(\S+)/) { + $obj->{HASH} = $1; + } elsif ($_ =~ /^\s*GNU_HASH\s+(\S+)/) { + $obj->{GNU_HASH} = $1; + } elsif ($_ =~ /^\s*RPATH\s+(\S+)/) { + push @{$obj->{RPATH}}, split (/:/, $1); + } + } elsif ($section eq "none") { + if ($_ =~ /^\s*\S+:\s*file\s+format\s+(\S+)\s*$/) { + $obj->{format} = $1; + } + } + } + close(OBJDUMP); + if ($section eq "none") { + return undef; + } else { + my $id = $obj->{SONAME} || $obj->{file}; + $self->{objects}{$id} = $obj; + return $id; + } +} + +# Output format of objdump -w -T +# +# /lib/libc.so.6: format de fichier elf32-i386 +# +# DYNAMIC SYMBOL TABLE: +# 00056ef0 g DF .text 000000db GLIBC_2.2 getwchar +# 00000000 g DO *ABS* 00000000 GCC_3.0 GCC_3.0 +# 00069960 w DF .text 0000001e GLIBC_2.0 bcmp +# 00000000 w D *UND* 00000000 _pthread_cleanup_pop_restore +# 0000b788 g DF .text 0000008e Base .protected xine_close +# | ||||||| | | | | +# | ||||||| | | Version str (.visibility) + Symbol name +# | ||||||| | Alignment +# | ||||||| Section name (or *UND* for an undefined symbol) +# | ||||||F=Function,f=file,O=object +# | |||||d=debugging,D=dynamic +# | ||||I=Indirect +# | |||W=warning +# | ||C=constructor +# | |w=weak +# | g=global,l=local,!=both global/local +# Size of the symbol +# +# GLIBC_2.2 is the version string associated to the symbol +# (GLIBC_2.2) is the same but the symbol is hidden, a newer version of the +# symbol exist + +sub parse_dynamic_symbol { + my ($self, $line, $obj) = @_; + my $vis = '(?:\s+(?:\.protected|\.hidden|\.internal|0x\S+))?'; + if ($line =~ /^[0-9a-f]+ (.{7})\s+(\S+)\s+[0-9a-f]+\s+(\S+)?(?:$vis\s+(\S+))/) { + + my ($flags, $sect, $ver, $name) = ($1, $2, $3, $4); + my $symbol = { + 'name' => $name, + 'version' => defined($ver) ? $ver : '', + 'section' => $sect, + 'dynamic' => substr($flags, 5, 1) eq "D", + 'debug' => substr($flags, 5, 1) eq "d", + 'type' => substr($flags, 6, 1), + 'weak' => substr($flags, 1, 1) eq "w", + 'hidden' => 0, + 'defined' => $sect ne '*UND*' + }; + + #Â Handle hidden symbols + if (defined($ver) and $ver =~ /^\((.*)\)$/) { + $ver = $1; + $symbol->{'version'} = $1; + $symbol->{'hidden'} = 1; + } + + # Register symbol + $obj->add_dynamic_symbol($symbol); + } elsif ($line =~ /^[0-9a-f]+ (.{7})\s+(\S+)\s+[0-9a-f]+/) { + # Same start but no version and no symbol ... just ignore + } else { + main::warning(sprintf(_g("Couldn't parse one line of objdump's output: %s"), $line)); + } +} + +sub locate_symbol { + my ($self, $name) = @_; + foreach my $obj (values %{$self->{objects}}) { + my $sym = $obj->get_symbol($name); + if (defined($sym) && $sym->{defined}) { + return $sym; + } + } + return undef; +} + +sub get_object { + my ($self, $objid) = @_; + if (exists $self->{objects}{$objid}) { + return $self->{objects}{$objid}; + } + return undef; +} + +{ + my %format; # Cache of result + sub get_format { + my ($file) = @_; + + if (exists $format{$file}) { + return $format{$file}; + } else { + local $ENV{LC_ALL} = "C"; + open(P, "objdump -a -- $file |") || syserr(_g("cannot fork for objdump")); + while (<P>) { + chomp; + if (/^\s*\S+:\s*file\s+format\s+(\S+)\s*$/) { + $format{$file} = $1; + return $format{$file}; + } + } + close(P) or main::subprocerr(sprintf(_g("objdump on \`%s'"), $file)); + } + } +} + +sub is_elf { + my ($file) = @_; + open(FILE, "< $file") || main::syserr(sprintf(_g("Can't open %s for test: %s"), $file, $!)); + my ($header, $result) = ("", 0); + if (read(FILE, $header, 4) == 4) { + $result = 1 if ($header =~ /^\177ELF$/); + } + close(FILE); + return $result; +} + +package Dpkg::Shlibs::Objdump::Object; + +sub new { + my $this = shift; + my $file = shift || ''; + my $class = ref($this) || $this; + my $self = { + 'file' => $file, + 'SONAME' => '', + 'NEEDED' => [], + 'RPATH' => [], + 'dynsyms' => {} + }; + bless $self, $class; + return $self; +} + +sub add_dynamic_symbol { + my ($self, $symbol) = @_; + $symbol->{soname} = $self->{SONAME}; + if ($symbol->{version}) { + $self->{dynsyms}{$symbol->{name} . '@' . $symbol->{version}} = $symbol; + } else { + $self->{dynsyms}{$symbol->{name}} = $symbol; + } +} + +sub get_symbol { + my ($self, $name) = @_; + if (exists $self->{dynsyms}{$name}) { + return $self->{dynsyms}{$name}; + } + return undef; +} + +sub get_exported_dynamic_symbols { + my ($self) = @_; + return grep { $_->{defined} && $_->{dynamic} } + values %{$self->{dynsyms}}; +} + +sub get_undefined_dynamic_symbols { + my ($self) = @_; + return grep { (!$_->{defined}) && $_->{dynamic} } + values %{$self->{dynsyms}}; +} + +sub get_needed_libraries { + my $self = shift; + return @{$self->{NEEDED}}; +} + +1; diff --git a/scripts/modules/Shlibs.pm b/scripts/modules/Shlibs.pm new file mode 100644 index 0000000..f029933 --- /dev/null +++ b/scripts/modules/Shlibs.pm @@ -0,0 +1,69 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +require 'dpkg-gettext.pl'; + +use IO::File; + +use Exporter 'import'; +our @EXPORT_OK = qw(@librarypaths find_library); + +our @librarypaths = qw(/lib /usr/lib /lib32 /usr/lib32 /lib64 /usr/lib64 + /emul/ia32-linux/lib /emul/ia32-linux/usr/lib); + +# Update library paths with LD_LIBRARY_PATH +if ($ENV{LD_LIBRARY_PATH}) { + foreach my $path (reverse split( /:/, $ENV{LD_LIBRARY_PATH} )) { + $path =~ s{/+$}{}; + unless (scalar grep { $_ eq $path } @librarypaths) { + unshift @librarypaths, $path; + } + } +} + +# Update library paths with ld.so config +parse_ldso_conf("/etc/ld.so.conf") if -e "/etc/ld.so.conf"; + +sub parse_ldso_conf { + my $file = shift; + my $fh = new IO::File; + $fh->open("< $file") + or main::syserr(sprintf(_g("couldn't open %s: %s"), $file, $!)); + while (<$fh>) { + next if /^\s*$/; + chomp; + s{/+$}{}; + if (/^include\s+(\S.*\S)\s*$/) { + foreach my $include (glob($1)) { + parse_ldso_conf($include) if -e $include; + } + } elsif (m{^\s*/}) { + s/^\s+//; + my $libdir = $_; + unless (scalar grep { $_ eq $libdir } @librarypaths) { + push @librarypaths, $libdir; + } + } + } + $fh->close; +} + +# find_library ($soname, [EMAIL PROTECTED], $format, $root) +sub find_library { + my ($lib, $rpath, $format, $root) = @_; + $root = "" if not defined($root); + $root =~ s{/+$}{}; + my @rpath = @{$rpath}; + foreach my $dir (@rpath, @librarypaths) { + if (-e "$root$dir/$lib") { + my $libformat = Dpkg::Shlibs::Objdump::get_format("$root$dir/$lib"); + if ($format eq $libformat) { + return "$root$dir/$lib"; + } + } + } + return undef; +} + diff --git a/scripts/modules/SymbolFile.pm b/scripts/modules/SymbolFile.pm new file mode 100644 index 0000000..ccec332 --- /dev/null +++ b/scripts/modules/SymbolFile.pm @@ -0,0 +1,237 @@ +package Dpkg::Shlibs::SymbolFile; + +require 'dpkg-gettext.pl'; + +use Dpkg::Version qw(compare_versions); + +sub new { + my $this = shift; + my $file = shift; + my $class = ref($this) || $this; + my $self = { }; + bless $self, $class; + if (defined($file) ) { + $self->{file} = $file; + $self->load($file) if -e $file; + } + return $self; +} + +sub clear { + my ($self) = @_; + $self->{objects} = {}; +} + +sub clear_except { + my ($self, @ids) = @_; + my %has; + $has{$_} = 1 foreach (@ids); + foreach my $objid (keys %{$self->{objects}}) { + delete $self->{objects}{$objid} unless exists $has{$objid}; + } +} + +sub load { + my ($self, $file) = @_; + $self->{file} = $file; + open(SYM_FILE, "< $file") || main::syserr(sprintf(_g("Can't open %s: %s"), $file)); + my ($object); + while (defined($_ = <SYM_FILE>)) { + chomp($_); + if (/^\s+(\S+)\s(\S+)(?:\s(\d+))?/) { + # New symbol + my $sym = { + 'minver' => $2, + 'dep_id' => defined($3) ? $3 : 0, + 'deprecated' => 0 + }; + $self->{objects}{$object}{syms}{$1} = $sym; + } elsif (/^#DEPRECATED: ([^#]+)#\s*(\S+)\s(\S+)(?:\s(\d+))?/) { + my $sym = { + 'minver' => $3, + 'dep_id' => defined($4) ? $4 : 0, + 'deprecated' => $1 + }; + $self->{objects}{$object}{syms}{$2} = $sym; + } elsif (/^\|\s*(.*)$/) { + # Alternative dependency template + push @{$self->{objects}{$object}{deps}}, "$1"; + } elsif (/^(\S+)\s+(.*)$/) { + # New object and dependency template + $object = $1; + $self->{objects}{$object} = { + 'syms' => {}, + 'deps' => [ "$2" ] + }; + } else { + main::warning(sprintf(_g("Failed to parse a line in %s: %s"), $file, $_)); + } + } + close(SYM_FILE); +} + +sub save { + my ($self, $file) = @_; + $file = $self->{file} unless defined($file); + my $fh; + if ($file eq "-") { + $fh = \*STDOUT; + } else { + open(SYM_FILE, "> $file") || main::syserr(sprintf(_g("Can't open %s for writing: %s"), $file, $!)); + $fh = \*SYM_FILE; + } + $self->dump($fh); + close($fh) if ($file ne "-"); +} + +sub dump { + my ($self, $fh) = @_; + foreach my $soname (sort keys %{$self->{objects}}) { + print $fh "$soname $self->{objects}{$soname}{deps}[0]\n"; + print $fh "| $_" foreach (@{$self->{objects}{$soname}{deps}}[ 1 .. -1 ]); + foreach my $sym (sort keys %{$self->{objects}{$soname}{syms}}) { + my $info = $self->{objects}{$soname}{syms}{$sym}; + print $fh "#DEPRECATED: $info->{deprecated}#" if $info->{deprecated}; + print $fh " $sym $info->{minver}"; + print $fh " $info->{dep_id}" if $info->{dep_id}; + print $fh "\n"; + } + } +} + +# merge_symbols($object, $minver) +# Needs $Objdump->get_object($soname) as parameter +sub merge_symbols { + my ($self, $object, $minver) = @_; + my $soname = $object->{SONAME} || main::error(_g("Can't merge symbols from objects without SONAME.")); + my %dynsyms = map { $_ => $object->{dynsyms}{$_} } + grep { local $a = $object->{dynsyms}{$_}; $a->{dynamic} && $a->{defined} } + keys %{$object->{dynsyms}}; + # Scan all symbols provided by the objects + foreach my $sym (keys %dynsyms) { + if (exists $self->{objects}{$soname}{syms}{$sym}) { + # If the symbol is already listed in the file + my $info = $self->{objects}{$soname}{syms}{$sym}; + if ($info->{deprecated}) { + #Â Symbol reappeared somehow + $info->{deprecated} = 0; + $info->{minver} = $minver; + next; + } + # We assume that the right dependency information is already + # there. + if (compare_versions($minver, "lt", $info->{minver})) { + $info->{minver} = $minver; + } + } else { + # The symbol is new and not present in the file + my $info = { + 'minver' => $minver, + 'deprecated' => 0, + 'dep_id' => 0 + }; + $self->{objects}{$soname}{syms}{$sym} = $info; + } + } + + # Scan all symbols in the file and mark as deprecated those that are + # no more provided + foreach my $sym (keys %{$self->{objects}{$soname}{syms}}) { + if (! exists $dynsyms{$sym}) { + $self->{objects}{$soname}{syms}{$sym}{deprecated} = $minver; + } + } +} + +sub has_object { + my ($self, $soname) = @_; + return exists $self->{objects}{$soname}; +} + +sub create_object { + my ($self, $soname, @deps) = @_; + $self->{objects}{$soname} = { + "syms" => {}, + "deps" => [ @deps ] + }; +} + +sub get_dependency { + my ($self, $soname, $dep_id) = @_; + $dep_id = 0 unless defined($dep_id); + return $self->{objects}{$soname}{deps}[$dep_id]; +} + +sub lookup_symbol { + my ($self, $name, $sonames) = @_; + foreach my $so (@{$sonames}) { + next if (! exists $self->{objects}{$so}); + if (exists $self->{objects}{$so}{syms}{$name} and + not $self->{objects}{$so}{syms}{$name}{deprecated}) + { + my $dep_id = $self->{objects}{$so}{syms}{$name}{dep_id}; + return { + 'depends' => $self->{objects}{$so}{deps}[$dep_id], + 'soname' => $so, + %{$self->{objects}{$so}{syms}{$name}} + }; + } + } + return undef; +} + +sub has_lost_symbols { + my ($self, $ref) = @_; + foreach my $soname (keys %{$self->{objects}}) { + my $mysyms = $self->{objects}{$soname}{syms}; + next if not exists $ref->{objects}{$soname}; + my $refsyms = $ref->{objects}{$soname}{syms}; + foreach my $sym (grep { not $refsyms->{$_}{deprecated} } + keys %{$refsyms}) + { + if ((not exists $mysyms->{$sym}) or + $mysyms->{$sym}{deprecated}) + { + return 1; + } + } + } + return 0; +} + +sub has_new_symbols { + my ($self, $ref) = @_; + foreach my $soname (keys %{$self->{objects}}) { + my $mysyms = $self->{objects}{$soname}{syms}; + next if not exists $ref->{objects}{$soname}; + my $refsyms = $ref->{objects}{$soname}{syms}; + foreach my $sym (grep { not $mysyms->{$_}{deprecated} } + keys %{$mysyms}) + { + if ((not exists $refsyms->{$sym}) or + $refsyms->{$sym}{deprecated}) + { + return 1; + } + } + } + return 0; +} + +sub has_new_libs { + my ($self, $ref) = @_; + foreach my $soname (keys %{$self->{objects}}) { + return 1 if not exists $ref->{objects}{$soname}; + } + return 0; +} + +sub has_lost_libs { + my ($self, $ref) = @_; + foreach my $soname (keys %{$ref->{objects}}) { + return 1 if not exists $self->{objects}{$soname}; + } + return 0; +} + +1; diff --git a/scripts/modules/Version.pm b/scripts/modules/Version.pm new file mode 100644 index 0000000..04132cf --- /dev/null +++ b/scripts/modules/Version.pm @@ -0,0 +1,16 @@ +package Dpkg::Version; + +use strict; +use warnings; + +use Exporter 'import'; +our @EXPORT_OK = qw(compare_versions); + +sub compare_versions { + my ($a, $op, $b) = @_; + # TODO: maybe replace by a real full-perl versions + system("dpkg", "--compare-versions", $a, $op, $b) == 0 + or return 0; + return 1; +} +