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


line stmt bran cond sub pod time code
1             package Sys::GNU::ldconfig;
2             # $Id: ldconfig.pm 2456 2023-07-06 23:06:00Z fil $
3             # Copyright 2013 Philip Gwyn - All rights reserved
4              
5 1     1   67297 use 5.00405;
  1         11  
6 1     1   5 use strict;
  1         2  
  1         30  
7 1     1   6 use warnings;
  1         2  
  1         31  
8              
9 1     1   4 use vars qw($VERSION @ISA @EXPORT);
  1         2  
  1         162  
10              
11             $VERSION = '0.03';
12              
13             require Exporter;
14             @ISA = qw( Exporter );
15             @EXPORT = qw( ld_lookup ld_root );
16              
17             sub DEBUG () { 0 }
18              
19 1     1   8 use Carp;
  1         2  
  1         64  
20 1     1   6 use Config;
  1         2  
  1         52  
21 1     1   7 use File::Basename qw( dirname );
  1         1  
  1         95  
22 1     1   7 use File::Glob qw( bsd_glob );
  1         2  
  1         99  
23 1     1   540 use File::Slurp qw( slurp );
  1         40765  
  1         54  
24 1     1   8 use File::Spec;
  1         2  
  1         1404  
25              
26              
27             #############################################################################
28             our $LD;
29             sub ld_lookup
30             {
31 2     2 1 108 my( $name ) = @_;
32 2   66     27 $LD ||= Sys::GNU::ldconfig->new;
33 2         5 return $LD->lookup( $name );
34             }
35              
36             sub ld_root
37             {
38 1     1 1 575 my( $path ) = @_;
39 1   33     4 $LD ||= Sys::GNU::ldconfig->new;
40 1         4 $LD->root( $path );
41             }
42              
43             #############################################################################
44             sub new
45             {
46 2     2 1 671 my( $package ) = @_;
47 2 50       6 $package = ref $package if ref $package;
48 2         22 my $self = bless { root => File::Spec->rootdir,
49             absroot => File::Spec->rootdir,
50             dirs => [],
51             have_dirs => 0
52             }, $package;
53 2         13 return $self;
54             }
55              
56             #################################################
57             sub root
58             {
59 2     2 1 386 my( $self, $path ) = @_;
60 2 50       34 confess "Root '$path' doesn't exist" unless -d $path;
61 2         7 $self->{root} = $path;
62 2         4 $self->{have_dirs} = 0;
63 2         4 $self->{dirs} = [];
64 2         7 return;
65             }
66              
67              
68             #################################################
69             # The heart of the module
70             sub lookup
71             {
72 8     8 1 2969 my( $self, $part ) = @_;
73              
74 8         19 my $file = $self->_lookup( $part );
75 8 100       24 return unless defined $file;
76 7         16 return $self->_derooted( $file );
77             }
78              
79             sub _lookup
80             {
81 8     8   15 my( $self, $part ) = @_;
82              
83 8 100       35 $part = "lib$part" unless $part =~ /^lib/;
84 8 100       100 $part = "$part.$Config{dlext}" unless $part =~ /\.\Q$Config{dlext}\E/; # allow .so.7 (for example)
85 8         20 DEBUG and warn "Looking for '$part'\n";
86              
87 8 50       151 return $self->_chase_lib( $part ) if -e $part;
88 8         45 foreach my $dir ( $self->dirs ) {
89 26         217 my $file = File::Spec->catfile( $dir, $part );
90 26 100       499 return $self->_chase_lib( $file ) if -e $file;
91             }
92 1         6 return;
93             }
94              
95              
96             # This logic is lifted from PAR::Packer
97             # _chase_lib - find the runtime link of a shared library
98             # Logic based on info found at the following sites:
99             # http://lists.debian.org/lsb-spec/1999/05/msg00011.html
100             # http://docs.sun.com/app/docs/doc/806-0641/6j9vuqujh?a=view#chapter5-97360
101             sub _chase_lib {
102 7     7   22 my ($self, $file) = @_;
103              
104 7   33     137 while ($Config{d_symlink} and -l $file) {
105 0 0       0 if ($file =~ /^(.*?\.\Q$Config{dlext}\E\.\d+)\..*/) {
106 0 0       0 return $1 if -e $1;
107             }
108              
109 0 0       0 return $file if $file =~ /\.\Q$Config{dlext}\E\.\d+$/;
110              
111 0         0 my $dir = File::Basename::dirname($file);
112 0         0 $file = readlink($file);
113              
114 0 0       0 unless (File::Spec->file_name_is_absolute($file)) {
115 0         0 $file = File::Spec->rel2abs($file, $dir);
116             }
117             }
118              
119 7 50       94 if ($file =~ /^(.*?\.\Q$Config{dlext}\E\.\d+)\..*/) {
120 0 0       0 return $1 if -e $1;
121             }
122            
123 7         27 return $file;
124             }
125              
126             #################################################
127             sub _rooted
128             {
129 29     29   54 my( $self, $dir ) = @_;
130 29         39 my $root = $self->{root};
131 29 100       72 return $dir if $root eq $self->{absroot};
132 14         88 return File::Spec->catdir( $root, $dir );
133             }
134              
135             #################################################
136             sub _derooted
137             {
138 7     7   15 my( $self, $file ) = @_;
139 7         10 my $root = $self->{root};
140 7 50       57 $file =~ s/^\Q$root// unless $root eq $self->{absroot};
141 7         29 return $file;
142             }
143              
144             #################################################
145             sub _list_dirs
146             {
147 3     3   7 my( $self ) = @_;
148 3         4 my @dirs;
149 3 50       24 if( $ENV{$Config{ldlibpthname}} ) {
150 0         0 DEBUG and warn "Using $Config{ldlibpthname}\n";
151 0         0 push @dirs, map { $self->_rooted( $_ ) }
152 0         0 split ':', $ENV{$Config{ldlibpthname}};
153             }
154 3         34 my $conf = File::Spec->catfile( $self->{root}, 'etc', 'ld.so.conf' );
155 3 50       90 push @dirs, $self->_read_conf( $conf ) if -f $conf;
156              
157 3         8 push @dirs, map { $self->_rooted( $_ ) } qw( /lib64 /lib /usr/lib64 /usr/lib );
  12         22  
158 3         8 foreach my $dir ( @dirs ) {
159 29 100       402 next unless -d $dir;
160 15         28 DEBUG and warn "Search in $dir\n";
161 15         22 push @{ $self->{dirs} }, $dir;
  15         45  
162             }
163 3         13 $self->{have_dirs} = 1;
164             }
165              
166              
167             #################################################
168             sub _read_conf
169             {
170 8     8   22 my( $self, $file ) = @_;
171 8         8 DEBUG and warn "Reading config '$file'\n";
172 8         29 my $c = slurp( $file );
173 8         1060 my @dirs = split /[: \t\n,]+/, $c;
174 8         17 my @ret;
175 8         12 my $include_next = 0;
176 8         16 foreach my $dir ( @dirs ) {
177 23 100       52 if( $include_next ) {
    100          
178 3         5 $include_next = 0;
179 3         8 push @ret, $self->_read_glob( $file, $dir );
180             }
181             elsif( $dir eq 'include' ) {
182 3         7 $include_next = 1;
183             }
184             else {
185 17         38 push @ret, $self->_rooted( $dir );
186             }
187             }
188 8         30 return @ret;
189             }
190              
191              
192             sub _read_glob
193             {
194 3     3   8 my( $self, $file, $dir ) = @_;
195 3         42 my( $vol, $dirname, $glob ) = File::Spec->splitpath( $dir );
196 3         10 my $root = $self->{root};
197 3 100       117 $root = dirname( $file ) unless File::Spec->file_name_is_absolute( $dir );
198 3         22 my $confdir = File::Spec->catdir( $root, $dirname );
199 3         6 DEBUG and warn "Look in $confdir for $glob\n";
200 3         4 my @ret;
201 3         327 foreach my $conf ( bsd_glob( File::Spec->catfile( $confdir, $glob ) ) ) {
202 5 50       71 next unless -f $conf;
203 5         23 push @ret, $self->_read_conf( $conf );
204             }
205 3         13 return @ret;
206             }
207              
208              
209             #################################################
210             sub dirs
211             {
212 8     8 1 19 my( $self ) = @_;
213 8 100       25 $self->_list_dirs unless $self->{have_dirs};
214 8         11 return @{ $self->{dirs} };
  8         31  
215             }
216              
217             1;
218             __END__