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