[p5sagit/p5-mst-13.2.git] / cpan / Module-Load-Conditional / lib / Module / Load / Conditional.pm

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 
                        $FIND_VERSION $ERROR $CHECK_INC_HASH];
    use Exporter;
    @ISA            = qw[Exporter];
    $VERSION        = '0.30';
    $VERBOSE        = 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

=head1 $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.

=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 ;)
    
                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->($dir, $file);
                }
    
                if (!UNIVERSAL::isa($fh, 'GLOB')) {
                    warn loc(q[Cannot open file '%1': %2], $file, $!)
                            if $args->{verbose};
                    next;
                }
    
                $filename = $INC{$file_inc} || $file;
    
            } 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
        $href->{uptodate} = 
            version->new( $args->{version} ) <= version->new( $href->{version} )
                ? 1 
                : 0;
    }

    return $href;
}

sub _parse_version {
    my $self    = shift;
    my $str     = shift or return;
    my $verbose = shift or 0;

    ### 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 modifiy 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 avialable 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>.

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