From: Matt S Trout <mst@shadowcat.co.uk>
Date: Wed, 14 Nov 2007 19:27:33 +0000 (+0000)
Subject: fix ClassName constraint to use symbol table
X-Git-Tag: 0_30~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5d776bdf0946d77af8b444f75493184a3a255c46;p=gitmo%2FMoose.git

fix ClassName constraint to use symbol table
---

diff --git a/Changes b/Changes
index 78fee19..105dd00 100644
--- a/Changes
+++ b/Changes
@@ -1,15 +1,18 @@
 Revision history for Perl extension Moose
 
+    * Moose::Util::TypeConstraints
+      - fix ClassName constraint to introspect symbol table
+
 0.29 Tues. Nov. 13, 2007
     * Moose::Meta::Attribute
-      -Fix error message on missing builder method (groditi)
+      - Fix error message on missing builder method (groditi)
 
     * Moose::Meta::Method::Accessor
-      -Fix error message on missing builder method (groditi)
+      - Fix error message on missing builder method (groditi)
 
     * t/ 
-      -Add test to check for the correct error message when
-       builder method is missing (groditi)
+      - Add test to check for the correct error message when
+        builder method is missing (groditi)
 
 0.28 Tues. Nov. 13, 2007
     - 0.27 packaged incorrectly (groditi)     
diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index 807e61a..44690df 100644
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -411,8 +411,61 @@ subtype 'Role'
 
 subtype 'ClassName'
     => as 'Str'
-    => where { eval { $_->isa('UNIVERSAL') } }
-    => optimize_as { !ref($_[0]) && eval { $_[0]->isa('UNIVERSAL') } };
+    => where {
+         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;
+       }
+    => optimize_as {
+         return if ref($_[0]);
+         return unless defined($_[0]) && length($_[0]);
+
+         # walk the symbol table tree to avoid autovififying
+         # \*{${main::}{"Foo::"}} == \*main::Foo::
+
+         my $pack = \*::;
+         foreach my $part (split('::', $_[0])) {
+           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;
+       };
 
 ## --------------------------------------------------------
 # end of built-in types ...
diff --git a/t/040_type_constraints/003_util_std_type_constraints.t b/t/040_type_constraints/003_util_std_type_constraints.t
index 3341efc..2961044 100644
--- a/t/040_type_constraints/003_util_std_type_constraints.t
+++ b/t/040_type_constraints/003_util_std_type_constraints.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 270;
+use Test::More tests => 271;
 use Test::Exception;
 
 use Scalar::Util ();
@@ -306,6 +306,8 @@ ok(!defined ClassName('Baz'),           '... ClassName rejects anything which is
 
 {
   package Quux::Wibble; # this makes Quux symbol table exist
+
+  sub foo {}
 }
 
 ok(!defined ClassName('Quux'),           '... ClassName rejects anything which is not a ClassName');
@@ -319,6 +321,7 @@ ok(!defined ClassName(qr/../),          '... ClassName rejects anything which is
 ok(!defined ClassName(bless {}, 'Foo'), '... ClassName rejects anything which is not a ClassName');
 ok(!defined ClassName(undef),           '... ClassName rejects anything which is not a ClassName');
 ok(defined ClassName('UNIVERSAL'),      '... ClassName accepts anything which is a ClassName');
+ok(defined ClassName('Quux::Wibble'),      '... ClassName accepts anything which is a ClassName');
 ok(defined ClassName('Moose::Meta::TypeConstraint'), '... ClassName accepts anything which is a ClassName');
 
 close($fh) || die "Could not close the filehandle $0 for test";