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