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
 117 {
 118     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);
 119     $x->Moose::XS::new_accessor("Foo::x");
 120     $x->Moose::XS::new_predicate("Foo::has_x");
 121     $y->Moose::XS::new_getter("Foo::y");
 122     $z->Moose::XS::new_getter("Foo::z");
 123     $z->Moose::XS::new_setter("Foo::set_z");
 124     $ref->Moose::XS::new_accessor("Foo::ref");
 125     $a->Moose::XS::new_accessor("Foo::a");
 126     $s->Moose::XS::new_accessor("Foo::s");
 127     $i->Moose::XS::new_accessor("Foo::i");
 128     $o->Moose::XS::new_accessor("Foo::o");
 129     $f->Moose::XS::new_accessor("Foo::f");
 130     $c->Moose::XS::new_accessor("Foo::c");
 131 }
 132
 133
 134 my $ref = [ ];
 135
 136 my $foo = Foo->new( x => "ICKS", y => "WHY", z => "ZEE", ref => $ref );
 137
 138 is( $foo->x, "ICKS" );
 139 is( $foo->y, "WHY" );
 140 is( $foo->z, "ZEE" );
 141 is( $foo->ref, $ref, );
 142
 143 lives_ok { $foo->x("YASE") };
 144
 145 is( $foo->x, "YASE" );
 146
 147 dies_ok { $foo->y("blah") };
 148
 149 is( $foo->y, "WHY" );
 150
 151 dies_ok { $foo->z("blah") };
 152
 153 is( $foo->z, "ZEE" );
 154
 155 lives_ok { $foo->set_z("new") };
 156
 157 is( $foo->z, "new" );
 158
 159 ok( $foo->has_x );
 160
 161 ok( !Foo->new->has_x );
 162
 163 undef $ref;
 164
 165 is( $foo->ref(), undef );
 166
 167 $ref = { };
 168
 169 $foo->ref($ref);
 170
 171 is( $foo->ref, $ref, );
 172
 173 undef $ref;
 174
 175 is( $foo->ref(), undef );
 176
 177 ok( !eval { $foo->a("not a ref"); 1 } );
 178 ok( !eval { $foo->i(1.3); 1 } );
 179 ok( !eval { $foo->s(undef); 1 } );
 180 ok( !eval { $foo->o({}); 1 } );
 181 ok( !eval { $foo->f(bless {}, "Bar"); 1 } );
 182 ok( !eval { $foo->c("Horse"); 1 } );
 183
 184 ok( eval { $foo->a([]); 1 } );
 185 ok( eval { $foo->i(3); 1 } );
 186 ok( eval { $foo->s("foo"); 1 } );
 187 ok( eval { $foo->o(bless {}, "Bar"); 1 } );
 188 ok( eval { $foo->f(Foo->new); 1 } );
 189 ok( eval { $foo->c("Foo"); 1 } );
 190
 191 use Data::Dumper;
 192 warn Dumper($foo);