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
 111     # FIXME Regexp, Class, ClassName, Object, parametrized, filehandle
 112 }
 113
 114 {
 115     my ( $x, $y, $z, $ref, $a, $s, $i ) = map { Foo->meta->get_attribute($_) } qw(x y z ref a s i);
 116     $x->Moose::XS::new_accessor("Foo::x");
 117     $x->Moose::XS::new_predicate("Foo::has_x");
 118     $y->Moose::XS::new_getter("Foo::y");
 119     $z->Moose::XS::new_getter("Foo::z");
 120     $z->Moose::XS::new_setter("Foo::set_z");
 121     $ref->Moose::XS::new_accessor("Foo::ref");
 122     $a->Moose::XS::new_accessor("Foo::a");
 123     $s->Moose::XS::new_accessor("Foo::s");
 124     $i->Moose::XS::new_accessor("Foo::i");
 125 }
 126
 127
 128 my $ref = [ ];
 129
 130 my $foo = Foo->new( x => "ICKS", y => "WHY", z => "ZEE", ref => $ref );
 131
 132 is( $foo->x, "ICKS" );
 133 is( $foo->y, "WHY" );
 134 is( $foo->z, "ZEE" );
 135 is( $foo->ref, $ref, );
 136
 137 lives_ok { $foo->x("YASE") };
 138
 139 is( $foo->x, "YASE" );
 140
 141 dies_ok { $foo->y("blah") };
 142
 143 is( $foo->y, "WHY" );
 144
 145 dies_ok { $foo->z("blah") };
 146
 147 is( $foo->z, "ZEE" );
 148
 149 lives_ok { $foo->set_z("new") };
 150
 151 is( $foo->z, "new" );
 152
 153 ok( $foo->has_x );
 154
 155 ok( !Foo->new->has_x );
 156
 157 undef $ref;
 158
 159 is( $foo->ref(), undef );
 160
 161 $ref = { };
 162
 163 $foo->ref($ref);
 164
 165 is( $foo->ref, $ref, );
 166
 167 undef $ref;
 168
 169 is( $foo->ref(), undef );
 170
 171 ok( !eval { $foo->a("not a ref"); 1 } );
 172 ok( !eval { $foo->i(1.3); 1 } );
 173 ok( !eval { $foo->s(undef); 1 } );
 174
 175 ok( eval { $foo->a([]); 1 } );
 176 ok( eval { $foo->i(3); 1 } );
 177 ok( eval { $foo->s("foo"); 1 } );
 178
 179 use Data::Dumper;
 180 warn Dumper($foo);