File Coverage

blib/lib/mop/traits.pm

Criterion	Covered	Total	%
statement	98	98	100.0
branch	33	42	78.5
condition	14	32	43.7
subroutine	30	30	100.0
pod	9	11	81.8
total	184	213	86.3

package mop::traits;

use v5.16;
use warnings;

use Scalar::Util 'blessed', 'weaken';

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

our @available_traits = qw[
    rw
    ro
    required
    weak_ref
    lazy
    abstract
    overload
    extending_non_mop
    repr
];

require Carp;

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

    mop::internals::util::install_sub($pkg, 'mop::traits', $_)
        for @available_traits;
}

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

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

sub rw {
    my ($attr) = @_;

    die "rw trait is only valid on attributes"
        unless blessed($attr) && $attr->isa('mop::attribute');

    my $meta = $attr->associated_meta;
    weaken(my $weak_attr = $attr);
    $meta->add_method(
        $meta->method_class->new(
            name => $attr->key_name,
            body => sub {
                my $self = shift;
                $weak_attr->store_data_in_slot_for($self, shift) if @_;
                $weak_attr->fetch_data_in_slot_for($self);
            }
        )
    );
}

sub ro {
    my ($attr) = @_;

    die "ro trait is only valid on attributes"
        unless blessed($attr) && $attr->isa('mop::attribute');

    my $meta = $attr->associated_meta;
    weaken(my $weak_attr = $attr);
    $meta->add_method(
        $meta->method_class->new(
            name => $attr->key_name,
            body => sub {
                my $self = shift;
                die "Cannot assign to a read-only accessor" if @_;
                $weak_attr->fetch_data_in_slot_for($self);
            }
        )
    );
}

sub required {
    my ($attr) = @_;

    die "required trait is only valid on attributes"
        unless blessed($attr) && $attr->isa('mop::attribute');

    die "in '" . $attr->name . "' attribute definition: "
      . "'required' trait is incompatible with default value"
        if $attr->has_default;

    weaken(my $weak_attr = $attr);
    $attr->set_default(sub {
        Carp::croak("'" . $weak_attr->name . "' is required")
    });
}

sub abstract {
    my ($class) = @_;

    die "abstract trait is only valid on classes"
        unless blessed($class) && $class->isa('mop::class');

    $class->make_class_abstract;
}

sub overload {
    my ($method, $operator) = @_;

    die "overload trait is only valid on methods"
        unless blessed($method) && $method->isa('mop::method');

    my $method_name = $method->name;

    # NOTE:
    # This installs the methods into the package
    # directly, rather than going through the
    # mop. This is because overload methods
    # (with their weird names) should probably
    # not show up in the list of methods and such.

    overload::OVERLOAD(
        $method->associated_meta->name,
        $operator,
        sub {
            my $self = shift;
            $self->$method_name(@_)
        },
        fallback => 1
    );
}

sub weak_ref {
    my ($attr) = @_;

    die "weak_ref trait is only valid on attributes"
        unless blessed($attr) && $attr->isa('mop::attribute');

    weaken(my $weak_attr = $attr);
    $attr->bind('after:STORE_DATA' => sub {
        my (undef, $instance) = @_;
        $weak_attr->weaken_data_in_slot_for($instance);
    });
}

sub lazy {
    my ($attr) = @_;

    die "lazy trait is only valid on attributes"
        unless blessed($attr) && $attr->isa('mop::attribute');

    my $default = $attr->clear_default;
    weaken(my $weak_attr = $attr);
    $attr->bind('before:FETCH_DATA' => sub {
        my (undef, $instance) = @_;
        if ( !$weak_attr->has_data_in_slot_for($instance) ) {
            $weak_attr->store_data_in_slot_for($instance, do {
                local $_ = $instance;
                ref($default) ? $default->() : $default
            });
        }
    });
}

sub extending_non_mop {
    my ($class, $constructor_name) = @_;

    die "extending_non_mop trait is only valid on classes"
        unless blessed($class) && $class->isa('mop::class');

    $constructor_name //= 'new';
    my $super_constructor = join '::' => $class->superclass, $constructor_name;

    $class->add_method(
        $class->method_class->new(
            name => $constructor_name,
            body => sub {
                my $class = shift;
                my $self  = $class->$super_constructor( @_ );
                mop::internals::util::register_object( $self );

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

                foreach my $attr (values %attributes) {
                    $attr->store_default_in_slot_for( $self );
                }

                mop::internals::util::buildall($self, @_);

                $self;
            }
        )
    );
}

sub repr {
    my ($class, $instance) = @_;

    die "repr trait is only valid on classes"
        unless blessed($class) && $class->isa('mop::class');

    my $generator;
    if (ref $instance && ref $instance eq 'CODE') {
        $generator = $instance;
    }
    elsif (!ref $instance) {
        if ($instance eq 'SCALAR') {
            $generator = sub { \(my $anon) };
        }
        elsif ($instance eq 'ARRAY') {
            $generator = sub { [] };
        }
        elsif ($instance eq 'HASH') {
            $generator = sub { {} };
        }
        elsif ($instance eq 'GLOB') {
            $generator = sub { select select my $fh; %{*$fh} = (); $fh };
        }
        else {
            die "unknown instance generator type $instance";
        }
    }
    else {
        die "unknown instance generator $instance";
    }

    $class->set_instance_generator($generator);
}

1;

__END__