r19866 - in /trunk/libcoat-perl: debian/ lib/ lib/Coat/ lib/Coat/Meta/ t/

ghostbar-guest at users.alioth.debian.org ghostbar-guest at users.alioth.debian.org
Sun May 11 21:54:50 UTC 2008


Author: ghostbar-guest
Date: Sun May 11 21:54:49 2008
New Revision: 19866

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=19866
Log:
+ New upstream release, probably ready to be uploaded, doing some tests.

Added:
    trunk/libcoat-perl/lib/Coat/Meta/
      - copied from r19864, branches/upstream/libcoat-perl/current/lib/Coat/Meta/
    trunk/libcoat-perl/t/011_metaclass_attributes_inheritance.t.orig
      - copied unchanged from r19864, branches/upstream/libcoat-perl/current/t/011_metaclass_attributes_inheritance.t.orig
    trunk/libcoat-perl/t/019_type_constraints.t
      - copied unchanged from r19864, branches/upstream/libcoat-perl/current/t/019_type_constraints.t
    trunk/libcoat-perl/t/020_moose_std_type_constraints.t
      - copied unchanged from r19864, branches/upstream/libcoat-perl/current/t/020_moose_std_type_constraints.t
    trunk/libcoat-perl/t/021_type_coercion.t
      - copied unchanged from r19864, branches/upstream/libcoat-perl/current/t/021_type_coercion.t
    trunk/libcoat-perl/t/Point.pm
      - copied unchanged from r19864, branches/upstream/libcoat-perl/current/t/Point.pm
    trunk/libcoat-perl/t/Point3D.pm
      - copied unchanged from r19864, branches/upstream/libcoat-perl/current/t/Point3D.pm
Modified:
    trunk/libcoat-perl/debian/changelog
    trunk/libcoat-perl/lib/Coat.pm
    trunk/libcoat-perl/lib/Coat/Types.pm
    trunk/libcoat-perl/t/000_load.t
    trunk/libcoat-perl/t/004_wrapped_method_context_propagation.t
    trunk/libcoat-perl/t/006_extends.t
    trunk/libcoat-perl/t/007_inheritance.t

Modified: trunk/libcoat-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/debian/changelog?rev=19866&op=diff
==============================================================================
--- trunk/libcoat-perl/debian/changelog (original)
+++ trunk/libcoat-perl/debian/changelog Sun May 11 21:54:49 2008
@@ -1,3 +1,9 @@
+libcoat-perl (0.2-1) UNRELEASED; urgency=low
+
+  * New upstream release
+
+ -- Jose Luis Rivas <ghostbar38 at gmail.com>  Sun, 11 May 2008 17:16:03 -0430
+
 libcoat-perl (0.1-0.6-2) unstable; urgency=low
 
   * debian/control: Added: Vcs-Svn field (source stanza); Vcs-Browser field

Modified: trunk/libcoat-perl/lib/Coat.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat.pm?rev=19866&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat.pm (original)
+++ trunk/libcoat-perl/lib/Coat.pm Sun May 11 21:54:49 2008
@@ -14,7 +14,7 @@
 use Coat::Object;
 use Coat::Types;
 
-$VERSION   = '0.1_0.6';
+$VERSION   = '0.2';
 $AUTHORITY = 'cpan:SUKRIA';
 
 # our exported keywords for class description
@@ -49,7 +49,7 @@
             confess "Cannot set a read-only attribute ($attribute)" 
                 if ($attr->{'is'} eq 'ro');
 
-            Coat::Types->validate( $attr, $attribute, $value );
+            $value = Coat::Types->validate( $attr, $attribute, $value );
             $self->{$attribute} = $value;
 
             # handle the trigger, if exists
