From: Stevan Little Date: Sun, 19 Mar 2006 15:35:29 +0000 (+0000) Subject: types are no string, you can export if you want X-Git-Tag: 0_05~90 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=182134e8438a301a8e75a95cdd74e65987d11f13;p=gitmo%2FMoose.git types are no string, you can export if you want --- diff --git a/lib/Moose.pm b/lib/Moose.pm index 3c0b696..1127479 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -30,6 +30,12 @@ sub import { return if $pkg eq 'main'; Moose::Util::TypeConstraints->import($pkg); + + # make a subtype for each Moose class + Moose::Util::TypeConstraints::subtype($pkg + => Moose::Util::TypeConstraints::as Object + => Moose::Util::TypeConstraints::where { $_->isa($pkg) } + ); my $meta; if ($pkg->can('meta')) { @@ -71,13 +77,11 @@ sub import { } } if (exists $options{isa}) { - if (reftype($options{isa}) && reftype($options{isa}) eq 'CODE') { + if (reftype($options{isa}) && reftype($options{isa}) eq 'CODE') { $options{type_constraint} = $options{isa}; } else { - $options{type_constraint} = Moose::Util::TypeConstraints::subtype( - Object => Moose::Util::TypeConstraints::where { $_->isa($options{isa}) } - ); + $options{type_constraint} = Moose::Util::TypeConstraints::find_type_constraint($options{isa}); } } $meta->add_attribute($name, %options) @@ -122,8 +126,8 @@ Moose - Moose, it's the new Camel package Point; use Moose; - has 'x' => (isa => Int(), is => 'rw'); - has 'y' => (isa => Int(), is => 'rw'); + has 'x' => (isa => 'Int', is => 'rw'); + has 'y' => (isa => 'Int', is => 'rw'); sub clear { my $self = shift; @@ -136,7 +140,7 @@ Moose - Moose, it's the new Camel extends 'Point'; - has 'z' => (isa => Int()); + has 'z' => (isa => 'Int'); after 'clear' => sub { my $self = shift; diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 6c65523..3e6a854 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -14,60 +14,75 @@ sub import { my $pkg = shift || caller(); return if $pkg eq ':no_export'; no strict 'refs'; - foreach my $export (qw( - type subtype as where - )) { + foreach my $export (qw(type subtype coerce as where to)) { *{"${pkg}::${export}"} = \&{"${export}"}; - } - - foreach my $constraint (qw( - Any - Value Ref - Str Int - ScalarRef ArrayRef HashRef CodeRef RegexpRef - Object - )) { - *{"${pkg}::${constraint}"} = \&{"${constraint}"}; } - } -my %TYPES; +{ + my %TYPES; + sub find_type_constraint { + my $type_name = shift; + $TYPES{$type_name}; + } + + sub register_type_constraint { + my ($type_name, $type_constraint) = @_; + $TYPES{$type_name} = $type_constraint; + } + + sub export_type_contstraints_as_functions { + my $pkg = caller(); + no strict 'refs'; + foreach my $constraint (keys %TYPES) { + *{"${pkg}::${constraint}"} = $TYPES{$constraint}; + } + } +} + +{ + my %COERCIONS; + sub find_type_coercion { + my $type_name = shift; + $COERCIONS{$type_name}; + } + + sub register_type_coercion { + my ($type_name, $type_coercion) = @_; + $COERCIONS{$type_name} = $type_coercion; + } +} -#sub find_type_constraint { $TYPES{$_[0]} } sub type ($$) { my ($name, $check) = @_; - my $pkg = caller(); - my $full_name = "${pkg}::${name}"; - no strict 'refs'; - *{$full_name} = $TYPES{$name} = subname $full_name => sub { - return $TYPES{$name} unless defined $_[0]; + my $full_name = caller() . "::${name}"; + register_type_constraint($name => subname $full_name => sub { + return find_type_constraint($name) unless defined $_[0]; local $_ = $_[0]; return undef unless $check->($_[0]); $_[0]; - }; + }); } sub subtype ($$;$) { my ($name, $parent, $check) = @_; if (defined $check) { - my $pkg = caller(); - my $full_name = "${pkg}::${name}"; - no strict 'refs'; - $parent = $TYPES{$parent} unless $parent && ref($parent) eq 'CODE'; - *{$full_name} = $TYPES{$name} = subname $full_name => sub { - return $TYPES{$name} unless defined $_[0]; + my $full_name = caller() . "::${name}"; + $parent = find_type_constraint($parent) + unless $parent && ref($parent) eq 'CODE'; + register_type_constraint($name => subname $full_name => sub { + return find_type_constraint($name) unless defined $_[0]; local $_ = $_[0]; return undef unless defined $parent->($_[0]) && $check->($_[0]); $_[0]; - }; + }); } else { ($parent, $check) = ($name, $parent); - $parent = $TYPES{$parent} unless $parent && ref($parent) eq 'CODE'; - return subname '__anon_subtype__' => sub { - return $TYPES{$name} unless defined $_[0]; + $parent = find_type_constraint($parent) + unless $parent && ref($parent) eq 'CODE'; + return subname '__anon_subtype__' => sub { local $_ = $_[0]; return undef unless defined $parent->($_[0]) && $check->($_[0]); $_[0]; @@ -75,8 +90,16 @@ sub subtype ($$;$) { } } +sub coerce { + my ($type_name, %coercion_map) = @_; + register_type_coercion($type_name, sub { + %coercion_map + }); +} + sub as ($) { $_[0] } sub where (&) { $_[0] } +sub to (&) { $_[0] } # define some basic types @@ -153,6 +176,22 @@ Suggestions for improvement are welcome. =head1 FUNCTIONS +=head2 Type Constraint Registry + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + =head2 Type Constraint Constructors =over 4 @@ -165,6 +204,10 @@ Suggestions for improvement are welcome. =item B +=item B + +=item B + =back =head2 Built-in Type Constraints diff --git a/t/001_basic.t b/t/001_basic.t index 8f8acb9..49430ff 100644 --- a/t/001_basic.t +++ b/t/001_basic.t @@ -16,8 +16,8 @@ BEGIN { use warnings; use Moose; - has 'x' => (isa => Int(), is => 'ro'); - has 'y' => (isa => Int(), is => 'rw'); + has 'x' => (isa => 'Int', is => 'ro'); + has 'y' => (isa => 'Int', is => 'rw'); sub clear { my $self = shift; @@ -32,7 +32,7 @@ BEGIN { extends 'Point'; - has 'z' => (isa => Int()); + has 'z' => (isa => 'Int'); after 'clear' => sub { my $self = shift; diff --git a/t/002_basic.t b/t/002_basic.t index 1b6cc30..4d3943b 100644 --- a/t/002_basic.t +++ b/t/002_basic.t @@ -16,7 +16,7 @@ BEGIN { use warnings; use Moose; - has 'balance' => (isa => Int(), is => 'rw', default => 0); + has 'balance' => (isa => 'Int', is => 'rw', default => 0); sub deposit { my ($self, $amount) = @_; diff --git a/t/004_basic.t b/t/004_basic.t index a111d6c..e5a9665 100644 --- a/t/004_basic.t +++ b/t/004_basic.t @@ -42,17 +42,17 @@ BEGIN { /^$RE{zip}{US}{-extended => 'allow'}$/ }; - has 'street' => (is => 'rw', isa => Str()); - has 'city' => (is => 'rw', isa => Str()); - has 'state' => (is => 'rw', isa => USState()); - has 'zip_code' => (is => 'rw', isa => USZipCode()); + has 'street' => (is => 'rw', isa => 'Str'); + has 'city' => (is => 'rw', isa => 'Str'); + has 'state' => (is => 'rw', isa => 'USState'); + has 'zip_code' => (is => 'rw', isa => 'USZipCode'); package Company; use strict; use warnings; use Moose; - has 'name' => (is => 'rw', isa => Str()); + has 'name' => (is => 'rw', isa => 'Str'); has 'address' => (is => 'rw', isa => 'Address'); has 'employees' => (is => 'rw', isa => subtype ArrayRef => where { ($_->isa('Employee') || return) for @$_; 1 @@ -74,9 +74,9 @@ BEGIN { use warnings; use Moose; - has 'first_name' => (is => 'rw', isa => Str()); - has 'last_name' => (is => 'rw', isa => Str()); - has 'middle_initial' => (is => 'rw', isa => Str(), predicate => 'has_middle_initial'); + has 'first_name' => (is => 'rw', isa => 'Str'); + has 'last_name' => (is => 'rw', isa => 'Str'); + has 'middle_initial' => (is => 'rw', isa => 'Str', predicate => 'has_middle_initial'); has 'address' => (is => 'rw', isa => 'Address'); sub full_name { @@ -93,7 +93,7 @@ BEGIN { extends 'Person'; - has 'title' => (is => 'rw', isa => Str()); + has 'title' => (is => 'rw', isa => 'Str'); has 'company' => (is => 'rw', isa => 'Company', weak_ref => 1); } diff --git a/t/050_util_type_constraints.t b/t/050_util_type_constraints.t index c9d6529..bf2cd57 100644 --- a/t/050_util_type_constraints.t +++ b/t/050_util_type_constraints.t @@ -22,6 +22,8 @@ subtype Natural subtype NaturalLessThanTen => as Natural => where { $_ < 10 }; + +Moose::Util::TypeConstraints::export_type_contstraints_as_functions(); is(Num(5), 5, '... this is a Num'); ok(!defined(Num('Foo')), '... this is not a Num'); diff --git a/t/051_util_type_constraints_export.t b/t/051_util_type_constraints_export.t index b970a94..065fc12 100644 --- a/t/051_util_type_constraints_export.t +++ b/t/051_util_type_constraints_export.t @@ -25,6 +25,8 @@ BEGIN { }; ::ok(!$@, '... successfully exported &subtype to Foo package'); + Moose::Util::TypeConstraints::export_type_contstraints_as_functions(); + ::ok(MyRef({}), '... Ref worked correctly'); ::ok(MyArrayRef([]), '... ArrayRef worked correctly'); } \ No newline at end of file diff --git a/t/052_util_std_type_constraints.t b/t/052_util_std_type_constraints.t index 843c891..790b999 100644 --- a/t/052_util_std_type_constraints.t +++ b/t/052_util_std_type_constraints.t @@ -14,6 +14,8 @@ BEGIN { my $SCALAR_REF = \(my $var); +Moose::Util::TypeConstraints::export_type_contstraints_as_functions(); + ok(defined Any(0), '... Any accepts anything'); ok(defined Any(100), '... Any accepts anything'); ok(defined Any(''), '... Any accepts anything'); diff --git a/t/053_util_find_type_constraint.t b/t/053_util_find_type_constraint.t new file mode 100644 index 0000000..242abf9 --- /dev/null +++ b/t/053_util_find_type_constraint.t @@ -0,0 +1,12 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; +use Test::Exception; + +BEGIN { + use_ok('Moose::Util::TypeConstraints', (':no_export')); +} + diff --git a/t/054_util_type_coercion.t b/t/054_util_type_coercion.t new file mode 100644 index 0000000..5b9b62e --- /dev/null +++ b/t/054_util_type_coercion.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 6; +use Test::Exception; + +BEGIN { + use_ok('Moose::Util::TypeConstraints'); +} + +{ + package HTTPHeader; + use strict; + use warnings; + use Moose; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); +} + +subtype Header => + => as Object + => where { $_->isa('HTTPHeader') }; + +coerce Header + => as ArrayRef + => to { HTTPHeader->new(array => $_[0]) } + => as HashRef + => to { HTTPHeader->new(hash => $_[0]) }; + +Moose::Util::TypeConstraints::export_type_contstraints_as_functions(); + +my $header = HTTPHeader->new(); +isa_ok($header, 'HTTPHeader'); + +ok(Header($header), '... this passed the type test'); +ok(!Header([]), '... this did not pass the type test'); +ok(!Header({}), '... this did not pass the type test'); + +my $coercion = Moose::Util::TypeConstraints::find_type_coercion('Header'); +is(ref($coercion), 'CODE', '... got the right type of coercion'); + +#{ +# my $coerced = $coercion->([ 1, 2, 3 ]); +# isa_ok($coerced, 'HTTPHeader'); +# +# is_deeply( +# $coerced->array(), +# [ 1, 2, 3 ], +# '... got the right array'); +# is($coerced->hash(), undef, '... nothing assigned to the hash'); +#} +# +#{ +# my $coerced = $coercion->({ one => 1, two => 2, three => 3 }); +# isa_ok($coerced, 'HTTPHeader'); +# +# is_deeply( +# $coerced->hash(), +# { one => 1, two => 2, three => 3 }, +# '... got the right hash'); +# is($coerced->array(), undef, '... nothing assigned to the array'); +#}