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     my $i;
  30     my %checks = map { $_ => $i++ } qw(
  31         Any
  32         Undef
  33         Defined
  34         Str
  35         Num
  36         Int
  37         GlobRef
  38         ArrayRef
  39         HashRef
  40         CodeRef
  41         Ref
  42         ScalarRef
  43         FileHandle
  44         RegexpRef
  45         Object
  46         ClassName
  47     );
  48
  49     # aliases
  50     $checks{Bool} = $checks{Item} = $checks{Any};
  51     $checks{Value} = $checks{Str};
  52
  53     sub tc_params {
  54         my $tc = shift;
  55
  56         return ( undef, 0, undef ) unless $tc;
  57
  58         if ( ref $tc eq 'Moose::Meta::TypeConstraint' or ref $tc eq 'Moose::Meta::TypeConstraint::Parameterizable') {
  59             # builtin moose type #
  60             return ( $tc, 1, $checks{$tc->name} );
  61         } elsif ( $tc->isa("Moose::Meta::TypeConstraint::Class") ) {
  62             return ( $tc, 2, $tc->class );
  63         } else {
  64             warn ref $tc;
  65             return ( $tc, 3, $tc->_compiled_type_constraint );
  66         }
  67     }
  68
  69     sub meta_instance_to_attr_descs {
  70         my $mi = shift;
  71
  72         return (
  73             $mi->associated_metaclass->name,
  74             [ map {[
  75                 $_,
  76                 [$_->slots],
  77
  78                 $_->is_weak_ref,
  79                 $_->should_coerce,
  80                 $_->is_lazy,
  81
  82                 tc_params($_->type_constraint),
  83                 $_->trigger,
  84                 $_->initializer,
  85
  86                 $_->has_default,
  87                 $_->default,
  88                 $_->builder,
  89             ]} $mi->get_all_attributes ]
  90         );
  91     }
  92 }
  93
  94 ok( defined &Moose::XS::new_getter );
  95 ok( defined &Moose::XS::new_setter );
  96 ok( defined &Moose::XS::new_accessor );
  97 ok( defined &Moose::XS::new_predicate );
  98
  99 {
 100     package Foo;
 101     use Moose;
 102
 103     has x => ( is => "rw", predicate => "has_x" );
 104     has y => ( is => "ro" );
 105     has z => ( reader => "z", setter => "set_z" );
 106     has ref => ( is => "rw", weak_ref => 1 );
 107     has i => ( isa => "Int", is => "rw" );
 108     has s => ( isa => "Str", is => "rw" );
 109     has a => ( isa => "ArrayRef", is => "rw" );
 110     has o => ( isa => "Object", is => "rw" );
 111     has f => ( isa => "Foo", is => "rw" );
 112     has c => ( isa => "ClassName", is => "rw" );
 113
 114     # FIXME Regexp, ScalarRef, parametrized, filehandle
 115
 116     package Gorch;
 117     use Moose;
 118
 119     extends qw(Foo);
 120
 121     package Quxx;
 122     use Moose;
 123
 124     sub isa {
 125         return $_[1] eq 'Foo';
 126     }
 127 }
 128
 129 {
 130     my ( $x, $y, $z, $ref, $a, $s, $i, $o, $f, $c ) = map { Foo->meta->get_attribute($_) } qw(x y z ref a s i o f c);
 131     $x->Moose::XS::new_accessor("Foo::x");
 132     $x->Moose::XS::new_predicate("Foo::has_x");
 133     $y->Moose::XS::new_getter("Foo::y");
 134     $z->Moose::XS::new_getter("Foo::z");
 135     $z->Moose::XS::new_setter("Foo::set_z");
 136     $ref->Moose::XS::new_accessor("Foo::ref");
 137     $a->Moose::XS::new_accessor("Foo::a");
 138     $s->Moose::XS::new_accessor("Foo::s");
 139     $i->Moose::XS::new_accessor("Foo::i");
 140     $o->Moose::XS::new_accessor("Foo::o");
 141     $f->Moose::XS::new_accessor("Foo::f");
 142     $c->Moose::XS::new_accessor("Foo::c");
 143 }
 144
 145
 146 my $ref = [ ];
 147
 148 my $foo = Foo->new( x => "ICKS", y => "WHY", z => "ZEE", ref => $ref );
 149
 150 is( $foo->x, "ICKS" );
 151 is( $foo->y, "WHY" );
 152 is( $foo->z, "ZEE" );
 153 is( $foo->ref, $ref, );
 154
 155 lives_ok { $foo->x("YASE") };
 156
 157 is( $foo->x, "YASE" );
 158
 159 dies_ok { $foo->y("blah") };
 160
 161 is( $foo->y, "WHY" );
 162
 163 dies_ok { $foo->z("blah") };
 164
 165 is( $foo->z, "ZEE" );
 166
 167 lives_ok { $foo->set_z("new") };
 168
 169 is( $foo->z, "new" );
 170
 171 ok( $foo->has_x );
 172
 173 ok( !Foo->new->has_x );
 174
 175 undef $ref;
 176
 177 is( $foo->ref(), undef );
 178
 179 $ref = { };
 180
 181 $foo->ref($ref);
 182
 183 is( $foo->ref, $ref, );
 184
 185 undef $ref;
 186
 187 is( $foo->ref(), undef );
 188
 189 ok( !eval { $foo->a("not a ref"); 1 }, "ArrayRef" );
 190 ok( !eval { $foo->a(3); 1 }, "ArrayRef" );
 191 ok( !eval { $foo->a({}); 1 }, "ArrayRef" );
 192 ok( !eval { $foo->a(undef); 1 }, "ArrayRef" );
 193 ok( !eval { $foo->i(1.3); 1 }, "Int" );
 194 ok( !eval { $foo->i("1.3"); 1 }, "Int" );
 195 ok( !eval { $foo->i("foo"); 1 }, "Int" );
 196 ok( !eval { $foo->i(undef); 1 }, "Int" );
 197 ok( !eval { $foo->s(undef); 1 }, "Str" );
 198 ok( !eval { $foo->s([]); 1 }, "Str" );
 199 ok( !eval { $foo->o({}); 1 }, "Object" );
 200 ok( !eval { $foo->o(undef); 1 }, "Object" );
 201 ok( !eval { $foo->o(42); 1 }, "Object" );
 202 ok( !eval { $foo->o("hi ho"); 1 }, "Object" );
 203 ok( !eval { $foo->o(" ho"); 1 }, "Object" );
 204 ok( !eval { $foo->f(bless {}, "Bar"); 1 }, "Class (Foo)" );
 205 ok( !eval { $foo->f(undef); 1 }, "Class (Foo)" );
 206 ok( !eval { $foo->f("foo"); 1 }, "Class (Foo)" );
 207 ok( !eval { $foo->f(3); 1 }, "Class (Foo)" );
 208 ok( !eval { $foo->f({}); 1 }, "Class (Foo)" );
 209 ok( !eval { $foo->f("Foo"); 1 }, "Class (Foo)" );
 210 ok( !eval { $foo->c("Horse"); 1 }, "ClassName" );
 211 ok( !eval { $foo->c(3); 1 }, "ClassName" );
 212 ok( !eval { $foo->c(undef); 1 }, "ClassName" );
 213 ok( !eval { $foo->c("feck"); 1 }, "ClassName" );
 214 ok( !eval { $foo->c({}); 1 }, "ClassName" );
 215
 216 ok( eval { $foo->a([]); 1 }, "ArrayRef" );
 217 ok( eval { $foo->i(3); 1 }, "Int" );
 218 ok( eval { $foo->i("3"); 1 }, "Int" );
 219 ok( eval { $foo->i("-3"); 1 }, "Int" );
 220 ok( eval { $foo->i("  -3  "); 1 }, "Int" );
 221 ok( eval { $foo->s("foo"); 1 }, "Str" );
 222 ok( eval { $foo->s(""); 1 }, "Str" );
 223 ok( eval { $foo->s(4); 1 }, "Str" );
 224 ok( eval { $foo->o(bless {}, "Bar"); 1 }, "Object" );
 225 ok( eval { $foo->f(Foo->new); 1 }, "Class (Foo)" );
 226 ok( eval { $foo->f(Gorch->new); 1 }, "Class (Foo), real subclass");
 227 ok( eval { $foo->f(Quxx->new); 1 }, "Class (Foo), fake subclass");
 228 ok( eval { $foo->c("Foo"); 1 }, "ClassName" );
 229
 230
 231
 232 $foo->meta->invalidate_meta_instance();
 233 isa_ok( $foo->f, 'Foo' );
 234 $foo->meta->invalidate_meta_instance();
 235 isa_ok( $foo->f, 'Foo' );