@@ -195,9 +195,24 @@
 sub _build_sub_with_hook($$) {
     my ( $class, $method ) = @_;
 
-    my $parents      = Coat::Meta->parents( $class );
-    # FIXME : we have to find the good super: the one who provides the sub
-    my $super = $parents->[scalar(@$parents) - 1];
+    my $parents = Coat::Meta->family( $class );
+    my $super   = undef;
+
+    # we have to find where in the inheritance tree $super is providing
+    # $method
+    foreach my $parent_class (@$parents) {
+        # looking for the first inherited method
+        my $coderef;
+        { 
+            no strict 'refs'; 
+            $coderef = *{ "${parent_class}::${method}" };
+        }
+        $super = $parent_class if defined &$coderef;
+    }
+
+    # $method not found, something is wrong there
+    confess "Unable to find method \"$method\" in inherited classes"
+        unless defined $super;
 
     my $full_method  = "${class}::${method}";
     my $super_method = *{ qualify_to_ref( $method => $super ) };
@@ -244,8 +259,12 @@
 
     # then we inherit from all the mothers given, if they are valid
     foreach my $mother (@$mothers) {
-        confess "Class '$mother' is unknown, cannot extends"
-          unless Coat::Meta->exists($mother);
+        # class is unknown, never been loaded, let's try to import it
+        unless ( Coat::Meta->exists($mother) ) {
+            eval "use $mother";
+            confess "Failed to load class '$mother' : $@" if $@;
+            $mother->import;
+        }
         Coat::Meta->extends( $class, $mother );
     }
 

Modified: trunk/libcoat-perl/lib/Coat/Types.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/lib/Coat/Types.pm?rev=19866&op=diff
==============================================================================
--- trunk/libcoat-perl/lib/Coat/Types.pm (original)
+++ trunk/libcoat-perl/lib/Coat/Types.pm Sun May 11 21:54:49 2008
@@ -1,255 +1,132 @@
-{
-    package Util;
-    sub looks_like_number {
-        my $val = shift;
-        $val =~ /^[\d\.]+$/;
-    }
-}
-
-{
-    package Coat::Type;
-
-    use strict;
-    use warnings;
-    use Carp 'confess';
-
-    sub is_valid   { confess "is_valid Cannot be called from interface Coat::Type" }
-}
-{
-    package Coat::Type::Any;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type';
-
-    sub is_valid { 1 }
-}
-
-{
-    package Coat::Type::Item;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type';
-
-    sub is_valid { 1 }
-}
-{
-    package Coat::Type::Item::Bool;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item';
-
-    # A boolean must be defined and equal to 0 or 1
-    sub is_valid { 
-        (defined $_[1]) 
-        ? ( ($_[1] == 0 || $_[1] == 1) 
-            ? 1
-            : 0)
-        : 0
-    }
-}
-{
-    package Coat::Type::Item::Defined;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item';
-
-
-    sub is_valid {
-        (defined $_[1])
-        ? 1
-        : 0
-    }
-}
-{
-    package Coat::Type::Item::Undef;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item';
-
-    sub is_valid 
-    {
-        (! defined $_[1])
-        ? 1
-        : 0
-    }
-}
-{
-    package Coat::Type::Item::Defined::Ref;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item::Defined';
-
-    sub is_valid { 
-        my ($class, $value) = @_;    
-        ($class->SUPER::is_valid($value))
-        ? ((ref $value)
-            ? 1
-            : 0)
-        : 0
-    }
-}
-{
-    package Coat::Type::Item::Defined::Value;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item::Defined';
-
-
-    sub is_valid { 
-        $_[0]->SUPER::is_valid($_[1]) && ( ! ref $_[1] ) ;
-    }
-}
-{
-    package Coat::Type::Item::Defined::Value::Num;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item::Defined::Value';
-
-    sub is_valid { $_[0]->SUPER::is_valid($_[1]) && Util::looks_like_number( "$_[1]" ) }
-}
-{
-    package Coat::Type::Item::Defined::Value::Str;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item::Defined::Value';
-
-    sub is_valid { 
-        $_[0]->SUPER::is_valid($_[1])
-    }
-}
-{
-    package Coat::Type::Item::Defined::Value::Num::Int;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item::Defined::Value::Num';
-
-    sub is_valid {
-        $_[0]->SUPER::is_valid( $_[1] ) && ( Util::looks_like_number( "$_[1]" ) == 1 );
-    }
-}
-{
-    package Coat::Type::Item::Defined::Value::Str::ClassName;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item::Defined::Value::Str';
-
-    sub is_valid 
-    { 
-        my ($class, $classname, $value) = @_;
-        
-        return (defined $value) && 
-            (ref $value) &&
-            (ref $value eq $classname);
-    }
-}
-{
-    package Coat::Type::Item::Defined::Ref::ArrayRef;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item::Defined::Ref';
-
-    sub is_valid {
-        $_[0]->SUPER::is_valid($_[1]) && 
-        ((ref $_[1]) eq 'ARRAY');
-    }
-}
-{
-    package Coat::Type::Item::Defined::Ref::CodeRef;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item::Defined::Ref';
-
-    sub is_valid {
-        $_[0]->SUPER::is_valid($_[1]) && 
-        ((ref $_[1]) eq 'CODE');
-    }
-}
-{
-    package Coat::Type::Item::Defined::Ref::HashRef;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item::Defined::Ref';
-
-    sub is_valid {
-        $_[0]->SUPER::is_valid($_[1]) && 
-        ((ref $_[1]) eq 'HASH');
-    }
-}
-{
-    package Coat::Type::Item::Defined::Ref::ScalarRef;
-
-    use strict;
-    use warnings;
-
-    use base 'Coat::Type::Item::Defined::Ref';
-
-    sub is_valid {
-        $_[0]->SUPER::is_valid($_[1]) && 
-        ((ref $_[1]) eq 'SCALAR');
-    }
-}
-
-# Types 
-
 package Coat::Types;
 
 use strict;
 use warnings;
+
 use Carp 'confess';
-
-my $cache = {};
-
-sub validate
-{
-    my ($class, $attr, $attribute, $value) = @_;
-    my $isa = $attr->{isa};
-
-    my $isa_class = {
-        Any       => 'Coat::Type::Any',
-        Item      => 'Coat::Type::Item',
-        Bool      => 'Coat::Type::Item::Bool',
-        Undef     => 'Coat::Type::Item::Undef',
-        Defined   => 'Coat::Type::Item::Defined',
-        Value     => 'Coat::Type::Item::Defined::Value',
-        Num       => 'Coat::Type::Item::Defined::Value::Num',
-        Int       => 'Coat::Type::Item::Defined::Value::Num::Int',
-        Str       => 'Coat::Type::Item::Defined::Value::Str',
-        ClassName => 'Coat::Type::Item::Defined::Value::Str::ClassName',
-        Ref       => 'Coat::Type::Item::Defined::Ref',
-        ScalarRef => 'Coat::Type::Item::Defined::Ref::ScalarRef',
-        ArrayRef  => 'Coat::Type::Item::Defined::Ref::ArrayRef',
-        HashRef   => 'Coat::Type::Item::Defined::Ref::HashRef',
-        CodeRef   => 'Coat::Type::Item::Defined::Ref::CodeRef',
-        RegexpRef => 'Coat::Type::Item::Defined::Ref::RegexpRef',
-    };
+use base 'Exporter';
+use vars qw(@EXPORT);
+
+use Coat::Meta::TypeConstraint;
+
+# Moose/Coat keywords
+sub as      ($);
+sub from    ($);
+sub where   (&);
+sub message (&);
+sub type    ($$;$);
+sub subtype ($$;$$);
+sub enum    ($;@);
+sub via     (&);
+sub coerce  ($@);
+
+ at EXPORT = qw(
+    type subtype enum coerce
+    from as where via message
+    register_type_constraint
+    find_type_constraint
+);
+
+sub as      ($) { $_[0] }
+sub from    ($) { $_[0] }
+sub where   (&) { $_[0] }
+sub via     (&) { $_[0] }
+sub message (&) { $_[0] }
+
+# {{{ - Registry
+# singleton for storing Coat::Meta::Typeconstrain objects
+
+my $REGISTRY = { };
+
+sub register_type_constraint {
+    my ($tc) = @_;
+
+    confess "can't register an unnamed type constraint"
+        unless defined $tc->name;
+
+    $REGISTRY->{$tc->name} = $tc;
+}
+
+sub find_type_constraint         { $REGISTRY->{$_[0]} }
+sub list_all_type_constraints    { keys %$REGISTRY    }
+sub get_type_constraint_registry { $REGISTRY          }
+
+# }}}
+
+# {{{ - macro (type, subtype, coerce, enum)
+
+sub type($$;$) { 
+    my ($type_name, $validation_code, $message) = @_;
+    
+    register_type_constraint( new Coat::Meta::TypeConstraint(
+        name       => $type_name,
+        validation => $validation_code,
+        message    => $message) );
+}
+
+sub subtype ($$;$$) {
+    my ($type_name, $parent, $validation_code, $message) = @_;
+
+    register_type_constraint( new Coat::Meta::TypeConstraint(
+        name       => $type_name,
+        parent     => $parent,
+        validation => $validation_code,
+        message    => $message ) );
+}
+
+sub enum ($;@) {
+    my ($type_name, @values) = @_;
+    confess "You must have at least two values to enumerate through"
+        unless (scalar @values >= 2);
+
+    my $regexp = join( '|', @values );
+	
+    subtype $type_name 
+        => as 'Str' 
+        => where { /^$regexp$/i };    
+}
+
+sub coerce($@) {
+    my ($type_name, %coercion_map) = @_;
+    my $tc = find_type_constraint($type_name);
+
+    (defined $tc) || 
+        confess "Cannot find type '$type_name', perhaps you forgot to load it.";
+
+    if ($tc->has_coercion) {
+        $tc->coercion_map ( { %{ $tc->coercion_map }, %coercion_map });
+    }
+    else {
+        $tc->coercion_map ( \%coercion_map );
+    }
+}
+
+# }}}
+
+# {{{ - exported functions 
+
+sub export_type_constraints_as_functions {
+    my $caller = caller;
+    foreach my $t ( list_all_type_constraints() ) {
+        my $constraint = find_type_constraint( $t );
+        my $constraint_symbol = "${caller}::${t}";
+        my $constraint_sub = sub {
+            my ($value) = @_;
+            local $_ = $value;
+            return $constraint->validation->($value) ? 1 : undef;
+        };
+        {
+            no strict 'refs';
+            no warnings 'redefine', 'prototype';
+            *$constraint_symbol = $constraint_sub;
+        }
+    }
+}
+
+sub validate {
+    my ($class, $attr, $attribute, $value, $isa) = @_;
+    $isa ||= $attr->{isa};
+    my $tc = find_type_constraint( $isa );
 
     # Exception if not defined and required attribute 
     confess "Attribute \($attribute\) is required and cannot be undef" 
@@ -258,27 +135,105 @@
     # Bypass the type check if not defined and not required
     return 1 if (! defined $value && ! $attr->{required});
 
-    # now normal type constraint checks
-    if (exists $isa_class->{$isa}) {
-        my $type = $isa_class->{$isa};
-        $type->is_valid($value) 
-            or confess "Value '"
-                .(defined $value ? $value : 'undef')
-                ."' does not validate type constraint '$isa' "
-                . "for attribute '$attribute'";
-    }
-    
+    # 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;
-        $isa = $isa_class->{'ClassName'};
-        $isa->is_valid($classname, $value) 
+        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'";
     }
-}
+
+    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;
+}
+
+# }}}
+
+# {{{ - built-in types and subtypes
+
+## --------------------------------------------------------
+## some basic built-in types (mostly taken from Moose)
+## --------------------------------------------------------
+
+type 'Any'  => where { 1 }; # meta-type including all
+type 'Item' => where { 1 }; # base-type 
+
+subtype 'Undef'   => as 'Item' => where { !defined($_) };
+subtype 'Defined' => as 'Item' => where {  defined($_) };
+
+subtype 'Bool'
+    => as 'Item' 
+    => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
+
+subtype 'Value' 
+    => as 'Defined' 
+    => where { !ref($_) };
+    
+subtype 'Ref'
+    => as 'Defined' 
+    => where {  ref($_) };
+
+subtype 'Str' 
+    => as 'Value' 
+    => where { 1 };
+
+subtype 'Num' 
+    => as 'Value' 
+    => where { "$_" =~ /^-?[\d\.]+$/ };
+    
+subtype 'Int' 
+    => as 'Num'   
+    => where { "$_" =~ /^-?[0-9]+$/ };
+
+subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' };
+subtype 'ArrayRef'  => as 'Ref' => where { ref($_) eq 'ARRAY'  }; 
+subtype 'HashRef'   => as 'Ref' => where { ref($_) eq 'HASH'   }; 
+subtype 'CodeRef'   => as 'Ref' => where { ref($_) eq 'CODE'   }; 
+subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' }; 
+subtype 'GlobRef'   => as 'Ref' => where { ref($_) eq 'GLOB'   };
+
+subtype 'FileHandle' 
+    => as 'GlobRef' 
+    => where { ref($_) eq 'GLOB' };
+
+subtype 'Object' 
+    => as 'Ref' 
+    => where { ref($_) && ref($_) ne 'Regexp' };
+
+subtype 'ClassName' 
+    => as 'Str' 
+    => where { ref($_[0]) && ref($_[0]) eq $_[1] };
+
+# }}}
 
 1;
 __END__
