lib/Module/Load/Conditional.pm

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