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
gregoa at users.alioth.debian.org
Sat May 17 15:21:24 UTC 2008
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' );
More information about the Pkg-perl-cvs-commits
mailing list