recursion test

[gitmo/MooseX-Types.git] / lib / MooseX / Types / TypeDecorator.pm

diff --git a/lib/MooseX/Types/TypeDecorator.pm b/lib/MooseX/Types/TypeDecorator.pm
index 1d9d776..519cad7 100644 (file)
--- a/lib/MooseX/Types/TypeDecorator.pm
+++ b/lib/MooseX/Types/TypeDecorator.pm
@@ -1,16 +1,32 @@
 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;  
+        return shift->__type_constraint->name; 
+    },
+    '|' => 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
 
 MooseX::Types::TypeDecorator - More flexible access to a Type Constraint
@@ -20,51 +36,111 @@ MooseX::Types::TypeDecorator - More flexible access to a Type Constraint
 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 = 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.
 
-=head2 MooseX::Types::UndefinedType
+=cut
+
+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';
+    }
+}
 
-Used since sometimes our constraint is an unknown type.
+=head2 isa
+
+handle $self->isa since AUTOLOAD can't.
 
 =cut
 
-Moose::Util::TypeConstraints::class_type 'MooseX::Types::UndefinedType';
+sub isa {
+    my ($self, $target) = @_;  
+    if(defined $target) {
+        return $self->__type_constraint->isa($target);
+    } else {
+        return;
+    }
+}
 
-=head1 ATTRIBUTES
+=head2 can
 
-This class defines the following attributes
+handle $self->can since AUTOLOAD can't.
 
-=head2 type_constraint
+=cut
 
-This is the type constraint that we are delegating
+sub can {
+    my ($self, $target) = @_;
+    if(defined $target) {
+        return $self->__type_constraint->can($target);
+    } else {
+        return;
+    }
+}
+
+=head2 DESTROY
+
+We might need it later
 
 =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 DESTROY {
+    return;
+}
 
-=head1 METHODS
+=head2 AUTOLOAD
 
-This class defines the following methods.
+Delegate to the decorator targe
+
+=cut
+
+sub AUTOLOAD {
+    my ($self, @args) = @_;
+    my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
+    if($self->__type_constraint->can($method)) {
+        return $self->__type_constraint->$method(@args);
+    } else {
+        croak "Method '$method' is not supported for ". ref($self->__type_constraint);   
+    }
+}
 
 =head1 AUTHOR AND COPYRIGHT