mop traits

alias.pl

use mop;

use feature qw(postderef);
no warnings qw(experimental::postderef);

use Carp qw(confess);
use Package::Stash;

sub alias {
    my $meta = shift;
    if ($meta->isa('mop::class')) {
        my $name = $meta->name;
        my $alias = $name =~ s/.*:://r;
        my (undef, undef, undef, $subroutine) = caller(3);   # XXX: ugly like hell
        my $target = $subroutine =~ s/::[^:]*$//r;
        Package::Stash->new($target)->add_symbol('&'.$alias => sub () { $name });
    } else {
        confess 'trait only for class';
    }
}


class A::B::C is alias {
    method m { warn $self }
}

A::B::C->m;
C->m;

lvalue.pl

use feature qw(state);
use mop;

use Scalar::Util qw(weaken);
use Variable::Magic qw(wizard cast);
use Hash::Util::FieldHash;

sub lvalue {
    my $meta = shift;
    if ($meta->isa('mop::attribute')) {
        Hash::Util::FieldHash::fieldhash state %Lvalues;
        my $class_meta = $meta->associated_meta;
        weaken(my $weak_meta = $meta);
        my $name = $meta->key_name;
        my $accessor = $class_meta->get_method($name)->body;
        $class_meta->add_method(
            $class_meta->method_class->new(
                name => $name,
                body => sub :lvalue {
                    my $self = shift;
                    if (not exists $Lvalues{$self}{$name}) {
                        my $wiz = wizard(
                            set => sub {
                                $self->$accessor(${$_[0]});
                                return 1;
                            },
                            get => sub {
                                ${$_[0]} = $self->$accessor();
                                return 1;
                            },
                        );
                        cast($Lvalues{$self}{$name}, $wiz);
                    }
                    if (@_) {
                        $self->$accessor(@_);
                    }
                    $Lvalues{$self}{$name};
                }
            )
        );
    } elsif ($meta->isa('mop::class')) {
        mop::traits::util::apply_trait(\&lvalue, $_) foreach $meta->attributes;
    }
}

class A is lvalue {
    has $!a is rw = 42;
}

my $obj = A->new;
warn $obj->a;

$obj->a = 69;
warn $obj->a;

$obj->a++;
warn $obj->a;

ro.pl

use mop;

sub ro {
    my $meta = shift;
    if ($meta->isa('mop::attribute')) {
        mop::traits::ro($meta);
    } elsif ($meta->isa('mop::class')) {
        foreach my $attr ($meta->attributes) {
            next if grep {
                $_->{trait} == \&mop::traits::ro or $_->{trait} == \&ro or
                $_->{trait} == \&mop::traits::rw or $_->{trait} == \&rw
            } mop::traits::util::applied_traits($attr);
            mop::traits::util::apply_trait(\&ro, $attr);
        }
    }
}

class A is ro {
    has $!a = 42;
}

my $obj = A->new;
warn $obj->a;

rw.pl

use mop;

sub rw {
    my $meta = shift;
    if ($meta->isa('mop::attribute')) {
        mop::traits::rw($meta);
    } elsif ($meta->isa('mop::class')) {
        foreach my $attr ($meta->attributes) {
            next if grep {
                $_->{trait} == \&mop::traits::ro or $_->{trait} == \&ro or
                $_->{trait} == \&mop::traits::rw or $_->{trait} == \&rw
            } mop::traits::util::applied_traits($attr);
            mop::traits::util::apply_trait(\&rw, $attr);
        }
    }
}

class A is rw {
    has $!a;
}

my $obj = A->new;
$obj->a(42);
warn $obj->a;

static.pl

use mop;

use Scalar::Util qw(blessed weaken);

sub static {
    my $meta = shift;
    if ($meta->isa('mop::attribute')) {
        weaken(my $weak_meta = $meta);
        $meta->bind('after:FETCH_DATA' => sub {
            my (undef, $instance, $data) = @_;
            if (not blessed $instance) {
                $$data = $weak_meta->get_default;
            }
        });
        $meta->bind('after:STORE_DATA' => sub {
            my (undef, $instance, $data) = @_;
            if (not blessed $instance) {
                if (ref $$data and ref $$data ne 'CODE') {
                    $weak_meta->set_default(sub { $$data });
                } else {
                    $weak_meta->set_default($$data);
                }
            }
        });
    } elsif ($meta->isa('mop::class')) {
        mop::traits::util::apply_trait(\&static, $_) foreach $meta->attributes;
    }
}

class A is static {
    has $!a is rw = 42;
}

warn A->a;
A->a(69);

my $obj = A->new;
warn $obj->a;