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