From: Shawn M Moore <sartak@gmail.com>
Date: Wed, 11 Jun 2008 11:04:39 +0000 (+0000)
Subject: Add the Point example from Moose's tests. Except for method and type constraint stuff...
X-Git-Tag: 0.04~17
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d56e83889aa9d9220fc5e85d0f1b8916e4d7d201;p=gitmo%2FMouse.git
Add the Point example from Moose's tests. Except for method and type constraint stuff, it all passes. cool.
---
diff --git a/t/000-recipes/001_point.t b/t/000-recipes/001_point.t
new file mode 100644
index 0000000..d78638a
--- /dev/null
+++ b/t/000-recipes/001_point.t
@@ -0,0 +1,200 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 58;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Mouse');
+}
+
+{
+ package Point;
+ use Mouse;
+
+ has 'x' => (isa => 'Int', is => 'ro');
+ has 'y' => (isa => 'Int', is => 'rw');
+
+ sub clear {
+ my $self = shift;
+ $self->{x} = 0;
+ $self->y(0);
+ }
+
+}{
+ package Point3D;
+ use Mouse;
+
+ extends 'Point';
+
+ has 'z' => (isa => 'Int');
+
+ after 'clear' => sub {
+ my $self = shift;
+ $self->{z} = 0;
+ };
+
+}
+
+my $point = Point->new(x => 1, y => 2);
+isa_ok($point, 'Point');
+isa_ok($point, 'Mouse::Object');
+
+is($point->x, 1, '... got the right value for x');
+is($point->y, 2, '... got the right value for y');
+
+$point->y(10);
+is($point->y, 10, '... got the right (changed) value for y');
+
+dies_ok {
+ $point->y('Foo');
+} '... cannot assign a non-Int to y';
+
+dies_ok {
+ $point->x(1000);
+} '... cannot assign to a read-only method';
+is($point->x, 1, '... got the right (un-changed) value for x');
+
+$point->clear();
+
+is($point->x, 0, '... got the right (cleared) value for x');
+is($point->y, 0, '... got the right (cleared) value for y');
+
+# check the type constraints on the constructor
+
+lives_ok {
+ Point->new(x => 0, y => 0);
+} '... can assign a 0 to x and y';
+
+dies_ok {
+ Point->new(x => 10, y => 'Foo');
+} '... cannot assign a non-Int to y';
+
+dies_ok {
+ Point->new(x => 'Foo', y => 10);
+} '... cannot assign a non-Int to x';
+
+# Point3D
+
+my $point3d = Point3D->new({ x => 10, y => 15, z => 3 });
+isa_ok($point3d, 'Point3D');
+isa_ok($point3d, 'Point');
+isa_ok($point3d, 'Mouse::Object');
+
+is($point3d->x, 10, '... got the right value for x');
+is($point3d->y, 15, '... got the right value for y');
+is($point3d->{'z'}, 3, '... got the right value for z');
+
+dies_ok {
+ $point3d->z;
+} '... there is no method for z';
+
+$point3d->clear();
+
+is($point3d->x, 0, '... got the right (cleared) value for x');
+is($point3d->y, 0, '... got the right (cleared) value for y');
+is($point3d->{'z'}, 0, '... got the right (cleared) value for z');
+
+dies_ok {
+ Point3D->new(x => 10, y => 'Foo', z => 3);
+} '... cannot assign a non-Int to y';
+
+dies_ok {
+ Point3D->new(x => 'Foo', y => 10, z => 3);
+} '... cannot assign a non-Int to x';
+
+dies_ok {
+ Point3D->new(x => 0, y => 10, z => 'Bar');
+} '... cannot assign a non-Int to z';
+
+# test some class introspection
+
+can_ok('Point', 'meta');
+isa_ok(Point->meta, 'Mouse::Meta::Class');
+
+can_ok('Point3D', 'meta');
+isa_ok(Point3D->meta, 'Mouse::Meta::Class');
+
+isnt(Point->meta, Point3D->meta, '... they are different metaclasses as well');
+
+# poke at Point
+
+is_deeply(
+ [ Point->meta->superclasses ],
+ [ 'Mouse::Object' ],
+ '... Point got the automagic base class');
+
+my @Point_methods = qw(meta new x y clear);
+my @Point_attrs = ('x', 'y');
+
+SKIP: {
+ skip "Mouse has no method introspection", 2 + @Point_methods;
+
+ is_deeply(
+ [ sort @Point_methods ],
+ [ sort Point->meta->get_method_list() ],
+ '... we match the method list for Point');
+
+ is_deeply(
+ [ sort @Point_attrs ],
+ [ sort Point->meta->get_attribute_list() ],
+ '... we match the attribute list for Point');
+
+ foreach my $method (@Point_methods) {
+ ok(Point->meta->has_method($method), '... Point has the method "' . $method . '"');
+ }
+}
+
+foreach my $attr_name (@Point_attrs ) {
+ ok(Point->meta->has_attribute($attr_name), '... Point has the attribute "' . $attr_name . '"');
+ my $attr = Point->meta->get_attribute($attr_name);
+ ok($attr->has_type_constraint, '... Attribute ' . $attr_name . ' has a type constraint');
+
+ SKIP: {
+ skip "Mouse type constraints are not objects", 2;
+ isa_ok($attr->type_constraint, 'Mouse::Meta::TypeConstraint');
+ is($attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint');
+ }
+}
+
+# poke at Point3D
+
+is_deeply(
+ [ Point3D->meta->superclasses ],
+ [ 'Point' ],
+ '... Point3D gets the parent given to it');
+
+my @Point3D_methods = qw(new meta clear);
+my @Point3D_attrs = ('z');
+
+SKIP: {
+ skip "Mouse has no method introspection", 2 + @Point3D_methods;
+
+ is_deeply(
+ [ sort @Point3D_methods ],
+ [ sort Point3D->meta->get_method_list() ],
+ '... we match the method list for Point3D');
+
+ is_deeply(
+ [ sort @Point3D_attrs ],
+ [ sort Point3D->meta->get_attribute_list() ],
+ '... we match the attribute list for Point3D');
+
+ foreach my $method (@Point3D_methods) {
+ ok(Point3D->meta->has_method($method), '... Point3D has the method "' . $method . '"');
+ }
+};
+
+foreach my $attr_name (@Point3D_attrs ) {
+ ok(Point3D->meta->has_attribute($attr_name), '... Point3D has the attribute "' . $attr_name . '"');
+ my $attr = Point3D->meta->get_attribute($attr_name);
+ ok($attr->has_type_constraint, '... Attribute ' . $attr_name . ' has a type constraint');
+ SKIP: {
+ skip "Mouse type constraints are not objects", 2;
+ isa_ok($attr->type_constraint, 'Mouse::Meta::TypeConstraint');
+ is($attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint');
+ };
+}
+