From 7e7ddbe33ca34359d711aee1e0ddebaeb40c2a18 Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Thu, 25 Jun 2015 04:47:55 +0000 Subject: Class-Load-0.23 --- lib/Class/Load.pm | 405 +++++++++++++++++++++++++++++++++++++++++++++++++++ lib/Class/Load/PP.pm | 59 ++++++++ 2 files changed, 464 insertions(+) create mode 100644 lib/Class/Load.pm create mode 100644 lib/Class/Load/PP.pm (limited to 'lib/Class') diff --git a/lib/Class/Load.pm b/lib/Class/Load.pm new file mode 100644 index 0000000..ae03c77 --- /dev/null +++ b/lib/Class/Load.pm @@ -0,0 +1,405 @@ +use strict; +use warnings; +package Class::Load; # git description: v0.22-9-g29ebb54 +# ABSTRACT: A working (require "Class::Name") and more +# KEYWORDS: class module load require use runtime + +our $VERSION = '0.23'; + +use base 'Exporter'; +use Data::OptList (); +use Module::Implementation 0.04; +use Module::Runtime 0.012 (); +use Try::Tiny; + +{ + my $loader = Module::Implementation::build_loader_sub( + implementations => [ 'XS', 'PP' ], + symbols => ['is_class_loaded'], + ); + + $loader->(); +} + +our @EXPORT_OK = qw/load_class load_optional_class try_load_class is_class_loaded load_first_existing_class/; +our %EXPORT_TAGS = ( + all => \@EXPORT_OK, +); + +our $ERROR; + +sub load_class { + my $class = shift; + my $options = shift; + + my ($res, $e) = try_load_class($class, $options); + return $class if $res; + + _croak($e); +} + +sub load_first_existing_class { + my $classes = Data::OptList::mkopt(\@_) + or return; + + foreach my $class (@{$classes}) { + Module::Runtime::check_module_name($class->[0]); + } + + for my $class (@{$classes}) { + my ($name, $options) = @{$class}; + + # We need to be careful not to pass an undef $options to this sub, + # since the XS version will blow up if that happens. + return $name if is_class_loaded($name, ($options ? $options : ())); + + my ($res, $e) = try_load_class($name, $options); + + return $name if $res; + + my $file = Module::Runtime::module_notional_filename($name); + + next if $e =~ /^Can't locate \Q$file\E in \@INC/; + next + if $options + && defined $options->{-version} + && $e =~ _version_fail_re($name, $options->{-version}); + + _croak("Couldn't load class ($name) because: $e"); + } + + my @list = map { + $_->[0] + . ( $_->[1] && defined $_->[1]{-version} + ? " (version >= $_->[1]{-version})" + : q{} ) + } @{$classes}; + + my $err + .= q{Can't locate } + . _or_list(@list) + . " in \@INC (\@INC contains: @INC)."; + _croak($err); +} + +sub _version_fail_re { + my $name = shift; + my $vers = shift; + + return qr/\Q$name\E version \Q$vers\E required--this is only version/; +} + +sub _nonexistent_fail_re { + my $name = shift; + + my $file = Module::Runtime::module_notional_filename($name); + return qr/Can't locate \Q$file\E in \@INC/; +} + +sub _or_list { + return $_[0] if @_ == 1; + + return join ' or ', @_ if @_ ==2; + + my $last = pop; + + my $list = join ', ', @_; + $list .= ', or ' . $last; + + return $list; +} + +sub load_optional_class { + my $class = shift; + my $options = shift; + + Module::Runtime::check_module_name($class); + + my ($res, $e) = try_load_class($class, $options); + return 1 if $res; + + return 0 + if $options + && defined $options->{-version} + && $e =~ _version_fail_re($class, $options->{-version}); + + return 0 + if $e =~ _nonexistent_fail_re($class); + + _croak($e); +} + +sub try_load_class { + my $class = shift; + my $options = shift; + + Module::Runtime::check_module_name($class); + + local $@; + undef $ERROR; + + if (is_class_loaded($class)) { + # We need to check this here rather than in is_class_loaded() because + # we want to return the error message for a failed version check, but + # is_class_loaded just returns true/false. + return 1 unless $options && defined $options->{-version}; + return try { + $class->VERSION($options->{-version}); + 1; + } + catch { + _error($_); + }; + } + + my $file = Module::Runtime::module_notional_filename($class); + # This says "our diagnostics of the package + # say perl's INC status about the file being loaded are + # wrong", so we delete it from %INC, so when we call require(), + # perl will *actually* try reloading the file. + # + # If the file is already in %INC, it won't retry, + # And on 5.8, it won't fail either! + # + # The extra benefit of this trick, is it helps even on + # 5.10, as instead of dying with "Compilation failed", + # it will die with the actual error, and that's a win-win. + delete $INC{$file}; + return try { + local $SIG{__DIE__} = 'DEFAULT'; + if ($options && defined $options->{-version}) { + Module::Runtime::use_module($class, $options->{-version}); + } + else { + Module::Runtime::require_module($class); + } + 1; + } + catch { + _error($_); + }; +} + +sub _error { + my $e = shift; + + $e =~ s/ at .+?Runtime\.pm line [0-9]+\.$//; + chomp $e; + + $ERROR = $e; + return 0 unless wantarray; + return 0, $ERROR; +} + +sub _croak { + require Carp; + local $Carp::CarpLevel = $Carp::CarpLevel + 2; + Carp::croak(shift); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::Load - A working (require "Class::Name") and more + +=head1 VERSION + +version 0.23 + +=head1 SYNOPSIS + + use Class::Load ':all'; + + try_load_class('Class::Name') + or plan skip_all => "Class::Name required to run these tests"; + + load_class('Class::Name'); + + is_class_loaded('Class::Name'); + + my $baseclass = load_optional_class('Class::Name::MightExist') + ? 'Class::Name::MightExist' + : 'Class::Name::Default'; + +=head1 DESCRIPTION + +C only accepts C style module names, not +C. How frustrating! For that, we provide +C. + +It's often useful to test whether a module can be loaded, instead of throwing +an error when it's not available. For that, we provide +C. + +Finally, sometimes we need to know whether a particular class has been loaded. +Asking C<%INC> is an option, but that will miss inner packages and any class +for which the filename does not correspond to the package name. For that, we +provide C. + +=head1 FUNCTIONS + +=head2 load_class Class::Name, \%options + +C will load C or throw an error, much like C. + +If C is already loaded (checked with C) then it +will not try to load the class. This is useful when you have inner packages +which C does not check. + +The C<%options> hash currently accepts one key, C<-version>. If you specify a +version, then this subroutine will call C<< Class::Name->VERSION( +$options{-version} ) >> internally, which will throw an error if the class's +version is not equal to or greater than the version you requested. + +This method will return the name of the class on success. + +=head2 try_load_class Class::Name, \%options -> (0|1, error message) + +Returns 1 if the class was loaded, 0 if it was not. If the class was not +loaded, the error will be returned as a second return value in list context. + +Again, if C is already loaded (checked with C) +then it will not try to load the class. This is useful when you have inner +packages which C does not check. + +Like C, you can pass a C<-version> in C<%options>. If the version +is not sufficient, then this subroutine will return false. + +=head2 is_class_loaded Class::Name, \%options -> 0|1 + +This uses a number of heuristics to determine if the class C is +loaded. There heuristics were taken from L's old pure-perl +implementation. + +Like C, you can pass a C<-version> in C<%options>. If the version +is not sufficient, then this subroutine will return false. + +=head2 load_first_existing_class Class::Name, \%options, ... + +This attempts to load the first loadable class in the list of classes +given. Each class name can be followed by an options hash reference. + +If any one of the classes loads and passes the optional version check, that +class name will be returned. If I of the classes can be loaded (or none +pass their version check), then an error will be thrown. + +If, when attempting to load a class, it fails to load because of a syntax +error, then an error will be thrown immediately. + +=head2 load_optional_class Class::Name, \%options -> 0|1 + +C is a lot like C, but also a lot like +C. + +If the class exists, and it works, then it will return 1. If you specify a +version in C<%options>, then the version check must succeed or it will return +0. + +If the class doesn't exist, and it appears to not exist on disk either, it +will return 0. + +If the class exists on disk, but loading from disk results in an error +(e.g.: a syntax error), then it will C with that error. + +This is useful for using if you want a fallback module system, i.e.: + + my $class = load_optional_class($foo) ? $foo : $default; + +That way, if $foo does exist, but can't be loaded due to error, you won't +get the behaviour of it simply not existing. + +=head1 CAVEATS + +Because of some of the heuristics that this module uses to infer whether a +module has been loaded, some false positives may occur in C +checks (which are also performed internally in other interfaces) -- if a class +has started to be loaded but then dies, it may appear that it has already been +loaded, which can cause other things to make the wrong decision. +L doesn't have this issue, but it also doesn't do some things +that this module does -- for example gracefully handle packages that have been +defined inline in the same file as another package. + +=head1 SEE ALSO + +=over 4 + +=item L + +This blog post is a good overview of the current state of the existing modules +for loading other modules in various ways. + +=item L + +This blog post describes how to handle optional modules with L. + +=item L + +This Japanese blog post describes why L now uses L +over its competitors. + +=item L, L, L, etc + +This module was designed to be used anywhere you have +C, which occurs in many large projects. + +=item L + +A leaner approach to loading modules + +=back + +=head1 AUTHOR + +Shawn M Moore + +=head1 CONTRIBUTORS + +=for stopwords Dave Rolsky Shawn Moore Karen Etheridge M Jesse Luehrs Kent Fredric Caleb Cushing + +=over 4 + +=item * + +Dave Rolsky + +=item * + +Shawn Moore + +=item * + +Karen Etheridge + +=item * + +Shawn M Moore + +=item * + +Jesse Luehrs + +=item * + +Kent Fredric + +=item * + +Caleb Cushing + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2008 by Shawn M Moore. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/Load/PP.pm b/lib/Class/Load/PP.pm new file mode 100644 index 0000000..a38d408 --- /dev/null +++ b/lib/Class/Load/PP.pm @@ -0,0 +1,59 @@ +use strict; +use warnings; +package Class::Load::PP; + +our $VERSION = '0.23'; + +use Module::Runtime (); +use Package::Stash 0.14; +use Scalar::Util (); +use Try::Tiny; + +sub is_class_loaded { + my $class = shift; + my $options = shift; + + my $loaded = _is_class_loaded($class); + + return $loaded if ! $loaded; + return $loaded unless $options && $options->{-version}; + + return try { + $class->VERSION($options->{-version}); + 1; + } + catch { + 0; + }; +} + +sub _is_class_loaded { + my $class = shift; + + return 0 unless Module::Runtime::is_module_name($class); + + my $stash = Package::Stash->new($class); + + if ($stash->has_symbol('$VERSION')) { + my $version = ${ $stash->get_symbol('$VERSION') }; + if (defined $version) { + return 1 if ! ref $version; + # Sometimes $VERSION ends up as a reference to undef (weird) + return 1 if ref $version && Scalar::Util::reftype $version eq 'SCALAR' && defined ${$version}; + # a version object + return 1 if Scalar::Util::blessed $version; + } + } + + if ($stash->has_symbol('@ISA')) { + return 1 if @{ $stash->get_symbol('@ISA') }; + } + + # check for any method + return 1 if $stash->list_all_symbols('CODE'); + + # fail + return 0; +} + +1; -- cgit v1.2.1