File Coverage

blib/lib/ExtUtils/Installed.pm
Criterion Covered Total %
statement 145 181 80.1
branch 68 104 65.3
condition 20 33 60.6
subroutine 22 25 88.0
pod 8 8 100.0
total 263 351 74.9


line stmt bran cond sub pod time code
1 1     1   94775 use strict;
  1         16  
  1         40  
2             package ExtUtils::Installed;
3              
4             #use warnings; # XXX requires 5.6
5 1     1   5 use Carp qw();
  1         2  
  1         16  
6 1     1   423 use ExtUtils::Packlist;
  1         3  
  1         31  
7 1     1   895 use ExtUtils::MakeMaker;
  1         110571  
  1         111  
8 1     1   15 use Config;
  1         3  
  1         44  
9 1     1   5 use File::Find;
  1         3  
  1         75  
10 1     1   11 use File::Basename;
  1         8  
  1         53  
11 1     1   6 use File::Spec;
  1         3  
  1         2481  
12              
13             my $Is_VMS = $^O eq 'VMS';
14             my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
15              
16             require VMS::Filespec if $Is_VMS;
17              
18             our $VERSION = '2.22';
19             $VERSION = eval $VERSION;
20              
21             sub _is_prefix {
22 27     27   187 my ($self, $path, $prefix) = @_;
23 27 100 100     120 return unless defined $prefix && defined $path;
24              
25 25 50       50 if( $Is_VMS ) {
26 0         0 $prefix = VMS::Filespec::unixify($prefix);
27 0         0 $path = VMS::Filespec::unixify($path);
28             }
29              
30             # Unix path normalization.
31 25         82 $prefix = File::Spec->canonpath($prefix);
32              
33 25 100       121 return 1 if substr($path, 0, length($prefix)) eq $prefix;
34              
35 13 50       30 if ($DOSISH) {
36 0         0 $path =~ s|\\|/|g;
37 0         0 $prefix =~ s|\\|/|g;
38 0 0       0 return 1 if $path =~ m{^\Q$prefix\E}i;
39             }
40 13         52 return(0);
41             }
42              
43             sub _is_doc {
44 4     4   12 my ($self, $path) = @_;
45              
46 4         28 my $man1dir = $self->{':private:'}{Config}{man1direxp};
47 4         25 my $man3dir = $self->{':private:'}{Config}{man3direxp};
48 4 50 33     71 return(($man1dir && $self->_is_prefix($path, $man1dir))
49             ||
50             ($man3dir && $self->_is_prefix($path, $man3dir))
51             ? 1 : 0)
52             }
53              
54             sub _is_type {
55 14     14   1990 my ($self, $path, $type) = @_;
56 14 100       44 return 1 if $type eq "all";
57              
58 9 50       21 return($self->_is_doc($path)) if $type eq "doc";
59 9         20 my $conf= $self->{':private:'}{Config};
60 9 100       22 if ($type eq "prog") {
61             return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp})
62 8 100 66     66 && !($self->_is_doc($path)) ? 1 : 0);
63             }
64 1         5 return(0);
65             }
66              
67             sub _is_under {
68 10     10   28 my ($self, $path, @under) = @_;
69 10 100       32 $under[0] = "" if (! @under);
70 10         23 foreach my $dir (@under) {
71 15 100       34 return(1) if ($self->_is_prefix($path, $dir));
72             }
73              
74 3         44 return(0);
75             }
76              
77             sub _fix_dirs {
78 12     12   111 my ($self, @dirs)= @_;
79             # File::Find does not know how to deal with VMS filepaths.
80 12 50       35 if( $Is_VMS ) {
81             $_ = VMS::Filespec::unixify($_)
82 0         0 for @dirs;
83             }
84              
85 12 50       35 if ($DOSISH) {
86 0         0 s|\\|/|g for @dirs;
87             }
88 12 100       78 return wantarray ? @dirs : $dirs[0];
89             }
90              
91             sub _make_entry {
92 305     305   823 my ($self, $module, $packlist_file, $modfile)= @_;
93              
94 305         1876 my $data= {
95             module => $module,
96             packlist => scalar(ExtUtils::Packlist->new($packlist_file)),
97             packlist_file => $packlist_file,
98             };
99              
100 305 100       848 if (!$modfile) {
101 6         53 $data->{version} = $self->{':private:'}{Config}{version};
102             } else {
103 299         685 $data->{modfile} = $modfile;
104             # Find the top-level module file in @INC
105 299         563 $data->{version} = '';
106 299         405 foreach my $dir (@{$self->{':private:'}{INC}}) {
  299         836  
107 2903         22146 my $p = File::Spec->catfile($dir, $modfile);
108 2903 100       35232 if (-r $p) {
109 299 50       815 $module = _module_name($p, $module) if $Is_VMS;
110              
111 299         1654 $data->{version} = MM->parse_version($p);
112 299         97986 $data->{version_from} = $p;
113 299         1485 $data->{packlist_valid} = exists $data->{packlist}{$p};
114 299         822 last;
115             }
116             }
117             }
118 305         8950 $self->{$module}= $data;
119             }
120              
121             our $INSTALLED;
122             sub new {
123 6     6 1 84060 my ($class) = shift(@_);
124 6   33     89 $class = ref($class) || $class;
125              
126 6         68 my %args = @_;
127              
128 6 0 0     39 return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default});
      33        
