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