File Coverage

lib/Class/Dot/Meta/Class.pm

Criterion	Covered	Total	%
statement	147	173	84.9
branch	38	48	79.1
condition	4	5	80.0
subroutine	37	41	90.2
pod	0	14	0.0
total	226	281	80.4

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

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

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

use Carp qw(carp croak confess);
use Params::Util qw(_ARRAYLIKE _HASHLIKE);
use Class::Plugin::Util qw(require_class);
use Scalar::Util qw(blessed);

use Class::Dot::Registry;
our $REGISTRY = Class::Dot::Registry->new();

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

use Class::Dot::Devel::Sub::Name;

# Try to load the mro module available in recent perl's.
if (!defined $INC{'mro.pm'}) {
    no warnings 'all';      ## no critic
    eval 'require mro';     ## no critic
}

my $COMMON_BASE_CLASS = 'Class::Dot::Object';

# ------------------------------ CONSTRUCTOR  --------------------------- #
sub new {
    my ($class, $options_ref) = @_;
    $options_ref ||= { };

    if (! $options_ref->{property}) {
        $options_ref->{property} = Class::Dot::Meta::Property->new();
    }

    my $self = bless { %{$options_ref} }, $class;

    if (exists $options_ref->{for_class}) {
        my %init_methods; # initial class methods to be installed.

        # Make the class inherit from the common object base class.
        my $for_class = $options_ref->{for_class};
        $self->append_superclasses_for($for_class, $COMMON_BASE_CLASS);

        # Create constructor and destructor methods.

        if (not $options_ref->{'-no_constructor'}) {
            $init_methods{new} = $self->create_constructor($for_class);
        }
        $init_methods{DESTROY} = $self->create_destructor($for_class);

        # Install default methods to the new class.
        while (my ($method_name, $method_ref) = each %init_methods) {
            install_sub_from_coderef(
                $method_ref => $for_class, $method_name
            );
        }
    }

    return $self;
}

# ------------------------------ ATTRIBUTES ----------------------------- #

sub property {
    my ($self) = @_;
    return $self->{property};
}

sub set_property {
    my ($self, $property_obj) = @_;
    $self->{property} = $property_obj;
    return;
}

sub for_class {
    my ($self) = @_;
    return $self->{for_class};
}

sub set_for_class {
    my ($self, $class) = @_;
    $self->{for_class} = $class;
    return;
}

# ------------------------------ METHODS  ------------------------------- #
sub subclass_name {
    my ($self, $parent_class, $subclass_name) = @_;
    return join q{::}, $parent_class, $subclass_name;
}

my $created_classes = { };
sub create_class {
    my ($self, $class_name, $methods_ref, $append_isa_ref, $version) = @_;
    return if exists $created_classes->{$class_name};

    $version = defined $version ? $version
        : 1.0;

    no strict   'refs';     ## no critic
    no warnings 'redefine'; ## no critic

    if (_ARRAYLIKE($append_isa_ref)) {
        my $isa_ref = \@{ "${class_name}::ISA" };
        push @{ $isa_ref }, @{ $append_isa_ref };
    }

    if (_HASHLIKE($methods_ref)) {
        while (my ($method_name, $method_code) = each %{ $methods_ref }) {
            *{ "${class_name}::$method_name" } = $method_code;
        }
    }

    ${ "${class_name}::VERSION" } = $version;

    $created_classes->{$class_name} = 1;

    return;
}

sub append_superclasses_for {
    my ($self, $inheritor, @superclasses) = @_;

    my $options_ref;
    if (_HASHLIKE($superclasses[-1])) {
        $options_ref = pop @superclasses;
    }

    $options_ref->{append} = 1;

    return $self->superclasses_for(
        $inheritor, @superclasses, $options_ref
    );
}