129              
130 6         59 my $self = bless {}, $class;
131              
132 6 50 33     91 $INSTALLED= $self if $args{default_set} || $args{default};
133              
134              
135 6 100       33 if ($args{config_override}) {
136 1 50       13 eval {
137 1         15 $self->{':private:'}{Config} = { %{$args{config_override}} };
  1         1170  
138             } or Carp::croak(
139             "The 'config_override' parameter must be a hash reference."
140             );
141             }
142             else {
143 5         73 $self->{':private:'}{Config} = \%Config;
144             }
145              
146 6         257 for my $tuple ([inc_override => INC => [ @INC ] ],
147             [ extra_libs => EXTRA => [] ])
148             {
149 12         57 my ($arg,$key,$val)=@$tuple;
150 12 100       64 if ( $args{$arg} ) {
    50          
151 2 50       14 eval {
152 2         11 $self->{':private:'}{$key} = [ @{$args{$arg}} ];
  2         43  
153             } or Carp::croak(
154             "The '$arg' parameter must be an array reference."
155             );
156             }
157             elsif ($val) {
158 10         56 $self->{':private:'}{$key} = $val;
159             }
160             }
161             {
162 6         36 my %dupe;
  6         24  
163 6         79 @{$self->{':private:'}{LIBDIRS}} =
164 59 100       184 grep { $_ ne '.' || ! $args{skip_cwd} }
165 84 100       1632 grep { -e $_ && !$dupe{$_}++ }
166 6         17 @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}};
  6         14  
  6         40  
167             }
168              
169 6         17 my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}});
  6         189  
