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