This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Module-Load-Conditional to CPAN version 0.44
[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.44';
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 =head2 $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                 my $existed_in_inc = $INC{$file_inc};
209     
210                 if (UNIVERSAL::isa($dir, 'CODE')) {
211                     ($fh) = $dir->($dir, $file);
212     
213                 } elsif (UNIVERSAL::isa($dir, 'ARRAY')) {
214                     ($fh) = $dir->[0]->($dir, $file, @{$dir}{1..$#{$dir}})
215     
216                 } elsif (UNIVERSAL::can($dir, 'INC')) {
217                     ($fh) = $dir->INC($file);
218                 }
219     
220                 if (!UNIVERSAL::isa($fh, 'GLOB')) {
221                     warn loc(q[Cannot open file '%1': %2], $file, $!)
222                             if $args->{verbose};
223                     next;
224                 }
225     
226                 $filename = $INC{$file_inc} || $file;
227
228                 delete $INC{$file_inc} if not $existed_in_inc;
229     
230             } else {
231                 $filename = File::Spec->catfile($dir, $file);
232                 next unless -e $filename;
233     
234                 $fh = new FileHandle;
235                 if (!$fh->open($filename)) {
236                     warn loc(q[Cannot open file '%1': %2], $file, $!)
237                             if $args->{verbose};
238                     next;
239                 }
240             }
241     
242             ### store the directory we found the file in
243             $href->{dir} = $dir;
244     
245             ### files need to be in unix format under vms,
246             ### or they might be loaded twice
247             $href->{file} = ON_VMS
248                 ? VMS::Filespec::unixify( $filename )
249                 : $filename;
250     
251             ### user wants us to find the version from files
252             if( $FIND_VERSION ) {
253                 
254                 my $in_pod = 0;
255                 while ( my $line = <$fh> ) {
256     
257                     ### stolen from EU::MM_Unix->parse_version to address
258                     ### #24062: "Problem with CPANPLUS 0.076 misidentifying
259                     ### versions after installing Text::NSP 1.03" where a 
260                     ### VERSION mentioned in the POD was found before
261                     ### the real $VERSION declaration.
262                     $in_pod = $line =~ /^=(?!cut)/  ? 1 : 
263                               $line =~ /^=cut/      ? 0 : 
264                               $in_pod;
265                     next if $in_pod;
266                     
267                     ### try to find a version declaration in this string.
268                     my $ver = __PACKAGE__->_parse_version( $line );
269
270                     if( defined $ver ) {
271                         $href->{version} = $ver;
272         
273                         last DIR;
274                     }
275                 }
276             }
277         }
278     }
279     
280     ### if we couldn't find the file, return undef ###
281     return unless defined $href->{file};
282
283     ### only complain if we're expected to find a version higher than 0.0 anyway
284     if( $FIND_VERSION and not defined $href->{version} ) {
285         {   ### don't warn about the 'not numeric' stuff ###
286             local $^W;
287
288             ### if we got here, we didn't find the version
289             warn loc(q[Could not check version on '%1'], $args->{module} )
290                     if $args->{verbose} and $args->{version} > 0;
291         }
292         $href->{uptodate} = 1;
293
294     } else {
295         ### don't warn about the 'not numeric' stuff ###
296         local $^W;
297         
298         ### use qv(), as it will deal with developer release number
299         ### ie ones containing _ as well. This addresses bug report
300         ### #29348: Version compare logic doesn't handle alphas?
301         ###
302         ### Update from JPeacock: apparently qv() and version->new
303         ### are different things, and we *must* use version->new
304         ### here, or things like #30056 might start happening
305
306         ### We have to wrap this in an eval as version-0.82 raises
307         ### exceptions and not warnings now *sigh*
308
309         eval {
310
311           $href->{uptodate} = 
312             version->new( $args->{version} ) <= version->new( $href->{version} )
313                 ? 1 
314                 : 0;
315
316         };
317     }
318
319     if ( $DEPRECATED and version->new($]) >= version->new('5.011') ) {
320         require Module::CoreList;
321         require Config;
322
323         $href->{uptodate} = 0 if 
324            exists $Module::CoreList::version{ 0+$] }{ $args->{module} } and
325            Module::CoreList::is_deprecated( $args->{module} ) and
326            $Config::Config{privlibexp} eq $href->{dir};
327     }
328
329     return $href;
330 }
331
332 sub _parse_version {
333     my $self    = shift;
334     my $str     = shift or return;
335     my $verbose = shift or 0;
336
337     ### skip lines which doesn't contain VERSION
338     return unless $str =~ /VERSION/;
339
340     ### skip commented out lines, they won't eval to anything.
341     return if $str =~ /^\s*#/;
342         
343     ### the following regexp & eval statement comes from the 
344     ### ExtUtils::MakeMaker source (EU::MM_Unix->parse_version) 
345     ### Following #18892, which tells us the original
346     ### regex breaks under -T, we must modify it so
347     ### it captures the entire expression, and eval /that/
348     ### rather than $_, which is insecure.
349     my $taint_safe_str = do { $str =~ /(^.*$)/sm; $1 };
350         
351     if( $str =~ /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ ) {
352         
353         print "Evaluating: $str\n" if $verbose;
354         
355         ### this creates a string to be eval'd, like:
356         # package Module::Load::Conditional::_version;
357         # no strict;
358         # 
359         # local $VERSION;
360         # $VERSION=undef; do {
361         #     use version; $VERSION = qv('0.0.3');
362         # }; $VERSION        
363         
364         my $eval = qq{
365             package Module::Load::Conditional::_version;
366             no strict;
367
368             local $1$2;
369             \$$2=undef; do {
370                 $taint_safe_str
371             }; \$$2
372         };
373         
374         print "Evaltext: $eval\n" if $verbose;
375         
376         my $result = do {
377             local $^W = 0;
378             eval($eval); 
379         };
380         
381         
382         my $rv = defined $result ? $result : '0.0';
383
384         print( $@ ? "Error: $@\n" : "Result: $rv\n" ) if $verbose;
385
386         return $rv;
387     }
388     
389     ### unable to find a version in this string
390     return;
391 }
392
393 =head2 $bool = can_load( modules => { NAME => VERSION [,NAME => VERSION] }, [verbose => BOOL, nocache => BOOL] )
394
395 C<can_load> will take a list of modules, optionally with version
396 numbers and determine if it is able to load them. If it can load *ALL*
397 of them, it will. If one or more are unloadable, none will be loaded.
398
399 This is particularly useful if you have More Than One Way (tm) to
400 solve a problem in a program, and only wish to continue down a path
401 if all modules could be loaded, and not load them if they couldn't.
402
403 This function uses the C<load> function from Module::Load under the
404 hood.
405
406 C<can_load> takes the following arguments:
407
408 =over 4
409
410 =item modules
411
412 This is a hashref of module/version pairs. The version indicates the
413 minimum version to load. If no version is provided, any version is
414 assumed to be good enough.
415
416 =item verbose
417
418 This controls whether warnings should be printed if a module failed
419 to load.
420 The default is to use the value of $Module::Load::Conditional::VERBOSE.
421
422 =item nocache
423
424 C<can_load> keeps its results in a cache, so it will not load the
425 same module twice, nor will it attempt to load a module that has
426 already failed to load before. By default, C<can_load> will check its
427 cache, but you can override that by setting C<nocache> to true.
428
429 =cut
430
431 sub can_load {
432     my %hash = @_;
433
434     my $tmpl = {
435         modules     => { default => {}, strict_type => 1 },
436         verbose     => { default => $VERBOSE },
437         nocache     => { default => 0 },
438     };
439
440     my $args;
441
442     unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) {
443         $ERROR = loc(q[Problem validating arguments!]);
444         warn $ERROR if $VERBOSE;
445         return;
446     }
447
448     ### layout of $CACHE:
449     ### $CACHE = {
450     ###     $ module => {
451     ###             usable  => BOOL,
452     ###             version => \d,
453     ###             file    => /path/to/file,
454     ###     },
455     ### };
456
457     $CACHE ||= {}; # in case it was undef'd
458
459     my $error;
460     BLOCK: {
461         my $href = $args->{modules};
462
463         my @load;
464         for my $mod ( keys %$href ) {
465
466             next if $CACHE->{$mod}->{usable} && !$args->{nocache};
467
468             ### else, check if the hash key is defined already,
469             ### meaning $mod => 0,
470             ### indicating UNSUCCESSFUL prior attempt of usage
471
472             ### use qv(), as it will deal with developer release number
473             ### ie ones containing _ as well. This addresses bug report
474             ### #29348: Version compare logic doesn't handle alphas?
475             ###
476             ### Update from JPeacock: apparently qv() and version->new
477             ### are different things, and we *must* use version->new
478             ### here, or things like #30056 might start happening            
479             if (    !$args->{nocache}
480                     && defined $CACHE->{$mod}->{usable}
481                     && (version->new( $CACHE->{$mod}->{version}||0 ) 
482                         >= version->new( $href->{$mod} ) )
483             ) {
484                 $error = loc( q[Already tried to use '%1', which was unsuccessful], $mod);
485                 last BLOCK;
486             }
487
488             my $mod_data = check_install(
489                                     module  => $mod,
490                                     version => $href->{$mod}
491                                 );
492
493             if( !$mod_data or !defined $mod_data->{file} ) {
494                 $error = loc(q[Could not find or check module '%1'], $mod);
495                 $CACHE->{$mod}->{usable} = 0;
496                 last BLOCK;
497             }
498
499             map {
500                 $CACHE->{$mod}->{$_} = $mod_data->{$_}
501             } qw[version file uptodate];
502
503             push @load, $mod;
504         }
505
506         for my $mod ( @load ) {
507
508             if ( $CACHE->{$mod}->{uptodate} ) {
509
510                 eval { load $mod };
511
512                 ### in case anything goes wrong, log the error, the fact
513                 ### we tried to use this module and return 0;
514                 if( $@ ) {
515                     $error = $@;
516                     $CACHE->{$mod}->{usable} = 0;
517                     last BLOCK;
518                 } else {
519                     $CACHE->{$mod}->{usable} = 1;
520                 }
521
522             ### module not found in @INC, store the result in
523             ### $CACHE and return 0
524             } else {
525
526                 $error = loc(q[Module '%1' is not uptodate!], $mod);
527                 $CACHE->{$mod}->{usable} = 0;
528                 last BLOCK;
529             }
530         }
531
532     } # BLOCK
533
534     if( defined $error ) {
535         $ERROR = $error;
536         Carp::carp( loc(q|%1 [THIS MAY BE A PROBLEM!]|,$error) ) if $args->{verbose};
537         return;
538     } else {
539         return 1;
540     }
541 }
542
543 =back
544
545 =head2 @list = requires( MODULE );
546
547 C<requires> can tell you what other modules a particular module
548 requires. This is particularly useful when you're intending to write
549 a module for public release and are listing its prerequisites.
550
551 C<requires> takes but one argument: the name of a module.
552 It will then first check if it can actually load this module, and
553 return undef if it can't.
554 Otherwise, it will return a list of modules and pragmas that would
555 have been loaded on the module's behalf.
556
557 Note: The list C<require> returns has originated from your current
558 perl and your current install.
559
560 =cut
561
562 sub requires {
563     my $who = shift;
564
565     unless( check_install( module => $who ) ) {
566         warn loc(q[You do not have module '%1' installed], $who) if $VERBOSE;
567         return undef;
568     }
569
570     my $lib = join " ", map { qq["-I$_"] } @INC;
571     my $cmd = qq[$^X $lib -M$who -e"print(join(qq[\\n],keys(%INC)))"];
572
573     return  sort
574                 grep { !/^$who$/  }
575                 map  { chomp; s|/|::|g; $_ }
576                 grep { s|\.pm$||i; }
577             `$cmd`;
578 }
579
580 1;
581
582 __END__
583
584 =head1 Global Variables
585
586 The behaviour of Module::Load::Conditional can be altered by changing the
587 following global variables:
588
589 =head2 $Module::Load::Conditional::VERBOSE
590
591 This controls whether Module::Load::Conditional will issue warnings and
592 explanations as to why certain things may have failed. If you set it
593 to 0, Module::Load::Conditional will not output any warnings.
594 The default is 0;
595
596 =head2 $Module::Load::Conditional::FIND_VERSION
597
598 This controls whether Module::Load::Conditional will try to parse
599 (and eval) the version from the module you're trying to load. 
600
601 If you don't wish to do this, set this variable to C<false>. Understand
602 then that version comparisons are not possible, and Module::Load::Conditional
603 can not tell you what module version you have installed.
604 This may be desirable from a security or performance point of view. 
605 Note that C<$FIND_VERSION> code runs safely under C<taint mode>.
606
607 The default is 1;
608
609 =head2 $Module::Load::Conditional::CHECK_INC_HASH
610
611 This controls whether C<Module::Load::Conditional> checks your
612 C<%INC> hash to see if a module is available. By default, only
613 C<@INC> is scanned to see if a module is physically on your
614 filesystem, or available via an C<@INC-hook>. Setting this variable
615 to C<true> will trust any entries in C<%INC> and return them for
616 you.
617
618 The default is 0;
619
620 =head2 $Module::Load::Conditional::CACHE
621
622 This holds the cache of the C<can_load> function. If you explicitly
623 want to remove the current cache, you can set this variable to
624 C<undef>
625
626 =head2 $Module::Load::Conditional::ERROR
627
628 This holds a string of the last error that happened during a call to
629 C<can_load>. It is useful to inspect this when C<can_load> returns
630 C<undef>.
631
632 =head2 $Module::Load::Conditional::DEPRECATED
633
634 This controls whether C<Module::Load::Conditional> checks if 
635 a dual-life core module has been deprecated. If this is set to
636 true C<check_install> will return false to C<uptodate>, if 
637 a dual-life module is found to be loaded from C<$Config{privlibexp}>
638
639 The default is 0;
640
641 =head1 See Also
642
643 C<Module::Load>
644
645 =head1 BUG REPORTS
646
647 Please report bugs or other issues to E<lt>bug-module-load-conditional@rt.cpan.orgE<gt>.
648
649 =head1 AUTHOR
650
651 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
652
653 =head1 COPYRIGHT
654
655 This library is free software; you may redistribute and/or modify it 
656 under the same terms as Perl itself.
657
658 =cut