r20064 - in /trunk/libcoat-perl: debian/changelog lib/Coat.pm lib/Coat/Types.pm t/025_class_constraint.t t/026_attribute_overloading.t

gregoa at users.alioth.debian.org gregoa at users.alioth.debian.org
Sat May 17 15:23:08 UTC 2008


Author: gregoa
Date: Sat May 17 15:23:08 2008
New Revision: 20064

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=20064
Log:
New upstream release.

Added:
    trunk/libcoat-perl/t/026_attribute_overloading.t
      - copied unchanged from r20063, branches/upstream/libcoat-perl/current/t/026_attribute_overloading.t
Modified:
    trunk/libcoat-perl/debian/changelog
    trunk/libcoat-perl/lib/Coat.pm
    trunk/libcoat-perl/lib/Coat/Types.pm
    trunk/libcoat-perl/t/025_class_constraint.t

Modified: trunk/libcoat-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/debian/changelog?rev=20064&op=diff
==============================================================================
--- trunk/libcoat-perl/debian/changelog (original)
+++ trunk/libcoat-perl/debian/changelog Sat May 17 15:23:08 2008
@@ -1,3 +1,9 @@
+libcoat-perl (0.310-1) UNRELEASED; urgency=low
+
+  * New upstream release.
+
+ -- gregor herrmann <gregoa at debian.org>  Sat, 17 May 2008 17:22:15 +0200
+
 libcoat-perl (0.300-1) unstable; urgency=low
 
   * New upstream release.

Modified: trunk/libcoat-perl/lib/Coat.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat.pm?rev=20064&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat.pm (original)
+++ trunk/libcoat-perl/lib/Coat.pm Sat May 17 15:23:08 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: trunk/libcoat-perl/lib/Coat/Types.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat/Types.pm?rev=20064&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Types.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Types.pm Sat May 17 15:23:08 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: trunk/libcoat-perl/t/025_class_constraint.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/t/025_class_constraint.t?rev=20064&op=diff
==============================================================================
--- trunk/libcoat-perl/t/025_class_constraint.t (original)
+++ trunk/libcoat-perl/t/025_class_constraint.t Sat May 17 15:23:08 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' );
+




More information about the Pkg-perl-cvs-commits mailing list