This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade Module::Load::Conditional to 0.14
[perl5.git] / lib / Module / Load / Conditional.pm
1 package Module::Load::Conditional;
2
3 use strict;
4
5 use Module::Load;
6 use Params::Check qw[check];
7 use Locale::Maketext::Simple Style => 'gettext';
8
9 use Carp        ();
10 use File::Spec  ();
11 use FileHandle  ();
12
13 BEGIN {
14     use vars        qw[ $VERSION @ISA $VERBOSE $CACHE @EXPORT_OK 
15                         $FIND_VERSION $ERROR $CHECK_INC_HASH];
16     use Exporter;
17     @ISA            = qw[Exporter];
18     $VERSION        = '0.14';
19     $VERBOSE        = 0;
20     $FIND_VERSION   = 1;
21     $CHECK_INC_HASH = 0;
22     @EXPORT_OK      = qw[check_install can_load requires];
23 }
24
25 =pod
26
27 =head1 NAME
28
29 Module::Load::Conditional - Looking up module information / loading at runtime
30
31 =head1 SYNOPSIS
32
33     use Module::Load::Conditional qw[can_load check_install requires];
34
35
36     my $use_list = {
37             CPANPLUS        => 0.05,
38             LWP             => 5.60,
39             'Test::More'    => undef,
40     };
41
42     print can_load( modules => $use_list )
43             ? 'all modules loaded successfully'
44             : 'failed to load required modules';
45
46
47     my $rv = check_install( module => 'LWP', version => 5.60 )
48                 or print 'LWP is not installed!';
49
50     print 'LWP up to date' if $rv->{uptodate};
51     print "LWP version is $rv->{version}\n";
52     print "LWP is installed as file $rv->{file}\n";
53
54
55     print "LWP requires the following modules to be installed:\n";
56     print join "\n", requires('LWP');
57
58     ### allow M::L::C to peek in your %INC rather than just
59     ### scanning @INC
60     $Module::Load::Conditional::CHECK_INC_HASH = 1;
61
62     ### reset the 'can_load' cache
63     undef $Module::Load::Conditional::CACHE;
64
65     ### don't have Module::Load::Conditional issue warnings --
66     ### default is '1'
67     $Module::Load::Conditional::VERBOSE = 0;
68
69     ### The last error that happened during a call to 'can_load'
70     my $err = $Module::Load::Conditional::ERROR;
71
72
73 =head1 DESCRIPTION
74
75 Module::Load::Conditional provides simple ways to query and possibly load any of
76 the modules you have installed on your system during runtime.
77
78 It is able to load multiple modules at once or none at all if one of
79 them was not able to load. It also takes care of any error checking
80 and so forth.
81
82 =head1 Methods
83
84 =head1 $href = check_install( module => NAME [, version => VERSION, verbose => BOOL ] );
85
86 C<check_install> allows you to verify if a certain module is installed
87 or not. You may call it with the following arguments:
88
89 =over 4
90
91 =item module
92
93 The name of the module you wish to verify -- this is a required key
94
95 =item version
96
97 The version this module needs to be -- this is optional
98
99 =item verbose
100
101 Whether or not to be verbose about what it is doing -- it will default
102 to $Module::Load::Conditional::VERBOSE
103
104 =back
105
106 It will return undef if it was not able to find where the module was
107 installed, or a hash reference with the following keys if it was able
108 to find the file:
109
110 =over 4
111
112 =item file
113
114 Full path to the file that contains the module
115
116 =item version
117
118 The version number of the installed module - this will be C<undef> if
119 the module had no (or unparsable) version number, or if the variable
120 C<$Module::Load::Conditional::FIND_VERSION> was set to true.
121 (See the C<GLOBAL VARIABLES> section below for details)
122
123 =item uptodate
124
125 A boolean value indicating whether or not the module was found to be
126 at least the version you specified. If you did not specify a version,
127 uptodate will always be true if the module was found.
128 If no parsable version was found in the module, uptodate will also be
129 true, since C<check_install> had no way to verify clearly.
130
131 =back
132
133 =cut
134
135 ### this checks if a certain module is installed already ###
136 ### if it returns true, the module in question is already installed
137 ### or we found the file, but couldn't open it, OR there was no version
138 ### to be found in the module
139 ### it will return 0 if the version in the module is LOWER then the one
140 ### we are looking for, or if we couldn't find the desired module to begin with
141 ### if the installed version is higher or equal to the one we want, it will return
142 ### a hashref with he module name and version in it.. so 'true' as well.
143 sub check_install {
144     my %hash = @_;
145
146     my $tmpl = {
147             version => { default    => '0.0'    },
148             module  => { required   => 1        },
149             verbose => { default    => $VERBOSE },
150     };
151
152     my $args;
153     unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) {
154         warn loc( q[A problem occurred checking arguments] ) if $VERBOSE;
155         return;
156     }
157
158     my $file     = File::Spec->catfile( split /::/, $args->{module} ) . '.pm';
159     my $file_inc = File::Spec::Unix->catfile( 
160                         split /::/, $args->{module} 
161                     ) . '.pm';
162
163     ### where we store the return value ###
164     my $href = {
165             file        => undef,
166             version     => undef,
167             uptodate    => undef,
168     };
169     
170     my $filename;
171
172     ### check the inc hash if we're allowed to
173     if( $CHECK_INC_HASH ) {
174         $filename = $href->{'file'} = 
175             $INC{ $file_inc } if defined $INC{ $file_inc };
176
177         ### find the version by inspecting the package
178         if( defined $filename && $FIND_VERSION ) {
179             no strict 'refs';
180             $href->{version} = ${ "$args->{module}"."::VERSION" }; 
181         }
182     }     
183
184     ### we didnt find the filename yet by looking in %INC,
185     ### so scan the dirs
186     unless( $filename ) {
187
188         DIR: for my $dir ( @INC ) {
189     
190             my $fh;
191     
192             if ( ref $dir ) {
193                 ### @INC hook -- we invoke it and get the filehandle back
194                 ### this is actually documented behaviour as of 5.8 ;)
195     
196                 if (UNIVERSAL::isa($dir, 'CODE')) {
197                     ($fh) = $dir->($dir, $file);
198     
199                 } elsif (UNIVERSAL::isa($dir, 'ARRAY')) {
200                     ($fh) = $dir->[0]->($dir, $file, @{$dir}{1..$#{$dir}})
201     
202                 } elsif (UNIVERSAL::can($dir, 'INC')) {
203                     ($fh) = $dir->INC->($dir, $file);
204                 }
205     
206                 if (!UNIVERSAL::isa($fh, 'GLOB')) {
207                     warn loc(q[Cannot open file '%1': %2], $file, $!)
208                             if $args->{verbose};
209                     next;
210                 }
211     
212                 $filename = $INC{$file_inc} || $file;
213     
214             } else {
215                 $filename = File::Spec->catfile($dir, $file);
216                 next unless -e $filename;
217     
218                 $fh = new FileHandle;
219                 if (!$fh->open($filename)) {
220                     warn loc(q[Cannot open file '%1': %2], $file, $!)
221                             if $args->{verbose};
222                     next;
223                 }
224             }
225     
226             $href->{file} = $filename;
227     
228             ### user wants us to find the version from files
229             if( $FIND_VERSION ) {
230                 
231                 my $in_pod = 0;
232                 while (local $_ = <$fh> ) {
233     
234                     ### stolen from EU::MM_Unix->parse_version to address
235                     ### #24062: "Problem with CPANPLUS 0.076 misidentifying
236                     ### versions after installing Text::NSP 1.03" where a 
237                     ### VERSION mentioned in the POD was found before
238                     ### the real $VERSION declaration.
239                     $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
240                     next if $in_pod;
241                     
242                     ### skip commented out lines, they won't eval to anything.
243                     next if /^\s*#/;
244         
245                     ### the following regexp comes from the ExtUtils::MakeMaker
246                     ### documentation.
247                     ### Following #18892, which tells us the original
248                     ### regex breaks under -T, we must modifiy it so
249                     ### it captures the entire expression, and eval /that/
250                     ### rather than $_, which is insecure.
251                     if ( /([\$*][\w\:\']*\bVERSION\b.*\=.*)/ ) {
252          
253                         ### this will eval the version in to $VERSION if it
254                         ### was declared as $VERSION in the module.
255                         ### else the result will be in $res.
256                         ### this is a fix on skud's Module::InstalledVersion
257          
258                         local $VERSION;
259                         my $res = eval $1;
260          
261                         ### default to '0.0' if there REALLY is no version
262                         ### all to satisfy warnings
263                         $href->{version} = $VERSION || $res || '0.0';
264         
265                         last DIR;
266                     }
267                 }
268             }
269         }
270     }
271     
272     ### if we couldn't find the file, return undef ###
273     return unless defined $href->{file};
274
275     ### only complain if we expected fo find a version higher than 0.0 anyway
276     if( $FIND_VERSION and not defined $href->{version} ) {
277         {   ### don't warn about the 'not numeric' stuff ###
278             local $^W;
279
280             ### if we got here, we didn't find the version
281             warn loc(q[Could not check version on '%1'], $args->{module} )
282                     if $args->{verbose} and $args->{version} > 0;
283         }
284         $href->{uptodate} = 1;
285
286     } else {
287         ### don't warn about the 'not numeric' stuff ###
288         local $^W;
289         $href->{uptodate} = $args->{version} <= $href->{version} ? 1 : 0;
290     }
291
292     return $href;
293 }
294
295 =head2 $bool = can_load( modules => { NAME => VERSION [,NAME => VERSION] }, [verbose => BOOL, nocache => BOOL] )
296
297 C<can_load> will take a list of modules, optionally with version
298 numbers and determine if it is able to load them. If it can load *ALL*
299 of them, it will. If one or more are unloadable, none will be loaded.
300
301 This is particularly useful if you have More Than One Way (tm) to
302 solve a problem in a program, and only wish to continue down a path
303 if all modules could be loaded, and not load them if they couldn't.
304
305 This function uses the C<load> function from Module::Load under the
306 hood.
307
308 C<can_load> takes the following arguments:
309
310 =over 4
311
312 =item modules
313
314 This is a hashref of module/version pairs. The version indicates the
315 minimum version to load. If no version is provided, any version is
316 assumed to be good enough.
317
318 =item verbose
319
320 This controls whether warnings should be printed if a module failed
321 to load.
322 The default is to use the value of $Module::Load::Conditional::VERBOSE.
323
324 =item nocache
325
326 C<can_load> keeps its results in a cache, so it will not load the
327 same module twice, nor will it attempt to load a module that has
328 already failed to load before. By default, C<can_load> will check its
329 cache, but you can override that by setting C<nocache> to true.
330
331 =cut
332
333 sub can_load {
334     my %hash = @_;
335
336     my $tmpl = {
337         modules     => { default => {}, strict_type => 1 },
338         verbose     => { default => $VERBOSE },
339         nocache     => { default => 0 },
340     };
341
342     my $args;
343
344     unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) {
345         $ERROR = loc(q[Problem validating arguments!]);
346         warn $ERROR if $VERBOSE;
347         return;
348     }
349
350     ### layout of $CACHE:
351     ### $CACHE = {
352     ###     $ module => {
353     ###             usable  => BOOL,
354     ###             version => \d,
355     ###             file    => /path/to/file,
356     ###     },
357     ### };
358
359     $CACHE ||= {}; # in case it was undef'd
360
361     my $error;
362     BLOCK: {
363         my $href = $args->{modules};
364
365         my @load;
366         for my $mod ( keys %$href ) {
367
368             next if $CACHE->{$mod}->{usable} && !$args->{nocache};
369
370             ### else, check if the hash key is defined already,
371             ### meaning $mod => 0,
372             ### indicating UNSUCCESSFUL prior attempt of usage
373             if (    !$args->{nocache}
374                     && defined $CACHE->{$mod}->{usable}
375                     && (($CACHE->{$mod}->{version}||0) >= $href->{$mod})
376             ) {
377                 $error = loc( q[Already tried to use '%1', which was unsuccessful], $mod);
378                 last BLOCK;
379             }
380
381             my $mod_data = check_install(
382                                     module  => $mod,
383                                     version => $href->{$mod}
384                                 );
385
386             if( !$mod_data or !defined $mod_data->{file} ) {
387                 $error = loc(q[Could not find or check module '%1'], $mod);
388                 $CACHE->{$mod}->{usable} = 0;
389                 last BLOCK;
390             }
391
392             map {
393                 $CACHE->{$mod}->{$_} = $mod_data->{$_}
394             } qw[version file uptodate];
395
396             push @load, $mod;
397         }
398
399         for my $mod ( @load ) {
400
401             if ( $CACHE->{$mod}->{uptodate} ) {
402
403                 eval { load $mod };
404
405                 ### in case anything goes wrong, log the error, the fact
406                 ### we tried to use this module and return 0;
407                 if( $@ ) {
408                     $error = $@;
409                     $CACHE->{$mod}->{usable} = 0;
410                     last BLOCK;
411                 } else {
412                     $CACHE->{$mod}->{usable} = 1;
413                 }
414
415             ### module not found in @INC, store the result in
416             ### $CACHE and return 0
417             } else {
418
419                 $error = loc(q[Module '%1' is not uptodate!], $mod);
420                 $CACHE->{$mod}->{usable} = 0;
421                 last BLOCK;
422             }
423         }
424
425     } # BLOCK
426
427     if( defined $error ) {
428         $ERROR = $error;
429         Carp::carp( loc(q|%1 [THIS MAY BE A PROBLEM!]|,$error) ) if $args->{verbose};
430         return undef;
431     } else {
432         return 1;
433     }
434 }
435
436 =head2 @list = requires( MODULE );
437
438 C<requires> can tell you what other modules a particular module
439 requires. This is particularly useful when you're intending to write
440 a module for public release and are listing its prerequisites.
441
442 C<requires> takes but one argument: the name of a module.
443 It will then first check if it can actually load this module, and
444 return undef if it can't.
445 Otherwise, it will return a list of modules and pragmas that would
446 have been loaded on the module's behalf.
447
448 Note: The list C<require> returns has originated from your current
449 perl and your current install.
450
451 =cut
452
453 sub requires {
454     my $who = shift;
455
456     unless( check_install( module => $who ) ) {
457         warn loc(q[You do not have module '%1' installed], $who) if $VERBOSE;
458         return undef;
459     }
460
461     my $lib = join " ", map { qq["-I$_"] } @INC;
462     my $cmd = qq[$^X $lib -M$who -e"print(join(qq[\\n],keys(%INC)))"];
463
464     return  sort
465                 grep { !/^$who$/  }
466                 map  { chomp; s|/|::|g; $_ }
467                 grep { s|\.pm$||i; }
468             `$cmd`;
469 }
470
471 1;
472
473 __END__
474
475 =head1 Global Variables
476
477 The behaviour of Module::Load::Conditional can be altered by changing the
478 following global variables:
479
480 =head2 $Module::Load::Conditional::VERBOSE
481
482 This controls whether Module::Load::Conditional will issue warnings and
483 explanations as to why certain things may have failed. If you set it
484 to 0, Module::Load::Conditional will not output any warnings.
485 The default is 0;
486
487 =head2 $Module::Load::Conditional::FIND_VERSION
488
489 This controls whether Module::Load::Conditional will try to parse
490 (and eval) the version from the module you're trying to load. 
491
492 If you don't wish to do this, set this variable to C<false>. Understand
493 then that version comparisons are not possible, and Module::Load::Conditional
494 can not tell you what module version you have installed.
495 This may be desirable from a security or performance point of view. 
496 Note that C<$FIND_VERSION> code runs safely under C<taint mode>.
497
498 The default is 1;
499
500 =head2 $Module::Load::Conditional::CHECK_INC_HASH
501
502 This controls whether C<Module::Load::Conditional> checks your
503 C<%INC> hash to see if a module is available. By default, only
504 C<@INC> is scanned to see if a module is physically on your
505 filesystem, or avialable via an C<@INC-hook>. Setting this variable
506 to C<true> will trust any entries in C<%INC> and return them for
507 you.
508
509 The default is 0;
510
511 =head2 $Module::Load::Conditional::CACHE
512
513 This holds the cache of the C<can_load> function. If you explicitly
514 want to remove the current cache, you can set this variable to
515 C<undef>
516
517 =head2 $Module::Load::Conditional::ERROR
518
519 This holds a string of the last error that happened during a call to
520 C<can_load>. It is useful to inspect this when C<can_load> returns
521 C<undef>.
522
523 =head1 See Also
524
525 C<Module::Load>
526
527 =head1 AUTHOR
528
529 This module by
530 Jos Boumans E<lt>kane@cpan.orgE<gt>.
531
532 =head1 COPYRIGHT
533
534 This module is copyright (c) 2002-2007 Jos Boumans 
535 E<lt>kane@cpan.orgE<gt>. All rights reserved.
536
537 This library is free software; you may redistribute and/or modify 
538 it under the same terms as Perl itself.