=cut
-use Data::Dump qw/dump/;
-
sub type_export_generator {
- my ($class, $type, $full) = @_;
+ my ($class, $type, $name) = @_;
return sub {
- ## todo, this needs to be some sort of ->process_args on the actual
- ## containing type constraints. This is ugly proof of concept
- if(my $param = shift @_) {
- #my @tc_args = map { find_type_constraint($full) } @args;
- $full = $full .'['. $param->[0]->name .']';
+ my $type_constraint;
+ if(my $params = shift @_) {
+ $type_constraint = $class->create_arged_type_constraint($name, @$params);
+ } else {
+ $type_constraint = $class->create_base_type_constraint($name)
+ || MooseX::Types::UndefinedType->new($name);
}
-
- my $type_constraint = find_type_constraint($full)
- || MooseX::Types::UndefinedType->new($full);
-
- return MooseX::Types::TypeDecorator->new(type_constraint=>$type_constraint);
+ return $class->create_type_decorator($type_constraint);
};
}
+=head2 create_arged_type_constraint ($name, @args)
+
+Given a String $name with @args find the matching typeconstraint.
+
+=cut
+
+sub create_arged_type_constraint {
+ my ($class, $name, @args) = @_;
+ ### This whole section is a real TODO :) Ugly hack to get the base tests working.
+ my $fullname = $name."[$args[0]]";
+ return Moose::Util::TypeConstraints::create_parameterized_type_constraint($fullname);
+}
+
+=head2 create_base_type_constraint ($name)
+
+Given a String $name, find the matching typeconstraint.
+
+=cut
+
+sub create_base_type_constraint {
+ my ($class, $name) = @_;
+ return find_type_constraint($name);
+}
+
+=head2 create_type_decorator ($type_constraint)
+
+Given a $type_constraint, return a lightweight L<MooseX::Types::TypeDecorator>
+instance.
+
+=cut
+
+sub create_type_decorator {
+ my ($class, $type_constraint) = @_;
+ return MooseX::Types::TypeDecorator->new(type_constraint=>$type_constraint);
+}
+
=head2 coercion_export_generator
This generates a coercion handler function, e.g. C<to_Int($value)>.
package MooseX::Types::TypeDecorator;
-use Moose;
-use Moose::Util::TypeConstraints ();
-use Moose::Meta::TypeConstraint ();
+use strict;
+use warnings;
use overload(
'""' => sub {
shift->type_constraint->name;
},
- '&' => sub {warn 'got code context'},
);
=head1 NAME
This is a decorator object that contains an underlying type constraint. We use
this to control access to the type constraint and to add some features.
-=head1 TYPES
+=head1 METHODS
-The following types are defined in this class.
+This class defines the following methods.
-=head2 Moose::Meta::TypeConstraint
+=head2 new
-Used to make sure we can properly validate incoming type constraints.
+Old school instantiation
=cut
-Moose::Util::TypeConstraints::class_type 'Moose::Meta::TypeConstraint';
+sub new {
+ my ($class, %args) = @_;
+ return bless \%args, $class;
+}
-=head2 MooseX::Types::UndefinedType
+=head type_constraint ($type_constraint)
-Used since sometimes our constraint is an unknown type.
+Set/Get the type_constraint
=cut
-Moose::Util::TypeConstraints::class_type 'MooseX::Types::UndefinedType';
+sub type_constraint {
+ my $self = shift @_;
+ if(my $tc = shift @_) {
+ $self->{type_constraint} = $tc;
+ }
+ return $self->{type_constraint};
+}
-=head1 ATTRIBUTES
+=head2 DESTROY
-This class defines the following attributes
+We might need it later
-=head2 type_constraint
+=cut
-This is the type constraint that we are delegating
+sub DESTROY {
+ return;
+}
-=cut
+=head2 AUTOLOAD
-has 'type_constraint' => (
- is=>'ro',
- isa=>'Moose::Meta::TypeConstraint|MooseX::Types::UndefinedType',
- handles=>[
- grep {
- $_ ne 'meta' && $_ ne '(""';
- } map {
- $_->{name};
- } Moose::Meta::TypeConstraint->meta->compute_all_applicable_methods,
- ],
-);
+Delegate to the decorator targe
-=head1 METHODS
+=cut
-This class defines the following methods.
+sub AUTOLOAD
+{
+ my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
+ return shift->type_constraint->$method(@_);
+}
=head1 AUTHOR AND COPYRIGHT
use warnings;
use strict;
-use Test::More tests => 10;
+use Test::More tests => 26;
+use Test::Exception;
use FindBin;
use lib "$FindBin::Bin/lib";
package Test::MooseX::TypeLibrary::TypeDecorator;
use Moose;
+ use MooseX::Types::Moose qw(
+ Int
+ );
use DecoratorLibrary qw(
- MyArrayRefBase
- MyArrayRefInt01
- MyArrayRefInt02
+ MyArrayRefBase MyArrayRefInt01 MyArrayRefInt02
);
has 'arrayrefbase' => (is=>'rw', isa=>MyArrayRefBase, coerce=>1);
has 'arrayrefint01' => (is=>'rw', isa=>MyArrayRefInt01, coerce=>1);
+ has 'arrayrefint02' => (is=>'rw', isa=>MyArrayRefInt02, coerce=>1);
+ has 'arrayrefint03' => (is=>'rw', isa=>MyArrayRefBase[Int]);
}
## Make sure we have a 'create object sanity check'
=> 'Assigned arrayrefbase qw(a b c)';
is_deeply $type->arrayrefbase, [qw(a b c)],
- => 'Assigment is correct';
+ => 'Assignment is correct';
ok $type->arrayrefbase('d,e,f')
- => 'Assigned arrayrefbase d,e,f to test coercion';
+ => 'Assignment arrayrefbase d,e,f to test coercion';
is_deeply $type->arrayrefbase, [qw(d e f)],
- => 'Assigment and coercion is correct';
+ => 'Assignment and coercion is correct';
## test arrayrefint01 normal and coercion
ok $type->arrayrefint01([qw(1 2 3)])
- => 'Assigned arrayrefbase qw(1 2 3)';
+ => 'Assignment arrayrefint01 qw(1 2 3)';
is_deeply $type->arrayrefint01, [qw(1 2 3)],
- => 'Assigment is correct';
+ => 'Assignment is correct';
ok $type->arrayrefint01('4.5.6')
- => 'Assigned arrayrefbase 4.5.6 to test coercion from Str';
+ => 'Assigned arrayrefint01 4.5.6 to test coercion from Str';
is_deeply $type->arrayrefint01, [qw(4 5 6)],
- => 'Assigment and coercion is correct';
+ => 'Assignment and coercion is correct';
ok $type->arrayrefint01({a=>7,b=>8})
- => 'Assigned arrayrefbase {a=>7,b=>8} to test coercion from HashRef';
+ => 'Assigned arrayrefint01 {a=>7,b=>8} to test coercion from HashRef';
is_deeply $type->arrayrefint01, [qw(7 8)],
- => 'Assigment and coercion is correct';
+ => 'Assignment and coercion is correct';
+
+throws_ok sub {
+ $type->arrayrefint01([qw(a b c)])
+}, qr/Attribute \(arrayrefint01\) does not pass the type constraint/ => 'Dies when values are strings';
+
+## test arrayrefint02 normal and coercion
+
+ok $type->arrayrefint02([qw(1 2 3)])
+ => 'Assigned arrayrefint02 qw(1 2 3)';
+
+is_deeply $type->arrayrefint02, [qw(1 2 3)],
+ => 'Assignment is correct';
+
+ok $type->arrayrefint02('4:5:6')
+ => 'Assigned arrayrefint02 4:5:6 to test coercion from Str';
+
+is_deeply $type->arrayrefint02, [qw(4 5 6)],
+ => 'Assignment and coercion is correct';
+
+ok $type->arrayrefint02({a=>7,b=>8})
+ => 'Assigned arrayrefint02 {a=>7,b=>8} to test coercion from HashRef';
+
+is_deeply $type->arrayrefint02, [qw(7 8)],
+ => 'Assignment and coercion is correct';
+
+ok $type->arrayrefint02({a=>'AA',b=>'BBB', c=>'CCCCCCC'})
+ => "Assigned arrayrefint02 {a=>'AA',b=>'BBB', c=>'CCCCCCC'} to test coercion from HashRef";
+
+is_deeply $type->arrayrefint02, [qw(2 3 7)],
+ => 'Assignment and coercion is correct';
+
+ok $type->arrayrefint02({a=>[1,2],b=>[3,4]})
+ => "Assigned arrayrefint02 {a=>[1,2],b=>[3,4]} to test coercion from HashRef";
+
+is_deeply $type->arrayrefint02, [qw(1 2 3 4)],
+ => 'Assignment and coercion is correct';
+
+# test arrayrefint03
+
+ok $type->arrayrefint03([qw(11 12 13)])
+ => 'Assigned arrayrefint01 qw(11 12 13)';
+
+is_deeply $type->arrayrefint03, [qw(11 12 13)],
+ => 'Assignment is correct';
-#use Data::Dump qw/dump/;
-#warn dump MyArrayRefInt01;
-#warn dump MyArrayRefBase->validate('aaa,bbb,ccc');
+throws_ok sub {
+ $type->arrayrefint03([qw(a b c)])
+}, qr/Attribute \(arrayrefint03\) does not pass the type constraint/ => 'Dies when values are strings';
\ No newline at end of file
projects / gitmo/MooseX-Types.git / commitdiff