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