From e1c675f0a434b6323cff812c8293eee5dc0c6c28 Mon Sep 17 00:00:00 2001
From: Jesse Luehrs <doy@tozt.net>
Date: Mon, 10 Oct 2011 14:10:14 -0500
Subject: sketch out subcontainers (still needs work)

---
 lib/Bread/Board/Declare/Meta/Role/Attribute.pm     | 11 ++--
 .../Board/Declare/Meta/Role/Attribute/Container.pm | 75 ++++++++++++++++++++++
 lib/Bread/Board/Declare/Role/Object.pm             | 22 +++++++
 3 files changed, 104 insertions(+), 4 deletions(-)
 create mode 100644 lib/Bread/Board/Declare/Meta/Role/Attribute/Container.pm

(limited to 'lib')

diff --git a/lib/Bread/Board/Declare/Meta/Role/Attribute.pm b/lib/Bread/Board/Declare/Meta/Role/Attribute.pm
index d356e3a..7a08376 100644
--- a/lib/Bread/Board/Declare/Meta/Role/Attribute.pm
+++ b/lib/Bread/Board/Declare/Meta/Role/Attribute.pm
@@ -5,6 +5,9 @@ use Moose::Role;
 use List::MoreUtils 'any';
 use Moose::Util 'does_role', 'find_meta';
 
+use Bread::Board::Declare::Meta::Role::Attribute::Container;
+use Bread::Board::Declare::Meta::Role::Attribute::Service;
+
 =attr service
 
 Whether or not to create a service for this attribute. Defaults to true.
@@ -28,14 +31,14 @@ around interpolate_class => sub {
     return $class->$orig(@_)
         if $options->{metaclass};
 
-    if (exists $options->{service} && !$options->{service}) {
-        return $class->$orig(@_);
-    }
+    return $class->$orig(@_)
+        if exists $options->{service} && !$options->{service};
 
     my ($new_class, @traits) = $class->$orig(@_);
 
     return wantarray ? ($new_class, @traits) : $new_class
-        if does_role($new_class, 'Bread::Board::Declare::Meta::Role::Attribute::Service');
+        if does_role($new_class, 'Bread::Board::Declare::Meta::Role::Attribute::Service')
+        || does_role($new_class, 'Bread::Board::Declare::Meta::Role::Attribute::Container');
 
     my $parent = @traits
         ? (find_meta($new_class)->superclasses)[0]
diff --git a/lib/Bread/Board/Declare/Meta/Role/Attribute/Container.pm b/lib/Bread/Board/Declare/Meta/Role/Attribute/Container.pm
new file mode 100644
index 0000000..90d027d
--- /dev/null
+++ b/lib/Bread/Board/Declare/Meta/Role/Attribute/Container.pm
@@ -0,0 +1,75 @@
+package Bread::Board::Declare::Meta::Role::Attribute::Container;
+use Moose::Role;
+Moose::Util::meta_attribute_alias('Container');
+
+use Class::Load 'load_class';
+
+has dependencies => (
+    is        => 'ro',
+    isa       => 'Bread::Board::Service::Dependencies',
+    coerce    => 1,
+    predicate => 'has_dependencies',
+);
+
+after attach_to_class => sub {
+    my $self = shift;
+
+    my $tc = $self->type_constraint;
+    if ($tc && $tc->isa('Moose::Meta::TypeConstraint::Class')) {
+        load_class($tc->class);
+        confess "Subcontainers must inherit from Bread::Board::Container"
+            unless $tc->class->isa('Bread::Board::Container');
+    }
+    else {
+        confess "Attributes for subcontainers must specify a class type constraint";
+    }
+};
+
+around get_value => sub {
+    my $orig = shift;
+    my $self = shift;
+    my ($instance) = @_;
+
+    return $self->$orig($instance)
+        if $self->has_value($instance)
+        || $self->has_default
+        || $self->has_builder;
+
+    my $val = $instance->get_sub_container($self->name);
+
+    if ($self->has_type_constraint) {
+        $val = $self->type_constraint->coerce($val)
+            if $self->should_coerce;
+
+        $self->verify_against_type_constraint($val, instance => $instance);
+    }
+
+    return $val;
+};
+
+around _inline_instance_get => sub {
+    my $orig = shift;
+    my $self = shift;
+    my ($instance) = @_;
+    return 'do {' . "\n"
+            . 'my $val;' . "\n"
+            . 'if (' . $self->_inline_instance_has($instance) . ') {' . "\n"
+                . '$val = ' . $self->$orig($instance) . ';' . "\n"
+            . '}' . "\n"
+            . 'else {' . "\n"
+                . '$val = ' . $instance . '->get_sub_container(\'' . $self->name . '\');' . "\n"
+                . join("\n", $self->_inline_check_constraint(
+                    '$val',
+                    '$type_constraint',
+                    (Moose->VERSION >= 2.0100
+                        ? '$type_message'
+                        : '$type_constraint_obj'),
+                )) . "\n"
+            . '}' . "\n"
+            . '$val' . "\n"
+        . '}';
+};
+
+no Moose::Role;
+
+1;
diff --git a/lib/Bread/Board/Declare/Role/Object.pm b/lib/Bread/Board/Declare/Role/Object.pm
index fe0c651..b1f5fbd 100644
--- a/lib/Bread/Board/Declare/Role/Object.pm
+++ b/lib/Bread/Board/Declare/Role/Object.pm
@@ -1,6 +1,8 @@
 package Bread::Board::Declare::Role::Object;
 use Moose::Role;
 
+use Moose::Util 'does_role';
+
 has name => (
     is      => 'rw',
     isa     => 'Str',
@@ -46,6 +48,26 @@ after BUILD => sub {
             $self->add_service($service->clone);
         }
     }
+
+    for my $attr (grep { does_role($_, 'Bread::Board::Declare::Meta::Role::Attribute::Container') } $meta->get_all_attributes) {
+        my $container;
+        if ($attr->has_value($self) || $attr->has_default || $attr->has_builder) {
+            $container = $attr->get_value($self);
+        }
+        else {
+            my $s = Bread::Board::ConstructorInjection->new(
+                name         => '__ANON__',
+                parent       => $self,
+                class        => $attr->type_constraint->class,
+                ($attr->has_dependencies
+                    ? (dependencies => $attr->dependencies)
+                    : ()),
+            );
+            $container = $s->get;
+        }
+        $container->name($attr->name);
+        $self->add_sub_container($container);
+    }
 };
 
 no Moose::Role;
-- 
cgit v1.2.3