view release on metacpan or  search on metacpan

lib/Ambrosia/Meta.pm  view on Meta::CPAN

package Ambrosia::Meta;
use strict;
no strict 'refs';
use warnings;
no warnings 'redefine';

use base qw/Exporter/;
our @EXPORT = qw/class abstract sealed inheritable/;

use Ambrosia::Assert;
use Ambrosia::error::Exceptions;
require Ambrosia::core::Object;

our $VERSION = 0.010;

#fields
sub __PRIVATE()   { 1 }
sub __PUBLIC()    { 2 }
sub __PROTECTED() { 3 }
sub __FRIENDS()   { 4 }

#classes
sub __ABSTRACT()    { 1 }
sub __SEALED()      { 2 }
sub __INHERITABLE() { 3 }

my %FIELDS_ACCESS = (
        private   => &__PRIVATE,
        protected => &__PROTECTED,
        public    => &__PUBLIC,
        friends   => &__FRIENDS,
    );

my %CLASS_TYPE = (
        abstract    => &__ABSTRACT,
        sealed      => &__SEALED,
        inheritable => &__INHERITABLE,
    );

sub import
{
    my $proto = shift;

    assert {$proto eq __PACKAGE__} "'$proto' cannot be inherited from sealed class '" . __PACKAGE__ . '\'.';
    #throw Ambrosia::error::Exception("'$proto' cannot be inherited from sealed class '" . __PACKAGE__ . '\'.') if $proto ne __PACKAGE__;

    my $INSTANCE_CLASS = caller(0);
    unless ( eval { $INSTANCE_CLASS->isa('Ambrosia::core::Object') } )
    {
        @{$INSTANCE_CLASS . '::ISA'} = ();
        my $ISA = \@{$INSTANCE_CLASS . '::ISA'};
        unshift @$ISA, 'Ambrosia::core::Object';
    }

    $proto->export_to_level(1, $proto, @EXPORT);
}

sub abstract(@)
{
    return abstract => @_;
}

sub sealed(@)
{
    return sealed => @_;
}

sub inheritable(@)
{
    return inheritable => @_;
}

sub class(@)
{
    my $INSTANCE_CLASS;

# You can create your class
# 1. so: class {} or equalent class inheritable {}
# 2. or so: class abstract {}
# 3. and so: class sealed {}
#
    my ( $clsType, $params ) = @_ == 1 ? (&__INHERITABLE, shift) : ( @_ == 2 ? ($CLASS_TYPE{lc(+shift)}, shift) : (&__INHERITABLE, {}) );

    if ( defined $params->{package} )
    {
        $INSTANCE_CLASS = $params->{package};
        delete $params->{package};
        unless ( eval { $INSTANCE_CLASS->isa('Ambrosia::core::Object') } )
        {
            @{$INSTANCE_CLASS . '::ISA'} = ();
            my $ISA = \@{$INSTANCE_CLASS . '::ISA'};
            unshift @$ISA, 'Ambrosia::core::Object';
        }
    }
    else
    {
        $INSTANCE_CLASS = caller(0);
    }

    my $alias = {};
    if ( defined $params->{alias} )
    {
        $alias = $params->{alias};
        delete $params->{alias};
    }

    return if ${"$INSTANCE_CLASS\::__AMBROSIA_INSTANCE__"};
    ${"$INSTANCE_CLASS\::__AMBROSIA_INSTANCE__"} = $clsType;

    *{$INSTANCE_CLASS.'::__AMBROSIA_IS_ABSTRACT__'} = sub() {${"$INSTANCE_CLASS\::__AMBROSIA_INSTANCE__"} == &__ABSTRACT};

    *{"$INSTANCE_CLASS\::__AMBROSIA_ALIAS_FIELDS__"} = sub() { $alias };
    %{"$INSTANCE_CLASS\::__AMBROSIA_INTERNAL_FLDS__"} = ();
    my $__FIELDS__ = \%{"$INSTANCE_CLASS\::__AMBROSIA_INTERNAL_FLDS__"};

    my %__PARENT__ = ();

################################################################################
#   Обрабатываем базовые классы
#   Заполняю $__FIELDS__ списком полей
################################################################################
    my $ISA = \@{$INSTANCE_CLASS . '::ISA' || []};
    my @PUB_FLDS = ();

    foreach my $inheritable (qw<extends implements>)
    {
        next unless exists $params->{$inheritable};

        foreach my $package ( @{$params->{$inheritable}} )
        {
            unless ( eval {$package->VERSION} )
            {
                if ( eval qq{require $package;} )
                {
                    eval {$package->import; 1;}
                    or throw Ambrosia::error::Exception 'Cannot import ' . $package . ': ', $@;
                    if ( (${"$package\::__AMBROSIA_INSTANCE__"} || -42) == &__SEALED )
                    {
                        throw Ambrosia::error::Exception $INSTANCE_CLASS . ' cannot be inherited from sealed class ' . $package;
                    }
                }
                else
                {
                    throw Ambrosia::error::Exception 'Cannot require ' . $package . ': ', $@;
                }
            }
            unshift @$ISA, $package;

            foreach my $f ( keys %{"$package\::__AMBROSIA_INTERNAL_FLDS__"} )
            {
                $__PARENT__{$f} = !exists $__PARENT__{$f} ? $package : throw Ambrosia::error::Exception "Duplicate field $f for $package that exists one of a base class.";
            }
            push @PUB_FLDS, $package->fields if eval { $package->can('fields') };
        }
        delete $params->{$inheritable};
    }