File Coverage

blib/lib/mop.pm

Criterion	Covered	Total	%
statement	186	191	97.3
branch	24	32	75.0
condition	6	14	42.8
subroutine	34	34	100.0
pod	10	10	100.0
total	260	281	92.5

package mop;

use v5.16;
use mro;
use warnings;

use overload ();
use Scalar::Util ();

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

our $BOOTSTRAPPED = 0;

use XSLoader;
XSLoader::load(__PACKAGE__, $VERSION);

use mop::object;
use mop::class;
use mop::method;
use mop::attribute;

use mop::internals::observable;

use mop::internals::syntax;
use mop::internals::util;

use mop::traits;
use mop::traits::util;

$Carp::Internal{$_}++ for qw/
  op
  mop
  mop::attribute
  mop::class
  mop::internals::observable
  mop::internals::syntax
  mop::internals::util
  mop::method
  mop::object
  mop::role
  mop::traits
  mop::traits::util
  /;

sub import {
    shift;
    my $pkg = caller;
    my %opts = @_;

    initialize();
    mop::internals::syntax::setup_for($pkg);
    mop::traits::setup_for($pkg);

    # NOTE: don't allow setting attribute or method metaclasses here, because
    # that is controlled by the class or role metaclass via method_class and
    # attribute_class.
    for my $type (qw(class role)) {
        if (defined(my $meta = $opts{"${type}_metaclass"})) {
            require(($meta =~ s{::}{/}gr) . '.pm');
            $^H{"mop/default_${type}_metaclass"} = $meta;
        }
    }
}

sub unimport {
    my $pkg = caller;
    mop::internals::syntax::teardown_for($pkg);
    mop::traits::teardown_for($pkg);
}

sub meta {
    my $pkg = ref($_[0]) || $_[0];
    mop::internals::util::get_meta($pkg);
}

sub remove_meta {
    my $pkg = ref($_[0]) || $_[0];
    mop::internals::util::unset_meta($pkg);
}

sub id { Hash::Util::FieldHash::id( $_[0] ) }

sub is_mop_object {
    defined Hash::Util::FieldHash::id_2obj( id( $_[0] ) );
}

sub apply_metaclass {
    # TODO: we should really not be calling apply_metaclass at all during
    # bootstrapping, but it's done in a couple places for simplicity, to avoid
    # needing multiple implementations of things for pre- and
    # post-bootstrapping. we should probably eventually actually do the
    # replacement in those methods, to make sure bootstrapping isn't doing
    # unnecessary extra work. the actual implementation is replaced below.
    return;
}

sub apply_metarole {
    my ($instance, $new_metarole) = @_;

    my $meta      = mop::meta($instance);
    my $meta_name = Scalar::Util::blessed($meta);
    my $role_name = Scalar::Util::blessed($new_metarole) // $new_metarole;
    my $metarole  = mop::meta($role_name);

    die "Could not find metaclass for role: $_"
        unless $metarole;

    my $new_meta_name = "mop::metarole::${meta_name}::${role_name}";
    my $new_meta;
    if (!($new_meta = mop::meta($new_meta_name))) {
        $new_meta = $meta_name->new(
            name       => $new_meta_name,
            superclass => $meta->name,
            roles      => [$metarole],
        );
        $new_meta->FINALIZE;
    }

    apply_metaclass($instance, $new_meta->name);
}

sub rebless {
    my ($object, $into) = @_;

    my $from = Scalar::Util::blessed($object);
    my $common_base = mop::internals::util::find_common_base($from, $into);

    my @from_isa = @{ mro::get_linear_isa($from) };
    if ($common_base) {
        pop @from_isa until $from_isa[-1] eq $common_base;
        pop @from_isa;
    }
    @from_isa = grep { defined } map { meta($_) } @from_isa;

    my @into_isa = @{ mro::get_linear_isa($into) };
    if ($common_base) {
        pop @into_isa until $into_isa[-1] eq $common_base;
        pop @into_isa;
    }
    @into_isa = grep { defined } map { meta($_) } @into_isa;

    for my $attr (map { $_->attributes } @from_isa) {
        $attr->store_data_in_slot_for($object, undef);
    }

    bless($object, $into);

    for my $attr (map { $_->attributes } reverse @into_isa) {
        $attr->store_default_in_slot_for($object);
    }

    $object
}

