r19960 - in /trunk/libcoat-perl: debian/ lib/ lib/Coat/ lib/Coat/Meta/ t/
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Wed May 14 18:30:31 UTC 2008
Author: gregoa
Date: Wed May 14 18:30:30 2008
New Revision: 19960
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=19960
Log:
New upstream release.
Added:
trunk/libcoat-perl/t/022_type_coercion_datetime.t
- copied unchanged from r19959, branches/upstream/libcoat-perl/current/t/022_type_coercion_datetime.t
trunk/libcoat-perl/t/023_parameterized_type_constraint.t
- copied unchanged from r19959, branches/upstream/libcoat-perl/current/t/023_parameterized_type_constraint.t
trunk/libcoat-perl/t/024_class_name_type_constraint.t
- copied unchanged from r19959, branches/upstream/libcoat-perl/current/t/024_class_name_type_constraint.t
trunk/libcoat-perl/t/025_class_constraint.t
- copied unchanged from r19959, branches/upstream/libcoat-perl/current/t/025_class_constraint.t
Modified:
trunk/libcoat-perl/debian/changelog
trunk/libcoat-perl/lib/Coat.pm
trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm
trunk/libcoat-perl/lib/Coat/Types.pm
trunk/libcoat-perl/t/006_extends.t
trunk/libcoat-perl/t/021_type_coercion.t
Modified: trunk/libcoat-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/debian/changelog?rev=19960&op=diff
==============================================================================
--- trunk/libcoat-perl/debian/changelog (original)
+++ trunk/libcoat-perl/debian/changelog Wed May 14 18:30:30 2008
@@ -1,3 +1,9 @@
+libcoat-perl (0.300-1) UNRELEASED; urgency=low
+
+ * New upstream release.
+
+ -- gregor herrmann <gregoa at debian.org> Wed, 14 May 2008 20:29:38 +0200
+
libcoat-perl (0.2-1) unstable; urgency=low
[ Jose Luis Rivas ]
Modified: trunk/libcoat-perl/lib/Coat.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat.pm?rev=19960&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat.pm (original)
+++ trunk/libcoat-perl/lib/Coat.pm Wed May 14 18:30:30 2008
@@ -14,7 +14,7 @@
use Coat::Object;
use Coat::Types;
-$VERSION = '0.2';
+$VERSION = '0.300';
$AUTHORITY = 'cpan:SUKRIA';
# our exported keywords for class description
@@ -110,19 +110,32 @@
sub import {
my $caller = caller;
return if $caller eq 'main';
+ my $class_name = getscope();
# import strict and warnings
strict->import;
warnings->import;
# delcare the class
- Coat::Meta->class( getscope() );
+ Coat::Meta->class( $class_name );
# be sure Coat::Object is known as a valid class
Coat::Meta->class('Coat::Object');
+ # the class *cannot* be named like a built-in type!
+ (grep /^$class_name$/, Coat::Types::list_all_builtin_type_constraints) &&
+ confess "Class cannot be named like a built-in type constraint ($class_name)";
+
+ # register the class as a valid type
+ Coat::Types::register_type_constraint( Coat::Meta::TypeConstraint->new(
+ name => $class_name,
+ parent => 'Object',
+ validation => sub { ref($_) eq $class_name },
+ message => sub { "Value is not a member of class '$class_name' ($_)" },
+ ));
+
# force inheritance from Coat::Object
- _extends_class( ['Coat::Object'], getscope() );
+ _extends_class( ['Coat::Object'], $class_name );
Coat->export_to_level( 1, @_ );
}
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=19960&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Meta/TypeConstraint.pm Wed May 14 18:30:30 2008
@@ -14,20 +14,23 @@
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 message { $_[0]->{message} ||= $_[1] }
# coerce the given value with the first matching type
sub coerce {
my ($self, $value) = @_;
- # get the matching types for that value
- my @types = Coat::Types::find_matching_types($value);
# for each source registered, try coercion if the source is a valid type
local $_ = $value;
foreach my $source (keys %{ $self->coercion_map }) {
- (grep /^$source$/, @types) and
+ # if current value passes the current source check, coercing
+ my $tc = Coat::Types::find_type_constraint($source);
+ my $ok;
+ eval { $ok = $tc->validate($value) };
+ if ($ok && !$@) {
return $self->{coercion_map}{$source}->($value);
+ }
}
return $value;
}
@@ -57,3 +60,58 @@
1;
__END__
+=pod
+
+=head1 NAME
+
+Coat:Meta::TypeConstraint - The Coat Type Constraint metaclass
+
+=head1 DESCRIPTION
+
+For the most part, the only time you will ever encounter an
+instance of this class is if you are doing some serious deep
+introspection. This API should not be considered final, but
+it is B<highly unlikely> that this will matter to a regular
+Coat user.
+
+=head1 METHODS
+
+=over 4
+
+=item B<new>
+
+Constructor
+
+=item B<coerce ($value)>
+
+This will apply the type-coercion if applicable.
+
+=item B<validate ($value)>
+
+If the C<$value> passes the constraint, C<undef> will be
+returned. If the C<$value> does B<not> pass the constraint, then
+the C<message> will be used to construct a custom error message.
+
+=item B<has_coercion>
+Return true if coercion has been defined, false otherwise.
+
+=back
+
+=head1 AUTHOR
+
+Alexis Sukrieh E<lt>sukria at sukria.netE<gt> ;
+based on the work done by Stevan Little E<lt>stevan at iinteractive.comE<gt>
+on Moose::Meta::TypeConstraint
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Edenware - Alexis Sukrieh
+
+L<http://www.edenware.fr> - L<http://www.sukria.net>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+
+=cut
+
Modified: trunk/libcoat-perl/lib/Coat/Types.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat/Types.pm?rev=19960&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Types.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Types.pm Wed May 14 18:30:30 2008
@@ -23,8 +23,15 @@
@EXPORT = qw(
type subtype enum coerce
from as where via message
+
register_type_constraint
find_type_constraint
+
+ list_all_type_constraints
+ list_all_builtin_type_constraints
+
+ create_parameterized_type_constraint
+ find_or_create_parameterized_type_constraint
);
sub as ($) { $_[0] }
@@ -60,6 +67,7 @@
register_type_constraint( new Coat::Meta::TypeConstraint(
name => $type_name,
+ parent => undef,
validation => $validation_code,
message => $message) );
}
@@ -124,9 +132,8 @@
}
sub validate {
- my ($class, $attr, $attribute, $value, $isa) = @_;
- $isa ||= $attr->{isa};
- my $tc = find_type_constraint( $isa );
+ my ($class, $attr, $attribute, $value, $type_name) = @_;
+ $type_name ||= $attr->{isa};
# Exception if not defined and required attribute
confess "Attribute \($attribute\) is required and cannot be undef"
@@ -135,45 +142,123 @@
# Bypass the type check if not defined and not required
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 );
+
+ # 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 );
+ }
+
# look for coercion : if the constraint has coercion and
# current value is of a supported coercion source type, coerce.
- if (defined $tc && $tc->has_coercion) {
- $value = $tc->coerce($value)
- }
-
- # look through the type-constraints
- if (defined $tc) {
- $tc->validate( $value );
- }
-
- # unknown type, use it as a classname
- else {
- my $classname = $isa;
- my $tc = find_type_constraint( 'ClassName' );
-
- $tc->validation->($value, $classname)
- or confess "Value '"
- . (defined $value ? $value : 'undef')
- . " is not a member of class '$classname' "
- . "for attribute '$attribute'";
- }
+ if ($attr->{coerce}) {
+ (not $tc->has_coercion) &&
+ confess "Coercion is not available for type '".$tc->name."'";
+ # coercing...
+ $value = $tc->coerce($value);
+ }
+
+ # validate the value through the type-constraint
+ $tc->validate( $value );
return $value;
}
-# pass the value through all types ; return matching types
-sub find_matching_types {
- my ($value) = @_;
- my @matching_types;
-
- local $_ = $value;
- foreach my $t ( list_all_type_constraints() ){
- my $tc = find_type_constraint( $t );
- push @matching_types, $t
- if $tc->validation->( $value );
- }
-
- return @matching_types;
+# }}}
+
+# {{{ - parameterized type constraints
+
+sub find_or_create_parameterized_type_constraint ($) {
+ my ($type_name) = @_;
+ $REGISTRY->{$type_name} ||= create_parameterized_type_constraint( $type_name );
+}
+
+sub create_parameterized_type_constraint ($) {
+ my ($type_name) = @_;
+
+ my ($base_type, $type_parameter) =
+ _parse_parameterized_type_constraint($type_name);
+
+ (defined $base_type && defined $type_parameter)
+ || confess "Could not parse type name ($type_name) correctly";
+
+ my $tc_base = find_type_constraint( $base_type );
+ (defined $tc_base)
+ || confess "Could not locate the base type ($base_type)";
+
+ confess "Unsupported base type ($base_type)"
+ if (! _base_type_is_arrayref($base_type) &&
+ ! _base_type_is_hashref($base_type) );
+
+ my $tc_param = find_type_constraint( $type_parameter );
+
+ my $tc = Coat::Meta::TypeConstraint->new (
+ name => $type_name,
+ parent => $base_type,
+ message => sub { "Validation failed with value $_" });
+
+ # now add parameterized type constraint validation code
+ # depending on the base type
+ if (_base_type_is_arrayref( $base_type )) {
+ $tc->validation( sub {
+ foreach my $e (@$_) {
+ eval { $tc_param->validate( $e )};
+ return 0 if $@;
+ }
+ return 1;
+ });
+ }
+ elsif (_base_type_is_hashref( $base_type )) {
+ $tc->validation( sub {
+ my $value = $_ || $_[0];
+
+ foreach my $k (keys %$value) {
+ eval { $tc_param->validate( $value->{$k} )};
+ return 0 if $@;
+ }
+ return 1;
+ });
+ }
+
+ # the type-constraint object is ready!
+ return $tc;
+}
+
+# private subs for parameterized type constraints handling
+
+sub _base_type_is_arrayref ($) {
+ my ($type) = @_;
+ return $type =~ /^ArrayRef|ARRAY$/;
+}
+
+sub _base_type_is_hashref ($) {
+ my ($type) = @_;
+ return $type =~ /^HashRef|HASH$/;
+}
+
+sub _parse_parameterized_type_constraint ($) {
+ my ($type_name) = @_;
+
+ if ($type_name =~ /^(\w+)\[(\w+)\]$/) {
+ return ($1, $2);
+ }
+ else {
+ return (undef, undef);
+ }
+}
+
+sub _is_parameterized_type_constraint ($) {
+ my ($type_name) = @_;
+ return $type_name =~ /^\w+\[\w+\]$/;
}
# }}}
@@ -227,12 +312,23 @@
subtype 'Object'
=> as 'Ref'
- => where { ref($_) && ref($_) ne 'Regexp' };
+ => where { ref($_) &&
+ ref($_) ne 'Regexp' &&
+ ref($_) ne 'ARRAY' &&
+ ref($_) ne 'SCALAR' &&
+ ref($_) ne 'CODE' &&
+ ref($_) ne 'HASH'};
subtype 'ClassName'
=> as 'Str'
=> where { ref($_[0]) && ref($_[0]) eq $_[1] };
+# accesor to all the built-in types
+{
+ my @BUILTINS = list_all_type_constraints();
+ sub list_all_builtin_type_constraints { @BUILTINS }
+}
+
# }}}
1;
@@ -241,65 +337,219 @@
=head1 NAME
-Coat::Types -- Type constraints handling for Coat
+Coat::Types - Type constraint system for Coat
+
+=head1 NOTE
+
+This is a rewrite of Moose::Util::TypeConstraint for Coat.
+
+=head1 SYNOPSIS
+
+ use Coat::Types;
+
+ type 'Num' => where { Scalar::Util::looks_like_number($_) };
+
+ subtype 'Natural'
+ => as 'Num'
+ => where { $_ > 0 };
+
+ subtype 'NaturalLessThanTen'
+ => as 'Natural'
+ => where { $_ < 10 }
+ => message { "This number ($_) is not less than ten!" };
+
+ coerce 'Num'
+ => from 'Str'
+ => via { 0+$_ };
+
+ enum 'RGBColors' => qw(red green blue);
=head1 DESCRIPTION
-Attributes in Coat are bound to types with the keyword 'isa'. This lets Coat
-perform type-constraint validation when a value is set to an attribute of the
-class.
-
-The following types are supported by Coat (based on the ones provided by
-L<Moose>, those that are not available in Moose are marked 'C')
-
- Any
- Item
+This module provides Coat with the ability to create custom type
+contraints to be used in attribute definition.
+
+=head2 Important Caveat
+
+This is B<NOT> a type system for Perl 5. These are type constraints,
+and they are not used by Coat unless you tell it to. No type
+inference is performed, expression are not typed, etc. etc. etc.
+
+This is simply a means of creating small constraint functions which
+can be used to simplify your own type-checking code, with the added
+side benefit of making your intentions clearer through self-documentation.
+
+=head2 Slightly Less Important Caveat
+
+It is B<always> a good idea to quote your type and subtype names.
+
+This is to prevent perl from trying to execute the call as an indirect
+object call. This issue only seems to come up when you have a subtype
+the same name as a valid class, but when the issue does arise it tends
+to be quite annoying to debug.
+
+So for instance, this:
+
+ subtype DateTime => as Object => where { $_->isa('DateTime') };
+
+will I<Just Work>, while this:
+
+ use DateTime;
+ subtype DateTime => as Object => where { $_->isa('DateTime') };
+
+will fail silently and cause many headaches. The simple way to solve
+this, as well as future proof your subtypes from classes which have
+yet to have been created yet, is to simply do this:
+
+ use DateTime;
+ subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
+
+=head2 Default Type Constraints
+
+This module also provides a simple hierarchy for Perl 5 types, here is
+that hierarchy represented visually.
+
+ Any
+ Item
Bool
Undef
Defined
- Value
- Num
- Int
- Timestamp (C)
- Str
- ClassName
- Ref
- ScalarRef
- ArrayRef
- HashRef
- CodeRef
-
-
-Each of these types provides a static method called "is_valid" which takes a
-value and returns a boolean telling if the value given is valid according to
-the type.
-
-=head1 METHODS
-
-=head2 validate
-
-This module provides a method for validating a value set to an attribute. It
-calls the appropriate "is_valid" method according to the type given.
-
-If the type given is not a known type, it will be assumed this is a classname,
-and the value will then be checked with ClassName->is_valid.
-
-=head1 SEE ALSO
-
-See L<Coat> for more details.
-
-=head1 AUTHORS
-
-This module was written by Alexis Sukrieh E<lt>sukria+perl at sukria.netE<gt>
+ Value
+ Num
+ Int
+ Str
+ ClassName
+ Ref
+ ScalarRef
+ ArrayRef[`a]
+ HashRef[`a]
+ CodeRef
+ RegexpRef
+ GlobRef
+ Object
+
+=head2 Type Constraint Naming
+
+Since the types created by this module are global, it is suggested
+that you namespace your types just as you would namespace your
+modules. So instead of creating a I<Color> type for your B<My::Graphics>
+module, you would call the type I<My::Graphics::Color> instead.
+
+=head1 FUNCTIONS
+
+=head2 Type Constraint Constructors
+
+The following functions are used to create type constraints.
+They will then register the type constraints in a global store
+where Coat can get to them if it needs to.
+
+See the L<SYNOPSIS> for an example of how to use these.
+
+=over 4
+
+=item B<type ($name, $where_clause)>
+
+This creates a base type, which has no parent.
+
+=item B<subtype ($name, $parent, $where_clause, ?$message)>
+
+This creates a named subtype.
+
+=item B<enum ($name, @values)>
+
+This will create a basic subtype for a given set of strings.
+The resulting constraint will be a subtype of C<Str> and
+will match any of the items in C<@values>. It is case sensitive.
+See the L<SYNOPSIS> for a simple example.
+
+B<NOTE:> This is not a true proper enum type, it is simple
+a convient constraint builder.
+
+=item B<as>
+
+This is just sugar for the type constraint construction syntax.
+
+=item B<where>
+
+This is just sugar for the type constraint construction syntax.
+
+=item B<message>
+
+This is just sugar for the type constraint construction syntax.
+
+=back
+
+=head2 Type Coercion Constructors
+
+Type constraints can also contain type coercions as well. If you
+ask your accessor to coerce, then Coat will run the type-coercion
+code first, followed by the type constraint check. This feature
+should be used carefully as it is very powerful and could easily
+take off a limb if you are not careful.
+
+See the L<SYNOPSIS> for an example of how to use these.
+
+=over 4
+
+=item B<coerce>
+
+=item B<from>
+
+This is just sugar for the type coercion construction syntax.
+
+=item B<via>
+
+This is just sugar for the type coercion construction syntax.
+
+=back
+
+=head2 Type Constraint Construction & Locating
+
+=over 4
+
+=item B<find_type_constraint ($type_name)>
+
+This function can be used to locate a specific type constraint
+meta-object, of the class L<Coat::Meta::TypeConstraint> or a
+derivative. What you do with it from there is up to you :)
+
+=item B<register_type_constraint ($type_object)>
+
+This function will register a named type constraint with the type registry.
+
+=item B<list_all_type_constraints>
+
+This will return a list of type constraint names, you can then
+fetch them using C<find_type_constraint ($type_name)> if you
+want to.
+
+=item B<export_type_constraints_as_functions>
+
+This will export all the current type constraints as functions
+into the caller's namespace. Right now, this is mostly used for
+testing, but it might prove useful to others.
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Alexis Sukrieh E<lt>sukria at sukria.netE<gt> ;
+based on the work done by Stevan Little E<lt>stevan at iinteractive.comE<gt>
+on Moose::Util::TypeConstraint
=head1 COPYRIGHT AND LICENSE
-Copyright 2007 by Alexis Sukrieh.
-
-L<http://www.sukria.net/perl/coat/>
+Copyright 2006-2008 by Edenware - Alexis Sukrieh
+
+L<http://www.edenware.fr> - L<http://www.sukria.net>
This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+it under the same terms as Perl itself.
=cut
-
Modified: trunk/libcoat-perl/t/006_extends.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/t/006_extends.t?rev=19960&op=diff
==============================================================================
--- trunk/libcoat-perl/t/006_extends.t (original)
+++ trunk/libcoat-perl/t/006_extends.t Wed May 14 18:30:30 2008
@@ -9,13 +9,13 @@
# classes
{
- package Item;
+ package MyItem;
use Coat;
has name => (isa => 'Str');
- package Item3D;
+ package MyItem3D;
use Coat;
- extends qw(Point3D Item);
+ extends qw(Point3D MyItem);
}
my $point2d = new Point x => 2, y => 4;
@@ -24,10 +24,10 @@
my $point3d = new Point3D x => 1, y => 3, z => 1;
isa_ok($point3d, 'Point3D');
-my $item = new Item3D name => 'foo', x => 4, z => 3;
-isa_ok($item, 'Item3D');
+my $item = new MyItem3D name => 'foo', x => 4, z => 3;
+isa_ok($item, 'MyItem3D');
isa_ok($item, 'Point3D');
-isa_ok($item, 'Item');
+isa_ok($item, 'MyItem');
# make sure the father didn't get any attribute property of his son
ok( ( ! Coat::Meta->has(ref($point2d), 'z')), "! \$point2d->can('z')" );
Modified: trunk/libcoat-perl/t/021_type_coercion.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/t/021_type_coercion.t?rev=19960&op=diff
==============================================================================
--- trunk/libcoat-perl/t/021_type_coercion.t (original)
+++ trunk/libcoat-perl/t/021_type_coercion.t Wed May 14 18:30:30 2008
@@ -13,7 +13,7 @@
=> from 'Int'
=> via { $_[0].".0" };
- has float => (isa => 'Float');
+ has float => (isa => 'Float', coerce => 1);
}
my $cal = new Calculator;
@@ -23,3 +23,4 @@
ok( $cal->float(2), '2 is accepted as a float' );
ok( $cal->float eq '2.0', '$cal->float == 2.0 (has been coerced)');
+
More information about the Pkg-perl-cvs-commits
mailing list