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