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 my $trigger;
 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 { $trigger = "got: " . $_[1] } );
 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( $trigger, undef, "trigger not yet called" );
 216 is( $foo->t, undef, "no value in t" );
 217 is( $trigger, undef, "trigger not yet called" );
 218 $foo->t("laaa");
 219 is( $trigger, "got: laaa", "trigger called" );
 220
 221 ok( !eval { $foo->a("not a ref"); 1 }, "ArrayRef" );
 222 ok( !eval { $foo->a(3); 1 }, "ArrayRef" );
 223 ok( !eval { $foo->a({}); 1 }, "ArrayRef" );
 224 ok( !eval { $foo->a(undef); 1 }, "ArrayRef" );
 225 ok( !eval { $foo->i(1.3); 1 }, "Int" );
 226 ok( !eval { $foo->i("1.3"); 1 }, "Int" );
 227 ok( !eval { $foo->i("foo"); 1 }, "Int" );
 228 ok( !eval { $foo->i(undef); 1 }, "Int" );
 229 ok( !eval { $foo->i(\undef); 1 }, "Int" );
 230 ok( !eval { $foo->s(undef); 1 }, "Str" );
 231 ok( !eval { $foo->s([]); 1 }, "Str" );
 232 ok( !eval { $foo->o({}); 1 }, "Object" );
 233 ok( !eval { $foo->o(undef); 1 }, "Object" );
 234 ok( !eval { $foo->o(42); 1 }, "Object" );
 235 ok( !eval { $foo->o("hi ho"); 1 }, "Object" );
 236 ok( !eval { $foo->o(" ho"); 1 }, "Object" );
 237 ok( !eval { $foo->f(bless {}, "Bar"); 1 }, "Class (Foo)" );
 238 ok( !eval { $foo->f(undef); 1 }, "Class (Foo)" );
 239 ok( !eval { $foo->f("foo"); 1 }, "Class (Foo)" );
 240 ok( !eval { $foo->f(3); 1 }, "Class (Foo)" );
 241 ok( !eval { $foo->f({}); 1 }, "Class (Foo)" );
 242 ok( !eval { $foo->f("Foo"); 1 }, "Class (Foo)" );
 243 ok( !eval { $foo->c("Horse"); 1 }, "ClassName" );
 244 ok( !eval { $foo->c(3); 1 }, "ClassName" );
 245 ok( !eval { $foo->c(undef); 1 }, "ClassName" );
 246 ok( !eval { $foo->c("feck"); 1 }, "ClassName" );
 247 ok( !eval { $foo->c({}); 1 }, "ClassName" );
 248 ok( !eval { $foo->tc(undef); 1 }, "custom type" );
 249 ok( !eval { $foo->tc(""); 1 }, "custom type" );
 250 ok( !eval { $foo->tc("foo"); 1 }, "custom type" );
 251 ok( !eval { $foo->tc(3); 1 }, "custom type" );
 252 ok( !eval { $foo->tc([]); 1 }, "custom type" );
 253
 254 ok( eval { $foo->a([]); 1 }, "ArrayRef" );
 255 ok( eval { $foo->i(3); 1 }, "Int" );
 256 ok( eval { $foo->i("3"); 1 }, "Int" );
 257 ok( eval { $foo->i("-3"); 1 }, "Int" );
 258 ok( eval { $foo->i("  -3  "); 1 }, "Int" );
 259 ok( eval { $foo->s("foo"); 1 }, "Str" );
 260 ok( eval { $foo->s(""); 1 }, "Str" );
 261 ok( eval { $foo->s(4); 1 }, "Str" );
 262 ok( eval { $foo->o(bless {}, "Bar"); 1 }, "Object" );
 263 ok( eval { $foo->f(Foo->new); 1 }, "Class (Foo)" );
 264 ok( eval { $foo->f(Gorch->new); 1 }, "Class (Foo), real subclass");
 265 ok( eval { $foo->f(Quxx->new); 1 }, "Class (Foo), fake subclass");
 266 ok( eval { $foo->c("Foo"); 1 }, "ClassName" );
 267 ok( eval { $foo->tc("hello"); 1 }, "custom type" );
 268
 269
 270
 271 $foo->meta->invalidate_meta_instance();
 272 isa_ok( $foo->f, 'Foo' );
 273 $foo->meta->invalidate_meta_instance();
 274 isa_ok( $foo->f, 'Foo' );
 275