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