sub superclasses_for {
    my ($self, $inheritor, @superclasses) = @_;
    my @final_isa;

    # If the last element of @superclasses is a hashref
    # it is considered options for this method.
    my $options_ref = { };
    if (_HASHLIKE($superclasses[-1])) {
        $options_ref = pop @superclasses;
    }

    no strict 'refs'; ## no critic

    SUPERCLASS:
    for my $base (@superclasses) {
        if ($inheritor eq $base) {
            carp "Class '$inheritor' tried to inherit from itself.";
            next SUPERCLASS;
        }

        next SUPERCLASS if $inheritor->isa($base);

        if (!require_class($base)) {
            croak "Couldn't load base class '$base'\n";
        }

        push @final_isa, $base;
    }

    # Append to the existing ISA if the "append" option is set
    # (this is used by the {append_superclasses_for()} method).
    if($options_ref->{append}) {
        push @final_isa, @{ "$inheritor\::ISA" };
    }

    # Setting all base classes as one is an optimization
    # over pushing them one for one, atleast in perl > 5.9.5.
    # see `perldoc mro` for more information.
    @{ "$inheritor\::ISA" } = @final_isa;

    return;
}

sub _get_linear_isa_pureperl {
    my ($self, $class) = @_;

    my @stream = $class;
    my @final;
    my %seen;

    no strict 'refs'; ## no critic
    STREAM:
    while (defined (my $atom = shift @stream)) {
        my @isa = @{ "$atom\::ISA" };
        my @keep;

        ISA:
        for my $isa_class (@isa) {
            next ISA if exists $seen{$isa_class};
            $seen{$isa_class} = 1;
            push @final, $isa_class;
            push @stream, $isa_class;
        }
    }

    unshift @final, $class;
    return \@final;
}

sub get_linear_isa {
    my ($self, $class) = @_;
    my $isa = defined $mro::VERSION ? mro::get_linear_isa($class)
            : $self->_get_linear_isa_pureperl($class);

    return $isa;
}

sub metaclass_for {
    my ($self, $other) = @_;
    confess   'Need the class name or an instance of the '
            . 'class you want metaclass for'
        if not defined $other;

    my $other_class = ref $other ? ref $other
        : $other;

    return $REGISTRY->get_metaclass_for($other);
}

sub composites {
    my ($self, $attribute_name, $composite_class) = @_;
    my $property = $self->property;
    my $for_class = $self->for_class;

    return $property->composites_for(
        ($for_class, $attribute_name) => $composite_class
    );
}

sub create_constructor {
    my ($self, $caller_class) = @_;
    my $options = $REGISTRY->get_options_for($caller_class);

    return subname "${caller_class}::new" => sub { ## no critic
        my $class = shift @_;

        my $has_options = (
                defined $_[0]
            &&  ref     $_[0]
            &&  ref     $_[0] eq 'HASH'
        );

        my $options_ref = $has_options ? shift @_
                                    : { };

        my $self;
        if ($options->{'-optimized'}) {
            $self = bless {%{ $options_ref }}, $class;
        }
        else {
            $self = bless { }, $class;
            OPTION:
            while (my ($opt_key, $opt_value) = each %{$options_ref}) {
                #my $attr_meta = $self->__meta__($opt_key);
                #next OPTION if not $attr_meta;
                #my $set_attr  = $attr_meta->setter_name;
                #$set_attr   ||= "set_$opt_key";

                #if ($self->can($set_attr)) {
                #    $self->$set_attr($opt_value);
                #}
                $self->__setattr__($opt_key, $opt_value);
            }
        }

        if ($self->can('BUILD')) {
            my $ret = $self->BUILD(
                $has_options ? $options_ref
                             : @_
            );
            if ($options->{'-rebuild'}) {
                if (ref $ret) {
                    $self = $ret;
                }
            }
        }

        return $self;
    }
}

sub create_destructor {
    my ($self, $caller_class) = @_;

    return subname "${caller_class}::DESTROY" => sub {
        my ($self) = @_;

        if ($self->can('DEMOLISH')) {
            $self->DEMOLISH();
        }

        return;
    }
}

1;

__END__