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