[gitmo/Moose.git] / t / 700_xs / 001_basic.t

#!/usr/bin/perl

use strict;
use warnings;

use Test::More;
use Test::Exception;

BEGIN {
    plan skip_all => "no XSLoader" unless eval { require XSLoader };

    plan skip_all => $@ unless eval {
        require Moose;
        Moose->XSLoader::load($Moose::VERSION);
        1;
    };

    plan 'no_plan';
}

{
    package Moose::XS;

    sub attr_to_meta_instance {
        my $attr = shift;
        return $attr->associated_class->get_meta_instance;
    }

    # FIXME this needs to be in a header that's written by a perl script
    my $i;
    my %checks = map { $_ => $i++ } qw(
        Any
        Undef
        Defined
        Str
        Num
        Int
        GlobRef
        ArrayRef
        HashRef
        CodeRef
        Ref
        ScalarRef
        FileHandle
        RegexpRef
        Object
        Role
        ClassName
    );

    # aliases
    $checks{Bool} = $checks{Item} = $checks{Any};
    $checks{Value} = $checks{Str};

    sub tc_params {
        my $tc = shift;

        return ( undef, 0, undef ) unless $tc; # tc_none

        if (
            # sleazy check for core types that haven't been parametrized
            #(ref $tc eq 'Moose::Meta::TypeConstraint' or ref $tc eq 'Moose::Meta::TypeConstraint::Parameterizable')
            #    and
            exists $checks{$tc->name}
        ) {
            # builtin moose type # 
            return ( $tc, 1, $checks{$tc->name} ); # tc_type
        } elsif ( $tc->isa("Moose::Meta::TypeConstraint::Class") ) {
            return ( $tc, 2, $tc->class ); # tc_stash
        } else {
            # FIXME enum is its own tc_kind
            return ( $tc, 3, $tc->_compiled_type_constraint ); # tc_cv
        }
    }

    sub meta_instance_to_attr_descs {
        my $mi = shift;

        return (
            $mi->associated_metaclass->name,
            [ map {[
                $_,
                [$_->slots],

                $_->is_weak_ref,
                $_->should_coerce,
                $_->is_lazy,

                tc_params($_->type_constraint),
                $_->trigger,
                $_->initializer,

                $_->has_default,
                $_->default,
                $_->builder,

                $_->init_arg,
            ]} $mi->get_all_attributes ]
        );
    }
}

ok( defined &Moose::XS::new_reader, "new_reader" );
ok( defined &Moose::XS::new_writer, "new_writer" );
ok( defined &Moose::XS::new_accessor, "new_accessor" );
ok( defined &Moose::XS::new_predicate, "new_predicate" );

my $trigger;

{
    package Foo;
    use Moose;

    use Moose::Util::TypeConstraints;

    subtype( 'FiveChars',
        as "Str",
        where { length == 5 },
    );

    has x => ( is => "rw", predicate => "has_x" );
    has y => ( is => "ro" );
    has z => ( reader => "z", writer => "set_z" );
    has ref => ( is => "rw", weak_ref => 1 );
    has i => ( isa => "Int", is => "rw" );
    has s => ( isa => "Str", is => "rw" );
    has a => ( isa => "ArrayRef", is => "rw" );
    has o => ( isa => "Object", is => "rw" );
    has f => ( isa => "Foo", is => "rw" );
    has c => ( isa => "ClassName", is => "rw" );
    has b => ( is => "ro", lazy_build => 1 ); # fixme type constraint checking
    has tc => ( is => "rw", isa => "FiveChars" );
    has t => ( is => "rw", trigger => sub { $trigger = "got: " . $_[1] } );

    sub _build_b { "builded!" }

    # FIXME Regexp, ScalarRef, parametrized, filehandle

    package Gorch;
    use Moose;

    extends qw(Foo);

    package Quxx;
    use Moose;

    sub isa {
        return $_[1] eq 'Foo';
    }
}

