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