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