File Coverage

blib/lib/mop/internals/syntax.pm

Criterion	Covered	Total	%
statement	42	47	89.3
branch	11	12	91.6
condition			n/a
subroutine	11	12	91.6
pod	0	8	0.0
total	64	79	81.0

package mop::internals::syntax;

use v5.16;
use warnings;

use version           ();
use Devel::CallParser ();

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

my @available_keywords = qw(class role method has);

# keep the local metaclass around
our $CURRENT_META;

sub setup_for {
    my ($pkg) = @_;

    $^H{__PACKAGE__ . '/twigils'} = 1;
    mop::internals::util::install_sub($pkg, 'mop::internals::syntax', $_)
        for @available_keywords;
}

sub teardown_for {
    my ($pkg) = @_;

    mop::internals::util::uninstall_sub($pkg, $_)
        for @available_keywords;
}

sub new_meta {
    my ($metaclass, $name, $version, $roles, $superclass) = @_;

    $metaclass->new(
        name       => $name,
        version    => $version,
        roles      => [map {
            mop::meta($_) or die "Could not find metaclass for role: $_"
          } @{ $roles }],
        (defined $superclass
            ? (superclass => $superclass)
            : ()),
    );
}

sub build_meta {
    my ($meta, $body, @traits) = @_;

    while (@traits) {
        my ($trait, $args) = splice @traits, 0, 2;
        mop::traits::util::apply_trait(
            $trait, $meta, $args ? @$args : (),
        );
    }

    $meta->FINALIZE;

    $body->();
}

sub add_method {
    my ($name, $body, @traits) = @_;

    if ($body) {
        $CURRENT_META->add_method(
            $CURRENT_META->method_class->new(
                name => $name,
                body => mop::internals::util::subname(
                    (join '::' => $CURRENT_META->name, $name),
                    $body,
                ),
            )
        );

        while (@traits) {
            my ($trait, $args) = splice @traits, 0, 2;
            mop::traits::util::apply_trait(
                $trait, $CURRENT_META->get_method($name), $args ? @$args : (),
            );
        }
    }
    else {
        $CURRENT_META->add_required_method($name);
    }

    return;
}

sub add_attribute {
    my ($name, $default, @traits) = @_;

    $CURRENT_META->add_attribute(
        $CURRENT_META->attribute_class->new(
            name    => $name,
            default => $default,
        )
    );

    while (@traits) {
        my ($trait, $args) = splice @traits, 0, 2;
        mop::traits::util::apply_trait(
            $trait, $CURRENT_META->get_attribute($name), $args ? @$args : (),
        );
    }

    return;
}

# B::Deparse doesn't know what to do with custom ops
{
    package
        B::Deparse;
    sub pp_init_attr {
        # XXX not sure why this doesn't work
        # "(init_attr " . maybe_targmy(@_, \&listop) . ")";
        my $self = shift;
        my ($op) = @_;
        my $targ = $self->padname($op->targ);
        return "(init_attr " . $targ . ": "
            . join(', ', map { $self->deparse($_) }
                             $op->first,
                             $op->first->sibling,
                             $op->first->sibling->sibling)
            . ")";
    }
    sub pp_intro_invocant { "(intro invocant)" }
}

1;

__END__