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