File Coverage

blib/lib/MouseX/Types.pm

Criterion	Covered	Total	%
statement	94	96	97.9
branch	12	14	85.7
condition	6	11	54.5
subroutine	25	25	100.0
pod			n/a
total	137	146	93.8

package MouseX::Types;
use 5.006_002;
use Mouse::Exporter; # turns on strict and warnings

our $VERSION = '0.06';

use Mouse::Util::TypeConstraints ();

sub import {
    my($class, %args) = @_;

    my $type_class = caller;

    {
        no strict 'refs';
        *{$type_class . '::import'} = \&_initialize_import;
        push @{$type_class . '::ISA'}, 'MouseX::Types::Base';
    }

    if(my $declare = $args{-declare}){
        if(ref($declare) ne 'ARRAY'){
            Carp::croak("You must pass an ARRAY reference to -declare");
        }
        my $storage = $type_class->type_storage();
        for my $name (@{ $declare }) {
            my $fq_name = $storage->{$name} = $type_class . '::' . $name;

            my $type = sub {
                my $obj = Mouse::Util::TypeConstraints::find_type_constraint($fq_name);
                if($obj){
                    my $type = $type_class->_generate_type($obj);

                    no strict 'refs';
                    no warnings 'redefine';
                    *{$fq_name} = $type;

                    return &{$type};
                 }
                 return $fq_name;
            };

            no strict;
            *{$fq_name} = $type;
        }
    }

    Mouse::Util::TypeConstraints->import({ into => $type_class });
}

sub _initialize_import {
    my $type_class = $_[0];

    my $storage = $type_class->type_storage;

    my @exporting;

    for my $name ($type_class->type_names) {
        my $fq_name = $storage->{$name}
            || Carp::croak(qq{"$name" is not exported by $type_class});

        my $obj = Mouse::Util::TypeConstraints::find_type_constraint($fq_name)
            || Carp::croak(qq{"$name" is declared but not defined in $type_class});

        push @exporting, $name, 'is_' . $name;

        no strict 'refs';
        no warnings 'redefine';
        *{$type_class . '::'    . $name} = $type_class->_generate_type($obj);
        *{$type_class . '::is_' . $name} = $obj->_compiled_type_constraint;
    }

    my($import, $unimport) = Mouse::Exporter->build_import_methods(
        exporting_package => $type_class,
        as_is             => \@exporting,
        groups            => { default => [] },
    );

    no warnings 'redefine';
    no strict 'refs';
    *{$type_class . '::import'}   = $import;   # redefine myself!
    *{$type_class . '::unimport'} = $unimport;

    goto &{$import};
}


{
    package MouseX::Types::Base;
    my %storage;
    sub type_storage { # can be overriden
        return $storage{$_[0]} ||= +{}
    }

    sub type_names {
        my($class) = @_;
        return keys %{$class->type_storage};
    }

    sub _generate_type {
        my($type_class, $type_constraint) = @_;
        return sub {
            if(@_){ # parameterization
                my $param = shift;
                if(!(ref($param) eq 'ARRAY' && @{$param} == 1)){
                    Carp::croak("Syntax error using type $type_constraint (you must pass an ARRAY reference of a parameter type)");
                }
                if(wantarray){
                    return( $type_constraint->parameterize(@{$param}), @_ );
                }
                else{
                    if(@_){
                        Carp::croak("Too many arguments for $type_constraint");
                    }
                    return $type_constraint->parameterize(@{$param});
                }
            }
            else{
                return $type_constraint;
            }
        };
    }
}

1;
__END__