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