File Coverage

lib/Module/Load/Conditional.pm
Criterion Covered Total %
statement 153 186 82.2
branch 41 82 50.0
condition 19 52 36.5
subroutine 21 21 100.0
pod 3 3 100.0
total 237 344 68.9


line stmt bran cond sub pod time code
1             package Module::Load::Conditional;
2              
3 1     1   747 use strict;
  1         3  
  1         35  
4              
5 1     1   528 use Module::Load qw/load autoload_remote/;
  1         1176  
  1         6  
6 1     1   578 use Params::Check qw[check];
  1         4185  
  1         63  
7 1     1   7 use Locale::Maketext::Simple Style => 'gettext';
  1         2  
  1         5  
8              
9 1     1   226 use Carp ();
  1         2  
  1         15  
10 1     1   19 use File::Spec ();
  1         3  
  1         15  
11 1     1   515 use FileHandle ();
  1         10156  
  1         31  
12 1     1   494 use version;
  1         1918  
  1         6  
13              
14 1     1   705 use Module::Metadata ();
  1         5999  
  1         38  
15              
16 1     1   9 use constant ON_VMS => $^O eq 'VMS';
  1         2  
  1         115  
17 1 50   1   7 use constant ON_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
  1         2  
  1         68  
18 1     1   7 use constant QUOTE => do { ON_WIN32 ? q["] : q['] };
  1         1  
  1         3  
  1         57  
19              
20             BEGIN {
21 1         90 use vars qw[ $VERSION @ISA $VERBOSE $CACHE @EXPORT_OK $DEPRECATED
22 1     1   6 $FIND_VERSION $ERROR $CHECK_INC_HASH $FORCE_SAFE_INC ];
  1         3  
23 1     1   6 use Exporter;
  1         2  
  1         71  
24 1     1   20 @ISA = qw[Exporter];
25 1         4 $VERSION = '0.72';
26 1         3 $VERBOSE = 0;
27 1         19 $DEPRECATED = 0;
28 1         2 $FIND_VERSION = 1;
29 1         2 $CHECK_INC_HASH = 0;
30 1         2 $FORCE_SAFE_INC = 0;
31 1         196 @EXPORT_OK = qw[check_install can_load requires];
32             }
33              
34             =pod
35              
36             =head1 NAME
37              
38             Module::Load::Conditional - Looking up module information / loading at runtime
39              
40             =head1 SYNOPSIS
41              
42             use Module::Load::Conditional qw[can_load check_install requires];
43              
44              
45             my $use_list = {
46             CPANPLUS => 0.05,
47             LWP => 5.60,
48             'Test::More' => undef,
49             };
50              
51             print can_load( modules => $use_list )
52             ? 'all modules loaded successfully'
53             : 'failed to load required modules';
54              
55              
56             my $rv = check_install( module => 'LWP', version => 5.60 )
57             or print 'LWP is not installed!';
58              
59             print 'LWP up to date' if $rv->{uptodate};
60             print "LWP version is $rv->{version}\n";
61             print "LWP is installed as file $rv->{file}\n";
62              
63              
64             print "LWP requires the following modules to be installed:\n";
65             print join "\n", requires('LWP');
66              
67             ### allow M::L::C to peek in your %INC rather than just
68             ### scanning @INC
69             $Module::Load::Conditional::CHECK_INC_HASH = 1;
70              
71             ### reset the 'can_load' cache
72             undef $Module::Load::Conditional::CACHE;
73              
74             ### don't have Module::Load::Conditional issue warnings --
75             ### default is '1'
76             $Module::Load::Conditional::VERBOSE = 0;
77              
78             ### The last error that happened during a call to 'can_load'
79             my $err = $Module::Load::Conditional::ERROR;
80              
81              
82             =head1 DESCRIPTION
83              
84             Module::Load::Conditional provides simple ways to query and possibly load any of
85             the modules you have installed on your system during runtime.
86              
87             It is able to load multiple modules at once or none at all if one of
88             them was not able to load. It also takes care of any error checking
89             and so forth.
90              
91             =head1 Methods
92              
93             =head2 $href = check_install( module => NAME [, version => VERSION, verbose => BOOL ] );
94              
95             C allows you to verify if a certain module is installed
96             or not. You may call it with the following arguments:
97              
98             =over 4
99              
100             =item module
101              
102             The name of the module you wish to verify -- this is a required key
103              
104             =item version
105              
106             The version this module needs to be -- this is optional
107              
108             =item verbose
109              
110             Whether or not to be verbose about what it is doing -- it will default
111             to $Module::Load::Conditional::VERBOSE
112              
113             =back
114              
115             It will return undef if it was not able to find where the module was
116             installed, or a hash reference with the following keys if it was able
117             to find the file:
118              
119             =over 4
120              
121             =item file
122              
123             Full path to the file that contains the module
124              
125             =item dir
126              
127             Directory, or more exact the C<@INC> entry, where the module was
128             loaded from.
129              
130             =item version
131              
132             The version number of the installed module - this will be C if
133             the module had no (or unparsable) version number, or if the variable
134             C<$Module::Load::Conditional::FIND_VERSION> was set to true.
135             (See the C section below for details)
136              
137             =item uptodate
138              
139             A boolean value indicating whether or not the module was found to be
140             at least the version you specified. If you did not specify a version,
141             uptodate will always be true if the module was found.
142             If no parsable version was found in the module, uptodate will also be
143             true, since C had no way to verify clearly.
144              
145             See also C<$Module::Load::Conditional::DEPRECATED>, which affects
146             the outcome of this value.
147              
148             =back
149              
150             =cut
151              
152             ### this checks if a certain module is installed already ###
153             ### if it returns true, the module in question is already installed
154             ### or we found the file, but couldn't open it, OR there was no version
155             ### to be found in the module
156             ### it will return 0 if the version in the module is LOWER then the one
157             ### we are looking for, or if we couldn't find the desired module to begin with
158             ### if the installed version is higher or equal to the one we want, it will return
159             ### a hashref with he module name and version in it.. so 'true' as well.
160             sub check_install {
161 21     21 1 12539 my %hash = @_;
162              
163 21         120 my $tmpl = {
164             version => { default => '0.0' },
165             module => { required => 1 },
166             verbose => { default => $VERBOSE },
167             };
168              
169 21         38 my $args;
170 21 50       95 unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) {
171 0 0       0 warn loc( q[A problem occurred checking arguments] ) if $VERBOSE;
172 0         0 return;
173             }
174              
175 21         2161 my $file = File::Spec->catfile( split /::/, $args->{module} ) . '.pm';
176             my $file_inc = File::Spec::Unix->catfile(
177             split /::/, $args->{module}
178 21         163 ) . '.pm';
179              
180             ### where we store the return value ###
181 21         84 my $href = {
182             file => undef,
183             version => undef,
184             uptodate => undef,
185             };
186              
187 21         39 my $filename;
188              
189             ### check the inc hash if we're allowed to
190 21 100       53 if( $CHECK_INC_HASH ) {
191             $filename = $href->{'file'} =
192 2 50       17 $INC{ $file_inc } if defined $INC{ $file_inc };
193              
194             ### find the version by inspecting the package
195 2 50 33     25 if( defined $filename && $FIND_VERSION ) {
196 1     1   7 no strict 'refs';
  1         2  
  1         518  
197 2         4 $href->{version} = ${ "$args->{module}"."::VERSION" };
  2         13  
198             }
199             }
200              
201             ### we didn't find the filename yet by looking in %INC,
202             ### so scan the dirs
203 21 100       53 unless( $filename ) {
204              
205 19 50 33     44 local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
206              
207 19         41 DIR: for my $dir ( @INC ) {
208              
209 83         163 my $fh;
210              
211 83 50       156 if ( ref $dir ) {
212             ### @INC hook -- we invoke it and get the filehandle back
213             ### this is actually documented behaviour as of 5.8 ;)
214              
215 0         0 my $existed_in_inc = $INC{$file_inc};
216              
217 0 0       0 if (UNIVERSAL::isa($dir, 'CODE')) {
    0          
    0          
218 0         0 ($fh) = $dir->($dir, $file);
219              
220             } elsif (UNIVERSAL::isa($dir, 'ARRAY')) {
221 0         0 ($fh) = $dir->[0]->($dir, $file, @{$dir}{1..$#{$dir}})
  0         0  
  0         0  
222              
223             } elsif (UNIVERSAL::can($dir, 'INC')) {
224 0         0 ($fh) = $dir->INC($file);
225             }
226              
227 0 0       0 if (!UNIVERSAL::isa($fh, 'GLOB')) {
228             warn loc(q[Cannot open file '%1': %2], $file, $!)
229 0 0       0 if $args->{verbose};
230 0         0 next;
231             }
232              
233 0   0     0 $filename = $INC{$file_inc} || $file;
234              
235 0 0       0 delete $INC{$file_inc} if not $existed_in_inc;
236              
237             } else {
238 83         618 $filename = File::Spec->catfile($dir, $file);
239 83 100       1857 next unless -e $filename;
240              
241 18         135 $fh = FileHandle->new();
242 18 50       662 if (!$fh->open($filename)) {
243             warn loc(q[Cannot open file '%1': %2], $file, $!)
244 0 0       0 if $args->{verbose};
245 0         0 next;
246             }
247             }
248              
249             ### store the directory we found the file in
250 18         899 $href->{dir} = $dir;
251              
252             ### files need to be in unix format under vms,
253             ### or they might be loaded twice
254 18         39 $href->{file} = ON_VMS
255             ? VMS::Filespec::unixify( $filename )
256             : $filename;
257              
258             ### if we don't need the version, we're done
259 18 100       64 last DIR unless $FIND_VERSION;
260              
261             ### otherwise, the user wants us to find the version from files
262              
263             {
264 16     1   29 local $SIG{__WARN__} = sub {};
  16         122  
265 16         33 my $ver = eval {
266 16         95 my $mod_info = Module::Metadata->new_from_handle( $fh, $filename );
267 15         49823 $mod_info->version( $args->{module} );
268             };
269              
270 16 100       642 if( defined $ver ) {
271 12         26 $href->{version} = $ver;
272              
273 12         256 last DIR;
274             }
275             }
276             }
277             }
278              
279             ### if we couldn't find the file, return undef ###
280 21 100       107 return unless defined $href->{file};
281              
282             ### only complain if we're expected to find a version higher than 0.0 anyway
283 20 100 100     118 if( $FIND_VERSION and not defined $href->{version} ) {
284             { ### don't warn about the 'not numeric' stuff ###
285 4         8 local $^W;
  4         18  
286              
287             ### if we got here, we didn't find the version
288             warn loc(q[Could not check version on '%1'], $args->{module} )
289 4 50 33     21 if $args->{verbose} and $args->{version} > 0;
290             }
291 4         10 $href->{uptodate} = 1;
292              
293             } else {
294             ### don't warn about the 'not numeric' stuff ###
295 16         78 local $^W;
296              
297             ### use qv(), as it will deal with developer release number
298             ### ie ones containing _ as well. This addresses bug report
299             ### #29348: Version compare logic doesn't handle alphas?
300             ###
301             ### Update from JPeacock: apparently qv() and version->new
302             ### are different things, and we *must* use version->new
303             ### here, or things like #30056 might start happening
304              
305             ### We have to wrap this in an eval as version-0.82 raises
306             ### exceptions and not warnings now *sigh*
307              
308 16         39 eval {
309              
310             $href->{uptodate} =
311             version->new( $args->{version} ) <= version->new( $href->{version} )
312 16 100       316 ? 1
313             : 0;
314              
315             };
316             }
317              
318 20 50 33     86 if ( $DEPRECATED and "$]" >= 5.011 ) {
319 0 0 0     0 local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
320 0         0 require Module::CoreList;
321 0         0 require Config;
322              
323 1     1   8 no warnings 'once';
  1         3  
  1         1074  
324             $href->{uptodate} = 0 if
325             exists $Module::CoreList::version{ 0+$] }{ $args->{module} } and
326             Module::CoreList::is_deprecated( $args->{module} ) and
327             $Config::Config{privlibexp} eq $href->{dir}
328 0 0 0     0 and $Config::Config{privlibexp} ne $Config::Config{sitelibexp};
      0        
      0        
329             }
330              
331 20         122 return $href;
332             }
333              
334             =head2 $bool = can_load( modules => { NAME => VERSION [,NAME => VERSION] }, [verbose => BOOL, nocache => BOOL, autoload => BOOL] )
335              
336             C will take a list of modules, optionally with version
337             numbers and determine if it is able to load them. If it can load *ALL*
338             of them, it will. If one or more are unloadable, none will be loaded.
339              
340             This is particularly useful if you have More Than One Way (tm) to
341             solve a problem in a program, and only wish to continue down a path
342             if all modules could be loaded, and not load them if they couldn't.
343              
344             This function uses the C function or the C function
345             from Module::Load under the hood.
346              
347             C takes the following arguments:
348              
349             =over 4
350              
351             =item modules
352              
353             This is a hashref of module/version pairs. The version indicates the
354             minimum version to load. If no version is provided, any version is
355             assumed to be good enough.
356              
357             =item verbose
358              
359             This controls whether warnings should be printed if a module failed
360             to load.
361             The default is to use the value of $Module::Load::Conditional::VERBOSE.
362              
363             =item nocache
364              
365             C keeps its results in a cache, so it will not load the
366             same module twice, nor will it attempt to load a module that has
367             already failed to load before. By default, C will check its
368             cache, but you can override that by setting C to true.
369              
370             =item autoload
371              
372             This controls whether imports the functions of a loaded modules to the caller package. The default is no importing any functions.
373              
374             See the C function and the C function from L for details.
375              
376             =cut
377              
378             sub can_load {
379 7     7 1 5723 my %hash = @_;
380              
381 7         95 my $tmpl = {
382             modules => { default => {}, strict_type => 1 },
383             verbose => { default => $VERBOSE },
384             nocache => { default => 0 },
385             autoload => { default => 0 },
386             };
387              
388 7         20 my $args;
389              
390 7 50       27 unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) {
391 0         0 $ERROR = loc(q[Problem validating arguments!]);
392 0 0       0 warn $ERROR if $VERBOSE;
393 0         0 return;
394             }
395              
396             ### layout of $CACHE:
397             ### $CACHE = {
398             ### $ module => {
399             ### usable => BOOL,
400             ### version => \d,
401             ### file => /path/to/file,
402             ### },
403             ### };
404              
405 7   100     700 $CACHE ||= {}; # in case it was undef'd
406              
407 7         13 my $error;
408             BLOCK: {
409 7         10 my $href = $args->{modules};
  7         14  
410              
411 7         12 my @load;
412 7         19 for my $mod ( keys %$href ) {
413              
414 8 100 66     34 next if $CACHE->{$mod}->{usable} && !$args->{nocache};
415              
416             ### else, check if the hash key is defined already,
417             ### meaning $mod => 0,
418             ### indicating UNSUCCESSFUL prior attempt of usage
419              
420             ### use qv(), as it will deal with developer release number
421             ### ie ones containing _ as well. This addresses bug report
422             ### #29348: Version compare logic doesn't handle alphas?
423             ###
424             ### Update from JPeacock: apparently qv() and version->new
425             ### are different things, and we *must* use version->new
426             ### here, or things like #30056 might start happening
427 7 50 66     77 if ( !$args->{nocache}
      50        
      66        
428             && defined $CACHE->{$mod}->{usable}
429             && (version->new( $CACHE->{$mod}->{version}||0 )
430             >= version->new( $href->{$mod} ) )
431             ) {
432 0         0 $error = loc( q[Already tried to use '%1', which was unsuccessful], $mod);
433 0         0 last BLOCK;
434             }
435              
436             my $mod_data = check_install(
437             module => $mod,
438 7         55 version => $href->{$mod}
439             );
440              
441 7 50 33     35 if( !$mod_data or !defined $mod_data->{file} ) {
442 0         0 $error = loc(q[Could not find or check module '%1'], $mod);
443 0         0 $CACHE->{$mod}->{usable} = 0;
444 0         0 last BLOCK;
445             }
446              
447             map {
448 7         15 $CACHE->{$mod}->{$_} = $mod_data->{$_}
  21         59  
449             } qw[version file uptodate];
450              
451 7         26 push @load, $mod;
452             }
453              
454 7         20 for my $mod ( @load ) {
455              
456 7 100       19 if ( $CACHE->{$mod}->{uptodate} ) {
457              
458 5 50 33     19 local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
459              
460 5 100       14 if ( $args->{autoload} ) {
461 1         4 my $who = (caller())[0];
462 1         3 eval { autoload_remote $who, $mod };
  1         6  
463             } else {
464 4         8 eval { load $mod };
  4         26  
465             }
466              
467             ### in case anything goes wrong, log the error, the fact
468             ### we tried to use this module and return 0;
469 5 50       2253 if( $@ ) {
470 0         0 $error = $@;
471 0         0 $CACHE->{$mod}->{usable} = 0;
472 0         0 last BLOCK;
473             } else {
474 5         29 $CACHE->{$mod}->{usable} = 1;
475             }
476              
477             ### module not found in @INC, store the result in
478             ### $CACHE and return 0
479             } else {
480              
481 2         9 $error = loc(q[Module '%1' is not uptodate!], $mod);
482 2         41 $CACHE->{$mod}->{usable} = 0;
483 2         7 last BLOCK;
484             }
485             }
486              
487             } # BLOCK
488              
489 7 100       20 if( defined $error ) {
490 2         4 $ERROR = $error;
491 2 50       5 Carp::carp( loc(q|%1 [THIS MAY BE A PROBLEM!]|,$error) ) if $args->{verbose};
492 2         11 return;
493             } else {
494 5         39 return 1;
495             }
496             }
497              
498             =back
499              
500             =head2 @list = requires( MODULE );
501              
502             C can tell you what other modules a particular module
503             requires. This is particularly useful when you're intending to write
504             a module for public release and are listing its prerequisites.
505              
506             C takes but one argument: the name of a module.
507             It will then first check if it can actually load this module, and
508             return undef if it can't.
509             Otherwise, it will return a list of modules and pragmas that would
510             have been loaded on the module's behalf.
511              
512             Note: The list C returns has originated from your current
513             perl and your current install.
514              
515             =cut
516              
517             sub requires {
518 1     1 1 916 my $who = shift;
519              
520 1 50       4 unless( check_install( module => $who ) ) {
521 0 0       0 warn loc(q[You do not have module '%1' installed], $who) if $VERBOSE;
522 0         0 return undef;
523             }
524              
525 1 50 33     9 local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
526              
527 1         7 my $lib = join " ", map { qq["-I$_"] } @INC;
  11         33  
528 1         4 my $oneliner = 'print(join(qq[\n],map{qq[BONG=$_]}keys(%INC)),qq[\n])';
529 1         8 my $cmd = join '', qq["$^X" $lib -M$who -e], QUOTE, $oneliner, QUOTE;
530              
531             return sort
532 4         124 grep { !/^$who$/ }
533 4         18 map { chomp; s|/|::|g; $_ }
  4         15  
  4         10  
534 4         32 grep { s|\.pm$||i; }
535 4         36 map { s!^BONG\=!!; $_ }
  4         22  
536 1         16772 grep { m!^BONG\=! }
  4         74  
537             `$cmd`;
538             }
539              
540             1;
541              
542             __END__