File Coverage

lib/Class/Dot/Meta/Type.pm

Criterion	Covered	Total	%
statement	44	49	89.8
branch	6	10	60.0
condition			n/a
subroutine	17	19	89.4
pod	0	1	0.0
total	67	79	84.8

# $Id$
# $Source$
# $Author$
# $HeadURL$
# $Revision$
# $Date$
package Class::Dot::Meta::Type;

use strict;
use warnings;
use version;
use 5.00600;

use Carp qw(croak);
use Scalar::Util qw(blessed);

use Class::Dot::Meta::Method qw(install_sub_from_class);

use Class::Dot::Devel::Sub::Name qw(subname);

our $VERSION   = qv('2.0.0_15');
our $AUTHORITY = 'cpan:ASKSH';

my %EXPORT_OK  = map { $_ => 1 } qw(
    create_type_instance
    _NEWSCHOOL_TYPE _OLDSCHOOL_TYPE
);

# All type classes inherits from this.
my $TYPE_BASE_CLASS = 'Class::Dot::Type';

sub import {
    my ($this_class, @subs) = @_;
    my $caller_class = caller 0;

    for my $sub (@subs) {
        if (! exists $EXPORT_OK{$sub}) {
            croak "$sub is not exported by " . __PACKAGE__;
        }
        install_sub_from_class($this_class, $sub => $caller_class);
    }

    return;
}

sub _NEWSCHOOL_TYPE {
    my ($type_var) = @_;
    return if not blessed $type_var;
    return if not $type_var->isa($TYPE_BASE_CLASS);
    return 1;
}

sub _OLDSCHOOL_TYPE {
    my ($type_var) = @_;
    return if not ref $type_var eq 'CODE';
    return 1;
}

sub create_type_instance {
    my ($type, $isa, $constraint, $linear_isa_ref) = @_;
    $constraint = defined $constraint ? $constraint
        : sub { };

    my $metaclass = Class::Dot::Meta::Class->new();

    my $full_class_name = $metaclass->subclass_name($TYPE_BASE_CLASS, $type);

    $metaclass->create_class($full_class_name, {
            default_value   =>
                (subname "${full_class_name}::default_value" => sub {
                    my ($self)  = @_;
                    my $sub_ref = $self->__isa__;
                    return $sub_ref->();
            }),
        },
        [ $TYPE_BASE_CLASS ],
    );

    my $type_instance = $full_class_name->new({
        type        => $type,
        linear_isa  => $linear_isa_ref,
        __isa__     => $isa,
        constraint  => $constraint,
    });

    return $type_instance;
}

1;

__END__