[Bps-public-commit] Class-Load branch, master, updated. f04f8f08a569e15cf0727f1f182136b4e0d548a1

[sartak at bestpractical.com]

The branch, master has been updated
       via  f04f8f08a569e15cf0727f1f182136b4e0d548a1 (commit)
      from  b578d8a54a7b15109774ebf9bb4280d0d78de59f (commit)

Summary of changes:
 lib/Class/Load.pm       |   69 +++++++++++++++++++++++++++++++++++++---------
 t/001-is-class-loaded.t |    9 +-----
 t/002-try-load-class.t  |    2 +-
 t/003-load-class.t      |    2 +-
 4 files changed, 58 insertions(+), 24 deletions(-)

- Log -----------------------------------------------------------------
commit f04f8f08a569e15cf0727f1f182136b4e0d548a1
Author: Shawn M Moore <sartak at bestpractical.com>
Date:   Wed Sep 2 06:17:14 2009 -0400

    Cargo cult CMOP's old pure-perl is_class_loaded

diff --git a/lib/Class/Load.pm b/lib/Class/Load.pm
index ff41387..4beb8ab 100644
--- a/lib/Class/Load.pm
+++ b/lib/Class/Load.pm
@@ -14,6 +14,12 @@ our %EXPORT_TAGS = (
 
 our $ERROR;
 
+BEGIN {
+    *IS_RUNNING_ON_5_10 = ($] < 5.009_005)
+        ? sub () { 0 }
+        : sub () { 1 };
+}
+
 sub load_class {
     my $class = shift;
 
@@ -47,30 +53,63 @@ sub try_load_class {
     return 0;
 }
 
+sub _is_valid_class_name {
+    my $class = shift;
+
+    return 0 if ref($class);
+    return 0 unless defined($class);
+    return 0 unless length($class);
+
+    return 1 if $class =~ /^\w+(?:::\w+)*$/;
+
+    return 0;
+}
+
 sub is_class_loaded {
     my $class = shift;
 
-    # is the module's file in %INC?
-    my $file = (join '/', split '::', $class) . '.pm';
-    return 1 if $INC{$file};
+    return 0 unless _is_valid_class_name($class);
 
-    # any interesting symbols in this module's symbol table?
-    my $table = do {
+    # walk the symbol table tree to avoid autovififying
+    # \*{${main::}{"Foo::"}} == \*main::Foo::
+
+    my $pack = \*::;
+    foreach my $part (split('::', $class)) {
+        return 0 unless exists ${$$pack}{"${part}::"};
+        $pack = \*{${$$pack}{"${part}::"}};
+    }
+
+    # We used to check in the package stash, but it turns out that
+    # *{${$$package}{VERSION}{SCALAR}} can end up pointing to a
+    # reference to undef. It looks
+
+    my $version = do {
         no strict 'refs';
-        \%{ $class . '::' };
+        ${$class . '::VERSION'};
     };
 
-    # ..such as @ISA?
-    return 1 if exists $table->{ISA};
+    return 1 if ! ref $version && defined $version;
+    # Sometimes $VERSION ends up as a reference to undef (weird)
+    return 1 if ref $version && reftype $version eq 'SCALAR' && defined ${$version};
 
-    # ..such as $VERSION?
-    return 1 if exists $table->{VERSION};
+    return 1 if exists ${$$pack}{ISA}
+             && defined *{${$$pack}{ISA}}{ARRAY};
 
-    # ..or a method?
-    for my $glob (values %$table) {
-        return 1 if *{$glob}{CODE};
+    # check for any method
+    foreach ( keys %{$$pack} ) {
+        next if substr($_, -2, 2) eq '::';
+
+        my $glob = ${$$pack}{$_} || next;
+
+        # constant subs
+        if ( IS_RUNNING_ON_5_10 ) {
+            return 1 if ref $glob eq 'SCALAR';
+        }
+
+        return 1 if defined *{$glob}{CODE};
     }
 
+    # fail
     return 0;
 }
 
@@ -155,6 +194,8 @@ C<if (eval "require $module"; 1)>.
 
 Shawn M Moore, C<< <sartak at bestpractical.com> >>
 
+The implementation if C<is_class_loaded> has been taken from L<Class::MOP>.
+
 =head1 BUGS
 
 Please report any bugs or feature requests to
@@ -163,7 +204,7 @@ L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Class-Load>.
 
 =head1 COPYRIGHT & LICENSE
 
-Copyright 2008 Best Practical Solutions.
+Copyright 2008-2009 Best Practical Solutions.
 
 This program is free software; you can redistribute it and/or modify it
 under the same terms as Perl itself.
diff --git a/t/001-is-class-loaded.t b/t/001-is-class-loaded.t
index 2da9302..3aacdc5 100644
--- a/t/001-is-class-loaded.t
+++ b/t/001-is-class-loaded.t
@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 use strict;
 use warnings;
-use Test::More tests => 11;
+use Test::More tests => 10;
 
 use Class::Load 'is_class_loaded';
 
@@ -31,13 +31,6 @@ do {
 };
 ok(is_class_loaded('Class::Load::WithVERSION'), "class that defines \$VERSION is loaded");
 # }}}
-# @VERSION (yes, sadly) {{{
-do {
-    package Class::Load::WithArrayVERSION;
-    our @VERSION = "1.0";
-};
-ok(is_class_loaded('Class::Load::WithArrayVERSION'), "class that defines \@VERSION is loaded");
-# }}}
 # method (yes) {{{
 do {
     package Class::Load::WithMethod;
diff --git a/t/002-try-load-class.t b/t/002-try-load-class.t
index 7a600f7..94e2bb8 100644
--- a/t/002-try-load-class.t
+++ b/t/002-try-load-class.t
@@ -19,7 +19,7 @@ like($Class::Load::ERROR, qr{^Missing right curly or square bracket at });
 
 ok(is_class_loaded('Class::Load::OK'));
 ok(!is_class_loaded('Class::Load::Nonexistent'));
-ok(is_class_loaded('Class::Load::SyntaxError'));
+ok(!is_class_loaded('Class::Load::SyntaxError'));
 
 do {
     package Class::Load::Inlined;
diff --git a/t/003-load-class.t b/t/003-load-class.t
index 983e0d1..183de51 100644
--- a/t/003-load-class.t
+++ b/t/003-load-class.t
@@ -24,7 +24,7 @@ like($Class::Load::ERROR, qr{^Missing right curly or square bracket at });
 
 ok(is_class_loaded('Class::Load::OK'));
 ok(!is_class_loaded('Class::Load::Nonexistent'));
-ok(is_class_loaded('Class::Load::SyntaxError'));
+ok(!is_class_loaded('Class::Load::SyntaxError'));
 
 do {
     package Class::Load::Inlined;

-----------------------------------------------------------------------