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__ |