t/700_xs/001_basic.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Exception;
   8
   9 BEGIN {
  10     plan skip_all => "no XSLoader" unless eval { require XSLoader };
  11
  12     plan skip_all => $@ unless eval {
  13         require Moose;
  14         Moose->XSLoader::load($Moose::VERSION);
  15         1;
  16     };
  17
  18     plan 'no_plan';
  19 }
  20
  21 {
  22     package Moose::XS;
  23
  24     sub attr_to_meta_instance {
  25         my $attr = shift;
  26         return $attr->associated_class->get_meta_instance;
  27     }
  28
  29     # FIXME this needs to be in a header that's written by a perl script
  30     my $i;
  31     my %checks = map { $_ => $i++ } qw(
  32         Any
  33         Undef
  34         Defined
  35         Str
  36         Num
  37         Int
  38         GlobRef
  39         ArrayRef
  40         HashRef
  41         CodeRef
  42         Ref
  43         ScalarRef
  44         FileHandle
  45         RegexpRef
  46         Object
  47         ClassName
  48     );
  49
  50     # aliases
  51     $checks{Bool} = $checks{Item} = $checks{Any};
  52     $checks{Value} = $checks{Str};
  53
  54     sub tc_params {
  55         my $tc = shift;
  56
  57         return ( undef, 0, undef ) unless $tc;
  58
  59         if ( ref $tc eq 'Moose::Meta::TypeConstraint' or ref $tc eq 'Moose::Meta::TypeConstraint::Parameterizable') {
  60             # builtin moose type #
  61             return ( $tc, 1, $checks{$tc->name} );
  62         } elsif ( $tc->isa("Moose::Meta::TypeConstraint::Class") ) {
  63             return ( $tc, 2, $tc->class );
  64         } else {
  65             warn ref $tc;
  66             return ( $tc, 3, $tc->_compiled_type_constraint );
  67         }
  68     }
  69
  70     sub meta_instance_to_attr_descs {
  71         my $mi = shift;
  72
  73         return (
  74             $mi->associated_metaclass->name,
  75             [ map {[
  76                 $_,
  77                 [$_->slots],
  78
  79                 $_->is_weak_ref,
  80                 $_->should_coerce,
  81                 $_->is_lazy,
  82
  83                 tc_params($_->type_constraint),
  84                 $_->trigger,
  85                 $_->initializer,
  86
  87                 $_->has_default,
  88                 $_->default,
  89                 $_->builder,
  90             ]} $mi->get_all_attributes ]
  91         );
  92     }
  93 }
  94
  95 ok( defined &Moose::XS::new_getter, "new_getter" );
  96 ok( defined &Moose::XS::new_setter, "new_setter" );
  97 ok( defined &Moose::XS::new_accessor, "new_accessor" );
  98 ok( defined &Moose::XS::new_predicate, "new_predicate" );
  99
 100 {
 101     package Foo;
 102     use Moose;
 103
 104     has x => ( is => "rw", predicate => "has_x" );
 105     has y => ( is => "ro" );
 106     has z => ( reader => "z", setter => "set_z" );
 107     has ref => ( is => "rw", weak_ref => 1 );
 108     has i => ( isa => "Int", is => "rw" );
 109     has s => ( isa => "Str", is => "rw" );
 110     has a => ( isa => "ArrayRef", is => "rw" );
 111     has o => ( isa => "Object", is => "rw" );
 112     has f => ( isa => "Foo", is => "rw" );
 113     has c => ( isa => "ClassName", is => "rw" );
 114     has b => ( is => "ro", lazy_build => 1 ); # fixme type constraint checking
 115
 116     sub _build_b { "builded!" }
 117
 118     # FIXME Regexp, ScalarRef, parametrized, filehandle
 119
 120     package Gorch;
 121     use Moose;
 122
 123     extends qw(Foo);
 124
 125     package Quxx;
 126     use Moose;
 127
 128     sub isa {
 129         return $_[1] eq 'Foo';
 130     }
 131 }
 132
 133 {
 134     my ( $x, $y, $z, $ref, $a, $s, $i, $o, $f, $c, $b ) = map { Foo->meta->get_attribute($_) } qw(x y z ref a s i o f c b);
 135     $x->Moose::XS::new_accessor("Foo::x");
 136     $x->Moose::XS::new_predicate("Foo::has_x");
 137     $y->Moose::XS::new_getter("Foo::y");
 138     $z->Moose::XS::new_getter("Foo::z");
 139     $z->Moose::XS::new_setter("Foo::set_z");
 140     $ref->Moose::XS::new_accessor("Foo::ref");
 141     $a->Moose::XS::new_accessor("Foo::a");
 142     $s->Moose::XS::new_accessor("Foo::s");
 143     $i->Moose::XS::new_accessor("Foo::i");
 144     $o->Moose::XS::new_accessor("Foo::o");
 145     $f->Moose::XS::new_accessor("Foo::f");
 146     $c->Moose::XS::new_accessor("Foo::c");
 147     $b->Moose::XS::new_accessor("Foo::b");
 148 }
 149
 150
 151 my $ref = [ ];
 152
 153 my $foo = Foo->new( x => "ICKS", y => "WHY", z => "ZEE", ref => $ref );
 154
 155 is( $foo->x, "ICKS", "accessor as reader" );
 156 is( $foo->y, "WHY", "reader" );
 157 is( $foo->z, "ZEE", "reader" );
 158 is( $foo->ref, $ref, "accessor for ref" );
 159 is( $foo->b, "builded!", "lazy builder" );
 160
 161 lives_ok { $foo->x("YASE") } "accessor";
 162
 163 is( $foo->x, "YASE", "attr value set by accessor" );
 164
 165 dies_ok { $foo->y("blah") } "reader dies when used as writer";
 166
 167 is( $foo->y, "WHY", "reader" );
 168
 169 dies_ok { $foo->z("blah") } "reader dies when used as writer";
 170
 171 is( $foo->z, "ZEE", "reader" );
 172
 173 lives_ok { $foo->set_z("new") } "writer";
 174
 175 is( $foo->z, "new", "attr set by writer" );
 176
 177 ok( $foo->has_x, "predicate" );
 178
 179 ok( !Foo->new->has_x, "predicate on new obj is false" );
 180
 181 is( $foo->ref, $ref, "ref attr" );
 182
 183 undef $ref;
 184 is( $foo->ref(), undef, "weak ref detstroyed" );
 185
 186 $ref = { };
 187
 188 $foo->ref($ref);
 189 is( $foo->ref, $ref, "attr set" );
 190
 191 undef $ref;
 192 is( $foo->ref(), undef, "weak ref destroyed" );
 193
 194 ok( !eval { $foo->a("not a ref"); 1 }, "ArrayRef" );
 195 ok( !eval { $foo->a(3); 1 }, "ArrayRef" );
 196 ok( !eval { $foo->a({}); 1 }, "ArrayRef" );
 197 ok( !eval { $foo->a(undef); 1 }, "ArrayRef" );
 198 ok( !eval { $foo->i(1.3); 1 }, "Int" );
 199 ok( !eval { $foo->i("1.3"); 1 }, "Int" );
 200 ok( !eval { $foo->i("foo"); 1 }, "Int" );
 201 ok( !eval { $foo->i(undef); 1 }, "Int" );
 202 ok( !eval { $foo->s(undef); 1 }, "Str" );
 203 ok( !eval { $foo->s([]); 1 }, "Str" );
 204 ok( !eval { $foo->o({}); 1 }, "Object" );
 205 ok( !eval { $foo->o(undef); 1 }, "Object" );
 206 ok( !eval { $foo->o(42); 1 }, "Object" );
 207 ok( !eval { $foo->o("hi ho"); 1 }, "Object" );
 208 ok( !eval { $foo->o(" ho"); 1 }, "Object" );
 209 ok( !eval { $foo->f(bless {}, "Bar"); 1 }, "Class (Foo)" );
 210 ok( !eval { $foo->f(undef); 1 }, "Class (Foo)" );
 211 ok( !eval { $foo->f("foo"); 1 }, "Class (Foo)" );
 212 ok( !eval { $foo->f(3); 1 }, "Class (Foo)" );
 213 ok( !eval { $foo->f({}); 1 }, "Class (Foo)" );
 214 ok( !eval { $foo->f("Foo"); 1 }, "Class (Foo)" );
 215 ok( !eval { $foo->c("Horse"); 1 }, "ClassName" );
 216 ok( !eval { $foo->c(3); 1 }, "ClassName" );
 217 ok( !eval { $foo->c(undef); 1 }, "ClassName" );
 218 ok( !eval { $foo->c("feck"); 1 }, "ClassName" );
 219 ok( !eval { $foo->c({}); 1 }, "ClassName" );
 220
 221 ok( eval { $foo->a([]); 1 }, "ArrayRef" );
 222 ok( eval { $foo->i(3); 1 }, "Int" );
 223 ok( eval { $foo->i("3"); 1 }, "Int" );
 224 ok( eval { $foo->i("-3"); 1 }, "Int" );
 225 ok( eval { $foo->i("  -3  "); 1 }, "Int" );
 226 ok( eval { $foo->s("foo"); 1 }, "Str" );
 227 ok( eval { $foo->s(""); 1 }, "Str" );
 228 ok( eval { $foo->s(4); 1 }, "Str" );
 229 ok( eval { $foo->o(bless {}, "Bar"); 1 }, "Object" );
 230 ok( eval { $foo->f(Foo->new); 1 }, "Class (Foo)" );
 231 ok( eval { $foo->f(Gorch->new); 1 }, "Class (Foo), real subclass");
 232 ok( eval { $foo->f(Quxx->new); 1 }, "Class (Foo), fake subclass");
 233 ok( eval { $foo->c("Foo"); 1 }, "ClassName" );
 234
 235
 236
 237 $foo->meta->invalidate_meta_instance();
 238 isa_ok( $foo->f, 'Foo' );
 239 $foo->meta->invalidate_meta_instance();
 240 isa_ok( $foo->f, 'Foo' );