From: Shawn M Moore <sartak@gmail.com>
Date: Tue, 10 Jun 2008 00:52:57 +0000 (+0000)
Subject: Implementation of ClassName, borrowed from Moose
X-Git-Tag: 0.04~85
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=31f5a7f75be930dbeffb8836e7e21faf4312a1dc

Implementation of ClassName, borrowed from Moose
---

diff --git a/lib/Mouse/TypeRegistry.pm b/lib/Mouse/TypeRegistry.pm
index 4f3125c..9c18bd2 100644
--- a/lib/Mouse/TypeRegistry.pm
+++ b/lib/Mouse/TypeRegistry.pm
@@ -18,7 +18,6 @@ sub optimized_constraints {
         Num        => sub { !ref($_) && looks_like_number($_) },
         Int        => sub { defined($_) && !ref($_) && /^-?[0-9]+$/ },
         Str        => sub { defined($_) && !ref($_) },
-        ClassName  => sub { 1 },
         Ref        => sub { ref($_) },
 
         ScalarRef  => sub { ref($_) eq 'SCALAR' },
@@ -37,6 +36,35 @@ sub optimized_constraints {
         },
 
         Object     => sub { blessed($_) && blessed($_) ne 'Regexp' },
+
+        ClassName  => sub {
+            return if ref($_);
+            return unless defined($_) && length($_);
+
+            # walk the symbol table tree to avoid autovififying
+            # \*{${main::}{"Foo::"}} == \*main::Foo::
+
+            my $pack = \*::;
+            foreach my $part (split('::', $_)) {
+                return unless exists ${$$pack}{"${part}::"};
+                $pack = \*{${$$pack}{"${part}::"}};
+            }
+
+            # check for $VERSION or @ISA
+            return 1 if exists ${$$pack}{VERSION}
+                    && defined *{${$$pack}{VERSION}}{SCALAR};
+            return 1 if exists ${$$pack}{ISA}
+                    && defined *{${$$pack}{ISA}}{ARRAY};
+
+            # check for any method
+            foreach ( keys %{$$pack} ) {
+                next if substr($_, -2, 2) eq '::';
+                return 1 if defined *{${$$pack}{$_}}{CODE};
+            }
+
+            # fail
+            return;
+        },
     };
 }