basic implementationHEADmaster

4 files changed, 192 insertions, 0 deletions

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;