[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");
}


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");
1ea12c91	169	}
1ea12c91	170
1ea12c91	171
de2f2e97	172	my $ref = [ ];
	173
	174	my $foo = Foo->new( x => "ICKS", y => "WHY", z => "ZEE", ref => $ref );
1ea12c91	175
7d73c8a9	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" );
fe0194bf	180	is( $foo->b, "builded!", "lazy builder" );
1ea12c91	181
7d73c8a9	182	lives_ok { $foo->x("YASE") } "accessor";
1ea12c91	183
7d73c8a9	184	is( $foo->x, "YASE", "attr value set by accessor" );
1ea12c91	185
7d73c8a9	186	dies_ok { $foo->y("blah") } "reader dies when used as writer";
1ea12c91	187
7d73c8a9	188	is( $foo->y, "WHY", "reader" );
1ea12c91	189
7d73c8a9	190	dies_ok { $foo->z("blah") } "reader dies when used as writer";
1ea12c91	191
7d73c8a9	192	is( $foo->z, "ZEE", "reader" );
1ea12c91	193
7d73c8a9	194	lives_ok { $foo->set_z("new") } "writer";
1ea12c91	195
7d73c8a9	196	is( $foo->z, "new", "attr set by writer" );
1ea12c91	197
7d73c8a9	198	ok( $foo->has_x, "predicate" );
1ea12c91	199
7d73c8a9	200	ok( !Foo->new->has_x, "predicate on new obj is false" );
1ea12c91	201
7d73c8a9	202	is( $foo->ref, $ref, "ref attr" );
de2f2e97	203
7d73c8a9	204	undef $ref;
7d73c8a9	205	is( $foo->ref(), undef, "weak ref detstroyed" );
de2f2e97	206
	207	$ref = { };
	208
	209	$foo->ref($ref);
7d73c8a9	210	is( $foo->ref, $ref, "attr set" );
de2f2e97	211
de2f2e97	212	undef $ref;
7d73c8a9	213	is( $foo->ref(), undef, "weak ref destroyed" );
de2f2e97	214
d08b3299	215	is( $trigger, undef, "trigger not yet called" );
7bc5b9a9	216	is( $foo->t, undef, "no value in t" );
d08b3299	217	is( $trigger, undef, "trigger not yet called" );
	218	$foo->t("laaa");
	219	is( $trigger, "got: laaa", "trigger called" );
7bc5b9a9	220
7ce1a351	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" );
4d0ab1b9	229	ok( !eval { $foo->i(\undef); 1 }, "Int" );
7ce1a351	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" );
45922f54	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" );
7ce1a351	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" );
0be3b17f	258	ok( eval { $foo->i(" -3 "); 1 }, "Int" );
7ce1a351	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" );
45922f54	267	ok( eval { $foo->tc("hello"); 1 }, "custom type" );
7ce1a351	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' );
45922f54	275