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     Foo->meta->get_meta_instance->Moose::XS::new_new_object("Foo::new");
 171 }
 172
 173
 174 my $ref = [ ];
 175
 176 my $foo = Foo->new( x => "ICKS", y => "WHY", z => "ZEE", ref => $ref );
 177
 178 is( $foo->x, "ICKS", "accessor as reader" );
 179 is( $foo->y, "WHY", "reader" );
 180 is( $foo->z, "ZEE", "reader" );
 181 is( $foo->ref, $ref, "accessor for ref" );
 182 is( $foo->b, "builded!", "lazy builder" );
 183
 184 lives_ok { $foo->x("YASE") } "accessor";
 185
 186 is( $foo->x, "YASE", "attr value set by accessor" );
 187
 188 dies_ok { $foo->y("blah") } "reader dies when used as writer";
 189
 190 is( $foo->y, "WHY", "reader" );
 191
 192 dies_ok { $foo->z("blah") } "reader dies when used as writer";
 193
 194 is( $foo->z, "ZEE", "reader" );
 195
 196 lives_ok { $foo->set_z("new") } "writer";
 197
 198 is( $foo->z, "new", "attr set by writer" );
 199
 200 ok( $foo->has_x, "predicate" );
 201
 202 ok( !Foo->new->has_x, "predicate on new obj is false" );
 203
 204 is( $foo->ref, $ref, "ref attr" );
 205
 206 undef $ref;
 207 is( $foo->ref(), undef, "weak ref detstroyed" );
 208
 209 $ref = { };
 210
 211 $foo->ref($ref);
 212 is( $foo->ref, $ref, "attr set" );
 213
 214 undef $ref;
 215 is( $foo->ref(), undef, "weak ref destroyed" );
 216
 217 is( $trigger, undef, "trigger not yet called" );
 218 is( $foo->t, undef, "no value in t" );
 219 is( $trigger, undef, "trigger not yet called" );
 220 $foo->t("laaa");
 221 is( $trigger, "got: laaa", "trigger called" );
 222
 223 ok( !eval { $foo->a("not a ref"); 1 }, "ArrayRef" );
 224 ok( !eval { $foo->a(3); 1 }, "ArrayRef" );
 225 ok( !eval { $foo->a({}); 1 }, "ArrayRef" );
 226 ok( !eval { $foo->a(undef); 1 }, "ArrayRef" );
 227 ok( !eval { $foo->i(1.3); 1 }, "Int" );
 228 ok( !eval { $foo->i("1.3"); 1 }, "Int" );
 229 ok( !eval { $foo->i("foo"); 1 }, "Int" );
 230 ok( !eval { $foo->i(undef); 1 }, "Int" );
 231 ok( !eval { $foo->i(\undef); 1 }, "Int" );
 232 ok( !eval { $foo->s(undef); 1 }, "Str" );
 233 ok( !eval { $foo->s([]); 1 }, "Str" );
 234 ok( !eval { $foo->o({}); 1 }, "Object" );
 235 ok( !eval { $foo->o(undef); 1 }, "Object" );
 236 ok( !eval { $foo->o(42); 1 }, "Object" );
 237 ok( !eval { $foo->o("hi ho"); 1 }, "Object" );
 238 ok( !eval { $foo->o(" ho"); 1 }, "Object" );
 239 ok( !eval { $foo->f(bless {}, "Bar"); 1 }, "Class (Foo)" );
 240 ok( !eval { $foo->f(undef); 1 }, "Class (Foo)" );
 241 ok( !eval { $foo->f("foo"); 1 }, "Class (Foo)" );
 242 ok( !eval { $foo->f(3); 1 }, "Class (Foo)" );
 243 ok( !eval { $foo->f({}); 1 }, "Class (Foo)" );
 244 ok( !eval { $foo->f("Foo"); 1 }, "Class (Foo)" );
 245 ok( !eval { $foo->c("Horse"); 1 }, "ClassName" );
 246 ok( !eval { $foo->c(3); 1 }, "ClassName" );
 247 ok( !eval { $foo->c(undef); 1 }, "ClassName" );
 248 ok( !eval { $foo->c("feck"); 1 }, "ClassName" );
 249 ok( !eval { $foo->c({}); 1 }, "ClassName" );
 250 ok( !eval { $foo->tc(undef); 1 }, "custom type" );
 251 ok( !eval { $foo->tc(""); 1 }, "custom type" );
 252 ok( !eval { $foo->tc("foo"); 1 }, "custom type" );
 253 ok( !eval { $foo->tc(3); 1 }, "custom type" );
 254 ok( !eval { $foo->tc([]); 1 }, "custom type" );
 255
 256 ok( eval { $foo->a([]); 1 }, "ArrayRef" );
 257 ok( eval { $foo->i(3); 1 }, "Int" );
 258 ok( eval { $foo->i("3"); 1 }, "Int" );
 259 ok( eval { $foo->i("-3"); 1 }, "Int" );
 260 ok( eval { $foo->i("  -3  "); 1 }, "Int" );
 261 ok( eval { $foo->s("foo"); 1 }, "Str" );
 262 ok( eval { $foo->s(""); 1 }, "Str" );
 263 ok( eval { $foo->s(4); 1 }, "Str" );
 264 ok( eval { $foo->o(bless {}, "Bar"); 1 }, "Object" );
 265
 266 ok( eval { $foo->f(Foo->new); 1 }, "Class (Foo)" );
 267 ok( eval { $foo->f(Gorch->new); 1 }, "Class (Foo), real subclass");
 268 ok( eval { $foo->f(Quxx->new); 1 }, "Class (Foo), fake subclass");
 269 ok( eval { $foo->c("Foo"); 1 }, "ClassName" );
 270 ok( eval { $foo->tc("hello"); 1 }, "custom type" );
 271
 272
 273
 274 $foo->meta->invalidate_meta_instance();
 275 isa_ok( $foo->f, 'Foo' );
 276 $foo->meta->invalidate_meta_instance();
 277 isa_ok( $foo->f, 'Foo' );
 278