r20062 - in /branches/upstream/libcoat-perl/current: lib/Coat.pm lib/Coat/Types.pm t/025_class_constraint.t t/026_attribute_overloading.t

[gregoa at users.alioth.debian.org]

Author: gregoa
Date: Sat May 17 15:21:23 2008
New Revision: 20062

URL: http://svn.debian.org/wsvn/?sc=1&rev=20062
Log:
[svn-upgrade] Integrating new upstream version, libcoat-perl (0.310)

Added:
    branches/upstream/libcoat-perl/current/t/026_attribute_overloading.t
Modified:
    branches/upstream/libcoat-perl/current/lib/Coat.pm
    branches/upstream/libcoat-perl/current/lib/Coat/Types.pm
    branches/upstream/libcoat-perl/current/t/025_class_constraint.t

Modified: branches/upstream/libcoat-perl/current/lib/Coat.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/lib/Coat.pm?rev=20062&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat.pm Sat May 17 15:21:23 2008
@@ -14,7 +14,7 @@
 use Coat::Object;
 use Coat::Types;
 
-$VERSION   = '0.300';
+$VERSION   = '0.310';
 $AUTHORITY = 'cpan:SUKRIA';
 
 # our exported keywords for class description
@@ -38,6 +38,17 @@
 
     my $class    = $options{'!caller'} || getscope();
     my $accessor = "${class}::${attribute}";
+
+    # handle here attr overloading (eg: has '+foo' overload SUPER::foo)
+    if ($attribute =~ /^\+(\S+)$/) {
+        $attribute = $1;
+        
+        my $inherited_attrs = Coat::Meta->all_attributes( $class );
+        (exists $inherited_attrs->{$attribute}) ||
+            confess "Cannot overload unknown attribute ($attribute)";
+        
+        %options = (%{$inherited_attrs->{$attribute}}, %options );
+    }
 
     my $attr = Coat::Meta->attribute( $class, $attribute, \%options);
 

Modified: branches/upstream/libcoat-perl/current/lib/Coat/Types.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/lib/Coat/Types.pm?rev=20062&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat/Types.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat/Types.pm Sat May 17 15:21:23 2008
@@ -143,9 +143,9 @@
     return 1 if (! defined $value && ! $attr->{required});
 
     # get the current TypeConstraint object
-    my $tc = (_is_parameterized_type_constraint( $type_name )) 
-           ? find_or_create_parameterized_type_constraint( $type_name )
-           : find_type_constraint( $type_name );
+    my $tc = (_is_parameterized_type_constraint( $type_name ))
+        ? find_or_create_parameterized_type_constraint( $type_name )
+        : find_type_constraint( $type_name ) ;
     
     # anon type if not found & register
     if (not defined $tc) {
@@ -248,7 +248,7 @@
 sub _parse_parameterized_type_constraint ($) {
     my ($type_name) = @_;
 
-    if ($type_name =~ /^(\w+)\[(\w+)\]$/) {
+    if ($type_name =~ /^(\w+)\[([\w:_\d]+)\]$/) {
         return ($1, $2);
     }
     else { 
@@ -258,7 +258,7 @@
 
 sub _is_parameterized_type_constraint ($) {
     my ($type_name) = @_;
-    return $type_name =~ /^\w+\[\w+\]$/;
+    return $type_name =~ /^\w+\[[\w:_\d]+\]$/;
 }
 
 # }}}

Modified: branches/upstream/libcoat-perl/current/t/025_class_constraint.t
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/t/025_class_constraint.t?rev=20062&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/t/025_class_constraint.t (original)
+++ branches/upstream/libcoat-perl/current/t/025_class_constraint.t Sat May 17 15:21:23 2008
@@ -9,6 +9,8 @@
 
     has file => (is => 'rw', isa => 'IO::File');
 
+    has many_files => (is => 'rw', isa => 'ArrayRef[IO::File]');
+
 }
 use IO::File;
 
@@ -18,3 +20,9 @@
 eval { $a->file( A->new ) };
 ok( $@, 'Object A is not an IO::File' );
 
+eval { $a->many_files( A->new ) };
+ok( $@, 'Object A is not an ArrayRef of IO::File' );
+
+eval { $a->many_files( [IO::File->new, IO::File->new] ) };
+is( $@, '', 'ArrayRef of IO::File accepted' );
+

Added: branches/upstream/libcoat-perl/current/t/026_attribute_overloading.t
URL: http://svn.debian.org/wsvn/branches/upstream/libcoat-perl/current/t/026_attribute_overloading.t?rev=20062&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/026_attribute_overloading.t (added)
+++ branches/upstream/libcoat-perl/current/t/026_attribute_overloading.t Sat May 17 15:21:23 2008
@@ -1,0 +1,21 @@
+use Test::More 'no_plan';
+
+use strict;
+use warnings;
+
+{
+    package A;
+    use Coat;
+    has x => (is => 'rw', isa => 'Num', default => 42);
+
+    package B;
+    use Coat;
+    extends 'A';
+    has '+x' => (default => 23);
+}
+
+my $a = A->new;
+my $b = B->new;
+
+is ($a->x, 42, 'default value for a->x is 42' );
+is ($b->x, 23, 'default value for b->x is 23' );