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