| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701 |
- #!/usr/bin/perl -w
- use strict;
- use warnings;
- use English;
- use POSIX qw(:errno_h :signal_h);
- use Cwd qw(realpath);
- use Dpkg;
- use Dpkg::Gettext;
- use Dpkg::ErrorHandling qw(warning error failure syserr usageerr);
- use Dpkg::Path qw(relative_to_pkg_root guess_pkg_root_dir
- check_files_are_the_same);
- use Dpkg::Version qw(compare_versions);
- use Dpkg::Shlibs qw(find_library);
- use Dpkg::Shlibs::Objdump;
- use Dpkg::Shlibs::SymbolFile;
- use Dpkg::Arch qw(get_host_arch);
- use Dpkg::Fields qw(capit);
- use Dpkg::Deps;
- use Dpkg::Control;
- # By increasing importance
- my @depfields = qw(Suggests Recommends Depends Pre-Depends);
- my $i = 0; my %depstrength = map { $_ => $i++ } @depfields;
- textdomain("dpkg-dev");
- my $shlibsoverride = '/etc/dpkg/shlibs.override';
- my $shlibsdefault = '/etc/dpkg/shlibs.default';
- my $shlibslocal = 'debian/shlibs.local';
- my $packagetype = 'deb';
- my $dependencyfield = 'Depends';
- my $varlistfile = 'debian/substvars';
- my $varnameprefix = 'shlibs';
- my $ignore_missing_info = 0;
- my $debug = 0;
- my @exclude = ();
- my @pkg_dir_to_search = ();
- my $host_arch = get_host_arch();
- my (@pkg_shlibs, @pkg_symbols, @pkg_root_dirs);
- if (-d "debian") {
- push @pkg_symbols, <debian/*/DEBIAN/symbols>;
- push @pkg_shlibs, <debian/*/DEBIAN/shlibs>;
- my %uniq = map { guess_pkg_root_dir($_) => 1 } (@pkg_symbols, @pkg_shlibs);
- push @pkg_root_dirs, keys %uniq;
- }
- 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/^-S(.*)$/) {
- push @pkg_dir_to_search, $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(_g("administrative directory '%s' does not exist"), $admindir);
- } elsif (m/^-d(.*)$/) {
- $dependencyfield = capit($1);
- defined($depstrength{$dependencyfield}) ||
- warning(_g("unrecognised dependency field \`%s'"), $dependencyfield);
- } elsif (m/^-e(.*)$/) {
- if (exists $exec{$1}) {
- # Affect the binary to the most important field
- if ($depstrength{$dependencyfield} > $depstrength{$exec{$1}}) {
- $exec{$1} = $dependencyfield;
- }
- } else {
- $exec{$1} = $dependencyfield;
- }
- } elsif (m/^--ignore-missing-info$/) {
- $ignore_missing_info = 1;
- } elsif (m/^-t(.*)$/) {
- $packagetype = $1;
- } elsif (m/^-v$/) {
- $debug = 1;
- } elsif (m/^-x(.*)$/) {
- push @exclude, $1;
- } elsif (m/^-/) {
- usageerr(_g("unknown option \`%s'"), $_);
- } else {
- if (exists $exec{$_}) {
- # Affect the binary to the most important field
- if ($depstrength{$dependencyfield} > $depstrength{$exec{$_}}) {
- $exec{$_} = $dependencyfield;
- }
- } else {
- $exec{$_} = $dependencyfield;
- }
- }
- }
- scalar keys %exec || usageerr(_g("need at least one executable"));
- my $control = Dpkg::Control->new();
- my $fields = $control->get_source();
- my $build_depends = defined($fields->{"Build-Depends"}) ?
- $fields->{"Build-Depends"} : "";
- my $build_deps = Dpkg::Deps::parse($build_depends, reduce_arch => 1);
- my %dependencies;
- my %shlibs;
- my $cur_field;
- foreach my $file (keys %exec) {
- $cur_field = $exec{$file};
- print "Scanning $file (for $cur_field field)\n" if $debug;
- my $obj = Dpkg::Shlibs::Objdump::Object->new($file);
- my @sonames = $obj->get_needed_libraries;
- # Load symbols files for all needed libraries (identified by SONAME)
- my %libfiles;
- my %altlibfiles;
- my %soname_notfound;
- foreach my $soname (@sonames) {
- my $lib = my_find_library($soname, $obj->{RPATH}, $obj->{format}, $file);
- unless (defined $lib) {
- $soname_notfound{$soname} = 1;
- my $msg = _g("couldn't find library %s needed by %s (its RPATH is '%s').\n" .
- "Note: libraries are not searched in other binary packages " .
- "that do not have any shlibs or symbols file.\nTo help dpkg-shlibdeps " .
- "find private libraries, you might need to set LD_LIBRARY_PATH.");
- if (scalar(split_soname($soname))) {
- failure($msg, $soname, $file, join(":", @{$obj->{RPATH}}));
- } else {
- warning($msg, $soname, $file, join(":", @{$obj->{RPATH}}));
- }
- next;
- }
- $libfiles{$lib} = $soname;
- my $reallib = realpath($lib);
- if ($reallib ne $lib) {
- $altlibfiles{$reallib} = $soname;
- }
- print "Library $soname found in $lib\n" if $debug;
- }
- my $file2pkg = find_packages(keys %libfiles, keys %altlibfiles);
- my $symfile = Dpkg::Shlibs::SymbolFile->new();
- my $dumplibs_wo_symfile = Dpkg::Shlibs::Objdump->new();
- my @soname_wo_symfile;
- foreach my $lib (keys %libfiles) {
- my $soname = $libfiles{$lib};
- if (not scalar(grep { $_ ne '' } @{$file2pkg->{$lib}})) {
- # The path of the library as calculated is not the
- # official path of a packaged file, try to fallback on
- # on the realpath() first, maybe this one is part of a package
- my $reallib = realpath($lib);
- if (exists $file2pkg->{$reallib}) {
- $file2pkg->{$lib} = $file2pkg->{$reallib};
- }
- }
- if (not scalar(grep { $_ ne '' } @{$file2pkg->{$lib}})) {
- # If the library is really 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->{$lib} = [""];
- print "No associated package found for $lib\n" if $debug;
- }
- # Load symbols/shlibs files from packages providing libraries
- foreach my $pkg (@{$file2pkg->{$lib}}) {
- my $dpkg_symfile;
- if ($packagetype eq "deb") {
- # Use fine-grained dependencies only on real deb
- $dpkg_symfile = find_symbols_file($pkg, $soname, $lib);
- if (defined $dpkg_symfile) {
- # Load symbol information
- print "Using symbols file $dpkg_symfile for $soname\n" if $debug;
- $symfile->load($dpkg_symfile);
- }
- }
- if (defined($dpkg_symfile) && $symfile->has_object($soname)) {
- # 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
- my $id = $dumplibs_wo_symfile->parse($lib);
- push @soname_wo_symfile, $soname;
- my $libobj = $dumplibs_wo_symfile->get_object($id);
- # Only try to generate a dependency for libraries with a SONAME
- if ($libobj->is_public_library() and not
- add_shlibs_dep($soname, $pkg, $lib)) {
- # This failure is fairly new, try to be kind by
- # ignoring as many cases that can be safely ignored
- my $ignore = 0;
- # 1/ when the lib and the binary are in the same
- # package
- my $root_file = guess_pkg_root_dir($file);
- my $root_lib = guess_pkg_root_dir($lib);
- $ignore++ if defined $root_file and defined $root_lib
- and check_files_are_the_same($root_file, $root_lib);
- # 2/ when the lib is not versioned and can't be
- # handled by shlibs
- $ignore++ unless scalar(split_soname($soname));
- # 3/ when we have been asked to do so
- $ignore++ if $ignore_missing_info;
- failure(_g("no dependency information found for %s " .
- "(used by %s)."), $lib, $file)
- unless $ignore;
- }
- }
- }
- }
- # Scan all undefined symbols of the binary and resolve to a
- # dependency
- my %used_sonames = map { $_ => 0 } @sonames;
- my $nb_warnings = 0;
- my $nb_skipped_warnings = 0;
- # Disable warnings about missing symbols when we have not been able to
- # find all libs
- my $disable_warnings = scalar(keys(%soname_notfound));
- foreach my $sym ($obj->get_undefined_dynamic_symbols()) {
- my $name = $sym->{name};
- if ($sym->{version}) {
- $name .= "\@$sym->{version}";
- } else {
- $name .= "\@Base";
- }
- my $symdep = $symfile->lookup_symbol($name, \@sonames);
- if (defined($symdep)) {
- $used_sonames{$symdep->{soname}}++;
- update_dependency_version($symdep->{depends},
- $symdep->{minver});
- } else {
- my $syminfo = $dumplibs_wo_symfile->locate_symbol($name);
- if (not defined($syminfo)) {
- next if $disable_warnings;
- # Complain about missing symbols only for executables
- # and public libraries
- if ($obj->is_executable() or $obj->is_public_library()) {
- my $print_name = $name;
- # Drop the default suffix for readability
- $print_name =~ s/\@Base$//;
- unless ($sym->{weak}) {
- if ($debug or $nb_warnings < 10) {
- warning(_g("symbol %s used by %s found in none of the " .
- "libraries."), $print_name, $file);
- $nb_warnings++;
- } else {
- $nb_skipped_warnings++;
- }
- }
- }
- } else {
- $used_sonames{$syminfo->{soname}}++;
- }
- }
- }
- warning(_g("%d other similar warnings have been skipped (use -v to see " .
- "them all)."), $nb_skipped_warnings) if $nb_skipped_warnings;
- foreach my $soname (@sonames) {
- # Adjust minimal version of dependencies with information
- # extracted from build-dependencies
- my $dev_pkg = $symfile->get_field($soname, 'Build-Depends-Package');
- if (defined $dev_pkg) {
- my $minver = get_min_version_from_deps($build_deps, $dev_pkg);
- if (defined $minver) {
- foreach my $dep ($symfile->get_dependencies($soname)) {
- update_dependency_version($dep, $minver);
- }
- }
- }
- # Warn about un-NEEDED libraries
- unless ($soname_notfound{$soname} or $used_sonames{$soname}) {
- # Ignore warning for libm.so.6 if also linked against libstdc++
- next if ($soname =~ /^libm\.so\.\d+$/ and
- scalar grep(/^libstdc\+\+\.so\.\d+/, @sonames));
- warning(_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(_g("open new substvars file \`%s'"), "$varlistfile.new");
- if (-e $varlistfile) {
- open(OLD, "<", $varlistfile) ||
- syserr(_g("open old varlist file \`%s' for reading"), $varlistfile);
- foreach my $entry (grep { not m/^\Q$varnameprefix\E:/ } (<OLD>)) {
- print(NEW $entry) ||
- syserr(_g("copy old entry to new varlist file \`%s'"),
- "$varlistfile.new");
- }
- close(OLD);
- }
- $fh = \*NEW;
- }
- # Write out the shlibs substvars
- my %depseen;
- sub filter_deps {
- my ($dep, $field) = @_;
- # Skip dependencies on excluded packages
- foreach my $exc (@exclude) {
- return 0 if $dep =~ /^\s*\Q$exc\E\b/;
- }
- # Don't include dependencies if they are already
- # mentionned in a higher priority field
- if (not exists($depseen{$dep})) {
- $depseen{$dep} = $dependencies{$field}{$dep};
- return 1;
- } else {
- # Since dependencies can be versionned, we have to
- # verify if the dependency is stronger than the
- # previously seen one
- my $stronger;
- if ($depseen{$dep} eq $dependencies{$field}{$dep}) {
- # If both versions are the same (possibly unversionned)
- $stronger = 0;
- } elsif ($dependencies{$field}{$dep} eq '') {
- $stronger = 0; # If the dep is unversionned
- } elsif ($depseen{$dep} eq '') {
- $stronger = 1; # If the dep seen is unversionned
- } elsif (compare_versions($depseen{$dep}, '>>', $dependencies{$field}{$dep})) {
- # The version of the dep seen is stronger...
- $stronger = 0;
- } else {
- $stronger = 1;
- }
- $depseen{$dep} = $dependencies{$field}{$dep} if $stronger;
- return $stronger;
- }
- }
- 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 { filter_deps($_, $field) }
- 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(_g("install new varlist file \`%s'"), $varlistfile);
- }
- ##
- ## Functions
- ##
- sub version {
- printf _g("Debian %s version %s.\n"), $progname, $version;
- printf _g("
- Copyright (C) 1996 Ian Jackson.
- Copyright (C) 2000 Wichert Akkerman.
- 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
- later for copying conditions. There is NO warranty.
- ");
- }
- sub usage {
- printf _g(
- "Usage: %s [<option> ...] <executable>|-e<executable> [<option> ...]
- Positional options (order is significant):
- <executable> include dependencies for <executable>,
- -e<executable> (use -e if <executable> starts with \`-')
- -d<dependencyfield> next executable(s) set shlibs:<dependencyfield>.
- Options:
- -p<varnameprefix> set <varnameprefix>:* instead of shlibs:*.
- -O print variable settings to stdout.
- -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).
- -x<package> exclude package from the generated dependencies.
- -S<pkgbuilddir> search needed libraries in the given
- package build directory first.
- --admindir=<directory> change the administrative directory.
- -h, --help show this help message.
- --version show the version.
- Dependency fields recognised are:
- %s
- "), $progname, join("/",@depfields);
- }
- sub get_min_version_from_deps {
- my ($dep, $pkg) = @_;
- if ($dep->isa('Dpkg::Deps::Simple')) {
- if (($dep->{package} eq $pkg) &&
- defined($dep->{relation}) &&
- (($dep->{relation} eq ">=") ||
- ($dep->{relation} eq ">>")))
- {
- return $dep->{version};
- }
- return undef;
- } else {
- my $res;
- foreach my $subdep ($dep->get_deps()) {
- my $minver = get_min_version_from_deps($subdep, $pkg);
- next if not defined $minver;
- if (defined $res) {
- if (compare_versions($minver, '>>', $res)) {
- $res = $minver;
- }
- } else {
- $res = $minver;
- }
- }
- return $res;
- }
- }
- sub update_dependency_version {
- my ($dep, $minver) = @_;
- return if not defined($minver);
- foreach my $subdep (split /\s*,\s*/, $dep) {
- if (exists $dependencies{$cur_field}{$subdep} and
- defined($dependencies{$cur_field}{$subdep}))
- {
- if ($dependencies{$cur_field}{$subdep} eq '' or
- compare_versions($minver, '>>',
- $dependencies{$cur_field}{$subdep}))
- {
- $dependencies{$cur_field}{$subdep} = $minver;
- }
- } else {
- $dependencies{$cur_field}{$subdep} = $minver;
- }
- }
- }
- sub add_shlibs_dep {
- my ($soname, $pkg, $libfile) = @_;
- my @shlibs = ($shlibslocal, $shlibsoverride);
- if ($pkg eq "") {
- # If the file is not packaged, try to find out the shlibs file in
- # the package being built where the lib has been found
- my $pkg_root = guess_pkg_root_dir($libfile);
- if (defined $pkg_root) {
- push @shlibs, "$pkg_root/DEBIAN/shlibs";
- }
- # Fallback to other shlibs files but it shouldn't be necessary
- push @shlibs, @pkg_shlibs;
- } else {
- push @shlibs, "$admindir/info/$pkg.shlibs";
- }
- push @shlibs, $shlibsdefault;
- print "Looking up shlibs dependency of $soname provided by '$pkg'\n" if $debug;
- foreach my $file (@shlibs) {
- next if not -e $file;
- my $dep = extract_from_shlibs($soname, $file);
- if (defined($dep)) {
- print "Found $dep in $file\n" if $debug;
- foreach (split(/,\s*/, $dep)) {
- # Note: the value is empty for shlibs based dependency
- # symbol based dependency will put a version as value
- $dependencies{$cur_field}{$_} = '';
- }
- return 1;
- }
- }
- print "Found nothing\n" if $debug;
- return 0;
- }
- sub split_soname {
- my $soname = shift;
- if ($soname =~ /^(.*)\.so\.(.*)$/) {
- return wantarray ? ($1, $2) : 1;
- } elsif ($soname =~ /^(.*)-(\d.*)\.so$/) {
- return wantarray ? ($1, $2) : 1;
- } else {
- return wantarray ? () : 0;
- }
- }
- sub extract_from_shlibs {
- my ($soname, $shlibfile) = @_;
- # Split soname in name/version
- my ($libname, $libversion) = split_soname($soname);
- unless (defined $libname) {
- warning(_g("Can't extract name and version from library name \`%s'"),
- $soname);
- return;
- }
- # Open shlibs file
- $shlibfile = "./$shlibfile" if $shlibfile =~ m/^\s/;
- open(SHLIBS, "<", $shlibfile) ||
- syserr(_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(_g("shared libs info file \`%s' line %d: bad line \`%s'"),
- $shlibfile, $., $_);
- next;
- }
- my $depread = defined($4) ? $4 : '';
- if (($libname eq $2) && ($libversion eq $3)) {
- # Define dep and end here if the package type explicitely
- # matches. Otherwise if the packagetype is not specified, use
- # the dep only as a default that can be overriden by a later
- # line
- if (defined($1)) {
- if ($1 eq $packagetype) {
- $dep = $depread;
- last;
- }
- } else {
- $dep = $depread unless defined $dep;
- }
- }
- }
- close(SHLIBS);
- return $dep;
- }
- sub find_symbols_file {
- my ($pkg, $soname, $libfile) = @_;
- my @files;
- if ($pkg eq "") {
- # If the file is not packaged, try to find out the symbols file in
- # the package being built where the lib has been found
- my $pkg_root = guess_pkg_root_dir($libfile);
- if (defined $pkg_root) {
- push @files, "$pkg_root/DEBIAN/symbols";
- }
- # Fallback to other symbols files but it shouldn't be necessary
- push @files, @pkg_symbols;
- } else {
- push @files, "/etc/dpkg/symbols/$pkg.symbols.$host_arch",
- "/etc/dpkg/symbols/$pkg.symbols",
- "$admindir/info/$pkg.symbols";
- }
- foreach my $file (@files) {
- if (-e $file and symfile_has_soname($file, $soname)) {
- return $file;
- }
- }
- return undef;
- }
- sub symfile_has_soname {
- my ($file, $soname) = @_;
- open(SYM_FILE, "<", $file) ||
- syserr(_g("cannot open file %s"), $file);
- my $result = 0;
- while (<SYM_FILE>) {
- if (/^\Q$soname\E /) {
- $result = 1;
- last;
- }
- }
- close(SYM_FILE);
- return $result;
- }
- # find_library ($soname, \@rpath, $format)
- sub my_find_library {
- my ($lib, $rpath, $format, $execfile) = @_;
- my $file;
- # Create real RPATH in case $ORIGIN is used
- # Note: ld.so also supports $PLATFORM and $LIB but they are
- # used in real case (yet)
- my $libdir = relative_to_pkg_root($execfile);
- my $origin;
- if (defined $libdir) {
- $origin = "/$libdir";
- $origin =~ s{/+[^/]*$}{};
- }
- my @RPATH = ();
- foreach my $path (@{$rpath}) {
- if ($path =~ /\$ORIGIN|\$\{ORIGIN\}/) {
- if (defined $origin) {
- $path =~ s/\$ORIGIN/$origin/g;
- $path =~ s/\$\{ORIGIN\}/$origin/g;
- } else {
- warning(_g("\$ORIGIN is used in RPATH of %s and the corresponding " .
- "directory could not be identified due to lack of DEBIAN " .
- "sub-directory in the root of package's build tree"), $execfile);
- }
- }
- push @RPATH, $path;
- }
- # Look into the packages we're currently building in the following
- # order:
- # - package build tree of the binary which is analyzed
- # - package build tree given on the command line (option -S)
- # - other package build trees that contain either a shlibs or a
- # symbols file
- my @builddirs;
- my $pkg_root = guess_pkg_root_dir($execfile);
- push @builddirs, $pkg_root if defined $pkg_root;
- push @builddirs, @pkg_dir_to_search;
- push @builddirs, @pkg_root_dirs;
- my %dir_checked;
- foreach my $builddir (@builddirs) {
- next if defined($dir_checked{$builddir});
- $file = find_library($lib, \@RPATH, $format, $builddir);
- return $file if defined($file);
- $dir_checked{$builddir} = 1;
- }
- # Fallback in the root directory if we have not found what we were
- # looking for in the packages
- $file = find_library($lib, \@RPATH, $format, "");
- return $file if defined($file);
- return undef;
- }
- my %cached_pkgmatch = ();
- sub find_packages {
- my @files;
- my $pkgmatch = {};
- foreach (@_) {
- if (exists $cached_pkgmatch{$_}) {
- $pkgmatch->{$_} = $cached_pkgmatch{$_};
- } else {
- push @files, $_;
- $cached_pkgmatch{$_} = [""]; # placeholder to cache misses too.
- $pkgmatch->{$_} = [""]; # might be replaced later on
- }
- }
- return $pkgmatch unless scalar(@files);
- my $pid = open(DPKG, "-|");
- syserr(_g("cannot fork for dpkg --search")) unless defined($pid);
- if (!$pid) {
- # Child process running dpkg --search and discarding errors
- close STDERR;
- open STDERR, ">", "/dev/null";
- $ENV{LC_ALL} = "C";
- exec("dpkg", "--search", "--", @files)
- || syserr(_g("cannot exec dpkg"));
- }
- 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+)$/) {
- $cached_pkgmatch{$2} = $pkgmatch->{$2} = [ split(/, /, $1) ];
- } else {
- warning(_g("unknown output from dpkg --search: '%s'"), $_);
- }
- }
- close(DPKG);
- return $pkgmatch;
- }
|