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