package MooseX::Types::TypeDecorator;
-use Moose;
+use strict;
+use warnings;
+
+
+use Carp::Clan qw( ^MooseX::Types );
use Moose::Util::TypeConstraints ();
-use Moose::Meta::TypeConstraint ();
+use Moose::Meta::TypeConstraint::Union;
+use Scalar::Util qw(blessed);
use overload(
'""' => sub {
- shift->type_constraint->name;
+ my $self = shift @_;
+ if(blessed $self) {
+ return $self->__type_constraint->name;
+ } else {
+ return "$self";
+ }
+ },
+ '|' => sub {
+
+ ## It's kind of ugly that we need to know about Union Types, but this
+ ## is needed for syntax compatibility. Maybe someday we'll all just do
+ ## Or[Str,Str,Int]
+
+ my @tc = grep {blessed $_} @_;
+ my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc);
+ return Moose::Util::TypeConstraints::register_type_constraint($union);
},
- '&' => sub {warn 'got code context'},
+ fallback => 1,
+
);
=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
+
+This class defines the following methods.
+
+=head2 new
-The following types are defined in this class.
+Old school instantiation
-=head2 Moose::Meta::TypeConstraint
+=cut
-Used to make sure we can properly validate incoming type constraints.
+sub new {
+ my $class = shift @_;
+ if(my $arg = shift @_) {
+ if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) {
+ return bless {'__type_constraint'=>$arg}, $class;
+ } elsif(
+ blessed $arg &&
+ $arg->isa('MooseX::Types::UndefinedType')
+ ) {
+ ## stub in case we'll need to handle these types differently
+ return bless {'__type_constraint'=>$arg}, $class;
+ } elsif(blessed $arg) {
+ croak "Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg;
+ } else {
+ croak "Argument cannot be '$arg'";
+ }
+ } else {
+ croak "This method [new] requires a single argument.";
+ }
+}
+
+=head __type_constraint ($type_constraint)
+
+Set/Get the type_constraint.
=cut
-Moose::Util::TypeConstraints::class_type 'Moose::Meta::TypeConstraint';
+sub __type_constraint {
+ my $self = shift @_;
+ if(blessed $self) {
+ if(defined(my $tc = shift @_)) {
+ $self->{__type_constraint} = $tc;
+ }
+ return $self->{__type_constraint};
+ } else {
+ croak 'cannot call __type_constraint as a class method';
+ }
+}
-=head2 MooseX::Types::UndefinedType
+=head2 isa
-Used since sometimes our constraint is an unknown type.
+handle $self->isa since AUTOLOAD can't.
=cut
-Moose::Util::TypeConstraints::class_type 'MooseX::Types::UndefinedType';
+sub isa {
+ my ($self, $target) = @_;
+ if(defined $target) {
+ if(blessed $self) {
+ return $self->__type_constraint->isa($target);
+ } else {
+ return;
+ }
+ } else {
+ return;
+ }
+}
+
+=head2 can
-=head1 ATTRIBUTES
+handle $self->can since AUTOLOAD can't.
-This class defines the following attributes
+=cut
+
+sub can {
+ my ($self, $target) = @_;
+ if(defined $target) {
+ if(blessed $self) {
+ return $self->__type_constraint->can($target);
+ } else {
+ return;
+ }
+ } else {
+ return;
+ }
+}
-=head2 type_constraint
+=head2 meta
-This is the type constraint that we are delegating
+have meta examine the underlying type constraints
=cut
-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,
- ],
-);
+sub meta {
+ my $self = shift @_;
+ if(blessed $self) {
+ return $self->__type_constraint->meta;
+ }
+}
-=head1 METHODS
-This class defines the following methods.
+=head2 DESTROY
+
+We might need it later
+
+=cut
+
+sub DESTROY {
+ return;
+}
+
+=head2 AUTOLOAD
+
+Delegate to the decorator targe
+
+=cut
+
+sub AUTOLOAD {
+
+ my ($self, @args) = @_;
+ my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
+
+ ## We delegate with this method in an attempt to support a value of
+ ## __type_constraint which is also AUTOLOADing, in particular the class
+ ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
+
+ my $return;
+
+ eval {
+ $return = $self->__type_constraint->$method(@args);
+ }; if($@) {
+ croak $@;
+ } else {
+ return $return;
+ }
+}
=head1 AUTHOR AND COPYRIGHT