File Coverage

blib/lib/Sys/GNU/ldconfig.pm

Criterion	Covered	Total	%
statement	111	122	90.9
branch	28	46	60.8
condition	4	9	44.4
subroutine	23	23	100.0
pod	6	6	100.0
total	172	206	83.5

package Sys::GNU::ldconfig;
# $Id: ldconfig.pm 2456 2023-07-06 23:06:00Z fil $
# Copyright 2013 Philip Gwyn - All rights reserved

use 5.00405;
use strict;
use warnings;

use vars qw($VERSION @ISA @EXPORT);

$VERSION = '0.03';

require Exporter;
@ISA = qw( Exporter );
@EXPORT = qw( ld_lookup ld_root );

sub DEBUG () { 0 }

use Carp;
use Config;
use File::Basename qw( dirname );
use File::Glob qw( bsd_glob );
use File::Slurp qw( slurp );
use File::Spec;


#############################################################################
our $LD;
sub ld_lookup
{
    my( $name ) = @_;
    $LD ||= Sys::GNU::ldconfig->new;
    return $LD->lookup( $name );
}

sub ld_root
{
    my( $path ) = @_;
    $LD ||= Sys::GNU::ldconfig->new;
    $LD->root( $path );
}

#############################################################################
sub new
{
    my( $package ) = @_;
    $package = ref $package if ref $package;
    my $self = bless { root => File::Spec->rootdir,
                       absroot => File::Spec->rootdir,
                       dirs => [],
                       have_dirs => 0
                     }, $package;
    return $self;
}

#################################################
sub root
{
    my( $self, $path ) = @_;
    confess "Root '$path' doesn't exist" unless -d $path;
    $self->{root} = $path;
    $self->{have_dirs} = 0;
    $self->{dirs} = [];
    return;
}


#################################################
# The heart of the module
sub lookup
{
    my( $self, $part ) = @_;

    my $file = $self->_lookup( $part );
    return unless defined $file;
    return $self->_derooted( $file );
}

sub _lookup
{
    my( $self, $part ) = @_;

    $part = "lib$part" unless $part =~ /^lib/;
    $part = "$part.$Config{dlext}" unless $part =~ /\.\Q$Config{dlext}\E/;  # allow .so.7 (for example)
    DEBUG and warn "Looking for '$part'\n";

    return $self->_chase_lib( $part ) if -e $part;
    foreach my $dir ( $self->dirs ) {
        my $file = File::Spec->catfile( $dir, $part );
        return $self->_chase_lib( $file ) if -e $file;
    }
    return;
}


# This logic is lifted from PAR::Packer
# _chase_lib - find the runtime link of a shared library
# Logic based on info found at the following sites:
# http://lists.debian.org/lsb-spec/1999/05/msg00011.html
# http://docs.sun.com/app/docs/doc/806-0641/6j9vuqujh?a=view#chapter5-97360
sub _chase_lib {
   my ($self, $file) = @_;

   while ($Config{d_symlink} and -l $file) {
       if ($file =~ /^(.*?\.\Q$Config{dlext}\E\.\d+)\..*/) {
           return $1 if -e $1;
       }

       return $file if $file =~ /\.\Q$Config{dlext}\E\.\d+$/;

       my $dir = File::Basename::dirname($file);
       $file = readlink($file);

       unless (File::Spec->file_name_is_absolute($file)) {
           $file = File::Spec->rel2abs($file, $dir);
       }
   }

   if ($file =~ /^(.*?\.\Q$Config{dlext}\E\.\d+)\..*/) {
       return $1 if -e $1;
   }

   return $file;
}

#################################################
sub _rooted
{
    my( $self, $dir ) = @_;
    my $root = $self->{root};
    return $dir if $root eq $self->{absroot};
    return File::Spec->catdir( $root, $dir );
}

#################################################
sub _derooted
{
    my( $self, $file ) = @_;
    my $root = $self->{root};
    $file =~ s/^\Q$root// unless $root eq $self->{absroot};
    return $file;
}

#################################################
sub _list_dirs
{
    my( $self ) = @_;
    my @dirs;
    if( $ENV{$Config{ldlibpthname}} ) {
        DEBUG and warn "Using $Config{ldlibpthname}\n";
        push @dirs, map { $self->_rooted( $_ ) }
                    split ':', $ENV{$Config{ldlibpthname}};
    }
    my $conf = File::Spec->catfile( $self->{root}, 'etc', 'ld.so.conf' );
    push @dirs, $self->_read_conf( $conf ) if -f $conf;

    push @dirs, map { $self->_rooted( $_ ) } qw( /lib64 /lib /usr/lib64 /usr/lib );
    foreach my $dir ( @dirs ) {
        next unless -d $dir;
        DEBUG and warn "Search in $dir\n";
        push @{ $self->{dirs} }, $dir;
    }
    $self->{have_dirs} = 1;
}


#################################################
sub _read_conf
{
    my( $self, $file ) = @_;
    DEBUG and warn "Reading config '$file'\n";
    my $c = slurp( $file );
    my @dirs = split /[: \t\n,]+/, $c;
    my @ret;
    my $include_next = 0;
    foreach my $dir ( @dirs ) {
        if( $include_next ) {
            $include_next = 0;
            push @ret, $self->_read_glob( $file, $dir );
        }
        elsif( $dir eq 'include' ) {
            $include_next = 1;
        }
        else {
            push @ret, $self->_rooted( $dir );
        }
    }
    return @ret;
}


sub _read_glob
{
    my( $self, $file, $dir ) = @_;
    my( $vol, $dirname, $glob ) = File::Spec->splitpath( $dir );
    my $root = $self->{root};
    $root = dirname( $file ) unless File::Spec->file_name_is_absolute( $dir );
    my $confdir = File::Spec->catdir( $root, $dirname );
    DEBUG and warn "Look in $confdir for $glob\n";
    my @ret;
    foreach my $conf ( bsd_glob( File::Spec->catfile( $confdir, $glob ) ) ) {
        next unless -f $conf;
        push @ret, $self->_read_conf( $conf );
    }
    return @ret;
}


#################################################
sub dirs
{
    my( $self ) = @_;
    $self->_list_dirs unless $self->{have_dirs};
    return @{ $self->{dirs} };
}

1;
__END__