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')) {
}
}
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)
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;
extends 'Point';
- has 'z' => (isa => Int());
+ has 'z' => (isa => 'Int');
after 'clear' => sub {
my $self = shift;
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];
}
}
+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
=head1 FUNCTIONS
+=head2 Type Constraint Registry
+
+=over 4
+
+=item B<find_type_constraint ($type_name)>
+
+=item B<register_type_constraint ($type_name, $type_constraint)>
+
+=item B<find_type_coercion>
+
+=item B<register_type_coercion>
+
+=item B<export_type_contstraints_as_functions>
+
+=back
+
=head2 Type Constraint Constructors
=over 4
=item B<where>
+=item B<coerce>
+
+=item B<to>
+
=back
=head2 Built-in Type Constraints
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;
extends 'Point';
- has 'z' => (isa => Int());
+ has 'z' => (isa => 'Int');
after 'clear' => sub {
my $self = shift;
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) = @_;
/^$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
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 {
extends 'Person';
- has 'title' => (is => 'rw', isa => Str());
+ has 'title' => (is => 'rw', isa => 'Str');
has 'company' => (is => 'rw', isa => 'Company', weak_ref => 1);
}
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');
};
::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
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');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose::Util::TypeConstraints', (':no_export'));
+}
+
--- /dev/null
+#!/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');
+#}
projects / gitmo/Moose.git / commitdiff