r27467 - in /branches/upstream/libcoat-perl/current: ./ lib/ lib/Coat/ lib/Coat/Meta/ t/ t/lib/ t/moose_tests/
ansgar-guest at users.alioth.debian.org
ansgar-guest at users.alioth.debian.org
Sun Nov 30 13:11:41 UTC 2008
Author: ansgar-guest
Date: Sun Nov 30 13:11:38 2008
New Revision: 27467
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=27467
Log:
[svn-upgrade] Integrating new upstream version, libcoat-perl (0.334)
Added:
branches/upstream/libcoat-perl/current/t/012_type_constraints.t
branches/upstream/libcoat-perl/current/t/037_attributes_and_constraints_overides.t
branches/upstream/libcoat-perl/current/t/lib/
branches/upstream/libcoat-perl/current/t/lib/Foo.pm
branches/upstream/libcoat-perl/current/t/lib/MyCoatA.pm
branches/upstream/libcoat-perl/current/t/lib/MyCoatB.pm
branches/upstream/libcoat-perl/current/t/lib/MyMooseObject.pm
branches/upstream/libcoat-perl/current/t/moose_tests/
branches/upstream/libcoat-perl/current/t/moose_tests/001_subtype_quote_bug.t
branches/upstream/libcoat-perl/current/t/moose_tests/002_subtype_conflict_bug.t
branches/upstream/libcoat-perl/current/t/moose_tests/004_subclass_use_base_bug.t
branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_002_require_superclasses.t
branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_011_moose_respects_type_constraints.t
branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_015_buildargs.t
branches/upstream/libcoat-perl/current/t/moose_tests/020_attributes_006_attribute_required.t
Modified:
branches/upstream/libcoat-perl/current/CHANGES
branches/upstream/libcoat-perl/current/Makefile.PL
branches/upstream/libcoat-perl/current/lib/Coat.pm
branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm
branches/upstream/libcoat-perl/current/lib/Coat/Meta/TypeConstraint.pm
branches/upstream/libcoat-perl/current/lib/Coat/Object.pm
Modified: branches/upstream/libcoat-perl/current/CHANGES
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/CHANGES?rev=27467&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/CHANGES (original)
+++ branches/upstream/libcoat-perl/current/CHANGES Sun Nov 30 13:11:38 2008
@@ -1,3 +1,10 @@
+2008-11-25 -- release 0.334
+ * feature: support for BUILDARGS in Coat objects
+ * new tests from Moose in t/moose_tests/
+ * change: error message when loading a class (moose)
+ * fix performance gap when coercing thanks to silent_validate
+ (thanks to Rached Ben Mustapha for finding this out).
+
2008-09-26 -- release 0.333
* bugfix: fixes multiple coercions on the same subtype.
* bugfix: fixes cascading inheritance
Modified: branches/upstream/libcoat-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/Makefile.PL?rev=27467&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/Makefile.PL (original)
+++ branches/upstream/libcoat-perl/current/Makefile.PL Sun Nov 30 13:11:38 2008
@@ -3,9 +3,10 @@
WriteMakefile(
NAME => 'Coat',
VERSION_FROM => 'lib/Coat.pm',
- ABSTRACT => 'Light meta class for writing fast OO Perl code',
+ ABSTRACT => 'Light meta class for writing Moose compatible code',
PREREQ_PM => {
'Scalar::Util' => 0,
+ 'Test::Exception' => 0,
},
- test => {TESTS => join( ' ', glob( 't/*.t' ))},
+ test => {TESTS => join( ' ', glob( 't/*.t' )).' '.join(' ', glob('t/moose_tests/*.t'))},
);
Modified: branches/upstream/libcoat-perl/current/lib/Coat.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/lib/Coat.pm?rev=27467&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat.pm Sun Nov 30 13:11:38 2008
@@ -14,7 +14,7 @@
use Coat::Object;
use Coat::Types;
-$VERSION = '0.332';
+$VERSION = '0.334';
$AUTHORITY = 'cpan:SUKRIA';
# our exported keywords for class description
@@ -51,8 +51,7 @@
}
my $attr_meta = Coat::Meta->attribute( $class, $attr_name, \%options);
-
- my $accessor_code = _accessor_for_attr($attr_name, $attr_meta);
+ my $accessor_code = _accessor_for_attr($attr_name);
# now bind the subref to the appropriate symbol in the caller class
_bind_coderef_to_symbol( $accessor_code, $accessor );
@@ -206,14 +205,15 @@
# TODO : Should find a way to build optimized non-mutable accessors here
-# It's ugly to check the meta of the attribute whenver using the setter or the
+# It's ugly to get and check the meta of the attribute whenver using the setter or the
# getter.
-sub _accessor_for_attr($$) {
- my ($name, $meta) = @_;
+sub _accessor_for_attr {
+ my ($name) = @_;
return sub {
my ( $self, $value ) = @_;
-
+ my $meta = Coat::Meta->has( ref($self), $name );
+
# setter
if ( @_ > 1 ) {
confess "Cannot set a read-only attribute ($name)"
@@ -327,7 +327,7 @@
# class is unknown, never been loaded, let's try to import it
unless ( Coat::Meta->exists($mother) ) {
eval "use $mother";
- confess "Failed to load class '$mother' : $@" if $@;
+ confess "Could not load class ($mother) because : $@" if $@;
$mother->import;
}
Coat::Meta->extends( $class, $mother );
Modified: branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm?rev=27467&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm Sun Nov 30 13:11:38 2008
@@ -12,7 +12,7 @@
sub classes { $CLASSES }
# returns all attributes for the given class
-sub attributes { $CLASSES->{ $_[1] } }
+sub attributes { $CLASSES->{ $_[1] } || {} }
# returns the meta-data for the given class
sub class
@@ -164,7 +164,10 @@
return grep /^$parent$/, @{ Coat::Meta->parents( $class ) };
}
-sub family { $CLASSES->{'@!family'}{ $_[1] } }
+sub family {
+ my ($self, $class) = @_;
+ $CLASSES->{'@!family'}{ $class } ||= Coat::Meta->parents( $class );
+}
sub add_to_family {
my ($self, $class, $parent) = @_;
Modified: branches/upstream/libcoat-perl/current/lib/Coat/Meta/TypeConstraint.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/lib/Coat/Meta/TypeConstraint.pm?rev=27467&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat/Meta/TypeConstraint.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat/Meta/TypeConstraint.pm Sun Nov 30 13:11:38 2008
@@ -35,33 +35,36 @@
foreach my $source (keys %{ $self->coercion_map }) {
# if current value passes the current source check, coercing
my $tc = Coat::Types::find_type_constraint($source);
- my $ok;
- eval {
- $ok = $tc->validate($value)
- };
- if ($ok && !$@) {
- return $self->{coercion_map}{$source}->($value);
- }
+ return $self->{coercion_map}{$source}->($value)
+ if $tc->silent_validate($value);
}
return $value;
}
# check the value through the type constraints
-sub validate {
+sub silent_validate {
my ($self, $value) = @_;
local $_ = $value;
- my $msg = (defined $self->message)
- ? $self->message->()
- : "Value '" .(defined $value ? $value : 'undef')
- ."' does not validate type constraint '".$self->name."'";
+ # validates the parent's type-constraint if exists
+ if (defined $self->parent) {
+ Coat::Types::find_type_constraint( $self->parent )->silent_validate( $value )
+ or return 0;
+ }
+ return $self->validation->($value);
+}
- # validates the parent's type-constraint if exists
- (defined $self->parent) &&
- Coat::Types::find_type_constraint( $self->parent )->validate( $value );
-
- # pass the value through the check
- $self->validation->($value) or confess $msg;
+sub validate {
+ my ($self, $value) = @_;
+ unless ($self->silent_validate($value)) {
+ local $_ = $value;
+ my $msg = (defined $self->message)
+ ? $self->message->()
+ : "Value '" .(defined $value ? $value : 'undef')
+ ."' does not validate type constraint '".$self->name."'";
+ confess $msg;
+ }
+ return 1;
}
sub has_coercion {
Modified: branches/upstream/libcoat-perl/current/lib/Coat/Object.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/lib/Coat/Object.pm?rev=27467&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat/Object.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat/Object.pm Sun Nov 30 13:11:38 2008
@@ -10,14 +10,59 @@
# The default constructor
sub new {
- my ( $class, %args ) = @_;
-
+ my ( $class, @args ) = @_;
+
+ # create the newborn
my $self = {};
bless $self, $class;
- $self->init(%args);
-
+ # parse and prepare the args
+ my $args = $self->build_args(@args);
+
+ # init the object
+ $self->init($args);
+
+ # done
return $self;
+}
+
+sub build_args {
+ my ($self, @args) = @_;
+ my $class = ref($self);
+
+ my $args;
+ $args = {@args} if @args % 2 == 0;
+
+ # if BUILDARGS exists, look or it and run it
+ if ($self->can('BUILDARGS')) {
+ foreach my $pkg (reverse Coat::Meta->linearized_isa($class)) {
+ my $buildargs_sub;
+ {
+ no strict 'refs';
+ $buildargs_sub = *{$pkg."::BUILDARGS"};
+ }
+ if (defined &$buildargs_sub) {
+ $args = $self->$buildargs_sub(@args);
+ last;
+ }
+ }
+ }
+
+ # now check everything is OK with the args
+ unless (defined $args) {
+ if (@args == 1) {
+ if (ref($args[0]) ne 'HASHREF') {
+ confess "Single argument must be an HASHREF";
+ }
+ else {
+ $args = $args[0];
+ }
+ }
+ else {
+ confess "Invalid arguments";
+ }
+ }
+ return $args;
}
# returns the meta-class description of that instance
@@ -29,7 +74,7 @@
# init an instance : put default values and set values
# given at instanciation time
sub init {
- my ( $self, %attrs ) = @_;
+ my ( $self, $attrs ) = @_;
my $class = ref $self;
my $class_attr = Coat::Meta->all_attributes( $class );
@@ -60,53 +105,46 @@
confess "Attribute ($attr) is required"
if ($meta->{'required'} &&
$meta->{'is'} eq 'ro' &&
- (! defined $meta->{'default'}) &&
- (! exists $attrs{$attr}));
+ (! exists $meta->{'default'}) &&
+ (! exists $attrs->{$attr}));
}
# setting values given at instanciation time
- foreach my $attr ( keys %attrs ) {
+ foreach my $attr ( keys %$attrs ) {
my $is = $class_attr->{$attr}{'is'};
$class_attr->{$attr}{'is'} = 'rw';
- $self->$attr( $attrs{$attr} );
+ $self->$attr( $attrs->{$attr} );
$class_attr->{$attr}{'is'} = $is;
}
- $self->BUILDALL(\%attrs);
+ $self->BUILDALL($attrs);
return $self;
}
-# All the BUILD/DEMOLISH stuff here is taken from Moose and
-# uses some Coat::Meta.
-
-sub BUILDALL {
- return unless $_[0]->can('BUILD');
- my ($self, $params) = @_;
-
- my $build_sub;
- foreach my $pkg (reverse Coat::Meta->linearized_isa(ref($self))) {
+# This is done to let us implement easily the BUILDARGS/BUILD/DEMOLISH stuff
+# It must behave the same: with inheritance in mind.
+# Thanks again to the Moose team for the idea of *ALL() methods.
+
+sub _run_for_all {
+ my ($method_name, $self, $params) = @_;
+ my $class = ref($self);
+
+ return unless $self->can($method_name);
+
+ my $sub;
+ foreach my $pkg (reverse Coat::Meta->linearized_isa($class)) {
{
no strict 'refs';
- $build_sub = *{$pkg."::BUILD"};
- }
- $self->$build_sub( %$params ) if defined &$build_sub;
- }
-}
-
-sub DEMOLISHALL {
- return unless $_[0]->can('DEMOLISH');
- my ($self) = @_;
-
- my $demolish_sub;
- foreach my $pkg (reverse Coat::Meta->linearized_isa(ref($self))) {
- {
- no strict 'refs';
- $demolish_sub = *{$pkg."::DEMOLISH"};
- }
- $self->$demolish_sub() if defined &$demolish_sub;
- }
-}
+ $sub = *{$pkg."::${method_name}"};
+ }
+ $self->$sub( %$params ) if defined &$sub;
+ }
+}
+
+sub BUILDALL { _run_for_all('BUILD', @_) }
+
+sub DEMOLISHALL { _run_for_all('DEMOLISH', @_) }
sub DESTROY { goto &DEMOLISHALL }
Added: branches/upstream/libcoat-perl/current/t/012_type_constraints.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/012_type_constraints.t?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/012_type_constraints.t (added)
+++ branches/upstream/libcoat-perl/current/t/012_type_constraints.t Sun Nov 30 13:11:38 2008
@@ -1,0 +1,56 @@
+use strict;
+use warnings;
+use Test::More 'no_plan';
+
+{
+ package Foo;
+ use Coat;
+
+ has 'x' => ( isa => 'Int');
+ has 's' => ( isa => 'Str', required => 1);
+
+ has 'a' => ( isa => 'ArrayRef');
+ has 'h' => ( isa => 'HashRef');
+ has 'c' => ( isa => 'CodeRef');
+
+ has 'subobject' => ( isa => 'Bar' );
+
+ package Bar;
+ use Coat;
+
+ has 'x';
+
+ package Baz;
+ use Coat;
+}
+
+my $foo = new Foo;
+
+# valid calls
+ok( $foo->x(43), 'foo->x allows integers' );
+ok( $foo->s(43), 'foo->s allows integers' );
+ok( $foo->s("message Perl Moose Coat"), 'foo->s allows strings' );
+ok( $foo->a( [1, 4, 6]), "foo->a allows array references" );
+ok( $foo->c(sub { 3 }), "foo->a allows code references" );
+ok( $foo->subobject(new Bar), 'foo->subobject allows class reference');
+
+# invalid calls
+eval { $foo->x("string") };
+ok( $@, "foo->x does not allow strings");
+
+eval { $foo->s(undef) };
+ok( $@, 'undef values are not allowed for required String' );
+
+eval { $foo->a(43) };
+ok( $@, 'ArrayRef does not allow non ref values' );
+
+eval { $foo->a({a => 1, b => 2}) };
+ok( $@, 'ArrayRef does not allow Hash references' );
+
+eval { $foo->c({a => 1, b => 2}) };
+ok( $@, 'CodeRef does not allow Hash references' );
+
+eval { $foo->subobject(new Baz) };
+ok( $@, 'foo->subobject does not allow Baz' );
+
+
Added: branches/upstream/libcoat-perl/current/t/037_attributes_and_constraints_overides.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/037_attributes_and_constraints_overides.t?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/037_attributes_and_constraints_overides.t (added)
+++ branches/upstream/libcoat-perl/current/t/037_attributes_and_constraints_overides.t Sun Nov 30 13:11:38 2008
@@ -1,0 +1,83 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+use Test::Exception;
+use Scalar::Util 'blessed';
+
+use Coat::Types;
+
+subtype 'Positive'
+ => as 'Num'
+ => where { $_ > 0 };
+
+{
+ package Parent;
+ use Coat;
+
+ has name => (
+ is => 'rw',
+ isa => 'Str',
+ );
+
+ has lazy_classname => (
+ is => 'ro',
+ lazy => 1,
+ default => sub { "Parent" },
+ );
+
+ has type_constrained => (
+ is => 'rw',
+ isa => 'Positive',
+ default => 5.5,
+ );
+
+ package Child;
+ use Coat;
+ extends 'Parent';
+
+ has '+name' => (
+ default => 'Junior',
+ );
+
+ has '+lazy_classname' => (
+ default => sub { "Child" },
+ );
+
+ has '+type_constrained' => (
+ isa => 'Int',
+ default => 100,
+ );
+}
+
+my $foo = Parent->new;
+my $bar = Child->new;
+
+my $attr = Coat::Meta->has( 'Parent', 'type_constrained');
+is( $attr->{isa}, 'Positive', 'Parent type_constrained isa Positive');
+
+is(blessed($foo), 'Parent', 'Parent->new gives a Parent object');
+is($foo->name, undef, 'No name yet');
+is($foo->lazy_classname, 'Parent', "lazy attribute initialized");
+lives_ok { $foo->type_constrained(10.5) } "Num type constraint for now..";
+
+lives_ok { $foo->type_constrained(10) } "10 passes the Positive type-constraint";
+
+is($bar->name, 'Junior', "Child->name's default came through");
+
+is($foo->lazy_classname, 'Parent', "lazy attribute was already initialized");
+
+is(blessed($bar), 'Child', 'successfully reblessed into Child');
+
+$attr = Coat::Meta->has( 'Child', 'type_constrained');
+is( $attr->{isa}, 'Int', 'Child type_constrained isa Int');
+
+is($bar->lazy_classname, 'Child', "lazy attribute just now initialized");
+is( $bar->type_constrained, 100, 'default value is overiden');
+lives_ok { $bar->type_constrained(5) } "5 passes the Int type-constraint";
+
+throws_ok { $bar->type_constrained(10.5) }
+qr/^Value '10.5' does not validate type constraint 'Int'/,
+'... this failed cause of type check';
Added: branches/upstream/libcoat-perl/current/t/lib/Foo.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/lib/Foo.pm?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/lib/Foo.pm (added)
+++ branches/upstream/libcoat-perl/current/t/lib/Foo.pm Sun Nov 30 13:11:38 2008
@@ -1,0 +1,6 @@
+package Foo;
+use Coat;
+
+has foo => (isa => 'Str', is => 'rw');
+
+1;
Added: branches/upstream/libcoat-perl/current/t/lib/MyCoatA.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/lib/MyCoatA.pm?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/lib/MyCoatA.pm (added)
+++ branches/upstream/libcoat-perl/current/t/lib/MyCoatA.pm Sun Nov 30 13:11:38 2008
@@ -1,0 +1,7 @@
+package MyCoatA;
+
+use Coat;
+
+has 'b' => (is => 'rw', isa => 'MyCoatB');
+
+1;
Added: branches/upstream/libcoat-perl/current/t/lib/MyCoatB.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/lib/MyCoatB.pm?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/lib/MyCoatB.pm (added)
+++ branches/upstream/libcoat-perl/current/t/lib/MyCoatB.pm Sun Nov 30 13:11:38 2008
@@ -1,0 +1,5 @@
+package MyCoatB;
+
+use Coat;
+
+1;
Added: branches/upstream/libcoat-perl/current/t/lib/MyMooseObject.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/lib/MyMooseObject.pm?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/lib/MyMooseObject.pm (added)
+++ branches/upstream/libcoat-perl/current/t/lib/MyMooseObject.pm Sun Nov 30 13:11:38 2008
@@ -1,0 +1,7 @@
+package MyMooseObject;
+
+use strict;
+use warnings;
+use base 'Moose::Object';
+
+1;
Added: branches/upstream/libcoat-perl/current/t/moose_tests/001_subtype_quote_bug.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/moose_tests/001_subtype_quote_bug.t?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/moose_tests/001_subtype_quote_bug.t (added)
+++ branches/upstream/libcoat-perl/current/t/moose_tests/001_subtype_quote_bug.t Sun Nov 30 13:11:38 2008
@@ -1,0 +1,31 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+=pod
+
+This is a test for a bug found by Purge on #moose:
+The code:
+
+ subtype Stuff
+ => as Object
+ => where { ... }
+
+will break if the Object:: namespace exists. So the
+solution is to quote 'Object', like so:
+
+ subtype Stuff
+ => as 'Object'
+ => where { ... }
+
+Moose 0.03 did this, now it doesn't, so all should
+be well from now on.
+
+=cut
+
+{ package Object::Test; }
+
+use_ok('Coat');
Added: branches/upstream/libcoat-perl/current/t/moose_tests/002_subtype_conflict_bug.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/moose_tests/002_subtype_conflict_bug.t?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/moose_tests/002_subtype_conflict_bug.t (added)
+++ branches/upstream/libcoat-perl/current/t/moose_tests/002_subtype_conflict_bug.t Sun Nov 30 13:11:38 2008
@@ -1,0 +1,15 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib 't/lib', 'lib', '../lib';
+
+use Test::More tests => 3;
+
+BEGIN {
+ use_ok('Coat');
+}
+
+use_ok('MyCoatA');
+use_ok('MyCoatB');
Added: branches/upstream/libcoat-perl/current/t/moose_tests/004_subclass_use_base_bug.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/moose_tests/004_subclass_use_base_bug.t?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/moose_tests/004_subclass_use_base_bug.t (added)
+++ branches/upstream/libcoat-perl/current/t/moose_tests/004_subclass_use_base_bug.t Sun Nov 30 13:11:38 2008
@@ -1,0 +1,32 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+BEGIN {
+ use_ok('Coat');
+}
+
+=pod
+
+This just makes sure that the Bar gets
+a metaclass initialized for it correctly.
+
+=cut
+
+{
+ package Foo;
+ use Coat;
+
+ package Bar;
+ use strict;
+ use warnings;
+
+ use base 'Foo';
+}
+
+my $bar = Bar->new;
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
Added: branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_002_require_superclasses.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_002_require_superclasses.t?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_002_require_superclasses.t (added)
+++ branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_002_require_superclasses.t Sun Nov 30 13:11:38 2008
@@ -1,0 +1,44 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib 't/lib', 'lib', '../lib';
+
+use Test::More tests => 5;
+
+
+
+{
+ package Bar;
+ use Coat;
+
+ eval { extends 'Foo'; };
+ ::ok(!$@, '... loaded Foo superclass correctly');
+}
+
+{
+ package Baz;
+ use Coat;
+
+ eval { extends 'Bar'; };
+ ::ok(!$@, '... loaded (inline) Bar superclass correctly');
+}
+
+{
+ package Foo::Bar;
+ use Coat;
+
+ eval { extends 'Foo', 'Bar'; };
+ ::ok(!$@, '... loaded Foo and (inline) Bar superclass correctly');
+}
+
+{
+ package Bling;
+ use Coat;
+
+ eval { extends 'No::Class'; };
+ ::ok($@, '... could not find the superclass (as expected)');
+ ::like($@, qr/^Could not load class \(No\:\:Class\) because \:/, '... and got the error we expected');
+}
+
Added: branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_011_moose_respects_type_constraints.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_011_moose_respects_type_constraints.t?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_011_moose_respects_type_constraints.t (added)
+++ branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_011_moose_respects_type_constraints.t Sun Nov 30 13:11:38 2008
@@ -1,0 +1,59 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+use Test::Exception;
+
+use Coat::Types;
+
+=pod
+
+This tests demonstrates that Coat will not override
+a pre-existing type constraint of the same name when
+making constraints for a Coat-class.
+
+It also tests that an attribute which uses a 'Foo' for
+it's isa option will get the subtype Foo, and not a
+type representing the Foo moose class.
+
+=cut
+
+BEGIN {
+ # create this subtype first (in BEGIN)
+ subtype Foo
+ => as 'Value'
+ => where { $_ eq 'Foo' };
+}
+
+{ # now seee if Coat will override it
+ package Foo;
+ use Coat;
+}
+
+my $foo_constraint = find_type_constraint('Foo');
+isa_ok($foo_constraint, 'Coat::Meta::TypeConstraint');
+
+is($foo_constraint->parent, 'Value', '... got the Value subtype for Foo');
+
+{
+ package Bar;
+ use Coat;
+
+ has 'foo' => (is => 'rw', isa => 'Foo');
+}
+
+my $bar = Bar->new;
+isa_ok($bar, 'Bar');
+
+lives_ok {
+ $bar->foo('Foo');
+} '... checked the type constraint correctly';
+
+dies_ok {
+ $bar->foo(Foo->new);
+} '... checked the type constraint correctly';
+
+
+
Added: branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_015_buildargs.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_015_buildargs.t?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_015_buildargs.t (added)
+++ branches/upstream/libcoat-perl/current/t/moose_tests/010_basics_015_buildargs.t Sun Nov 30 13:11:38 2008
@@ -1,0 +1,43 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+
+{
+ package Foo;
+ use Coat;
+
+ has bar => ( is => "rw" );
+ has baz => ( is => "rw" );
+
+ sub BUILDARGS {
+ my ( $self, @args ) = @_;
+ unshift @args, "bar" if @args % 2 == 1;
+ return {@args};
+ }
+
+ package Bar;
+ use Coat;
+
+ extends qw(Foo);
+}
+
+foreach my $class qw(Foo Bar) {
+ is( $class->new->bar, undef, "no args" );
+ is( $class->new( bar => 42 )->bar, 42, "normal args" );
+ is( $class->new( 37 )->bar, 37, "single arg" );
+ {
+ my $o = $class->new(bar => 42, baz => 47);
+ is($o->bar, 42, '... got the right bar');
+ is($o->baz, 47, '... got the right bar');
+ }
+ {
+ my $o = $class->new(42, baz => 47);
+ is($o->bar, 42, '... got the right bar');
+ is($o->baz, 47, '... got the right bar');
+ }
+}
+
+
Added: branches/upstream/libcoat-perl/current/t/moose_tests/020_attributes_006_attribute_required.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/moose_tests/020_attributes_006_attribute_required.t?rev=27467&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/moose_tests/020_attributes_006_attribute_required.t (added)
+++ branches/upstream/libcoat-perl/current/t/moose_tests/020_attributes_006_attribute_required.t Sun Nov 30 13:11:38 2008
@@ -1,0 +1,57 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 15;
+use Test::Exception;
+
+{
+ package Foo;
+ use Coat;
+
+ has 'bar' => (is => 'ro', required => 1);
+ has 'baz' => (is => 'rw', default => 100, required => 1);
+ has 'boo' => (is => 'rw', lazy => 1, default => 50, required => 1);
+}
+
+{
+ my $foo = Foo->new(bar => 10, baz => 20, boo => 100);
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 10, '... got the right bar');
+ is($foo->baz, 20, '... got the right baz');
+ is($foo->boo, 100, '... got the right boo');
+}
+
+{
+ my $foo = Foo->new(bar => 10, boo => 5);
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 10, '... got the right bar');
+ is($foo->baz, 100, '... got the right baz');
+ is($foo->boo, 5, '... got the right boo');
+}
+
+{
+ my $foo = Foo->new(bar => 10);
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 10, '... got the right bar');
+ is($foo->baz, 100, '... got the right baz');
+ is($foo->boo, 50, '... got the right boo');
+}
+
+throws_ok {
+ Foo->new(bar => 10, baz => undef);
+} qr/^Attribute \(baz\) is required and cannot be undef/, '... must supply all the required attribute';
+
+throws_ok {
+ Foo->new(bar => 10, boo => undef);
+} qr/^Attribute \(boo\) is required and cannot be undef/, '... must supply all the required attribute';
+
+
+throws_ok {
+ Foo->new;
+} qr/^Attribute \(bar\) is required/, '... must supply all the required attribute';
+
More information about the Pkg-perl-cvs-commits
mailing list