From c388fb9ba415d6543cff51aa35677f092cc0be93 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Wed, 30 Jun 2010 00:25:20 -0500 Subject: basic implementation --- lib/MooseX/ArrayRef.pm | 12 +++++ lib/MooseX/ArrayRef/Meta/Role/Class.pm | 39 ++++++++++++++ lib/MooseX/ArrayRef/Meta/Role/Instance.pm | 88 +++++++++++++++++++++++++++++++ t/01-basic.t | 53 +++++++++++++++++++ 4 files changed, 192 insertions(+) create mode 100644 lib/MooseX/ArrayRef/Meta/Role/Class.pm create mode 100644 lib/MooseX/ArrayRef/Meta/Role/Instance.pm create mode 100644 t/01-basic.t diff --git a/lib/MooseX/ArrayRef.pm b/lib/MooseX/ArrayRef.pm index e69de29..6c939e7 100644 --- a/lib/MooseX/ArrayRef.pm +++ b/lib/MooseX/ArrayRef.pm @@ -0,0 +1,12 @@ +package MooseX::ArrayRef; +use Moose::Exporter; +# ABSTRACT: arrayref-based moose instances + +Moose::Exporter->setup_import_methods( + class_metaroles => { + class => ['MooseX::ArrayRef::Meta::Role::Class'], + instance => ['MooseX::ArrayRef::Meta::Role::Instance'], + }, +); + +1; diff --git a/lib/MooseX/ArrayRef/Meta/Role/Class.pm b/lib/MooseX/ArrayRef/Meta/Role/Class.pm new file mode 100644 index 0000000..0873454 --- /dev/null +++ b/lib/MooseX/ArrayRef/Meta/Role/Class.pm @@ -0,0 +1,39 @@ +package MooseX::ArrayRef::Meta::Role::Class; +use Moose::Role; + +use List::MoreUtils qw(any); +use Data::OptList; + +before superclasses => sub { + my $self = shift; + return if @_ == 0; + + my $supers = Data::OptList::mkopt(\@_); + if (@$supers > 1 || any { scalar($_->meta->superclasses) > 1 } $self->linearized_isa) { + $self->throw_error("Multiple inheritance is not supported in the inheritance hierarchy of arrayref-based instances"); + } + + my $super_meta = Class::MOP::Class->initialize($_[0]); + if (!Moose::Util::does_role($super_meta->instance_metaclass, 'MooseX::ArrayRef::Meta::Role::Instance') && $super_meta->get_all_attributes) { + $self->throw_error("Can't inherit from hashref-based Moose classes"); + } +}; + +before add_attribute => sub { + my $self = shift; + if ($self->subclasses) { + $self->throw_error("Can't add attributes to a class with descendents"); + } +}; + +before rebless_instance => sub { + shift->throw_error("Can't rebless arrayref-based instances"); +}; + +before rebless_instance_back => sub { + shift->throw_error("Can't rebless arrayref-based instances"); +}; + +no Moose::Role; + +1; diff --git a/lib/MooseX/ArrayRef/Meta/Role/Instance.pm b/lib/MooseX/ArrayRef/Meta/Role/Instance.pm new file mode 100644 index 0000000..1258e79 --- /dev/null +++ b/lib/MooseX/ArrayRef/Meta/Role/Instance.pm @@ -0,0 +1,88 @@ +package MooseX::ArrayRef::Meta::Role::Instance; +use Moose::Role; + +my $NOT_EXISTS = \undef; + +has slot_mapping => ( + traits => ['Hash'], + isa => 'HashRef[Int]', + lazy => 1, + default => sub { + my $self = shift; + my @order = $self->_sorted_slots; + return { map { $order[$_] => $_ } 0..$#order }; + }, + handles => { + slot_index => 'get', + num_slots => 'count', + }, +); + +sub _sorted_attributes { + my $self = shift; + return sort { + my ($a_name, $b_name) = map { $_->associated_class->name } ($a, $b); + $a_name eq $b_name + ? $a->insertion_order <=> $b->insertion_order + : $a_name->isa($b_name) + ? 1 + : -1; + + } $self->get_all_attributes; +} + +sub _sorted_slots { + my $self = shift; + return map { sort $_->slots } $self->_sorted_attributes; +} + +sub create_instance { + my $self = shift; + bless [($NOT_EXISTS) x $self->num_slots], $self->_class_name; +} + +sub clone_instance { + my ($self, $instance) = @_; + bless [ @$instance ], $self->_class_name; +} + +sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + my $val = $instance->[$self->slot_index($slot_name)]; + return $val unless ref($val); + return undef if $val == $NOT_EXISTS; + return $val; +} + +sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $instance->[$self->slot_index($slot_name)] = $value; +} + +sub initialize_slot { + my ($self, $instance, $slot_name) = @_; + $instance->[$self->slot_index($slot_name)] = $NOT_EXISTS; +} + +sub deinitialize_slot { + my ($self, $instance, $slot_name) = @_; + $instance->[$self->slot_index($slot_name)] = $NOT_EXISTS; +} + +sub is_slot_initialized { + my ($self, $instance, $slot_name) = @_; + my $val = $instance->[$self->slot_index($slot_name)]; + !ref($val) || $val != $NOT_EXISTS; +} + +sub weaken_slot_value { + my ($self, $instance, $slot_name) = @_; + weaken $instance->[$self->slot_index($slot_name)]; +} + +# TODO +sub is_inlinable { 0 } + +no Moose::Role; + +1; diff --git a/t/01-basic.t b/t/01-basic.t new file mode 100644 index 0000000..2d75e59 --- /dev/null +++ b/t/01-basic.t @@ -0,0 +1,53 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Scalar::Util qw(reftype); + +{ + package Foo; + use Moose; + use MooseX::ArrayRef; + + has foo => (is => 'rw'); + has bar => (is => 'ro', lazy_build => 1); + sub _build_bar { 'BAR' } +} + +my $foo = Foo->new; +is(reftype($foo), 'ARRAY', "got an array instance"); +isa_ok($foo, 'Foo'); +ok(!$foo->has_bar, "bar not initialized yet"); +is($foo->bar, 'BAR', "lazy-built properly"); +ok($foo->has_bar, "bar initialized now"); +is($foo->foo, undef, "foo not initialized yet"); +$foo->foo('FOO'); +is($foo->foo, 'FOO', "foo initialized now"); +my @contents = @$foo; +is_deeply(\@$foo, ['FOO', 'BAR'], "got the right instance data"); + +{ + package Bar; + use Moose; + extends 'Foo'; + + has baz => (is => 'rw'); +} + +my $bar = Bar->new; +is(reftype($bar), 'ARRAY', "got an array instance"); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); +ok(!$bar->has_bar, "bar not initialized yet"); +is($bar->bar, 'BAR', "lazy-built properly"); +ok($bar->has_bar, "bar initialized now"); +is($bar->foo, undef, "foo not initialized yet"); +$bar->foo('FOO'); +is($bar->foo, 'FOO', "foo initialized now"); +is($bar->baz, undef, "baz not initialized yet"); +$bar->baz('BAZ'); +is($bar->baz, 'BAZ', "baz initialized now"); +is_deeply(\@$bar, ['FOO', 'BAR', 'BAZ'], "got the right instance data"); + +done_testing; -- cgit v1.2.3-54-g00ecf