This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add Module::Load::Conditional to the core
[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.12';
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                 while (local $_ = <$fh> ) {
232     
233                     ### skip commented out lines, they won't eval to anything.
234                     next if /^\s*#/;
235         
236                     ### the following regexp comes from the ExtUtils::MakeMaker
237                     ### documentation.
238                     ### Following #18892, which tells us the original
239                     ### regex breaks under -T, we must modifiy it so
240                     ### it captures the entire expression, and eval /that/
241                     ### rather than $_, which is insecure.
242                     if ( /([\$*][\w\:\']*\bVERSION\b.*\=.*)/ ) {
243          
244                         ### this will eval the version in to $VERSION if it
245                         ### was declared as $VERSION in the module.
246                         ### else the result will be in $res.
247                         ### this is a fix on skud's Module::InstalledVersion
248          
249                         local $VERSION;
250                         my $res = eval $1;
251          
252                         ### default to '0.0' if there REALLY is no version
253                         ### all to satisfy warnings
254                         $href->{version} = $VERSION || $res || '0.0';
255         
256                         last DIR;
257                     }
258                 }
259             }
260         }
261     }
262     
263     ### if we couldn't find the file, return undef ###
264     return unless defined $href->{file};
265
266     ### only complain if we expected fo find a version higher than 0.0 anyway
267     if( $FIND_VERSION and not defined $href->{version} ) {
268         {   ### don't warn about the 'not numeric' stuff ###
269             local $^W;
270
271             ### if we got here, we didn't find the version
272             warn loc(q[Could not check version on '%1'], $args->{module} )
273                     if $args->{verbose} and $args->{version} > 0;
274         }
275         $href->{uptodate} = 1;
276
277     } else {
278         ### don't warn about the 'not numeric' stuff ###
279         local $^W;
280         $href->{uptodate} = $args->{version} <= $href->{version} ? 1 : 0;
281     }
282
283     return $href;
284 }
285
286 =head2 $bool = can_load( modules => { NAME => VERSION [,NAME => VERSION] }, [verbose => BOOL, nocache => BOOL] )
287
288 C<can_load> will take a list of modules, optionally with version
289 numbers and determine if it is able to load them. If it can load *ALL*
290 of them, it will. If one or more are unloadable, none will be loaded.
291
292 This is particularly useful if you have More Than One Way (tm) to
293 solve a problem in a program, and only wish to continue down a path
294 if all modules could be loaded, and not load them if they couldn't.
295
296 This function uses the C<load> function from Module::Load under the
297 hood.
298
299 C<can_load> takes the following arguments:
300
301 =over 4
302
303 =item modules
304
305 This is a hashref of module/version pairs. The version indicates the
306 minimum version to load. If no version is provided, any version is
307 assumed to be good enough.
308
309 =item verbose
310
311 This controls whether warnings should be printed if a module failed
312 to load.
313 The default is to use the value of $Module::Load::Conditional::VERBOSE.
314
315 =item nocache
316
317 C<can_load> keeps its results in a cache, so it will not load the
318 same module twice, nor will it attempt to load a module that has
319 already failed to load before. By default, C<can_load> will check its
320 cache, but you can override that by setting C<nocache> to true.
321
322 =cut
323
324 sub can_load {
325     my %hash = @_;
326
327     my $tmpl = {
328         modules     => { default => {}, strict_type => 1 },
329         verbose     => { default => $VERBOSE },
330         nocache     => { default => 0 },
331     };
332
333     my $args;
334
335     unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) {
336         $ERROR = loc(q[Problem validating arguments!]);
337         warn $ERROR if $VERBOSE;
338         return;
339     }
340
341     ### layout of $CACHE:
342     ### $CACHE = {
343     ###     $ module => {
344     ###             usable  => BOOL,
345     ###             version => \d,
346     ###             file    => /path/to/file,
347     ###     },
348     ### };
349
350     $CACHE ||= {}; # in case it was undef'd
351
352     my $error;
353     BLOCK: {
354         my $href = $args->{modules};
355
356         my @load;
357         for my $mod ( keys %$href ) {
358
359             next if $CACHE->{$mod}->{usable} && !$args->{nocache};
360
361             ### else, check if the hash key is defined already,
362             ### meaning $mod => 0,
363             ### indicating UNSUCCESSFUL prior attempt of usage
364             if (    !$args->{nocache}
365                     && defined $CACHE->{$mod}->{usable}
366                     && (($CACHE->{$mod}->{version}||0) >= $href->{$mod})
367             ) {
368                 $error = loc( q[Already tried to use '%1', which was unsuccessful], $mod);
369                 last BLOCK;
370             }
371
372             my $mod_data = check_install(
373                                     module  => $mod,
374                                     version => $href->{$mod}
375                                 );
376
377             if( !$mod_data or !defined $mod_data->{file} ) {
378                 $error = loc(q[Could not find or check module '%1'], $mod);
379                 $CACHE->{$mod}->{usable} = 0;
380                 last BLOCK;
381             }
382
383             map {
384                 $CACHE->{$mod}->{$_} = $mod_data->{$_}
385             } qw[version file uptodate];
386
387             push @load, $mod;
388         }
389
390         for my $mod ( @load ) {
391
392             if ( $CACHE->{$mod}->{uptodate} ) {
393
394                 eval { load $mod };
395
396                 ### in case anything goes wrong, log the error, the fact
397                 ### we tried to use this module and return 0;
398                 if( $@ ) {
399                     $error = $@;
400                     $CACHE->{$mod}->{usable} = 0;
401                     last BLOCK;
402                 } else {
403                     $CACHE->{$mod}->{usable} = 1;
404                 }
405
406             ### module not found in @INC, store the result in
407             ### $CACHE and return 0
408             } else {
409
410                 $error = loc(q[Module '%1' is not uptodate!], $mod);
411                 $CACHE->{$mod}->{usable} = 0;
412                 last BLOCK;
413             }
414         }
415
416     } # BLOCK
417
418     if( defined $error ) {
419         $ERROR = $error;
420         Carp::carp( loc(q|%1 [THIS MAY BE A PROBLEM!]|,$error) ) if $args->{verbose};
421         return undef;
422     } else {
423         return 1;
424     }
425 }
426
427 =head2 @list = requires( MODULE );
428
429 C<requires> can tell you what other modules a particular module
430 requires. This is particularly useful when you're intending to write
431 a module for public release and are listing its prerequisites.
432
433 C<requires> takes but one argument: the name of a module.
434 It will then first check if it can actually load this module, and
435 return undef if it can't.
436 Otherwise, it will return a list of modules and pragmas that would
437 have been loaded on the module's behalf.
438
439 Note: The list C<require> returns has originated from your current
440 perl and your current install.
441
442 =cut
443
444 sub requires {
445     my $who = shift;
446
447     unless( check_install( module => $who ) ) {
448         warn loc(q[You do not have module '%1' installed], $who) if $VERBOSE;
449         return undef;
450     }
451
452     my $lib = join " ", map { qq["-I$_"] } @INC;
453     my $cmd = qq[$^X $lib -M$who -e"print(join(qq[\\n],keys(%INC)))"];
454
455     return  sort
456                 grep { !/^$who$/  }
457                 map  { chomp; s|/|::|g; $_ }
458                 grep { s|\.pm$||i; }
459             `$cmd`;
460 }
461
462 1;
463
464 __END__
465
466 =head1 Global Variables
467
468 The behaviour of Module::Load::Conditional can be altered by changing the
469 following global variables:
470
471 =head2 $Module::Load::Conditional::VERBOSE
472
473 This controls whether Module::Load::Conditional will issue warnings and
474 explanations as to why certain things may have failed. If you set it
475 to 0, Module::Load::Conditional will not output any warnings.
476 The default is 0;
477
478 =head2 $Module::Load::Conditional::FIND_VERSION
479
480 This controls whether Module::Load::Conditional will try to parse
481 (and eval) the version from the module you're trying to load. 
482
483 If you don't wish to do this, set this variable to C<false>. Understand
484 then that version comparisons are not possible, and Module::Load::Conditional
485 can not tell you what module version you have installed.
486 This may be desirable from a security or performance point of view. 
487 Note that C<$FIND_VERSION> code runs safely under C<taint mode>.
488
489 The default is 1;
490
491 =head2 $Module::Load::Conditional::CHECK_INC_HASH
492
493 This controls whether C<Module::Load::Conditional> checks your
494 C<%INC> hash to see if a module is available. By default, only
495 C<@INC> is scanned to see if a module is physically on your
496 filesystem, or avialable via an C<@INC-hook>. Setting this variable
497 to C<true> will trust any entries in C<%INC> and return them for
498 you.
499
500 The default is 0;
501
502 =head2 $Module::Load::Conditional::CACHE
503
504 This holds the cache of the C<can_load> function. If you explicitly
505 want to remove the current cache, you can set this variable to
506 C<undef>
507
508 =head2 $Module::Load::Conditional::ERROR
509
510 This holds a string of the last error that happened during a call to
511 C<can_load>. It is useful to inspect this when C<can_load> returns
512 C<undef>.
513
514 =head1 See Also
515
516 C<Module::Load>
517
518 =head1 AUTHOR
519
520 This module by
521 Jos Boumans E<lt>kane@cpan.orgE<gt>.
522
523 =head1 COPYRIGHT
524
525 This module is
526 copyright (c) 2002 Jos Boumans E<lt>kane@cpan.orgE<gt>.
527 All rights reserved.
528
529 This library is free software;
530 you may redistribute and/or modify it under the same
531 terms as Perl itself.