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         Role
  48         ClassName
  49     );
  50
  51     # aliases
  52     $checks{Bool} = $checks{Item} = $checks{Any};
  53     $checks{Value} = $checks{Str};
  54
  55     sub tc_params {
  56         my $tc = shift;
  57
  58         return ( undef, 0, undef ) unless $tc; # tc_none
  59
  60         if (
  61             # sleazy check for core types that haven't been parametrized
  62             #(ref $tc eq 'Moose::Meta::TypeConstraint' or ref $tc eq 'Moose::Meta::TypeConstraint::Parameterizable')
  63             #    and
  64             exists $checks{$tc->name}
  65         ) {
  66             # builtin moose type #
  67             return ( $tc, 1, $checks{$tc->name} ); # tc_type
  68         } elsif ( $tc->isa("Moose::Meta::TypeConstraint::Class") ) {
  69             return ( $tc, 2, $tc->class ); # tc_stash
  70         } else {
  71             # FIXME enum is its own tc_kind
  72             return ( $tc, 3, $tc->_compiled_type_constraint ); # tc_cv
  73         }
  74     }
  75
  76     sub meta_instance_to_attr_descs {
  77         my $mi = shift;
  78
  79         return (
  80             $mi->associated_metaclass->name,
  81             [ map {[
  82                 $_,
  83                 [$_->slots],
  84
  85                 $_->is_weak_ref,
  86                 $_->should_coerce,
  87                 $_->is_lazy,
  88
  89                 tc_params($_->type_constraint),
  90                 $_->trigger,
  91                 $_->initializer,
  92
  93                 $_->has_default,
  94                 $_->default,
  95                 $_->builder,
  96
  97                 $_->init_arg,
  98             ]} $mi->get_all_attributes ]
  99         );
 100     }
 101 }
 102
 103 ok( defined &Moose::XS::new_reader, "new_reader" );
 104 ok( defined &Moose::XS::new_writer, "new_writer" );
 105 ok( defined &Moose::XS::new_accessor, "new_accessor" );
 106 ok( defined &Moose::XS::new_predicate, "new_predicate" );
 107
 108 {
 109     package Foo;
 110     use Moose;
 111
 112     use Moose::Util::TypeConstraints;
 113
 114     subtype( 'FiveChars',
 115         as "Str",
 116         where { length == 5 },
 117     );
 118
 119     has x => ( is => "rw", predicate => "has_x" );
 120     has y => ( is => "ro" );
 121     has z => ( reader => "z", writer => "set_z" );
 122     has ref => ( is => "rw", weak_ref => 1 );
 123     has i => ( isa => "Int", is => "rw" );
 124     has s => ( isa => "Str", is => "rw" );
 125     has a => ( isa => "ArrayRef", is => "rw" );
 126     has o => ( isa => "Object", is => "rw" );
 127     has f => ( isa => "Foo", is => "rw" );
 128     has c => ( isa => "ClassName", is => "rw" );
 129     has b => ( is => "ro", lazy_build => 1 ); # fixme type constraint checking
 130     has tc => ( is => "rw", isa => "FiveChars" );
 131
 132     sub _build_b { "builded!" }
 133
 134     # FIXME Regexp, ScalarRef, parametrized, filehandle
 135
 136     package Gorch;
 137     use Moose;
 138
 139     extends qw(Foo);
 140
 141     package Quxx;
 142     use Moose;
 143
 144     sub isa {
 145         return $_[1] eq 'Foo';
 146     }
 147 }
 148
 149 {
 150     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);
 151     $x->Moose::XS::new_accessor("Foo::x");
 152     $x->Moose::XS::new_predicate("Foo::has_x");
 153     $y->Moose::XS::new_reader("Foo::y");
 154     $z->Moose::XS::new_reader("Foo::z");
 155     $z->Moose::XS::new_writer("Foo::set_z");
 156     $ref->Moose::XS::new_accessor("Foo::ref");
 157     $a->Moose::XS::new_accessor("Foo::a");
 158     $s->Moose::XS::new_accessor("Foo::s");
 159     $i->Moose::XS::new_accessor("Foo::i");
 160     $o->Moose::XS::new_accessor("Foo::o");
 161     $f->Moose::XS::new_accessor("Foo::f");
 162     $c->Moose::XS::new_accessor("Foo::c");
 163     $b->Moose::XS::new_accessor("Foo::b");
 164 }
 165
 166
 167 my $ref = [ ];
 168
 169 my $foo = Foo->new( x => "ICKS", y => "WHY", z => "ZEE", ref => $ref );
 170
 171 is( $foo->x, "ICKS", "accessor as reader" );
 172 is( $foo->y, "WHY", "reader" );
 173 is( $foo->z, "ZEE", "reader" );
 174 is( $foo->ref, $ref, "accessor for ref" );
 175 is( $foo->b, "builded!", "lazy builder" );
 176
 177 lives_ok { $foo->x("YASE") } "accessor";
 178
 179 is( $foo->x, "YASE", "attr value set by accessor" );
 180
 181 dies_ok { $foo->y("blah") } "reader dies when used as writer";
 182
 183 is( $foo->y, "WHY", "reader" );
 184
 185 dies_ok { $foo->z("blah") } "reader dies when used as writer";
 186
 187 is( $foo->z, "ZEE", "reader" );
 188
 189 lives_ok { $foo->set_z("new") } "writer";
 190
 191 is( $foo->z, "new", "attr set by writer" );
 192
 193 ok( $foo->has_x, "predicate" );
 194
 195 ok( !Foo->new->has_x, "predicate on new obj is false" );
 196
 197 is( $foo->ref, $ref, "ref attr" );
 198
 199 undef $ref;
 200 is( $foo->ref(), undef, "weak ref detstroyed" );
 201
 202 $ref = { };
 203
 204 $foo->ref($ref);
 205 is( $foo->ref, $ref, "attr set" );
 206
 207 undef $ref;
 208 is( $foo->ref(), undef, "weak ref destroyed" );
 209
 210 ok( !eval { $foo->a("not a ref"); 1 }, "ArrayRef" );
 211 ok( !eval { $foo->a(3); 1 }, "ArrayRef" );
 212 ok( !eval { $foo->a({}); 1 }, "ArrayRef" );
 213 ok( !eval { $foo->a(undef); 1 }, "ArrayRef" );
 214 ok( !eval { $foo->i(1.3); 1 }, "Int" );
 215 ok( !eval { $foo->i("1.3"); 1 }, "Int" );
 216 ok( !eval { $foo->i("foo"); 1 }, "Int" );
 217 ok( !eval { $foo->i(undef); 1 }, "Int" );
 218 ok( !eval { $foo->s(undef); 1 }, "Str" );
 219 ok( !eval { $foo->s([]); 1 }, "Str" );
 220 ok( !eval { $foo->o({}); 1 }, "Object" );
 221 ok( !eval { $foo->o(undef); 1 }, "Object" );
 222 ok( !eval { $foo->o(42); 1 }, "Object" );
 223 ok( !eval { $foo->o("hi ho"); 1 }, "Object" );
 224 ok( !eval { $foo->o(" ho"); 1 }, "Object" );
 225 ok( !eval { $foo->f(bless {}, "Bar"); 1 }, "Class (Foo)" );
 226 ok( !eval { $foo->f(undef); 1 }, "Class (Foo)" );
 227 ok( !eval { $foo->f("foo"); 1 }, "Class (Foo)" );
 228 ok( !eval { $foo->f(3); 1 }, "Class (Foo)" );
 229 ok( !eval { $foo->f({}); 1 }, "Class (Foo)" );
 230 ok( !eval { $foo->f("Foo"); 1 }, "Class (Foo)" );
 231 ok( !eval { $foo->c("Horse"); 1 }, "ClassName" );
 232 ok( !eval { $foo->c(3); 1 }, "ClassName" );
 233 ok( !eval { $foo->c(undef); 1 }, "ClassName" );
 234 ok( !eval { $foo->c("feck"); 1 }, "ClassName" );
 235 ok( !eval { $foo->c({}); 1 }, "ClassName" );
 236 ok( !eval { $foo->tc(undef); 1 }, "custom type" );
 237 ok( !eval { $foo->tc(""); 1 }, "custom type" );
 238 ok( !eval { $foo->tc("foo"); 1 }, "custom type" );
 239 ok( !eval { $foo->tc(3); 1 }, "custom type" );
 240 ok( !eval { $foo->tc([]); 1 }, "custom type" );
 241
 242 ok( eval { $foo->a([]); 1 }, "ArrayRef" );
 243 ok( eval { $foo->i(3); 1 }, "Int" );
 244 ok( eval { $foo->i("3"); 1 }, "Int" );
 245 ok( eval { $foo->i("-3"); 1 }, "Int" );
 246 ok( eval { $foo->i("  -3  "); 1 }, "Int" );
 247 ok( eval { $foo->s("foo"); 1 }, "Str" );
 248 ok( eval { $foo->s(""); 1 }, "Str" );
 249 ok( eval { $foo->s(4); 1 }, "Str" );
 250 ok( eval { $foo->o(bless {}, "Bar"); 1 }, "Object" );
 251 ok( eval { $foo->f(Foo->new); 1 }, "Class (Foo)" );
 252 ok( eval { $foo->f(Gorch->new); 1 }, "Class (Foo), real subclass");
 253 ok( eval { $foo->f(Quxx->new); 1 }, "Class (Foo), fake subclass");
 254 ok( eval { $foo->c("Foo"); 1 }, "ClassName" );
 255 ok( eval { $foo->tc("hello"); 1 }, "custom type" );
 256
 257
 258
 259 $foo->meta->invalidate_meta_instance();
 260 isa_ok( $foo->f, 'Foo' );
 261 $foo->meta->invalidate_meta_instance();
 262 isa_ok( $foo->f, 'Foo' );
 263