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