@@ -295,7 +250,7 @@
 class.
 
 The following types are supported by Coat (based on the ones provided by
-L<Moose>)
+L<Moose>, those that are not available in Moose are marked 'C')
 
     Any
     Item
@@ -305,6 +260,7 @@
         Value
           Num
             Int
+              Timestamp (C)
           Str
             ClassName
         Ref
@@ -313,6 +269,7 @@
           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.

Modified: trunk/libcoat-perl/t/000_load.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/t/000_load.t?rev=19866&op=diff
==============================================================================
--- trunk/libcoat-perl/t/000_load.t (original)
+++ trunk/libcoat-perl/t/000_load.t Sun May 11 21:54:49 2008
@@ -8,3 +8,4 @@
 BEGIN {
     use_ok('Coat');
 }
+

Modified: trunk/libcoat-perl/t/004_wrapped_method_context_propagation.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/t/004_wrapped_method_context_propagation.t?rev=19866&op=diff
==============================================================================
--- trunk/libcoat-perl/t/004_wrapped_method_context_propagation.t (original)
+++ trunk/libcoat-perl/t/004_wrapped_method_context_propagation.t Sun May 11 21:54:49 2008
@@ -15,7 +15,9 @@
 
     has x => ( is => 'rw', default => 0 );
 
-    sub inc { $_[0]->x( 1 + $_[0]->x ) }
+    sub inc { 
+        $_[0]->x( 1 + $_[0]->x );
+    }
 
     sub scalar_or_array {
         wantarray ? (qw/a b c/) : "x";

Modified: trunk/libcoat-perl/t/006_extends.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/t/006_extends.t?rev=19866&op=diff
==============================================================================
--- trunk/libcoat-perl/t/006_extends.t (original)
+++ trunk/libcoat-perl/t/006_extends.t Sun May 11 21:54:49 2008
@@ -5,22 +5,10 @@
 use warnings;
 use Coat::Meta;
 
+use lib 't';
+
 # classes 
 {
-    package Point;
-
-    use Coat;
-
-    has 'x' => ( isa => 'Int', default => 0);
-    has 'y' => ( isa => 'Int', default => 0);
-
-    package Point3D;
-
-    use Coat;
-    extends 'Point';
-
-    has 'z' => ( isa => 'Int', default => 0);
-
     package Item;
     use Coat;
     has name => (isa => 'Str');
@@ -29,7 +17,6 @@
     use Coat;
     extends qw(Point3D Item);
 }
-
 
 my $point2d = new Point x => 2, y => 4;
 isa_ok($point2d, 'Point');

Modified: trunk/libcoat-perl/t/007_inheritance.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcoat-perl/t/007_inheritance.t?rev=19866&op=diff
==============================================================================
--- trunk/libcoat-perl/t/007_inheritance.t (original)
+++ trunk/libcoat-perl/t/007_inheritance.t Sun May 11 21:54:49 2008
@@ -1,52 +1,43 @@
-package Person;
-use Coat;
+use strict;
+use warnings;
+use Test::Simple qw(no_plan);
+use Coat::Meta;
 
-has 'name' => (
-    isa => 'Str',
-);
+{
+    package Person;
+    use Coat;
 
-has 'force' => (
-    isa => 'Int',
-    default => 1,
-);
+    has 'name' => ( isa => 'Str'); 
+    has 'force' => ( isa => 'Int', default => 1);
 
-sub walk
-{
-    my ($self) = @_;
-    return $self->name . " walks\n";
+    sub walk {
+        my ($self) = @_;
+        return $self->name . " walks\n";
+    }
+
+    package Soldier;
+    use Coat;
+    extends 'Person';
+
+    has 'force' => ( isa => 'Int', default => 3);
+
+    sub attack {
+        my ($self) = @_;
+        return $self->force + int(rand(10));
+    }
+
+    package General;
+    use Coat;
+    extends 'Soldier';
+
+    has 'force' => ( isa => 'Int', default => '5');
+
+    # just to make sur we can hook something inherited
+    before walk => sub {
+        return 1;
+    };
 }
 
-package Soldier;
-use Coat;
-extends 'Person';
-
-has 'force' => (
-    isa => 'Int',
-    default => 3,
-);
-
-sub attack
-{
-    my ($self) = @_;
-    return $self->force + int(rand(10));
-}
-
-package General;
-use Coat;
-extends 'Soldier';
-
-has 'force' => (
-    isa => 'Int',
-    default => '5',
-);
-
-package main;
-
-use strict;
-use warnings;
-
-use Coat::Meta;
-use Test::Simple qw(no_plan);
 
 my $man = new Person name => 'John';
 my $soldier = new Soldier name => 'Dude';




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