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