{
    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);
    $x->Moose::XS::new_accessor("Foo::x");
    $x->Moose::XS::new_predicate("Foo::has_x");
    $y->Moose::XS::new_reader("Foo::y");
    $z->Moose::XS::new_reader("Foo::z");
    $z->Moose::XS::new_writer("Foo::set_z");
    $ref->Moose::XS::new_accessor("Foo::ref");
    $a->Moose::XS::new_accessor("Foo::a");
    $s->Moose::XS::new_accessor("Foo::s");
    $i->Moose::XS::new_accessor("Foo::i");
    $o->Moose::XS::new_accessor("Foo::o");
    $f->Moose::XS::new_accessor("Foo::f");
    $c->Moose::XS::new_accessor("Foo::c");
    $b->Moose::XS::new_accessor("Foo::b");
    $tc->Moose::XS::new_accessor("Foo::tc");
    $t->Moose::XS::new_accessor("Foo::t");

    Foo->meta->get_meta_instance->Moose::XS::new_new_object("Foo::new");
}


my $ref = [ ];

my $foo = Foo->new( x => "ICKS", y => "WHY", z => "ZEE", ref => $ref );

is( $foo->x, "ICKS", "accessor as reader" );
is( $foo->y, "WHY", "reader" );
is( $foo->z, "ZEE", "reader" );
is( $foo->ref, $ref, "accessor for ref" );
is( $foo->b, "builded!", "lazy builder" );

lives_ok { $foo->x("YASE") } "accessor";

is( $foo->x, "YASE", "attr value set by accessor" );

dies_ok { $foo->y("blah") } "reader dies when used as writer";

is( $foo->y, "WHY", "reader" );

dies_ok { $foo->z("blah") } "reader dies when used as writer";

is( $foo->z, "ZEE", "reader" );

lives_ok { $foo->set_z("new") } "writer";

is( $foo->z, "new", "attr set by writer" );

ok( $foo->has_x, "predicate" );

ok( !Foo->new->has_x, "predicate on new obj is false" );

is( $foo->ref, $ref, "ref attr" );

undef $ref;
is( $foo->ref(), undef, "weak ref detstroyed" );

$ref = { };

$foo->ref($ref);
is( $foo->ref, $ref, "attr set" );

undef $ref;
is( $foo->ref(), undef, "weak ref destroyed" );

is( $trigger, undef, "trigger not yet called" );
is( $foo->t, undef, "no value in t" );
is( $trigger, undef, "trigger not yet called" );
$foo->t("laaa");
is( $trigger, "got: laaa", "trigger called" );

ok( !eval { $foo->a("not a ref"); 1 }, "ArrayRef" );
ok( !eval { $foo->a(3); 1 }, "ArrayRef" );
ok( !eval { $foo->a({}); 1 }, "ArrayRef" );
ok( !eval { $foo->a(undef); 1 }, "ArrayRef" );
ok( !eval { $foo->i(1.3); 1 }, "Int" );
ok( !eval { $foo->i("1.3"); 1 }, "Int" );
ok( !eval { $foo->i("foo"); 1 }, "Int" );
ok( !eval { $foo->i(undef); 1 }, "Int" );
ok( !eval { $foo->i(\undef); 1 }, "Int" );
ok( !eval { $foo->s(undef); 1 }, "Str" );
ok( !eval { $foo->s([]); 1 }, "Str" );
ok( !eval { $foo->o({}); 1 }, "Object" );
ok( !eval { $foo->o(undef); 1 }, "Object" );
ok( !eval { $foo->o(42); 1 }, "Object" );
ok( !eval { $foo->o("hi ho"); 1 }, "Object" );
ok( !eval { $foo->o(" ho"); 1 }, "Object" );
ok( !eval { $foo->f(bless {}, "Bar"); 1 }, "Class (Foo)" );
ok( !eval { $foo->f(undef); 1 }, "Class (Foo)" );
ok( !eval { $foo->f("foo"); 1 }, "Class (Foo)" );
ok( !eval { $foo->f(3); 1 }, "Class (Foo)" );
ok( !eval { $foo->f({}); 1 }, "Class (Foo)" );
ok( !eval { $foo->f("Foo"); 1 }, "Class (Foo)" );
ok( !eval { $foo->c("Horse"); 1 }, "ClassName" );
ok( !eval { $foo->c(3); 1 }, "ClassName" );
ok( !eval { $foo->c(undef); 1 }, "ClassName" );
ok( !eval { $foo->c("feck"); 1 }, "ClassName" );
ok( !eval { $foo->c({}); 1 }, "ClassName" );
ok( !eval { $foo->tc(undef); 1 }, "custom type" );
ok( !eval { $foo->tc(""); 1 }, "custom type" );
ok( !eval { $foo->tc("foo"); 1 }, "custom type" );
ok( !eval { $foo->tc(3); 1 }, "custom type" );
ok( !eval { $foo->tc([]); 1 }, "custom type" );

