File Coverage

blib/lib/mop/class.pm

Criterion	Covered	Total	%
statement	85	88	96.5
branch	14	16	87.5
condition	8	11	72.7
subroutine	16	17	94.1
pod	9	9	100.0
total	132	141	93.6

package mop::class;

use v5.16;
use warnings;

use mop::internals::util;

our $VERSION   = '0.03';
our $AUTHORITY = 'cpan:STEVAN';

use parent 'mop::role';

mop::internals::util::init_attribute_storage(my %superclass);
mop::internals::util::init_attribute_storage(my %is_abstract);
mop::internals::util::init_attribute_storage(my %instance_generator);

sub superclass         { ${ $superclass{ $_[0] }         // \undef } }
sub is_abstract        { ${ $is_abstract{ $_[0] }        // \undef } }
sub instance_generator { ${ $instance_generator{ $_[0] } // \undef } }

sub make_class_abstract    { $is_abstract{ $_[0] }        = \1     }
sub set_instance_generator { $instance_generator{ $_[0] } = \$_[1] }

# temporary, for bootstrapping
sub new {
    my $class = shift;
    my %args  = @_;

    my $self = $class->SUPER::new( @_ );

    $is_abstract{ $self }        = \($args{'is_abstract'} // 0);
    $superclass{ $self }         = \($args{'superclass'});
    $instance_generator{ $self } = \(sub { \(my $anon) });

    $self;
}

sub BUILD {
    my $self = shift;

    mop::internals::util::install_meta($self);

    if (my @nometa = grep { !mop::meta($_) } @{ $self->roles }) {
        die "No metaclass found for these roles: @nometa";
    }

    if ($self->superclass && (my $meta = mop::meta($self->superclass))) {
        $self->set_instance_generator($meta->instance_generator);

        # merge required methods with superclass
        $self->add_required_method($_)
            for $meta->required_methods;

        mop::apply_metaclass($self, $meta);
    }
    else {
        mop::internals::util::mark_nonmop_class($self->superclass)
            if $self->superclass;
    }
}

sub new_fresh_instance {
    my $self = shift;
    my $instance = bless $self->instance_generator->(), $self->name;
    mop::internals::util::register_object($instance);
    return $instance;
}

sub new_instance {
    my $self = shift;
    my (%args) = @_;

    die 'Cannot instantiate abstract class (' . $self->name . ')'
        if $self->is_abstract;

    my $instance = $self->new_fresh_instance;

    my %attributes = map {
        if (my $m = mop::meta($_)) {
            %{ $m->attribute_map }
        }
        else {
            ()
        }
    } reverse @{ mro::get_linear_isa($self->name) };

    foreach my $attr (values %attributes) {
        if ( exists $args{ $attr->key_name }) {
            $attr->store_data_in_slot_for( $instance, $args{ $attr->key_name } )
        } else {
            $attr->store_default_in_slot_for( $instance );
        }
    }

    mop::internals::util::buildall($instance, \%args);

    return $instance;
}

sub clone_instance {
    my $self = shift;
    my ($instance, %args) = @_;

    my $attributes = {
        map {
            if (my $m = mop::meta($_)) {
                %{ $m->attribute_map }
            }
        } reverse @{ mro::get_linear_isa($self->name) }
    };

    %args = (
        (map {
            my $attr = $attributes->{$_};
            $attr->has_data_in_slot_for($instance)
                ? ($attr->key_name => $attr->fetch_data_in_slot_for($instance))
                : ()
        } grep {
            !exists $args{ $_ }
        } keys %$attributes),
        %args,
    );

    my $clone = $self->new_instance(%args);

    return $clone;
}

sub __INIT_METACLASS__ {
    my $METACLASS = mop::class->new(
        name       => 'mop::class',
        version    => $VERSION,
        authority  => $AUTHORITY,
        superclass => 'mop::object',
    );

    $METACLASS->add_attribute(mop::attribute->new(
        name    => '$!superclass',
        storage => \%superclass,
    ));
    $METACLASS->add_attribute(mop::attribute->new(
        name    => '$!is_abstract',
        storage => \%is_abstract,
        default => 0,
    ));
    $METACLASS->add_attribute(mop::attribute->new(
        name    => '$!instance_generator',
        storage => \%instance_generator,
        default => sub { sub { \(my $anon) } },
    ));

    $METACLASS->add_method( mop::method->new( name => 'BUILD', body => \&BUILD ) );

    $METACLASS->add_method( mop::method->new( name => 'superclass', body => \&superclass ) );

    $METACLASS->add_method( mop::method->new( name => 'is_abstract',         body => \&is_abstract         ) );
    $METACLASS->add_method( mop::method->new( name => 'make_class_abstract', body => \&make_class_abstract ) );

    $METACLASS->add_method( mop::method->new( name => 'instance_generator',     body => \&instance_generator     ) );
    $METACLASS->add_method( mop::method->new( name => 'set_instance_generator', body => \&set_instance_generator ) );
    $METACLASS->add_method( mop::method->new( name => 'new_fresh_instance',     body => \&new_fresh_instance     ) );

    $METACLASS->add_method( mop::method->new( name => 'new_instance',   body => \&new_instance   ) );
    $METACLASS->add_method( mop::method->new( name => 'clone_instance', body => \&clone_instance ) );

    $METACLASS;
}

1;

__END__