r25702 - in /branches/upstream/libcoat-perl/current: ./ lib/Coat/ lib/Coat/Meta/ t/

ansgar-guest at users.alioth.debian.org ansgar-guest at users.alioth.debian.org
Sat Sep 27 12:28:41 UTC 2008


Author: ansgar-guest
Date: Sat Sep 27 12:28:34 2008
New Revision: 25702

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=25702
Log:
[svn-upgrade] Integrating new upstream version, libcoat-perl (0.333)

Added:
    branches/upstream/libcoat-perl/current/t/033_cascading_inheritance.t
    branches/upstream/libcoat-perl/current/t/034_undef_value.t
    branches/upstream/libcoat-perl/current/t/035_multiple_coercions.t
    branches/upstream/libcoat-perl/current/t/036_type.t
Modified:
    branches/upstream/libcoat-perl/current/CHANGES
    branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm
    branches/upstream/libcoat-perl/current/lib/Coat/Meta/TypeConstraint.pm
    branches/upstream/libcoat-perl/current/lib/Coat/Types.pm
    branches/upstream/libcoat-perl/current/t/011_metaclass_attributes_inheritance.t
    branches/upstream/libcoat-perl/current/t/022_type_coercion_datetime.t

Modified: branches/upstream/libcoat-perl/current/CHANGES
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/CHANGES?rev=25702&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/CHANGES (original)
+++ branches/upstream/libcoat-perl/current/CHANGES Sat Sep 27 12:28:34 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: branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm?rev=25702&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat/Meta.pm Sat Sep 27 12:28:34 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: branches/upstream/libcoat-perl/current/lib/Coat/Meta/TypeConstraint.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/lib/Coat/Meta/TypeConstraint.pm?rev=25702&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat/Meta/TypeConstraint.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat/Meta/TypeConstraint.pm Sat Sep 27 12:28:34 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: branches/upstream/libcoat-perl/current/lib/Coat/Types.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/lib/Coat/Types.pm?rev=25702&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/lib/Coat/Types.pm (original)
+++ branches/upstream/libcoat-perl/current/lib/Coat/Types.pm Sat Sep 27 12:28:34 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: branches/upstream/libcoat-perl/current/t/011_metaclass_attributes_inheritance.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/011_metaclass_attributes_inheritance.t?rev=25702&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/t/011_metaclass_attributes_inheritance.t (original)
+++ branches/upstream/libcoat-perl/current/t/011_metaclass_attributes_inheritance.t Sat Sep 27 12:28:34 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: branches/upstream/libcoat-perl/current/t/022_type_coercion_datetime.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/022_type_coercion_datetime.t?rev=25702&op=diff
==============================================================================
--- branches/upstream/libcoat-perl/current/t/022_type_coercion_datetime.t (original)
+++ branches/upstream/libcoat-perl/current/t/022_type_coercion_datetime.t Sat Sep 27 12:28:34 2008
@@ -15,7 +15,7 @@
 coerce 'IO::File'
     => from 'Str'
     => via {
-        IO::File->new
+        IO::File->new()
     };
 
 {

Added: branches/upstream/libcoat-perl/current/t/033_cascading_inheritance.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/033_cascading_inheritance.t?rev=25702&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/033_cascading_inheritance.t (added)
+++ branches/upstream/libcoat-perl/current/t/033_cascading_inheritance.t Sat Sep 27 12:28:34 2008
@@ -1,0 +1,32 @@
+use strict;
+use warnings;
+
+{
+    package One;
+	use Coat;
+	has 'one' => (isa => 'Int', is => 'rw', default => 1);
+	
+	package Two;
+	use Coat;
+	extends 'One';
+	has 'two' => (isa => 'Int', is => 'rw', default => 2);
+	
+	package Three;
+	use Coat;
+	extends 'Two';
+	has 'three' => (isa => 'Int', is => 'rw', default => 3);
+	
+	package Four;
+	use Coat;
+	extends 'Three';
+	has 'four' => (isa => 'Int', is => 'rw', default => 4);
+}
+
+use Test::More tests => 4;
+
+my $four = Four->new;
+
+is($four->four, 4, 'Level 4 return 4');
+is($four->three, 3, 'Level 3 return 3');
+is($four->two, 2, 'Level 2 return 2');
+is($four->one, 1, 'Level 1 return 1');

Added: branches/upstream/libcoat-perl/current/t/034_undef_value.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/034_undef_value.t?rev=25702&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/034_undef_value.t (added)
+++ branches/upstream/libcoat-perl/current/t/034_undef_value.t Sat Sep 27 12:28:34 2008
@@ -1,0 +1,12 @@
+use strict;
+use warnings;
+use Test::More 'no_plan';
+
+{
+    package A;
+    use Coat;
+    has one => (isa => 'Int');
+}
+
+my $a = A->new(one => undef);
+ok( !defined($a->one), "one is undef" );

Added: branches/upstream/libcoat-perl/current/t/035_multiple_coercions.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/035_multiple_coercions.t?rev=25702&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/035_multiple_coercions.t (added)
+++ branches/upstream/libcoat-perl/current/t/035_multiple_coercions.t Sat Sep 27 12:28:34 2008
@@ -1,0 +1,62 @@
+use Test::More 'no_plan';
+use strict;
+use warnings;
+
+sub time_to_datetime($) {
+    my $time = shift;
+    my ($sec, $min, $hour, $day, $mon, $year) = localtime($time);
+    $mon++;
+    $year += 1900;
+    $sec = sprintf('%02d', $sec);
+    $min = sprintf('%02d', $min);
+    $hour = sprintf('%02d', $hour);
+    $mon = sprintf('%02d', $mon);
+    $day = sprintf('%02d', $day);
+    return "${year}-${mon}-${day} ${hour}:${min}:${sec}";
+}
+
+# Types & Coercions
+BEGIN { use_ok 'Coat::Types' }
+
+subtype 'Date'
+    => as 'Str'
+    => where { /^\d\d\d\d-\d\d-\d\d$/ };
+
+subtype 'DateTime'
+    => as 'Str'
+    => where { /^\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d$/ };
+
+coerce 'DateTime'
+    => from 'Int'
+    => via { time_to_datetime($_) };
+
+coerce 'DateTime'
+    => from 'Date'
+    => via { "$_ 00:00:00" };
+
+{
+    package Foo;
+    use Coat;
+
+    has 'date' => (
+        is => 'rw',
+        isa => 'Date',
+    );
+
+    has 'date_time' => (
+        is => 'rw',
+        isa => 'DateTime',
+        coerce => 1,
+    );
+}
+
+# fixtures
+my $date      = '2008-09-12';
+my $date_time =  '2008-09-12 00:00:00';
+
+my $o = Foo->new;
+is( $date, $o->date($date), "date set to $date" );
+ok( $o->date_time($o->date), 'coerce date_time from date' );
+is( $date_time, $o->date_time, 'date_time correctly coerced' );
+
+ok( $o->date_time( time ), 'coerce from Int' );

Added: branches/upstream/libcoat-perl/current/t/036_type.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libcoat-perl/current/t/036_type.t?rev=25702&op=file
==============================================================================
--- branches/upstream/libcoat-perl/current/t/036_type.t (added)
+++ branches/upstream/libcoat-perl/current/t/036_type.t Sat Sep 27 12:28:34 2008
@@ -1,0 +1,121 @@
+use Test::More 'no_plan';
+
+use strict;
+use warnings;
+
+
+{
+	package A;
+	use Coat;
+	has 'a'	=> (is =>'rw', isa => 'A');
+	
+	package B;
+	use Coat;
+	
+	extends 'A';
+	has 'b'			=> (is => 'rw', isa => 'B');
+
+	package C;
+	use Coat;
+	
+	extends 'B';
+	has 'c'			=> (is => 'rw', isa => 'C');
+}
+
+
+# OBJET A
+my $a = A->new();
+
+# Methode a
+eval {
+	$a->a(A->new());
+};
+ok(!$@,'$a->a(A->new()) ok');
+
+eval {
+	$a->a(B->new());
+};
+is($@, '', '$a->a(B->new()) ok');
+eval {
+	$a->a(C->new());
+};
+ok(!$@,'$a->a(C->new()) ok');
+
+
+# OBJET B
+my $b = B->new();
+
+# Methode a
+eval {
+	$b->a(A->new());
+};
+ok(!$@,'$b->a(A->new()) ok');
+eval {
+	$b->a(B->new());
+};
+ok(!$@,'$b->a(B->new()) ok');
+eval {
+	$b->a(C->new());
+};
+ok(!$@,'$b->a(C->new()) ok');
+
+# Methode b
+eval {
+	$b->b(A->new());
+};
+ok($@,'$b->b(A->new()) not valide');
+eval {
+	$b->b(B->new());
+};
+ok(!$@,'$b->a(B->new()) ok');
+eval {
+	$b->b(C->new());
+};
+ok(!$@,'$b->a(C->new()) ok');
+
+# OBJET C
+my $c = C->new();
+
+# Methode a
+eval {
+	$c->a(A->new());
+};
+ok(!$@,'$c->a(A->new()) ok');
+eval {
+	$c->a(B->new());
+};
+ok(!$@,'$c->a(B->new()) ok');
+eval {
+	$c->a(C->new());
+};
+ok(!$@,'$c->a(C->new()) ok');
+
+# Methode b
+eval {
+	$c->b(A->new());
+};
+ok($@,'$c->b(A->new()) not valide');
+eval {
+	$c->b(B->new());
+};
+ok(!$@,'$c->b(B->new()) ok');
+eval {
+	$c->b(C->new());
+};
+ok(!$@,'$c->b(C->new()) ok');
+
+# Methode c
+eval {
+	$c->c(A->new());
+};
+ok($@,'$c->c(A->new()) not valide');
+eval {
+	$c->c(B->new());
+};
+ok($@,'$c->c(B->new()) not valide');
+eval {
+	$c->c(C->new());
+};
+ok(!$@,'$c->c(C->new()) ok');
+
+1;




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