From: Yuval Kogman <nothingmuch@woobling.org>
Date: Wed, 20 Aug 2008 09:52:20 +0000 (+0000)
Subject: CV type constraints
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=45922f54134aeaca67d9bc7b72a3191cb403ce88;p=gitmo%2FMoose.git

CV type constraints
---

diff --git a/Moose.xs b/Moose.xs
index b187946..5183a20 100644
--- a/Moose.xs
+++ b/Moose.xs
@@ -150,11 +150,12 @@ typedef struct {
  * 00000000 00000000 00000000 00000000
  *                             ^       trigger
  *                              ^      weak
- *                               ^     tc refcnt
+ *                               ^     tc.sv is refcounted
  *                                 ^^^ tc_kind
  *                                ^    coerce
  *                        ^^^          default_kind
  *                       ^             lazy
+ *                      ^              def.sv is refcounted
  *                 ^                   required
  * ^^^^^^^                             if 0 then nothing special (just hash)? FIXME TBD
  */
@@ -383,6 +384,28 @@ STATIC bool check_sv_type (TC type, SV *sv) {
     return 0;
 }
 
+STATIC bool check_sv_cv (pTHX_ SV *cv, SV *sv) {
+    bool ret;
+    dSP;
+
+    ENTER;
+    SAVETMPS;
+    PUSHMARK(SP);
+    XPUSHs(sv);
+    PUTBACK;
+
+    call_sv(cv, G_SCALAR);
+
+    SPAGAIN;
+    ret = SvTRUE(POPs);
+
+    PUTBACK;
+    FREETMPS;
+    LEAVE;
+
+    return ret;
+}
+
 STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *type_constraint, SV *sv) {
     switch (kind) {
         case tc_none:
@@ -398,6 +421,8 @@ STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *typ
             return tc_check.fptr(aTHX_ type_constraint, sv);
             break;
         case tc_cv:
+            return check_sv_cv(aTHX_ tc_check.sv, sv);
+            break;
         case tc_op:
             croak("todo");
             break;
diff --git a/benchmarks/caf_vs_moose.pl b/benchmarks/caf_vs_moose.pl
index 2634484..a2f2091 100644
--- a/benchmarks/caf_vs_moose.pl
+++ b/benchmarks/caf_vs_moose.pl
@@ -18,6 +18,8 @@
     use Moose;
     has foo => (is => 'rw');
     __PACKAGE__->meta->make_immutable(inline_constructor => 0);
+    __PACKAGE__->meta->get_attribute("foo")->Moose::XS::new_accessor(__PACKAGE__ . "::foo");
+
 }
 {
     package ClassAccessorFast;
@@ -35,8 +37,8 @@ my $moose_immut          = MooseImmutable->new;
 my $moose_immut_no_const = MooseImmutable::NoConstructor->new;
 my $caf                  = ClassAccessorFast->new;
 
-my $acc_rounds = 100_000;
-my $ins_rounds = 100_000;
+my $acc_rounds = -1;
+my $ins_rounds = -1;
 
 print "\nSETTING\n";
 cmpthese($acc_rounds, {
diff --git a/t/700_xs/001_basic.t b/t/700_xs/001_basic.t
index 04a4dea..1be2c15 100644
--- a/t/700_xs/001_basic.t
+++ b/t/700_xs/001_basic.t
@@ -56,13 +56,17 @@ BEGIN {
 
         return ( undef, 0, undef ) unless $tc;
 
-        if ( ref $tc eq 'Moose::Meta::TypeConstraint' or ref $tc eq 'Moose::Meta::TypeConstraint::Parameterizable') {
+        if (
+            # sleazy check for core types that haven't been parametrized
+            #(ref $tc eq 'Moose::Meta::TypeConstraint' or ref $tc eq 'Moose::Meta::TypeConstraint::Parameterizable')
+            #    and
+            exists $checks{$tc->name}
+        ) {
             # builtin moose type #
             return ( $tc, 1, $checks{$tc->name} );
         } elsif ( $tc->isa("Moose::Meta::TypeConstraint::Class") ) {
             return ( $tc, 2, $tc->class );
         } else {
-            warn ref $tc;
             return ( $tc, 3, $tc->_compiled_type_constraint );
         }
     }
@@ -101,6 +105,13 @@ ok( defined &Moose::XS::new_predicate, "new_predicate" );
     package Foo;
     use Moose;
 
+    use Moose::Util::TypeConstraints;
+
+    subtype( 'FiveChars',
+        as "Str",
+        where { length == 5 },
+    );
+
     has x => ( is => "rw", predicate => "has_x" );
     has y => ( is => "ro" );
     has z => ( reader => "z", setter => "set_z" );
@@ -112,6 +123,7 @@ ok( defined &Moose::XS::new_predicate, "new_predicate" );
     has f => ( isa => "Foo", is => "rw" );
     has c => ( isa => "ClassName", is => "rw" );
     has b => ( is => "ro", lazy_build => 1 ); # fixme type constraint checking
+    has tc => ( is => "rw", isa => "FiveChars" );
 
     sub _build_b { "builded!" }
 
@@ -217,6 +229,11 @@ ok( !eval { $foo->c(3); 1 }, "ClassName" );
 ok( !eval { $foo->c(undef); 1 }, "ClassName" );
 ok( !eval { $foo->c("feck"); 1 }, "ClassName" );
 ok( !eval { $foo->c({}); 1 }, "ClassName" );
+ok( !eval { $foo->tc(undef); 1 }, "custom type" );
+ok( !eval { $foo->tc(""); 1 }, "custom type" );
+ok( !eval { $foo->tc("foo"); 1 }, "custom type" );
+ok( !eval { $foo->tc(3); 1 }, "custom type" );
+ok( !eval { $foo->tc([]); 1 }, "custom type" );
 
 ok( eval { $foo->a([]); 1 }, "ArrayRef" );
 ok( eval { $foo->i(3); 1 }, "Int" );
@@ -231,6 +248,7 @@ ok( eval { $foo->f(Foo->new); 1 }, "Class (Foo)" );
 ok( eval { $foo->f(Gorch->new); 1 }, "Class (Foo), real subclass");
 ok( eval { $foo->f(Quxx->new); 1 }, "Class (Foo), fake subclass");
 ok( eval { $foo->c("Foo"); 1 }, "ClassName" );
+ok( eval { $foo->tc("hello"); 1 }, "custom type" );
 
 
 
@@ -238,3 +256,4 @@ $foo->meta->invalidate_meta_instance();
 isa_ok( $foo->f, 'Foo' );
 $foo->meta->invalidate_meta_instance();
 isa_ok( $foo->f, 'Foo' );
+