| package Module::Load::Conditional; |
| |
| use strict; |
| |
| use Module::Load; |
| use Params::Check qw[check]; |
| use Locale::Maketext::Simple Style => 'gettext'; |
| |
| use Carp (); |
| use File::Spec (); |
| use FileHandle (); |
| use version; |
| |
| use constant ON_VMS => $^O eq 'VMS'; |
| |
| BEGIN { |
| use vars qw[ $VERSION @ISA $VERBOSE $CACHE @EXPORT_OK $DEPRECATED |
| $FIND_VERSION $ERROR $CHECK_INC_HASH]; |
| use Exporter; |
| @ISA = qw[Exporter]; |
| $VERSION = '0.46'; |
| $VERBOSE = 0; |
| $DEPRECATED = 0; |
| $FIND_VERSION = 1; |
| $CHECK_INC_HASH = 0; |
| @EXPORT_OK = qw[check_install can_load requires]; |
| } |
| |
| =pod |
| |
| =head1 NAME |
| |
| Module::Load::Conditional - Looking up module information / loading at runtime |
| |
| =head1 SYNOPSIS |
| |
| use Module::Load::Conditional qw[can_load check_install requires]; |
| |
| |
| my $use_list = { |
| CPANPLUS => 0.05, |
| LWP => 5.60, |
| 'Test::More' => undef, |
| }; |
| |
| print can_load( modules => $use_list ) |
| ? 'all modules loaded successfully' |
| : 'failed to load required modules'; |
| |
| |
| my $rv = check_install( module => 'LWP', version => 5.60 ) |
| or print 'LWP is not installed!'; |
| |
| print 'LWP up to date' if $rv->{uptodate}; |
| print "LWP version is $rv->{version}\n"; |
| print "LWP is installed as file $rv->{file}\n"; |
| |
| |
| print "LWP requires the following modules to be installed:\n"; |
| print join "\n", requires('LWP'); |
| |
| ### allow M::L::C to peek in your %INC rather than just |
| ### scanning @INC |
| $Module::Load::Conditional::CHECK_INC_HASH = 1; |
| |
| ### reset the 'can_load' cache |
| undef $Module::Load::Conditional::CACHE; |
| |
| ### don't have Module::Load::Conditional issue warnings -- |
| ### default is '1' |
| $Module::Load::Conditional::VERBOSE = 0; |
| |
| ### The last error that happened during a call to 'can_load' |
| my $err = $Module::Load::Conditional::ERROR; |
| |
| |
| =head1 DESCRIPTION |
| |
| Module::Load::Conditional provides simple ways to query and possibly load any of |
| the modules you have installed on your system during runtime. |
| |
| It is able to load multiple modules at once or none at all if one of |
| them was not able to load. It also takes care of any error checking |
| and so forth. |
| |
| =head1 Methods |
| |
| =head2 $href = check_install( module => NAME [, version => VERSION, verbose => BOOL ] ); |
| |
| C<check_install> allows you to verify if a certain module is installed |
| or not. You may call it with the following arguments: |
| |
| =over 4 |
| |
| =item module |
| |
| The name of the module you wish to verify -- this is a required key |
| |
| =item version |
| |
| The version this module needs to be -- this is optional |
| |
| =item verbose |
| |
| Whether or not to be verbose about what it is doing -- it will default |
| to $Module::Load::Conditional::VERBOSE |
| |
| =back |
| |
| It will return undef if it was not able to find where the module was |
| installed, or a hash reference with the following keys if it was able |
| to find the file: |
| |
| =over 4 |
| |
| =item file |
| |
| Full path to the file that contains the module |
| |
| =item dir |
| |
| Directory, or more exact the C<@INC> entry, where the module was |
| loaded from. |
| |
| =item version |
| |
| The version number of the installed module - this will be C<undef> if |
| the module had no (or unparsable) version number, or if the variable |
| C<$Module::Load::Conditional::FIND_VERSION> was set to true. |
| (See the C<GLOBAL VARIABLES> section below for details) |
| |
| =item uptodate |
| |
| A boolean value indicating whether or not the module was found to be |
| at least the version you specified. If you did not specify a version, |
| uptodate will always be true if the module was found. |
| If no parsable version was found in the module, uptodate will also be |
| true, since C<check_install> had no way to verify clearly. |
| |
| See also C<$Module::Load::Conditional::DEPRECATED>, which affects |
| the outcome of this value. |
| |
| =back |
| |
| =cut |
| |
| ### this checks if a certain module is installed already ### |
| ### if it returns true, the module in question is already installed |
| ### or we found the file, but couldn't open it, OR there was no version |
| ### to be found in the module |
| ### it will return 0 if the version in the module is LOWER then the one |
| ### we are looking for, or if we couldn't find the desired module to begin with |
| ### if the installed version is higher or equal to the one we want, it will return |
| ### a hashref with he module name and version in it.. so 'true' as well. |
| sub check_install { |
| my %hash = @_; |
| |
| my $tmpl = { |
| version => { default => '0.0' }, |
| module => { required => 1 }, |
| verbose => { default => $VERBOSE }, |
| }; |
| |
| my $args; |
| unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) { |
| warn loc( q[A problem occurred checking arguments] ) if $VERBOSE; |
| return; |
| } |
| |
| my $file = File::Spec->catfile( split /::/, $args->{module} ) . '.pm'; |
| my $file_inc = File::Spec::Unix->catfile( |
| split /::/, $args->{module} |
| ) . '.pm'; |
| |
| ### where we store the return value ### |
| my $href = { |
| file => undef, |
| version => undef, |
| uptodate => undef, |
| }; |
| |
| my $filename; |
| |
| ### check the inc hash if we're allowed to |
| if( $CHECK_INC_HASH ) { |
| $filename = $href->{'file'} = |
| $INC{ $file_inc } if defined $INC{ $file_inc }; |
| |
| ### find the version by inspecting the package |
| if( defined $filename && $FIND_VERSION ) { |
| no strict 'refs'; |
| $href->{version} = ${ "$args->{module}"."::VERSION" }; |
| } |
| } |
| |
| ### we didnt find the filename yet by looking in %INC, |
| ### so scan the dirs |
| unless( $filename ) { |
| |
| DIR: for my $dir ( @INC ) { |
| |
| my $fh; |
| |
| if ( ref $dir ) { |
| ### @INC hook -- we invoke it and get the filehandle back |
| ### this is actually documented behaviour as of 5.8 ;) |
| |
| my $existed_in_inc = $INC{$file_inc}; |
| |
| if (UNIVERSAL::isa($dir, 'CODE')) { |
| ($fh) = $dir->($dir, $file); |
| |
| } elsif (UNIVERSAL::isa($dir, 'ARRAY')) { |
| ($fh) = $dir->[0]->($dir, $file, @{$dir}{1..$#{$dir}}) |
| |
| } elsif (UNIVERSAL::can($dir, 'INC')) { |
| ($fh) = $dir->INC($file); |
| } |
| |
| if (!UNIVERSAL::isa($fh, 'GLOB')) { |
| warn loc(q[Cannot open file '%1': %2], $file, $!) |
| if $args->{verbose}; |
| next; |
| } |
| |
| $filename = $INC{$file_inc} || $file; |
| |
| delete $INC{$file_inc} if not $existed_in_inc; |
| |
| } else { |
| $filename = File::Spec->catfile($dir, $file); |
| next unless -e $filename; |
| |
| $fh = new FileHandle; |
| if (!$fh->open($filename)) { |
| warn loc(q[Cannot open file '%1': %2], $file, $!) |
| if $args->{verbose}; |
| next; |
| } |
| } |
| |
| ### store the directory we found the file in |
| $href->{dir} = $dir; |
| |
| ### files need to be in unix format under vms, |
| ### or they might be loaded twice |
| $href->{file} = ON_VMS |
| ? VMS::Filespec::unixify( $filename ) |
| : $filename; |
| |
| ### user wants us to find the version from files |
| if( $FIND_VERSION ) { |
| |
| my $in_pod = 0; |
| while ( my $line = <$fh> ) { |
| |
| ### stolen from EU::MM_Unix->parse_version to address |
| ### #24062: "Problem with CPANPLUS 0.076 misidentifying |
| ### versions after installing Text::NSP 1.03" where a |
| ### VERSION mentioned in the POD was found before |
| ### the real $VERSION declaration. |
| $in_pod = $line =~ /^=(?!cut)/ ? 1 : |
| $line =~ /^=cut/ ? 0 : |
| $in_pod; |
| next if $in_pod; |
| |
| ### try to find a version declaration in this string. |
| my $ver = __PACKAGE__->_parse_version( $line ); |
| |
| if( defined $ver ) { |
| $href->{version} = $ver; |
| |
| last DIR; |
| } |
| } |
| } |
| } |
| } |
| |
| ### if we couldn't find the file, return undef ### |
| return unless defined $href->{file}; |
| |
| ### only complain if we're expected to find a version higher than 0.0 anyway |
| if( $FIND_VERSION and not defined $href->{version} ) { |
| { ### don't warn about the 'not numeric' stuff ### |
| local $^W; |
| |
| ### if we got here, we didn't find the version |
| warn loc(q[Could not check version on '%1'], $args->{module} ) |
| if $args->{verbose} and $args->{version} > 0; |
| } |
| $href->{uptodate} = 1; |
| |
| } else { |
| ### don't warn about the 'not numeric' stuff ### |
| local $^W; |
| |
| ### use qv(), as it will deal with developer release number |
| ### ie ones containing _ as well. This addresses bug report |
| ### #29348: Version compare logic doesn't handle alphas? |
| ### |
| ### Update from JPeacock: apparently qv() and version->new |
| ### are different things, and we *must* use version->new |
| ### here, or things like #30056 might start happening |
| |
| ### We have to wrap this in an eval as version-0.82 raises |
| ### exceptions and not warnings now *sigh* |
| |
| eval { |
| |
| $href->{uptodate} = |
| version->new( $args->{version} ) <= version->new( $href->{version} ) |
| ? 1 |
| : 0; |
| |
| }; |
| } |
| |
| if ( $DEPRECATED and version->new($]) >= version->new('5.011') ) { |
| require Module::CoreList; |
| require Config; |
| |
| $href->{uptodate} = 0 if |
| exists $Module::CoreList::version{ 0+$] }{ $args->{module} } and |
| Module::CoreList::is_deprecated( $args->{module} ) and |
| $Config::Config{privlibexp} eq $href->{dir}; |
| } |
| |
| return $href; |
| } |
| |
| sub _parse_version { |
| my $self = shift; |
| my $str = shift or return; |
| my $verbose = shift || 0; |
| |
| ### skip lines which doesn't contain VERSION |
| return unless $str =~ /VERSION/; |
| |
| ### skip commented out lines, they won't eval to anything. |
| return if $str =~ /^\s*#/; |
| |
| ### the following regexp & eval statement comes from the |
| ### ExtUtils::MakeMaker source (EU::MM_Unix->parse_version) |
| ### Following #18892, which tells us the original |
| ### regex breaks under -T, we must modify it so |
| ### it captures the entire expression, and eval /that/ |
| ### rather than $_, which is insecure. |
| my $taint_safe_str = do { $str =~ /(^.*$)/sm; $1 }; |
| |
| if( $str =~ /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ ) { |
| |
| print "Evaluating: $str\n" if $verbose; |
| |
| ### this creates a string to be eval'd, like: |
| # package Module::Load::Conditional::_version; |
| # no strict; |
| # |
| # local $VERSION; |
| # $VERSION=undef; do { |
| # use version; $VERSION = qv('0.0.3'); |
| # }; $VERSION |
| |
| my $eval = qq{ |
| package Module::Load::Conditional::_version; |
| no strict; |
| |
| local $1$2; |
| \$$2=undef; do { |
| $taint_safe_str |
| }; \$$2 |
| }; |
| |
| print "Evaltext: $eval\n" if $verbose; |
| |
| my $result = do { |
| local $^W = 0; |
| eval($eval); |
| }; |
| |
| |
| my $rv = defined $result ? $result : '0.0'; |
| |
| print( $@ ? "Error: $@\n" : "Result: $rv\n" ) if $verbose; |
| |
| return $rv; |
| } |
| |
| ### unable to find a version in this string |
| return; |
| } |
| |
| =head2 $bool = can_load( modules => { NAME => VERSION [,NAME => VERSION] }, [verbose => BOOL, nocache => BOOL] ) |
| |
| C<can_load> will take a list of modules, optionally with version |
| numbers and determine if it is able to load them. If it can load *ALL* |
| of them, it will. If one or more are unloadable, none will be loaded. |
| |
| This is particularly useful if you have More Than One Way (tm) to |
| solve a problem in a program, and only wish to continue down a path |
| if all modules could be loaded, and not load them if they couldn't. |
| |
| This function uses the C<load> function from Module::Load under the |
| hood. |
| |
| C<can_load> takes the following arguments: |
| |
| =over 4 |
| |
| =item modules |
| |
| This is a hashref of module/version pairs. The version indicates the |
| minimum version to load. If no version is provided, any version is |
| assumed to be good enough. |
| |
| =item verbose |
| |
| This controls whether warnings should be printed if a module failed |
| to load. |
| The default is to use the value of $Module::Load::Conditional::VERBOSE. |
| |
| =item nocache |
| |
| C<can_load> keeps its results in a cache, so it will not load the |
| same module twice, nor will it attempt to load a module that has |
| already failed to load before. By default, C<can_load> will check its |
| cache, but you can override that by setting C<nocache> to true. |
| |
| =cut |
| |
| sub can_load { |
| my %hash = @_; |
| |
| my $tmpl = { |
| modules => { default => {}, strict_type => 1 }, |
| verbose => { default => $VERBOSE }, |
| nocache => { default => 0 }, |
| }; |
| |
| my $args; |
| |
| unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) { |
| $ERROR = loc(q[Problem validating arguments!]); |
| warn $ERROR if $VERBOSE; |
| return; |
| } |
| |
| ### layout of $CACHE: |
| ### $CACHE = { |
| ### $ module => { |
| ### usable => BOOL, |
| ### version => \d, |
| ### file => /path/to/file, |
| ### }, |
| ### }; |
| |
| $CACHE ||= {}; # in case it was undef'd |
| |
| my $error; |
| BLOCK: { |
| my $href = $args->{modules}; |
| |
| my @load; |
| for my $mod ( keys %$href ) { |
| |
| next if $CACHE->{$mod}->{usable} && !$args->{nocache}; |
| |
| ### else, check if the hash key is defined already, |
| ### meaning $mod => 0, |
| ### indicating UNSUCCESSFUL prior attempt of usage |
| |
| ### use qv(), as it will deal with developer release number |
| ### ie ones containing _ as well. This addresses bug report |
| ### #29348: Version compare logic doesn't handle alphas? |
| ### |
| ### Update from JPeacock: apparently qv() and version->new |
| ### are different things, and we *must* use version->new |
| ### here, or things like #30056 might start happening |
| if ( !$args->{nocache} |
| && defined $CACHE->{$mod}->{usable} |
| && (version->new( $CACHE->{$mod}->{version}||0 ) |
| >= version->new( $href->{$mod} ) ) |
| ) { |
| $error = loc( q[Already tried to use '%1', which was unsuccessful], $mod); |
| last BLOCK; |
| } |
| |
| my $mod_data = check_install( |
| module => $mod, |
| version => $href->{$mod} |
| ); |
| |
| if( !$mod_data or !defined $mod_data->{file} ) { |
| $error = loc(q[Could not find or check module '%1'], $mod); |
| $CACHE->{$mod}->{usable} = 0; |
| last BLOCK; |
| } |
| |
| map { |
| $CACHE->{$mod}->{$_} = $mod_data->{$_} |
| } qw[version file uptodate]; |
| |
| push @load, $mod; |
| } |
| |
| for my $mod ( @load ) { |
| |
| if ( $CACHE->{$mod}->{uptodate} ) { |
| |
| eval { load $mod }; |
| |
| ### in case anything goes wrong, log the error, the fact |
| ### we tried to use this module and return 0; |
| if( $@ ) { |
| $error = $@; |
| $CACHE->{$mod}->{usable} = 0; |
| last BLOCK; |
| } else { |
| $CACHE->{$mod}->{usable} = 1; |
| } |
| |
| ### module not found in @INC, store the result in |
| ### $CACHE and return 0 |
| } else { |
| |
| $error = loc(q[Module '%1' is not uptodate!], $mod); |
| $CACHE->{$mod}->{usable} = 0; |
| last BLOCK; |
| } |
| } |
| |
| } # BLOCK |
| |
| if( defined $error ) { |
| $ERROR = $error; |
| Carp::carp( loc(q|%1 [THIS MAY BE A PROBLEM!]|,$error) ) if $args->{verbose}; |
| return; |
| } else { |
| return 1; |
| } |
| } |
| |
| =back |
| |
| =head2 @list = requires( MODULE ); |
| |
| C<requires> can tell you what other modules a particular module |
| requires. This is particularly useful when you're intending to write |
| a module for public release and are listing its prerequisites. |
| |
| C<requires> takes but one argument: the name of a module. |
| It will then first check if it can actually load this module, and |
| return undef if it can't. |
| Otherwise, it will return a list of modules and pragmas that would |
| have been loaded on the module's behalf. |
| |
| Note: The list C<require> returns has originated from your current |
| perl and your current install. |
| |
| =cut |
| |
| sub requires { |
| my $who = shift; |
| |
| unless( check_install( module => $who ) ) { |
| warn loc(q[You do not have module '%1' installed], $who) if $VERBOSE; |
| return undef; |
| } |
| |
| my $lib = join " ", map { qq["-I$_"] } @INC; |
| my $cmd = qq[$^X $lib -M$who -e"print(join(qq[\\n],keys(%INC)))"]; |
| |
| return sort |
| grep { !/^$who$/ } |
| map { chomp; s|/|::|g; $_ } |
| grep { s|\.pm$||i; } |
| `$cmd`; |
| } |
| |
| 1; |
| |
| __END__ |
| |
| =head1 Global Variables |
| |
| The behaviour of Module::Load::Conditional can be altered by changing the |
| following global variables: |
| |
| =head2 $Module::Load::Conditional::VERBOSE |
| |
| This controls whether Module::Load::Conditional will issue warnings and |
| explanations as to why certain things may have failed. If you set it |
| to 0, Module::Load::Conditional will not output any warnings. |
| The default is 0; |
| |
| =head2 $Module::Load::Conditional::FIND_VERSION |
| |
| This controls whether Module::Load::Conditional will try to parse |
| (and eval) the version from the module you're trying to load. |
| |
| If you don't wish to do this, set this variable to C<false>. Understand |
| then that version comparisons are not possible, and Module::Load::Conditional |
| can not tell you what module version you have installed. |
| This may be desirable from a security or performance point of view. |
| Note that C<$FIND_VERSION> code runs safely under C<taint mode>. |
| |
| The default is 1; |
| |
| =head2 $Module::Load::Conditional::CHECK_INC_HASH |
| |
| This controls whether C<Module::Load::Conditional> checks your |
| C<%INC> hash to see if a module is available. By default, only |
| C<@INC> is scanned to see if a module is physically on your |
| filesystem, or available via an C<@INC-hook>. Setting this variable |
| to C<true> will trust any entries in C<%INC> and return them for |
| you. |
| |
| The default is 0; |
| |
| =head2 $Module::Load::Conditional::CACHE |
| |
| This holds the cache of the C<can_load> function. If you explicitly |
| want to remove the current cache, you can set this variable to |
| C<undef> |
| |
| =head2 $Module::Load::Conditional::ERROR |
| |
| This holds a string of the last error that happened during a call to |
| C<can_load>. It is useful to inspect this when C<can_load> returns |
| C<undef>. |
| |
| =head2 $Module::Load::Conditional::DEPRECATED |
| |
| This controls whether C<Module::Load::Conditional> checks if |
| a dual-life core module has been deprecated. If this is set to |
| true C<check_install> will return false to C<uptodate>, if |
| a dual-life module is found to be loaded from C<$Config{privlibexp}> |
| |
| The default is 0; |
| |
| =head1 See Also |
| |
| C<Module::Load> |
| |
| =head1 BUG REPORTS |
| |
| Please report bugs or other issues to E<lt>bug-module-load-conditional@rt.cpan.orgE<gt>. |
| |
| =head1 AUTHOR |
| |
| This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. |
| |
| =head1 COPYRIGHT |
| |
| This library is free software; you may redistribute and/or modify it |
| under the same terms as Perl itself. |
| |
| =cut |