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