170              
171             # Read the core packlist
172 6         41 my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp});
173 6         183 $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist'));
174              
175 6         20 my $root;
176             # Read the module packlists
177             my $sub = sub {
178             # Only process module .packlists
179 21571 100 100 21571   553309 return if $_ ne ".packlist" || $File::Find::dir eq $archlib;
180              
181             # Hack of the leading bits of the paths & convert to a module name
182 607         1030 my $module = $File::Find::name;
183             my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s
184 607 100       4489 or do {
185             # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n",
186             # join ("\n",@dirs);
187 10         255 return;
188             };
189              
190 597         1429 my $modfile = "$module.pm";
191 597         1613 $module =~ s!/!::!g;
192              
193 597 100       7374 return if $self->{$module}; #shadowing?
194 299         907 $self->_make_entry($module,$File::Find::name,$modfile);
195 6         140 };
196 6         21 while (@dirs) {
197 57         214 $root= shift @dirs;
198 57 50       731 next if !-d $root;
199 57         3544 find($sub,$root);
200             }
201              
202 6         112 return $self;
203             }
204              
205             # VMS's non-case preserving file-system means the package name can't
206             # be reconstructed from the filename.
207             sub _module_name {
208 0     0   0 my($file, $orig_module) = @_;
209              
210 0         0 my $module = '';
211 0 0       0 if (open PACKFH, $file) {
212 0         0 while () {
213 0 0       0 if (/package\s+(\S+)\s*;/) {
214 0         0 my $pack = $1;
215             # Make a sanity check, that lower case $module
216             # is identical to lowercase $pack before
217             # accepting it
218 0 0       0 if (lc($pack) eq lc($orig_module)) {
219 0         0 $module = $pack;
220 0         0 last;
221             }
222             }
223             }
224 0         0 close PACKFH;
225             }
226              
227 0 0       0 print STDERR "Couldn't figure out the package name for $file\n"
228             unless $module;
229              
230 0         0 return $module;
231             }
232              
233             sub modules {
234 2     2 1 4347 my ($self) = @_;
235 2 50       9 $self= $self->new(default=>1) if !ref $self;
236              
237             # Bug/feature of sort in scalar context requires this.
238             return wantarray
239 4         29 ? sort grep { not /^:private:$/ } keys %$self
240 2 100       19 : grep { not /^:private:$/ } keys %$self;
  4         19  
241             }
242              
243             sub files {
244 7     7 1 4519 my ($self, $module, $type, @under) = @_;
245 7 50       23 $self= $self->new(default=>1) if !ref $self;
246              
247             # Validate arguments
248 7 100       308 Carp::croak("$module is not installed") if (! exists($self->{$module}));
249 6 100       18 $type = "all" if (! defined($type));
250 6 100 100     119 Carp::croak('type must be "all", "prog" or "doc"')
      66        
251             if ($type ne "all" && $type ne "prog" && $type ne "doc");
252              
253 5         8 my (@files);
254 5         9 foreach my $file (keys(%{$self->{$module}{packlist}})) {
  5         25  
255 10 100 100     38 push(@files, $file)
256             if ($self->_is_type($file, $type) &&
257             $self->_is_under($file, @under));
258             }
259 5         30 return(@files);
260             }
261              
262             sub directories {
263 2     2 1 1724 my ($self, $module, $type, @under) = @_;
264 2 50       9 $self= $self->new(default=>1) if !ref $self;
265 2         5 my (%dirs);
266 2         6 foreach my $file ($self->files($module, $type, @under)) {
267 2         47 $dirs{dirname($file)}++;
268             }
269 2         14 return sort keys %dirs;
270             }
271              
272             sub directory_tree {
273 0     0 1 0 my ($self, $module, $type, @under) = @_;
274 0 0       0 $self= $self->new(default=>1) if !ref $self;
275 0         0 my (%dirs);
276 0         0 foreach my $dir ($self->directories($module, $type, @under)) {
277 0         0 $dirs{$dir}++;
278 0         0 my ($last) = ("");
279 0         0 while ($last ne $dir) {
280 0         0 $last = $dir;
281 0         0 $dir = dirname($dir);
282 0 0       0 last if !$self->_is_under($dir, @under);
283 0         0 $dirs{$dir}++;
284             }
285             }
286 0         0 return(sort(keys(%dirs)));
287             }
288              
289             sub validate {
290 2     2 1 2068 my ($self, $module, $remove) = @_;
291 2 50       9 $self= $self->new(default=>1) if !ref $self;
292 2 100       94 Carp::croak("$module is not installed") if (! exists($self->{$module}));
293 1         6 return($self->{$module}{packlist}->validate($remove));
294             }
295              
296             sub packlist {
297 2     2 1 1126 my ($self, $module) = @_;
298 2 50       8 $self= $self->new(default=>1) if !ref $self;
299 2 100       82 Carp::croak("$module is not installed") if (! exists($self->{$module}));
300 1         22 return($self->{$module}{packlist});
301             }
302              
303             sub version {
304 2     2 1 649 my ($self, $module) = @_;
305 2 50       9 $self= $self->new(default=>1) if !ref $self;
306 2 100       81 Carp::croak("$module is not installed") if (! exists($self->{$module}));
307 1         4 return($self->{$module}{version});
308             }
309              
310             sub _debug_dump {
311 0     0     my ($self, $module) = @_;
312 0 0         $self= $self->new(default=>1) if !ref $self;
313 0           local $self->{":private:"}{Config};
314 0           require Data::Dumper;
315 0           print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump();
316             }
317              
318              
319             1;
320              
321             __END__