r25704 - in /trunk/libcoat-perl: ./ debian/ lib/Coat/ lib/Coat/Meta/ t/
ansgar-guest at users.alioth.debian.org
ansgar-guest at users.alioth.debian.org
Sat Sep 27 12:40:10 UTC 2008
Author: ansgar-guest
Date: Sat Sep 27 12:40:06 2008
New Revision: 25704
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=25704
Log:
New upstream release.
Added:
trunk/libcoat-perl/t/033_cascading_inheritance.t
- copied unchanged from r25703, branches/upstream/libcoat-perl/current/t/033_cascading_inheritance.t
trunk/libcoat-perl/t/034_undef_value.t
- copied unchanged from r25703, branches/upstream/libcoat-perl/current/t/034_undef_value.t
trunk/libcoat-perl/t/035_multiple_coercions.t
- copied unchanged from r25703, branches/upstream/libcoat-perl/current/t/035_multiple_coercions.t
trunk/libcoat-perl/t/036_type.t
- copied unchanged from r25703, branches/upstream/libcoat-perl/current/t/036_type.t
Modified:
trunk/libcoat-perl/CHANGES
trunk/libcoat-perl/debian/changelog
trunk/libcoat-perl/lib/Coat/Meta.pm
trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm
trunk/libcoat-perl/lib/Coat/Types.pm
trunk/libcoat-perl/t/011_metaclass_attributes_inheritance.t
trunk/libcoat-perl/t/022_type_coercion_datetime.t
Modified: trunk/libcoat-perl/CHANGES
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/CHANGES?rev=25704&op=diff
==============================================================================
--- trunk/libcoat-perl/CHANGES (original)
+++ trunk/libcoat-perl/CHANGES Sat Sep 27 12:40:06 2008
@@ -1,3 +1,8 @@
+2008-09-26 -- release 0.333
+ * bugfix: fixes multiple coercions on the same subtype.
+ * bugfix: fixes cascading inheritance
+ * bugfix: fixes validation constraint of built-in type "Object"
+
2008-09-18 -- release 0.332
* bugfix: removed useless DateTime dependency in test suite, so Coat can be
Modified: trunk/libcoat-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/debian/changelog?rev=25704&op=diff
==============================================================================
--- trunk/libcoat-perl/debian/changelog (original)
+++ trunk/libcoat-perl/debian/changelog Sat Sep 27 12:40:06 2008
@@ -1,3 +1,9 @@
+libcoat-perl (0.333-1) unstable; urgency=low
+
+ * New upstream release.
+
+ -- Ansgar Burchardt <ansgar at 43-1.org> Sat, 27 Sep 2008 14:39:50 +0200
+
libcoat-perl (0.332-1) unstable; urgency=low
[ Ansgar Burchardt ]
Modified: trunk/libcoat-perl/lib/Coat/Meta.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat/Meta.pm?rev=25704&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Meta.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Meta.pm Sat Sep 27 12:40:06 2008
@@ -11,7 +11,10 @@
# the root accessor: returns the whole data structure, all meta classes
sub classes { $CLASSES }
+# returns all attributes for the given class
sub attributes { $CLASSES->{ $_[1] } }
+
+# returns the meta-data for the given class
sub class
{
my ($self, $class) = @_;
@@ -99,7 +102,6 @@
{
my ($self, $class, $attribute) = @_;
-
# if the attribute is declared for us, it's ok
return $CLASSES->{ $class }{ $attribute } if
exists $CLASSES->{ $class }{ $attribute };
@@ -164,7 +166,17 @@
sub family { $CLASSES->{'@!family'}{ $_[1] } }
-sub extends
+sub add_to_family {
+ my ($self, $class, $parent) = @_;
+
+ # add the parent to the family if not already present
+ if (not grep /^$parent$/, @{$CLASSES->{'@!family'}{ $class }}) {
+ push @{ $CLASSES->{'@!family'}{ $class } }, $parent;
+ }
+}
+
+sub extends($$$);
+sub extends($$$)
{
my ($self, $class, $parents) = @_;
$parents = [$parents] unless ref $parents;
@@ -174,21 +186,15 @@
$CLASSES->{'@!family'}{ $class } = [];
}
-
+ # loop on each parent, add it to family and do the same
+ # with recursion through its family
foreach my $parent (@$parents) {
- # make sure we don't inherit twice
- confess "Class '$class' already inherits from class '$parent'" if
- Coat::Meta->is_family( $class, $parent );
-
foreach my $ancestor (@{ Coat::Meta->parents( $parent ) }) {
- push @{ $CLASSES->{'@!family'}{ $class } }, $ancestor
- unless grep /^$ancestor$/,
- @{$CLASSES->{'@!family'}{ $class }};
+ Coat::Meta->extends($class, $ancestor);
}
-
- push @{ $CLASSES->{'@!family'}{ $class } }, $parent;
- }
-
+ # we do it at the end, so we respect the order of ancestry
+ Coat::Meta->add_to_family($class, $parent);
+ }
}
sub modifiers
Modified: trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm?rev=25704&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm Sat Sep 27 12:40:06 2008
@@ -13,9 +13,18 @@
# accessors
sub name { $_[0]->{name} ||= $_[1] }
sub validation { $_[0]->{validation} ||= $_[1] }
-sub coercion_map { $_[0]->{coercion_map} ||= $_[1] }
sub message { $_[0]->{message} ||= $_[1] }
sub parent { $_[0]->{parent} ||= $_[1] }
+
+sub coercion_map {
+ my ($self, $map) = @_;
+ if (@_ == 1) {
+ return $self->{coercion_map};
+ }
+ else {
+ return $self->{coercion_map} = $map;
+ }
+}
# coerce the given value with the first matching type
sub coerce {
@@ -27,7 +36,9 @@
# if current value passes the current source check, coercing
my $tc = Coat::Types::find_type_constraint($source);
my $ok;
- eval { $ok = $tc->validate($value) };
+ eval {
+ $ok = $tc->validate($value)
+ };
if ($ok && !$@) {
return $self->{coercion_map}{$source}->($value);
}
Modified: trunk/libcoat-perl/lib/Coat/Types.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat/Types.pm?rev=25704&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Types.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Types.pm Sat Sep 27 12:40:06 2008
@@ -68,7 +68,7 @@
return register_type_constraint( Coat::Meta::TypeConstraint->new(
name => $type_name,
parent => 'Object',
- validation => sub { ref($_) eq $type_name},
+ validation => sub { $_->isa($type_name) },
message => sub { "Value is not a member of class '$type_name' ($_)" },
));
}
@@ -114,7 +114,8 @@
my $tc = find_or_create_type_constraint($type_name);
if ($tc->has_coercion) {
- $tc->coercion_map ( { %{ $tc->coercion_map }, %coercion_map });
+ my $map = { %{ $tc->coercion_map }, %coercion_map };
+ $tc->coercion_map ( $map );
}
else {
$tc->coercion_map ( \%coercion_map );
@@ -154,22 +155,11 @@
# Bypass the type check if not defined and not required
return $value if (! defined $value && ! $attr->{required});
- # get the current TypeConstraint object
+ # get the current TypeConstraint object (or create it if not defined)
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) {
- $tc = Coat::Meta::TypeConstraint->new(
- name => $type_name,
- parent => 'Object',
- validation => sub { $_->isa( $type_name ) },
- message => sub { "Value is not a member of class '$type_name'" }
- );
- register_type_constraint( $tc );
- }
-
+ : find_or_create_type_constraint( $type_name ) ;
+
# look for coercion : if the constraint has coercion and
# current value is of a supported coercion source type, coerce.
if ($attr->{coerce}) {
Modified: trunk/libcoat-perl/t/011_metaclass_attributes_inheritance.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/t/011_metaclass_attributes_inheritance.t?rev=25704&op=diff
==============================================================================
--- trunk/libcoat-perl/t/011_metaclass_attributes_inheritance.t (original)
+++ trunk/libcoat-perl/t/011_metaclass_attributes_inheritance.t Sat Sep 27 12:40:06 2008
@@ -47,8 +47,10 @@
qq/Foo's family is correct/);
is_deeply(Coat::Meta->family( 'Bar' ), \@bar_family,
qq/Bar's family is correct/);
+
is_deeply(Coat::Meta->family( 'Baz' ), \@baz_family,
qq/Baz's family is correct/);
+
is_deeply(Coat::Meta->family( 'BalBaz' ), \@balbaz_family,
qq/BalBaz's family is correct/);
Modified: trunk/libcoat-perl/t/022_type_coercion_datetime.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/t/022_type_coercion_datetime.t?rev=25704&op=diff
==============================================================================
--- trunk/libcoat-perl/t/022_type_coercion_datetime.t (original)
+++ trunk/libcoat-perl/t/022_type_coercion_datetime.t Sat Sep 27 12:40:06 2008
@@ -15,7 +15,7 @@
coerce 'IO::File'
=> from 'Str'
=> via {
- IO::File->new
+ IO::File->new()
};
{
More information about the Pkg-perl-cvs-commits
mailing list