From: gfx <gfuji@cpan.org>
Date: Sat, 31 Oct 2009 04:06:06 +0000 (+0900)
Subject: Change is-a predicate stuff
X-Git-Tag: 0.40_04~30
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f48920c11c806b2a1fd60be145ff2cdf79750878;p=gitmo%2FMouse.git

Change is-a predicate stuff
---

diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm
index df19986..22d556a 100644
--- a/lib/Mouse/Meta/Attribute.pm
+++ b/lib/Mouse/Meta/Attribute.pm
@@ -361,7 +361,7 @@ sub _canonicalize_handles {
         my $meta = Mouse::Meta::Class->initialize("$class_or_role"); # "" for stringify
         return map  { $_ => $_ }
                grep { $_ ne 'meta' && !Mouse::Object->can($_) && $_ =~ $handles }
-                   Mouse::Util::TypeConstraints::_is_a_metarole($meta)
+                   Mouse::Util::is_a_metarole($meta)
                         ? $meta->get_method_list
                         : $meta->get_all_method_names;
     }
diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm
index 5aab15e..8e3693b 100644
--- a/lib/Mouse/Meta/Class.pm
+++ b/lib/Mouse/Meta/Class.pm
@@ -56,7 +56,7 @@ sub superclasses {
         foreach my $super(@_){
             Mouse::Util::load_class($super);
             my $meta = Mouse::Util::get_metaclass_by_name($super);
-            if(Mouse::Util::TypeConstraints::_is_a_metarole($meta)){
+            if(Mouse::Util::is_a_metarole($meta)){
                 $self->throw_error("You cannot inherit from a Mouse Role ($super)");
             }
         }
diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm
index 76f704c..d83ea12 100755
--- a/lib/Mouse/Meta/Module.pm
+++ b/lib/Mouse/Meta/Module.pm
@@ -143,7 +143,7 @@ sub get_method_list {
 
         my $superclasses;
         if(exists $options{superclasses}){
-            if(Mouse::Util::TypeConstraints::_is_a_metarole($self)){
+            if(Mouse::Util::is_a_metarole($self)){
                 delete $options{superclasses};
             }
             else{
diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm
index 6f9c7a8..9c1e994 100644
--- a/lib/Mouse/Meta/Role.pm
+++ b/lib/Mouse/Meta/Role.pm
@@ -186,10 +186,10 @@ sub apply {
 
     my $instance;
 
-    if(Mouse::Util::TypeConstraints::_is_a_metaclass($applicant)){  # Application::ToClass
+    if(Mouse::Util::is_a_metaclass($applicant)){  # Application::ToClass
         $args{_to} = 'class';
     }
-    elsif(Mouse::Util::TypeConstraints::_is_a_metarole($applicant)){ # Application::ToRole
+    elsif(Mouse::Util::is_a_metarole($applicant)){ # Application::ToRole
         $args{_to} = 'role';
     }
     else{                                       # Appplication::ToInstance
diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index 8fa8a1b..0faa17c 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -76,15 +76,10 @@ sub get_code_ref{
     return *{$package . '::' . $name}{CODE};
 }
 
-package
-    Mouse::Util::TypeConstraints;
-
-use Scalar::Util qw(blessed looks_like_number openhandle);
-
-sub _generate_class_type_for{
+sub _generate_isa_predicate_for {
     my($for_class, $name) = @_;
 
-    my $predicate = sub{ blessed($_[0]) && $_[0]->isa($for_class) };
+    my $predicate = sub{ Scalar::Util::blessed($_[0]) && $_[0]->isa($for_class) };
 
     if(defined $name){
         no strict 'refs';
@@ -96,6 +91,11 @@ sub _generate_class_type_for{
 }
 
 
+package
+    Mouse::Util::TypeConstraints;
+
+use Scalar::Util qw(blessed looks_like_number openhandle);
+
 sub Any        { 1 }
 sub Item       { 1 }
 
diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index 8afb940..d117bd2 100644
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -73,8 +73,14 @@ BEGIN {
     *get_metaclass_by_name       = \&Mouse::Meta::Module::get_metaclass_by_name;
     *get_all_metaclass_instances = \&Mouse::Meta::Module::get_all_metaclass_instances;
     *get_all_metaclass_names     = \&Mouse::Meta::Module::get_all_metaclass_names;
+
+    # is-a predicates
+    _generate_isa_predicate_for('Mouse::Meta::TypeConstraint' => 'is_a_type_constraint');
+    _generate_isa_predicate_for('Mouse::Meta::Class'          => 'is_a_metaclass');
+    _generate_isa_predicate_for('Mouse::Meta::Role'           => 'is_a_metarole');
 }
 
+
 # Moose::Util compatible utilities
 
 sub find_meta{
@@ -259,7 +265,7 @@ sub apply_all_roles {
         my $role_name = $roles[-1][0];
         load_class($role_name);
 
-        Mouse::Util::TypeConstraints::_is_a_metarole( get_metaclass_by_name($role_name) )
+        is_a_metarole( get_metaclass_by_name($role_name) )
             || $applicant->meta->throw_error("You can only consume roles, $role_name(".$role_name->meta.") is not a Mouse role");
     }
 
diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm
index 79d9040..404cb36 100644
--- a/lib/Mouse/Util/TypeConstraints.pm
+++ b/lib/Mouse/Util/TypeConstraints.pm
@@ -74,14 +74,6 @@ BEGIN {
     sub list_all_type_constraints         { keys %TYPE }
 }
 
-# is-a predicates
-BEGIN{
-    _generate_class_type_for('Mouse::Meta::TypeConstraint' => '_is_a_type_constraint');
-    _generate_class_type_for('Mouse::Meta::Class'          => '_is_a_metaclass');
-    _generate_class_type_for('Mouse::Meta::Role'           => '_is_a_metarole');
-}
-
-
 sub _create_type{
     my $mode = shift;
 
@@ -163,7 +155,7 @@ sub class_type {
     my $class = $options->{class} || $name;
     return _create_type 'subtype', $name => (
         as           => 'Object',
-        optimized_as => _generate_class_type_for($class),
+        optimized_as => Mouse::Util::_generate_isa_predicate_for($class),
 
         type => 'Class',
     );
@@ -217,7 +209,7 @@ sub _find_or_create_regular_type{
     my $meta = Mouse::Util::get_metaclass_by_name($spec)
         or return undef;
 
-    if(_is_a_metarole($meta)){
+    if(Mouse::Util::is_a_metarole($meta)){
         return role_type($spec);
     }
     else{
@@ -351,7 +343,7 @@ sub _parse_type{
 
 sub find_type_constraint {
     my($spec) = @_;
-    return $spec if _is_a_type_constraint($spec);
+    return $spec if Mouse::Util::is_a_type_constraint($spec);
 
     $spec =~ s/\s+//g;
     return $TYPE{$spec};
@@ -359,7 +351,7 @@ sub find_type_constraint {
 
 sub find_or_parse_type_constraint {
     my($spec) = @_;
-    return $spec if _is_a_type_constraint($spec);
+    return $spec if Mouse::Util::is_a_type_constraint($spec);
 
     $spec =~ s/\s+//g;
     return $TYPE{$spec} || do{
diff --git a/mouse.h b/mouse.h
index 9447037..98f7f31 100644
--- a/mouse.h
+++ b/mouse.h
@@ -176,6 +176,10 @@ int mouse_tc_GlobRef   (pTHX_ SV* const sv);
 int mouse_tc_FileHandle(pTHX_ SV* const sv);
 int mouse_tc_Object    (pTHX_ SV* const sv);
 
+const char* mouse_canonicalize_package_name(const char* name);
+
+XS(XS_isa_check);
+XS(XS_isa_check_for_universal);
 
 #endif /* !MOUSE_H */
 
diff --git a/xs-src/Mouse.xs b/xs-src/Mouse.xs
index c59c15c..59070e4 100644
--- a/xs-src/Mouse.xs
+++ b/xs-src/Mouse.xs
@@ -86,6 +86,46 @@ CODE:
 OUTPUT:
     RETVAL
 
+void
+_generate_isa_predicate_for(SV* klass, const char* predicate_name = NULL)
+PPCODE:
+{
+    STRLEN klass_len;
+    const char* klass_pv;
+    HV* stash;
+    CV* xsub;
+
+    if(!SvOK(klass)){
+        croak("You must define a class name for generate_for");
+    }
+    klass_pv = SvPV_const(klass, klass_len);
+    klass_pv = mouse_canonicalize_package_name(klass_pv);
+
+    if(strNE(klass_pv, "UNIVERSAL")){
+        static MGVTBL mouse_util_type_constraints_vtbl; /* not used, only for identity */
+
+        xsub = newXS(predicate_name, XS_isa_check, __FILE__);
+
+        stash = gv_stashpvn(klass_pv, klass_len, GV_ADD);
+
+        CvXSUBANY(xsub).any_ptr = sv_magicext(
+            (SV*)xsub,
+            (SV*)stash, /* mg_obj */
+            PERL_MAGIC_ext,
+            &mouse_util_type_constraints_vtbl,
+            klass_pv,   /* mg_ptr */
+            klass_len   /* mg_len */
+        );
+    }
+    else{
+        xsub = newXS(predicate_name, XS_isa_check_for_universal, __FILE__);
+    }
+
+    if(predicate_name == NULL){ /* anonymous predicate */
+        XPUSHs( newRV_noinc((SV*)xsub) );
+    }
+}
+
 
 MODULE = Mouse  PACKAGE = Mouse::Meta::Module
 
diff --git a/xs-src/mouse_type_constraint.xs b/xs-src/mouse_type_constraint.xs
index 938a6d4..09e910e 100644
--- a/xs-src/mouse_type_constraint.xs
+++ b/xs-src/mouse_type_constraint.xs
@@ -277,8 +277,8 @@ START_MY_CXT
 
 static MGVTBL mouse_util_type_constraints_vtbl;
 
-static const char*
-canonicalize_package_name(const char* name){
+const char*
+mouse_canonicalize_package_name(const char* name){
 
     /* "::Foo" -> "Foo" */
     if(name[0] == ':' && name[1] == ':'){
@@ -301,7 +301,7 @@ lookup_isa(pTHX_ HV* const instance_stash, const char* const klass_pv){
 
     while(svp != end){
         assert(SvPVX(*svp));
-        if(strEQ(klass_pv, canonicalize_package_name(SvPVX(*svp)))){
+        if(strEQ(klass_pv, mouse_canonicalize_package_name(SvPVX(*svp)))){
             return TRUE;
         }
         svp++;
@@ -349,7 +349,7 @@ instance_isa(pTHX_ SV* const instance, const MAGIC* const mg){
     }
 }
 
-XS(XS_isa_check); /* -W */
+
 XS(XS_isa_check){
     dVAR;
     dXSARGS;
@@ -373,7 +373,7 @@ XS(XS_isa_check){
     XSRETURN(1);
 }
 
-XS(XS_isa_check_for_universal); /* -W */
+
 XS(XS_isa_check_for_universal){
     dVAR;
     dXSARGS;
@@ -426,44 +426,6 @@ CODE:
 #endif /* !USE_ITHREADS */
 
 void
-_generate_class_type_for(SV* klass, const char* predicate_name = NULL)
-PPCODE:
-{
-    STRLEN klass_len;
-    const char* klass_pv;
-    HV* stash;
-    CV* xsub;
-
-    if(!SvOK(klass)){
-        croak("You must define a class name for generate_for");
-    }
-    klass_pv = SvPV_const(klass, klass_len);
-    klass_pv = canonicalize_package_name(klass_pv);
-
-    if(strNE(klass_pv, "UNIVERSAL")){
-        xsub = newXS(predicate_name, XS_isa_check, __FILE__);
-
-        stash = gv_stashpvn(klass_pv, klass_len, GV_ADD);
-
-        CvXSUBANY(xsub).any_ptr = sv_magicext(
-            (SV*)xsub,
-            (SV*)stash, /* mg_obj */
-            PERL_MAGIC_ext,
-            &mouse_util_type_constraints_vtbl,
-            klass_pv,   /* mg_ptr */
-            klass_len   /* mg_len */
-        );
-    }
-    else{
-        xsub = newXS(predicate_name, XS_isa_check_for_universal, __FILE__);
-    }
-
-    if(predicate_name == NULL){ /* anonymous predicate */
-        XPUSHs( newRV_noinc((SV*)xsub) );
-    }
-}
-
-void
 Item(SV* sv = &PL_sv_undef)
 ALIAS:
     Any        = MOUSE_TC_ANY