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
  13 BEGIN {
  14     use vars        qw[ $VERSION @ISA $VERBOSE $CACHE @EXPORT_OK
  15                         $FIND_VERSION $ERROR $CHECK_INC_HASH];
  16     use Exporter;
  17     @ISA            = qw[Exporter];
  18     $VERSION        = '0.12';
  19     $VERBOSE        = 0;
  20     $FIND_VERSION   = 1;
  21     $CHECK_INC_HASH = 0;
  22     @EXPORT_OK      = qw[check_install can_load requires];
  23 }
  24
  25 =pod
  26
  27 =head1 NAME
  28
  29 Module::Load::Conditional - Looking up module information / loading at runtime
  30
  31 =head1 SYNOPSIS
  32
  33     use Module::Load::Conditional qw[can_load check_install requires];
  34
  35
  36     my $use_list = {
  37             CPANPLUS        => 0.05,
  38             LWP             => 5.60,
  39             'Test::More'    => undef,
  40     };
  41
  42     print can_load( modules => $use_list )
  43             ? 'all modules loaded successfully'
  44             : 'failed to load required modules';
  45
  46
  47     my $rv = check_install( module => 'LWP', version => 5.60 )
  48                 or print 'LWP is not installed!';
  49
  50     print 'LWP up to date' if $rv->{uptodate};
  51     print "LWP version is $rv->{version}\n";
  52     print "LWP is installed as file $rv->{file}\n";
  53
  54
  55     print "LWP requires the following modules to be installed:\n";
  56     print join "\n", requires('LWP');
  57
  58     ### allow M::L::C to peek in your %INC rather than just
  59     ### scanning @INC
  60     $Module::Load::Conditional::CHECK_INC_HASH = 1;
  61
  62     ### reset the 'can_load' cache
  63     undef $Module::Load::Conditional::CACHE;
  64
  65     ### don't have Module::Load::Conditional issue warnings --
  66     ### default is '1'
  67     $Module::Load::Conditional::VERBOSE = 0;
  68
  69     ### The last error that happened during a call to 'can_load'
  70     my $err = $Module::Load::Conditional::ERROR;
  71
  72
  73 =head1 DESCRIPTION
  74
  75 Module::Load::Conditional provides simple ways to query and possibly load any of
  76 the modules you have installed on your system during runtime.
  77
  78 It is able to load multiple modules at once or none at all if one of
  79 them was not able to load. It also takes care of any error checking
  80 and so forth.
  81
  82 =head1 Methods
  83
  84 =head1 $href = check_install( module => NAME [, version => VERSION, verbose => BOOL ] );
  85
  86 C<check_install> allows you to verify if a certain module is installed
  87 or not. You may call it with the following arguments:
  88
  89 =over 4
  90
  91 =item module
  92
  93 The name of the module you wish to verify -- this is a required key
  94
  95 =item version
  96
  97 The version this module needs to be -- this is optional
  98
  99 =item verbose
 100
 101 Whether or not to be verbose about what it is doing -- it will default
 102 to $Module::Load::Conditional::VERBOSE
 103
 104 =back
 105
 106 It will return undef if it was not able to find where the module was
 107 installed, or a hash reference with the following keys if it was able
 108 to find the file:
 109
 110 =over 4
 111
 112 =item file
 113
 114 Full path to the file that contains the module
 115
 116 =item version
 117
 118 The version number of the installed module - this will be C<undef> if
 119 the module had no (or unparsable) version number, or if the variable
 120 C<$Module::Load::Conditional::FIND_VERSION> was set to true.
 121 (See the C<GLOBAL VARIABLES> section below for details)
 122
 123 =item uptodate
 124
 125 A boolean value indicating whether or not the module was found to be
 126 at least the version you specified. If you did not specify a version,
 127 uptodate will always be true if the module was found.
 128 If no parsable version was found in the module, uptodate will also be
 129 true, since C<check_install> had no way to verify clearly.
 130
 131 =back
 132
 133 =cut
 134
 135 ### this checks if a certain module is installed already ###
 136 ### if it returns true, the module in question is already installed
 137 ### or we found the file, but couldn't open it, OR there was no version
 138 ### to be found in the module
 139 ### it will return 0 if the version in the module is LOWER then the one
 140 ### we are looking for, or if we couldn't find the desired module to begin with
 141 ### if the installed version is higher or equal to the one we want, it will return
 142 ### a hashref with he module name and version in it.. so 'true' as well.
 143 sub check_install {
 144     my %hash = @_;
 145
 146     my $tmpl = {
 147             version => { default    => '0.0'    },
 148             module  => { required   => 1        },
 149             verbose => { default    => $VERBOSE },
 150     };
 151
 152     my $args;
 153     unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) {
 154         warn loc( q[A problem occurred checking arguments] ) if $VERBOSE;
 155         return;
 156     }
 157
 158     my $file     = File::Spec->catfile( split /::/, $args->{module} ) . '.pm';
 159     my $file_inc = File::Spec::Unix->catfile(
 160                         split /::/, $args->{module}
 161                     ) . '.pm';
 162
 163     ### where we store the return value ###
 164     my $href = {
 165             file        => undef,
 166             version     => undef,
 167             uptodate    => undef,
 168     };
 169
 170     my $filename;
 171
 172     ### check the inc hash if we're allowed to
 173     if( $CHECK_INC_HASH ) {
 174         $filename = $href->{'file'} =
 175             $INC{ $file_inc } if defined $INC{ $file_inc };
 176
 177         ### find the version by inspecting the package
 178         if( defined $filename && $FIND_VERSION ) {
 179             no strict 'refs';
 180             $href->{version} = ${ "$args->{module}"."::VERSION" };
 181         }
 182     }
 183
 184     ### we didnt find the filename yet by looking in %INC,
 185     ### so scan the dirs
 186     unless( $filename ) {
 187
 188         DIR: for my $dir ( @INC ) {
 189
 190             my $fh;
 191
 192             if ( ref $dir ) {
 193                 ### @INC hook -- we invoke it and get the filehandle back
 194                 ### this is actually documented behaviour as of 5.8 ;)
 195
 196                 if (UNIVERSAL::isa($dir, 'CODE')) {
 197                     ($fh) = $dir->($dir, $file);
 198
 199                 } elsif (UNIVERSAL::isa($dir, 'ARRAY')) {
 200                     ($fh) = $dir->[0]->($dir, $file, @{$dir}{1..$#{$dir}})
 201
 202                 } elsif (UNIVERSAL::can($dir, 'INC')) {
 203                     ($fh) = $dir->INC->($dir, $file);
 204                 }
 205
 206                 if (!UNIVERSAL::isa($fh, 'GLOB')) {
 207                     warn loc(q[Cannot open file '%1': %2], $file, $!)
 208                             if $args->{verbose};
 209                     next;
 210                 }
 211
 212                 $filename = $INC{$file_inc} || $file;
 213
 214             } else {
 215                 $filename = File::Spec->catfile($dir, $file);
 216                 next unless -e $filename;
 217
 218                 $fh = new FileHandle;
 219                 if (!$fh->open($filename)) {
 220                     warn loc(q[Cannot open file '%1': %2], $file, $!)
 221                             if $args->{verbose};
 222                     next;
 223                 }
 224             }
 225
 226             $href->{file} = $filename;
 227
 228             ### user wants us to find the version from files
 229             if( $FIND_VERSION ) {
 230
 231                 while (local $_ = <$fh> ) {
 232
 233                     ### skip commented out lines, they won't eval to anything.
 234                     next if /^\s*#/;
 235
 236                     ### the following regexp comes from the ExtUtils::MakeMaker
 237                     ### documentation.
 238                     ### Following #18892, which tells us the original
 239                     ### regex breaks under -T, we must modifiy it so
 240                     ### it captures the entire expression, and eval /that/
 241                     ### rather than $_, which is insecure.
 242                     if ( /([\$*][\w\:\']*\bVERSION\b.*\=.*)/ ) {
 243
 244                         ### this will eval the version in to $VERSION if it
 245                         ### was declared as $VERSION in the module.
 246                         ### else the result will be in $res.
 247                         ### this is a fix on skud's Module::InstalledVersion
 248
 249                         local $VERSION;
 250                         my $res = eval $1;
 251
 252                         ### default to '0.0' if there REALLY is no version
 253                         ### all to satisfy warnings
 254                         $href->{version} = $VERSION || $res || '0.0';
 255
 256                         last DIR;
 257                     }
 258                 }
 259             }
 260         }
 261     }
 262
 263     ### if we couldn't find the file, return undef ###
 264     return unless defined $href->{file};
 265
 266     ### only complain if we expected fo find a version higher than 0.0 anyway
 267     if( $FIND_VERSION and not defined $href->{version} ) {
 268         {   ### don't warn about the 'not numeric' stuff ###
 269             local $^W;
 270
 271             ### if we got here, we didn't find the version
 272             warn loc(q[Could not check version on '%1'], $args->{module} )
 273                     if $args->{verbose} and $args->{version} > 0;
 274         }
 275         $href->{uptodate} = 1;
 276
 277     } else {
 278         ### don't warn about the 'not numeric' stuff ###
 279         local $^W;
 280         $href->{uptodate} = $args->{version} <= $href->{version} ? 1 : 0;
 281     }
 282
 283     return $href;
 284 }
 285
 286 =head2 $bool = can_load( modules => { NAME => VERSION [,NAME => VERSION] }, [verbose => BOOL, nocache => BOOL] )
 287
 288 C<can_load> will take a list of modules, optionally with version
 289 numbers and determine if it is able to load them. If it can load *ALL*
 290 of them, it will. If one or more are unloadable, none will be loaded.
 291
 292 This is particularly useful if you have More Than One Way (tm) to
 293 solve a problem in a program, and only wish to continue down a path
 294 if all modules could be loaded, and not load them if they couldn't.
 295
 296 This function uses the C<load> function from Module::Load under the
 297 hood.
 298
 299 C<can_load> takes the following arguments:
 300
 301 =over 4
 302
 303 =item modules
 304
 305 This is a hashref of module/version pairs. The version indicates the
 306 minimum version to load. If no version is provided, any version is
 307 assumed to be good enough.
 308
 309 =item verbose
 310
 311 This controls whether warnings should be printed if a module failed
 312 to load.
 313 The default is to use the value of $Module::Load::Conditional::VERBOSE.
 314
 315 =item nocache
 316
 317 C<can_load> keeps its results in a cache, so it will not load the
 318 same module twice, nor will it attempt to load a module that has
 319 already failed to load before. By default, C<can_load> will check its
 320 cache, but you can override that by setting C<nocache> to true.
 321
 322 =cut
 323
 324 sub can_load {
 325     my %hash = @_;
 326
 327     my $tmpl = {
 328         modules     => { default => {}, strict_type => 1 },
 329         verbose     => { default => $VERBOSE },
 330         nocache     => { default => 0 },
 331     };
 332
 333     my $args;
 334
 335     unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) {
 336         $ERROR = loc(q[Problem validating arguments!]);
 337         warn $ERROR if $VERBOSE;
 338         return;
 339     }
 340
 341     ### layout of $CACHE:
 342     ### $CACHE = {
 343     ###     $ module => {
 344     ###             usable  => BOOL,
 345     ###             version => \d,
 346     ###             file    => /path/to/file,
 347     ###     },
 348     ### };
 349
 350     $CACHE ||= {}; # in case it was undef'd
 351
 352     my $error;
 353     BLOCK: {
 354         my $href = $args->{modules};
 355
 356         my @load;
 357         for my $mod ( keys %$href ) {
 358
 359             next if $CACHE->{$mod}->{usable} && !$args->{nocache};
 360
 361             ### else, check if the hash key is defined already,
 362             ### meaning $mod => 0,
 363             ### indicating UNSUCCESSFUL prior attempt of usage
 364             if (    !$args->{nocache}
 365                     && defined $CACHE->{$mod}->{usable}
 366                     && (($CACHE->{$mod}->{version}||0) >= $href->{$mod})
 367             ) {
 368                 $error = loc( q[Already tried to use '%1', which was unsuccessful], $mod);
 369                 last BLOCK;
 370             }
 371
 372             my $mod_data = check_install(
 373                                     module  => $mod,
 374                                     version => $href->{$mod}
 375                                 );
 376
 377             if( !$mod_data or !defined $mod_data->{file} ) {
 378                 $error = loc(q[Could not find or check module '%1'], $mod);
 379                 $CACHE->{$mod}->{usable} = 0;
 380                 last BLOCK;
 381             }
 382
 383             map {
 384                 $CACHE->{$mod}->{$_} = $mod_data->{$_}
 385             } qw[version file uptodate];
 386
 387             push @load, $mod;
 388         }
 389
 390         for my $mod ( @load ) {
 391
 392             if ( $CACHE->{$mod}->{uptodate} ) {
 393
 394                 eval { load $mod };
 395
 396                 ### in case anything goes wrong, log the error, the fact
 397                 ### we tried to use this module and return 0;
 398                 if( $@ ) {
 399                     $error = $@;
 400                     $CACHE->{$mod}->{usable} = 0;
 401                     last BLOCK;
 402                 } else {
 403                     $CACHE->{$mod}->{usable} = 1;
 404                 }
 405
 406             ### module not found in @INC, store the result in
 407             ### $CACHE and return 0
 408             } else {
 409
 410                 $error = loc(q[Module '%1' is not uptodate!], $mod);
 411                 $CACHE->{$mod}->{usable} = 0;
 412                 last BLOCK;
 413             }
 414         }
 415
 416     } # BLOCK
 417
 418     if( defined $error ) {
 419         $ERROR = $error;
 420         Carp::carp( loc(q|%1 [THIS MAY BE A PROBLEM!]|,$error) ) if $args->{verbose};
 421         return undef;
 422     } else {
 423         return 1;
 424     }
 425 }
 426
 427 =head2 @list = requires( MODULE );
 428
 429 C<requires> can tell you what other modules a particular module
 430 requires. This is particularly useful when you're intending to write
 431 a module for public release and are listing its prerequisites.
 432
 433 C<requires> takes but one argument: the name of a module.
 434 It will then first check if it can actually load this module, and
 435 return undef if it can't.
 436 Otherwise, it will return a list of modules and pragmas that would
 437 have been loaded on the module's behalf.
 438
 439 Note: The list C<require> returns has originated from your current
 440 perl and your current install.
 441
 442 =cut
 443
 444 sub requires {
 445     my $who = shift;
 446
 447     unless( check_install( module => $who ) ) {
 448         warn loc(q[You do not have module '%1' installed], $who) if $VERBOSE;
 449         return undef;
 450     }
 451
 452     my $lib = join " ", map { qq["-I$_"] } @INC;
 453     my $cmd = qq[$^X $lib -M$who -e"print(join(qq[\\n],keys(%INC)))"];
 454
 455     return  sort
 456                 grep { !/^$who$/  }
 457                 map  { chomp; s|/|::|g; $_ }
 458                 grep { s|\.pm$||i; }
 459             `$cmd`;
 460 }
 461
 462 1;
 463
 464 __END__
 465
 466 =head1 Global Variables
 467
 468 The behaviour of Module::Load::Conditional can be altered by changing the
 469 following global variables:
 470
 471 =head2 $Module::Load::Conditional::VERBOSE
 472
 473 This controls whether Module::Load::Conditional will issue warnings and
 474 explanations as to why certain things may have failed. If you set it
 475 to 0, Module::Load::Conditional will not output any warnings.
 476 The default is 0;
 477
 478 =head2 $Module::Load::Conditional::FIND_VERSION
 479
 480 This controls whether Module::Load::Conditional will try to parse
 481 (and eval) the version from the module you're trying to load.
 482
 483 If you don't wish to do this, set this variable to C<false>. Understand
 484 then that version comparisons are not possible, and Module::Load::Conditional
 485 can not tell you what module version you have installed.
 486 This may be desirable from a security or performance point of view.
 487 Note that C<$FIND_VERSION> code runs safely under C<taint mode>.
 488
 489 The default is 1;
 490
 491 =head2 $Module::Load::Conditional::CHECK_INC_HASH
 492
 493 This controls whether C<Module::Load::Conditional> checks your
 494 C<%INC> hash to see if a module is available. By default, only
 495 C<@INC> is scanned to see if a module is physically on your
 496 filesystem, or avialable via an C<@INC-hook>. Setting this variable
 497 to C<true> will trust any entries in C<%INC> and return them for
 498 you.
 499
 500 The default is 0;
 501
 502 =head2 $Module::Load::Conditional::CACHE
 503
 504 This holds the cache of the C<can_load> function. If you explicitly
 505 want to remove the current cache, you can set this variable to
 506 C<undef>
 507
 508 =head2 $Module::Load::Conditional::ERROR
 509
 510 This holds a string of the last error that happened during a call to
 511 C<can_load>. It is useful to inspect this when C<can_load> returns
 512 C<undef>.
 513
 514 =head1 See Also
 515
 516 C<Module::Load>
 517
 518 =head1 AUTHOR
 519
 520 This module by
 521 Jos Boumans E<lt>kane@cpan.orgE<gt>.
 522
 523 =head1 COPYRIGHT
 524
 525 This module is
 526 copyright (c) 2002 Jos Boumans E<lt>kane@cpan.orgE<gt>.
 527 All rights reserved.
 528
 529 This library is free software;
 530 you may redistribute and/or modify it under the same
 531 terms as Perl itself.