ok( eval { $foo->a([]); 1 }, "ArrayRef" );
ok( eval { $foo->i(3); 1 }, "Int" );
ok( eval { $foo->i("3"); 1 }, "Int" );
ok( eval { $foo->i("-3"); 1 }, "Int" );
ok( eval { $foo->i("  -3  "); 1 }, "Int" );
ok( eval { $foo->s("foo"); 1 }, "Str" );
ok( eval { $foo->s(""); 1 }, "Str" );
ok( eval { $foo->s(4); 1 }, "Str" );
ok( eval { $foo->o(bless {}, "Bar"); 1 }, "Object" );

ok( eval { $foo->f(Foo->new); 1 }, "Class (Foo)" );
ok( eval { $foo->f(Gorch->new); 1 }, "Class (Foo), real subclass");
ok( eval { $foo->f(Quxx->new); 1 }, "Class (Foo), fake subclass");
ok( eval { $foo->c("Foo"); 1 }, "ClassName" );
ok( eval { $foo->tc("hello"); 1 }, "custom type" );


$foo->meta->invalidate_meta_instance();
isa_ok( $foo->f, 'Foo' );
$foo->meta->invalidate_meta_instance();
isa_ok( $foo->f, 'Foo' );
Commit	Line	Data
1ea12c91	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
f253044f	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
fe0194bf	29	# FIXME this needs to be in a header that's written by a perl script
160f9ca7	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
2cd9d2ba	47	Role
160f9ca7	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
2cd9d2ba	58	return ( undef, 0, undef ) unless $tc; # tc_none
160f9ca7	59
45922f54	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	) {
2cd9d2ba	66	# builtin moose type #
2cd9d2ba	67	return ( $tc, 1, $checks{$tc->name} ); # tc_type
160f9ca7	68	} elsif ( $tc->isa("Moose::Meta::TypeConstraint::Class") ) {
2cd9d2ba	69	return ( $tc, 2, $tc->class ); # tc_stash
160f9ca7	70	} else {
2cd9d2ba	71	# FIXME enum is its own tc_kind
2cd9d2ba	72	return ( $tc, 3, $tc->_compiled_type_constraint ); # tc_cv
160f9ca7	73	}
	74	}
	75
f253044f	76	sub meta_instance_to_attr_descs {
	77	my $mi = shift;
	78
	79	return (
	80	$mi->associated_metaclass->name,
160f9ca7	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,
f55aeea0	96
f55aeea0	97	$_->init_arg,
160f9ca7	98	]} $mi->get_all_attributes ]
f253044f	99	);
	100	}
	101	}
	102
24a7a8c5	103	ok( defined &Moose::XS::new_reader, "new_reader" );
24a7a8c5	104	ok( defined &Moose::XS::new_writer, "new_writer" );
7d73c8a9	105	ok( defined &Moose::XS::new_accessor, "new_accessor" );
7d73c8a9	106	ok( defined &Moose::XS::new_predicate, "new_predicate" );
1ea12c91	107
d08b3299	108	my $trigger;
d08b3299	109
1ea12c91	110	{
	111	package Foo;
	112	use Moose;
	113
45922f54	114	use Moose::Util::TypeConstraints;
	115
	116	subtype( 'FiveChars',
	117	as "Str",
	118	where { length == 5 },
	119	);
	120
1ea12c91	121	has x => ( is => "rw", predicate => "has_x" );
1ea12c91	122	has y => ( is => "ro" );
24a7a8c5	123	has z => ( reader => "z", writer => "set_z" );
de2f2e97	124	has ref => ( is => "rw", weak_ref => 1 );
4c6fbfb1	125	has i => ( isa => "Int", is => "rw" );
	126	has s => ( isa => "Str", is => "rw" );
	127	has a => ( isa => "ArrayRef", is => "rw" );
a812574b	128	has o => ( isa => "Object", is => "rw" );
	129	has f => ( isa => "Foo", is => "rw" );
	130	has c => ( isa => "ClassName", is => "rw" );
fe0194bf	131	has b => ( is => "ro", lazy_build => 1 ); # fixme type constraint checking
45922f54	132	has tc => ( is => "rw", isa => "FiveChars" );
d08b3299	133	has t => ( is => "rw", trigger => sub { $trigger = "got: " . $_[1] } );
fe0194bf	134
fe0194bf	135	sub _build_b { "builded!" }
160f9ca7	136
a812574b	137	# FIXME Regexp, ScalarRef, parametrized, filehandle
7ce1a351	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	}
de2f2e97	150	}
	151
	152	{
7bc5b9a9	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);
de2f2e97	154	$x->Moose::XS::new_accessor("Foo::x");
de2f2e97	155	$x->Moose::XS::new_predicate("Foo::has_x");
24a7a8c5	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");
de2f2e97	159	$ref->Moose::XS::new_accessor("Foo::ref");
4c6fbfb1	160	$a->Moose::XS::new_accessor("Foo::a");
	161	$s->Moose::XS::new_accessor("Foo::s");
	162	$i->Moose::XS::new_accessor("Foo::i");
