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.62'; 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 } 318 319 return $href; 320} 321 322=head2 $bool = can_load( modules => { NAME => VERSION [,NAME => VERSION] }, [verbose => BOOL, nocache => BOOL, autoload => BOOL] ) 323 324C<can_load> will take a list of modules, optionally with version 325numbers and determine if it is able to load them. If it can load *ALL* 326of them, it will. If one or more are unloadable, none will be loaded. 327 328This is particularly useful if you have More Than One Way (tm) to 329solve a problem in a program, and only wish to continue down a path 330if all modules could be loaded, and not load them if they couldn't. 331 332This function uses the C<load> function or the C<autoload_remote> function 333from Module::Load under the hood. 334 335C<can_load> takes the following arguments: 336 337=over 4 338 339=item modules 340 341This is a hashref of module/version pairs. The version indicates the 342minimum version to load. If no version is provided, any version is 343assumed to be good enough. 344 345=item verbose 346 347This controls whether warnings should be printed if a module failed 348to load. 349The default is to use the value of $Module::Load::Conditional::VERBOSE. 350 351=item nocache 352 353C<can_load> keeps its results in a cache, so it will not load the 354same module twice, nor will it attempt to load a module that has 355already failed to load before. By default, C<can_load> will check its 356cache, but you can override that by setting C<nocache> to true. 357 358=item autoload 359 360This controls whether imports the functions of a loaded modules to the caller package. The default is no importing any functions. 361 362See the C<autoload> function and the C<autoload_remote> function from L<Module::Load> for details. 363 364=cut 365 366sub can_load { 367 my %hash = @_; 368 369 my $tmpl = { 370 modules => { default => {}, strict_type => 1 }, 371 verbose => { default => $VERBOSE }, 372 nocache => { default => 0 }, 373 autoload => { default => 0 }, 374 }; 375 376 my $args; 377 378 unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) { 379 $ERROR = loc(q[Problem validating arguments!]); 380 warn $ERROR if $VERBOSE; 381 return; 382 } 383 384 ### layout of $CACHE: 385 ### $CACHE = { 386 ### $ module => { 387 ### usable => BOOL, 388 ### version => \d, 389 ### file => /path/to/file, 390 ### }, 391 ### }; 392 393 $CACHE ||= {}; # in case it was undef'd 394 395 my $error; 396 BLOCK: { 397 my $href = $args->{modules}; 398 399 my @load; 400 for my $mod ( keys %$href ) { 401 402 next if $CACHE->{$mod}->{usable} && !$args->{nocache}; 403 404 ### else, check if the hash key is defined already, 405 ### meaning $mod => 0, 406 ### indicating UNSUCCESSFUL prior attempt of usage 407 408 ### use qv(), as it will deal with developer release number 409 ### ie ones containing _ as well. This addresses bug report 410 ### #29348: Version compare logic doesn't handle alphas? 411 ### 412 ### Update from JPeacock: apparently qv() and version->new 413 ### are different things, and we *must* use version->new 414 ### here, or things like #30056 might start happening 415 if ( !$args->{nocache} 416 && defined $CACHE->{$mod}->{usable} 417 && (version->new( $CACHE->{$mod}->{version}||0 ) 418 >= version->new( $href->{$mod} ) ) 419 ) { 420 $error = loc( q[Already tried to use '%1', which was unsuccessful], $mod); 421 last BLOCK; 422 } 423 424 my $mod_data = check_install( 425 module => $mod, 426 version => $href->{$mod} 427 ); 428 429 if( !$mod_data or !defined $mod_data->{file} ) { 430 $error = loc(q[Could not find or check module '%1'], $mod); 431 $CACHE->{$mod}->{usable} = 0; 432 last BLOCK; 433 } 434 435 map { 436 $CACHE->{$mod}->{$_} = $mod_data->{$_} 437 } qw[version file uptodate]; 438 439 push @load, $mod; 440 } 441 442 for my $mod ( @load ) { 443 444 if ( $CACHE->{$mod}->{uptodate} ) { 445 446 if ( $args->{autoload} ) { 447 my $who = (caller())[0]; 448 eval { autoload_remote $who, $mod }; 449 } else { 450 eval { load $mod }; 451 } 452 453 ### in case anything goes wrong, log the error, the fact 454 ### we tried to use this module and return 0; 455 if( $@ ) { 456 $error = $@; 457 $CACHE->{$mod}->{usable} = 0; 458 last BLOCK; 459 } else { 460 $CACHE->{$mod}->{usable} = 1; 461 } 462 463 ### module not found in @INC, store the result in 464 ### $CACHE and return 0 465 } else { 466 467 $error = loc(q[Module '%1' is not uptodate!], $mod); 468 $CACHE->{$mod}->{usable} = 0; 469 last BLOCK; 470 } 471 } 472 473 } # BLOCK 474 475 if( defined $error ) { 476 $ERROR = $error; 477 Carp::carp( loc(q|%1 [THIS MAY BE A PROBLEM!]|,$error) ) if $args->{verbose}; 478 return; 479 } else { 480 return 1; 481 } 482} 483 484=back 485 486=head2 @list = requires( MODULE ); 487 488C<requires> can tell you what other modules a particular module 489requires. This is particularly useful when you're intending to write 490a module for public release and are listing its prerequisites. 491 492C<requires> takes but one argument: the name of a module. 493It will then first check if it can actually load this module, and 494return undef if it can't. 495Otherwise, it will return a list of modules and pragmas that would 496have been loaded on the module's behalf. 497 498Note: The list C<require> returns has originated from your current 499perl and your current install. 500 501=cut 502 503sub requires { 504 my $who = shift; 505 506 unless( check_install( module => $who ) ) { 507 warn loc(q[You do not have module '%1' installed], $who) if $VERBOSE; 508 return undef; 509 } 510 511 my $lib = join " ", map { qq["-I$_"] } @INC; 512 my $oneliner = 'print(join(qq[\n],map{qq[BONG=$_]}keys(%INC)),qq[\n])'; 513 my $cmd = join '', qq["$^X" $lib -M$who -e], QUOTE, $oneliner, QUOTE; 514 515 return sort 516 grep { !/^$who$/ } 517 map { chomp; s|/|::|g; $_ } 518 grep { s|\.pm$||i; } 519 map { s!^BONG\=!!; $_ } 520 grep { m!^BONG\=! } 521 `$cmd`; 522} 523 5241; 525 526__END__ 527 528=head1 Global Variables 529 530The behaviour of Module::Load::Conditional can be altered by changing the 531following global variables: 532 533=head2 $Module::Load::Conditional::VERBOSE 534 535This controls whether Module::Load::Conditional will issue warnings and 536explanations as to why certain things may have failed. If you set it 537to 0, Module::Load::Conditional will not output any warnings. 538The default is 0; 539 540=head2 $Module::Load::Conditional::FIND_VERSION 541 542This controls whether Module::Load::Conditional will try to parse 543(and eval) the version from the module you're trying to load. 544 545If you don't wish to do this, set this variable to C<false>. Understand 546then that version comparisons are not possible, and Module::Load::Conditional 547can not tell you what module version you have installed. 548This may be desirable from a security or performance point of view. 549Note that C<$FIND_VERSION> code runs safely under C<taint mode>. 550 551The default is 1; 552 553=head2 $Module::Load::Conditional::CHECK_INC_HASH 554 555This controls whether C<Module::Load::Conditional> checks your 556C<%INC> hash to see if a module is available. By default, only 557C<@INC> is scanned to see if a module is physically on your 558filesystem, or available via an C<@INC-hook>. Setting this variable 559to C<true> will trust any entries in C<%INC> and return them for 560you. 561 562The default is 0; 563 564=head2 $Module::Load::Conditional::CACHE 565 566This holds the cache of the C<can_load> function. If you explicitly 567want to remove the current cache, you can set this variable to 568C<undef> 569 570=head2 $Module::Load::Conditional::ERROR 571 572This holds a string of the last error that happened during a call to 573C<can_load>. It is useful to inspect this when C<can_load> returns 574C<undef>. 575 576=head2 $Module::Load::Conditional::DEPRECATED 577 578This controls whether C<Module::Load::Conditional> checks if 579a dual-life core module has been deprecated. If this is set to 580true C<check_install> will return false to C<uptodate>, if 581a dual-life module is found to be loaded from C<$Config{privlibexp}> 582 583The default is 0; 584 585=head1 See Also 586 587C<Module::Load> 588 589=head1 BUG REPORTS 590 591Please report bugs or other issues to E<lt>bug-module-load-conditional@rt.cpan.orgE<gt>. 592 593=head1 AUTHOR 594 595This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. 596 597=head1 COPYRIGHT 598 599This library is free software; you may redistribute and/or modify it 600under the same terms as Perl itself. 601 602=cut 603