sub dump_object {
    my ($obj) = @_;

    return $obj unless is_mop_object($obj);

    our %SEEN;
    if ($SEEN{id($obj)}) {
        return '';
    }
    local $SEEN{id($obj)} = ($SEEN{id($obj)} // 0) + 1;

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

    my $temp = {
        __ID__    => id($obj),
        __CLASS__ => meta($obj)->name,
        __SELF__  => $obj,
    };

    foreach my $attr (values %attributes) {
        if ($obj->isa('mop::attribute') && $attr->name eq '$!storage') {
            $temp->{ $attr->name } = '__INTERNAL_DETAILS__';
        } else {
            $temp->{ $attr->name } = sub {
                my ($data) = @_;
                if (Scalar::Util::blessed($data)) {
                    return dump_object($data);
                } elsif (ref $data) {
                    if (ref $data eq 'ARRAY') {
                        return [ map { __SUB__->( $_ ) } @$data ];
                    } elsif (ref $data eq 'HASH') {
                        return {
                            map { $_ => __SUB__->( $data->{$_} ) } keys %$data
                        };
                    } else {
                        return $data;
                    }
                } else {
                    return $data;
                }
            }->(${ $attr->get_slot_for($obj) });
        }
    }

    $temp;
}

# can't call this 'bootstrap' because XSLoader has a special meaning for that
sub initialize {
    return if $BOOTSTRAPPED;
    mop::internals::util::set_meta($_, $_->__INIT_METACLASS__) for qw[
        mop::object
        mop::role
        mop::class
        mop::attribute
        mop::method
        mop::internals::observable
    ];

    my $Object = meta('mop::object');

    my $Role  = meta('mop::role');
    my $Class = meta('mop::class');

    my $Method     = meta('mop::method');
    my $Attribute  = meta('mop::attribute');
    my $Observable = meta('mop::internals::observable');

    # flatten mop::observable into wherever it's needed (it's just an
    # implementation detail (#95), so it shouldn't end up being directly
    # visible)
    foreach my $meta ( $Role, $Attribute, $Method ) {
        for my $attribute ( $Observable->attributes ) {
            $meta->add_attribute($attribute->clone(associated_meta => $meta));
        }
        for my $method ( $Observable->methods ) {
            $meta->add_method($method->clone(associated_meta => $meta));
        }
    }

    # At this point the metaclass
    # layer class to role relationship
    # is correct. And the following
    #   - Class does Role
    #   - Role is instance of Class
    #   - Role does Role
    # is true.
    $Class->add_role( $Role );

    # normally this would be a call to FINALIZE for all of the mop classes,
    # but that complicates things too much during bootstrapping, and this
    # is the only thing that would have an actual effect anyway.
    mop::internals::util::apply_all_roles($Class, $Role);

    # and now this is no longer needed
    remove_meta('mop::internals::observable');

    {
        # NOTE:
        # This is ugly, but we need to do
        # it to set the record straight
        # and make sure that the relationship
        # between mop::class and mop::role
        # are correct and code is reused.
        # - SL
        foreach my $method ($Role->methods) {
            no strict 'refs';
            *{ 'mop::class::' . $method->name } = $method->body
                unless defined &{ 'mop::class::' . $method->name };
        }

        # now make sure the Observable roles are
        # completely intergrated into the stashes
        foreach my $method ($Observable->methods) {
            foreach my $package (qw(mop::role mop::method mop::attribute)) {
                no strict 'refs';
                *{ $package . '::' . $method->name } = $method->body
                    unless defined &{ $package . '::' . $method->name };
            }
        }

        # then clean up some of the @ISA by
        # removing mop::observable from them
        @mop::role::ISA      = ('mop::object');
        @mop::method::ISA    = ('mop::object');
        @mop::attribute::ISA = ('mop::object');

        # Here we finalize the rest of the
        # metaclass layer so that the following:
        #   - Class is an instance of Class
        #   - Object is an instance of Class
        #   - Class is a subclass of Object
        # is true.
        @mop::class::ISA = ('mop::object');

        # remove the temporary clone methods used in the bootstrap
        delete $mop::method::{clone};
        delete $mop::attribute::{clone};

        # replace the temporary implementation of mop::object::new
        {
            no strict 'refs';
            no warnings 'redefine';
            *{ 'mop::object::new' } = $Object->get_method('new')->body;
        }

        # remove the temporary constructors used in the bootstrap
        delete $mop::class::{new};
        delete $mop::role::{new};
        delete $mop::method::{new};
        delete $mop::attribute::{new};
    }

    {
        no warnings 'redefine';
        *apply_metaclass = mop::internals::util::subname(
            apply_metaclass => sub {
                my ($instance, $new_meta) = @_;
                rebless $instance, mop::internals::util::fix_metaclass_compatibility($new_meta, $instance);
            }
        );
    }

    $BOOTSTRAPPED = 1;
}

1;

__END__