a812574b	163	$o->Moose::XS::new_accessor("Foo::o");
	164	$f->Moose::XS::new_accessor("Foo::f");
	165	$c->Moose::XS::new_accessor("Foo::c");
fe0194bf	166	$b->Moose::XS::new_accessor("Foo::b");
7bc5b9a9	167	$tc->Moose::XS::new_accessor("Foo::tc");
7bc5b9a9	168	$t->Moose::XS::new_accessor("Foo::t");
b2dbd503	169
b2dbd503	170	Foo->meta->get_meta_instance->Moose::XS::new_new_object("Foo::new");
1ea12c91	171	}
1ea12c91	172
1ea12c91	173
de2f2e97	174	my $ref = [ ];
	175
	176	my $foo = Foo->new( x => "ICKS", y => "WHY", z => "ZEE", ref => $ref );
1ea12c91	177
7d73c8a9	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" );
fe0194bf	182	is( $foo->b, "builded!", "lazy builder" );
1ea12c91	183
7d73c8a9	184	lives_ok { $foo->x("YASE") } "accessor";
1ea12c91	185
7d73c8a9	186	is( $foo->x, "YASE", "attr value set by accessor" );
1ea12c91	187
7d73c8a9	188	dies_ok { $foo->y("blah") } "reader dies when used as writer";
1ea12c91	189
7d73c8a9	190	is( $foo->y, "WHY", "reader" );
1ea12c91	191
7d73c8a9	192	dies_ok { $foo->z("blah") } "reader dies when used as writer";
1ea12c91	193
7d73c8a9	194	is( $foo->z, "ZEE", "reader" );
1ea12c91	195
7d73c8a9	196	lives_ok { $foo->set_z("new") } "writer";
1ea12c91	197
7d73c8a9	198	is( $foo->z, "new", "attr set by writer" );
1ea12c91	199
7d73c8a9	200	ok( $foo->has_x, "predicate" );
1ea12c91	201
7d73c8a9	202	ok( !Foo->new->has_x, "predicate on new obj is false" );
1ea12c91	203
7d73c8a9	204	is( $foo->ref, $ref, "ref attr" );
de2f2e97	205
7d73c8a9	206	undef $ref;
7d73c8a9	207	is( $foo->ref(), undef, "weak ref detstroyed" );
de2f2e97	208
	209	$ref = { };
	210
	211	$foo->ref($ref);
7d73c8a9	212	is( $foo->ref, $ref, "attr set" );
de2f2e97	213
de2f2e97	214	undef $ref;
7d73c8a9	215	is( $foo->ref(), undef, "weak ref destroyed" );
de2f2e97	216
d08b3299	217	is( $trigger, undef, "trigger not yet called" );
7bc5b9a9	218	is( $foo->t, undef, "no value in t" );
d08b3299	219	is( $trigger, undef, "trigger not yet called" );
	220	$foo->t("laaa");
	221	is( $trigger, "got: laaa", "trigger called" );
7bc5b9a9	222
7ce1a351	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" );
4d0ab1b9	231	ok( !eval { $foo->i(\undef); 1 }, "Int" );
7ce1a351	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" );
45922f54	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" );
7ce1a351	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" );
0be3b17f	260	ok( eval { $foo->i(" -3 "); 1 }, "Int" );
7ce1a351	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" );
b2dbd503	265
7ce1a351	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" );
45922f54	270	ok( eval { $foo->tc("hello"); 1 }, "custom type" );
7ce1a351	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' );
45922f54	278