7 files changed, 390 insertions, 0 deletions
diff --git a/lib/Reaction/Meta/Attribute.pm b/lib/Reaction/Meta/Attribute.pm
new file mode 100644
index 0000000..38035d5
--- /dev/null
+++ b/lib/Reaction/Meta/Attribute.pm
@@ -0,0 +1,101 @@
+package Reaction::Meta::Attribute;
+
+use Moose;
+
+extends 'Moose::Meta::Attribute';
+
+#is => 'Bool' ? or leave it open
+has lazy_fail  =>
+    (is => 'ro', reader => 'is_lazy_fail',  required => 1, default => 0);
+has lazy_build =>
+    (is => 'ro', reader => 'is_lazy_build', required => 1, default => 0);
+
+around _process_options => sub {
+    my $super = shift;
+    my ($class, $name, $options) = @_;
+
+    my $fail  = $options->{lazy_fail}; #will this autovivify?
+    my $build = $options->{lazy_build};
+
+    if ( $fail || $build) {
+      confess("You may not use both lazy_build and lazy_fail for one attribute")
+        if $fail && $build;
+      confess("You may not supply a default value when using lazy_build or lazy_fail")
+        if exists $options->{default};
+
+      $options->{lazy} = 1;
+      $options->{required} = 1;
+
+      my $builder = ($name =~ /^_/) ? "_build${name}" : "build_${name}";
+      $options->{default} =  $fail ?
+        sub { confess "${name} must be provided before calling reader" } :
+          sub{ shift->$builder };
+    }
+
+    #we are using this everywhere so might as well move it here.
+    $options->{predicate} ||= ($name =~ /^_/) ? "_has${name}" : "has_${name}"
+      if !$options->{required} || $options->{lazy};
+
+
+    $super->($class, $name, $options);
+};
+
+1;
+
+__END__;
+
+=head1 NAME
+
+Reaction::Meta::Attribute
+
+=head1 SYNOPSIS
+
+    has description => (is => 'rw', isa => 'Str', lazy_fail => 1);
+
+    # OR
+    has description => (is => 'rw', isa => 'Str', lazy_build => 1);
+    sub build_description{ "My Description" }
+
+    # OR
+    has _description => (is => 'rw', isa => 'Str', lazy_build => 1);
+    sub _build_description{ "My Description" }
+
+=head1 Method-naming conventions
+
+Reaction::Meta::Attribute will never override the values you set for method names,
+but if you do not it will follow these basic rules:
+
+Attributes with a name that starts with an underscore will default to using
+builder and predicate method names in the form of the attribute name preceeded by
+either "_has" or "_build". Otherwise the method names will be in the form of the
+attribute names preceeded by "has_" or "build_". e.g.
+
+   #auto generates "_has_description" and expects "_build_description"
+   has _description => (is => 'rw', isa => 'Str', lazy_build => 1);
+
+   #auto generates "has_description" and expects "build_description"
+   has description => (is => 'rw', isa => 'Str', lazy_build => 1);
+
+=head2 Predicate generation
+
+All non-required or lazy attributes will have a predicate automatically
+generated for them if one is not already specified.
+
+=head2 lazy_fail
+
+=head2 lazy_build
+
+lazy_build will lazily build to the return value of a user-supplied builder sub
+ The builder sub will recieve C<$self> as the first argument.
+
+lazy_fail will simply fail if it is called without first having set the value.
+
+=head1 AUTHORS
+
+See L<Reaction::Class> for authors.
+
+=head1 LICENSE
+
+See L<Reaction::Class> for the license.
+
+=cut
diff --git a/lib/Reaction/Meta/Class.pm b/lib/Reaction/Meta/Class.pm
new file mode 100644
index 0000000..e963586
--- /dev/null
+++ b/lib/Reaction/Meta/Class.pm
@@ -0,0 +1,15 @@
+package Reaction::Meta::Class;
+
+use Moose;
+use Reaction::Meta::Attribute;
+
+extends 'Moose::Meta::Class';
+
+around initialize => sub {
+    my $super = shift;
+    my $class = shift;
+    my $pkg   = shift;
+    $super->($class, $pkg, 'attribute_metaclass' => 'Reaction::Meta::Attribute', @_ );
+};
+
+1;
diff --git a/lib/Reaction/Meta/InterfaceModel/Action/Class.pm b/lib/Reaction/Meta/InterfaceModel/Action/Class.pm
new file mode 100644
index 0000000..0c83353
--- /dev/null
+++ b/lib/Reaction/Meta/InterfaceModel/Action/Class.pm
@@ -0,0 +1,41 @@
+package Reaction::Meta::InterfaceModel::Action::Class;
+
+use Reaction::Class;
+use aliased 'Reaction::Meta::InterfaceModel::Action::ParameterAttribute';
+
+class Class is 'Reaction::Meta::Class', which {
+
+  around initialize => sub {
+    my $super = shift;
+    my $class = shift;
+    my $pkg   = shift;
+    $super->($class, $pkg, attribute_metaclass => ParameterAttribute, @_);
+  };
+
+  implements parameter_attributes => as {
+    my $self = shift;
+    return grep { $_->isa(ParameterAttribute) } 
+      $self->compute_all_applicable_attributes;
+  };
+
+};
+  
+1;
+
+=head1 NAME
+
+Reaction::Meta::InterfaceModel::Action::Class
+
+=head1 DESCRIPTION
+
+=head2 parameter_attributes
+
+=head1 AUTHORS
+
+See L<Reaction::Class> for authors.
+
+=head1 LICENSE
+
+See L<Reaction::Class> for the license.
+
+=cut
diff --git a/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm b/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm
new file mode 100644
index 0000000..8a52409
--- /dev/null
+++ b/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm
@@ -0,0 +1,102 @@
+package Reaction::Meta::InterfaceModel::Action::ParameterAttribute;
+
+use Reaction::Class;
+use Scalar::Util 'blessed';
+
+class ParameterAttribute is 'Reaction::Meta::Attribute', which {
+  has valid_values => (
+    isa => 'CodeRef',
+    is => 'rw', # hack since clone_and_inherit hates me.
+    predicate => 'has_valid_values'
+  );
+
+  implements new => as { shift->SUPER::new(@_); }; # work around immutable
+
+  implements check_valid_value => as {
+    my ($self, $object, $value) = @_;
+    confess "Can't check_valid_value when no valid_values set"
+      unless $self->has_valid_values;
+    my $valid = $self->valid_values->($object, $self);
+    if ($self->type_constraint
+        && ($self->type_constraint->name eq 'ArrayRef'
+            || $self->type_constraint->is_subtype_of('ArrayRef'))) {
+      confess "Parameter type is array ref but passed value isn't"
+        unless ref($value) eq 'ARRAY';
+      return [ map { $self->_check_single_valid($valid => $_) } @$value ];
+    } else {
+      return $self->_check_single_valid($valid => $value);
+    }
+  };
+
+  implements _check_single_valid => as {
+    my ($self, $valid, $value) = @_;
+    if (ref $valid eq 'ARRAY') {
+      return $value if grep { $_ eq $value } @$valid;
+    } else {
+      $value = $value->ident_condition if blessed($value);
+      return $valid->find($value);
+    }
+    return undef; # XXX this is an assumption that undef is never valid
+  };
+
+  implements all_valid_values => as {
+    my ($self, $object) = @_;
+    confess "Can't call all_valid_values on an attribute without valid_values"
+      unless $self->has_valid_values;
+    my $valid = $self->valid_values->($object, $self);
+    return ((ref $valid eq 'ARRAY')
+            ? @$valid
+            : $valid->all);
+  };
+
+  implements valid_value_collection => as {
+    my ($self, $object) = @_;
+    confess "Can't call valid_value_collection on an attribute without valid_values"
+      unless $self->has_valid_values;
+    my $valid = $self->valid_values->($object, $self);
+    confess "valid_values returned an arrayref, not a collection"
+      if (ref $valid eq 'ARRAY');
+    return $valid;
+  };
+
+};
+
+1;
+
+=head1 NAME
+
+Reaction::Meta::InterfaceModel::Action::ParamterAttribute
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 new
+
+=head2 valid_values
+
+=head2 has_valid_values
+
+=head2 check_valid_value
+
+=head2 all_valid_values
+
+=head2 valid_value_collection
+
+=head2 reader
+
+=head2 writer
+
+=head1 SEE ALSO
+
+L<Reaction::Meta::Attribute>
+
+=head1 AUTHORS
+
+See L<Reaction::Class> for authors.
+
+=head1 LICENSE
+
+See L<Reaction::Class> for the license.
+
+=cut
diff --git a/lib/Reaction/Meta/InterfaceModel/Object/Class.pm b/lib/Reaction/Meta/InterfaceModel/Object/Class.pm
new file mode 100644
index 0000000..77fbbe4
--- /dev/null
+++ b/lib/Reaction/Meta/InterfaceModel/Object/Class.pm
@@ -0,0 +1,60 @@
+package Reaction::Meta::InterfaceModel::Object::Class;
+
+use aliased 'Reaction::Meta::InterfaceModel::Object::ParameterAttribute';
+use aliased 'Reaction::Meta::InterfaceModel::Object::DomainModelAttribute';
+
+use Reaction::Class;
+
+class Class is 'Reaction::Meta::Class', which {
+
+  around initialize => sub {
+    my $super = shift;
+    my $class = shift;
+    my $pkg   = shift;
+    $super->($class, $pkg, attribute_metaclass => ParameterAttribute, @_);
+  };
+
+  implements add_domain_model => as{
+    my $self = shift;
+    $self->add_attribute( DomainModelAttribute->new(@_) );
+  };
+
+  implements parameter_attributes => as {
+    my $self = shift;
+    return grep { $_->isa(ParameterAttribute) } 
+      $self->compute_all_applicable_attributes;
+  };
+
+  implements domain_models => as {
+    my $self = shift;
+    return grep { $_->isa(DomainModelAttribute) } 
+      $self->compute_all_applicable_attributes;
+  };
+
+};
+  
+1;
+
+=head1 NAME
+
+Reaction::Meta::InterfaceModel::Object::Class
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 add_domain_model
+
+=head2 domain_models
+
+=head2 parameter_attributes
+
+=head1 AUTHORS
+
+See L<Reaction::Class> for authors.
+
+=head1 LICENSE
+
+See L<Reaction::Class> for the license.
+
+=cut
diff --git a/lib/Reaction/Meta/InterfaceModel/Object/DomainModelAttribute.pm b/lib/Reaction/Meta/InterfaceModel/Object/DomainModelAttribute.pm
new file mode 100644
index 0000000..ba1e9cc
--- /dev/null
+++ b/lib/Reaction/Meta/InterfaceModel/Object/DomainModelAttribute.pm
@@ -0,0 +1,28 @@
+package Reaction::Meta::InterfaceModel::Object::DomainModelAttribute;
+
+use Reaction::Class;
+
+class DomainModelAttribute is 'Reaction::Meta::Attribute', which {
+  #i feel like something should happen here, but i aint got nothin.
+
+  implements new => as { shift->SUPER::new(@_); }; # work around immutable
+
+};
+
+1;
+
+=head1 NAME
+
+Reaction::Meta::InterfaceModel::Action::DomainModelAttribute
+
+=head1 DESCRIPTION
+
+=head1 AUTHORS
+
+See L<Reaction::Class> for authors.
+
+=head1 LICENSE
+
+See L<Reaction::Class> for the license.
+
+=cut
diff --git a/lib/Reaction/Meta/InterfaceModel/Object/ParameterAttribute.pm b/lib/Reaction/Meta/InterfaceModel/Object/ParameterAttribute.pm
new file mode 100644
index 0000000..835fa09
--- /dev/null
+++ b/lib/Reaction/Meta/InterfaceModel/Object/ParameterAttribute.pm
@@ -0,0 +1,43 @@
+package Reaction::Meta::InterfaceModel::Object::ParameterAttribute;
+
+use Reaction::Class;
+
+class ParameterAttribute is 'Reaction::Meta::Attribute', which {
+  has domain_model => (
+    isa => 'Str',
+    is => 'ro',
+    predicate => 'has_domain_model'
+  );
+
+  has orig_attr_name => (
+    isa => 'Str',
+    is => 'ro',
+    predicate => 'has_orig_attr_name'
+  );
+
+  implements new => as { shift->SUPER::new(@_); }; # work around immutable
+};
+
+1;
+
+=head1 NAME
+
+Reaction::Meta::InterfaceModel::Object::ParameterAttribute
+
+=head1 DESCRIPTION
+
+=head1 ATTRIBUTES
+
+=head2 domain_model
+
+=head2 orig_attr_name
+
+=head1 AUTHORS
+
+See L<Reaction::Class> for authors.
+
+=head1 LICENSE
+
+See L<Reaction::Class> for the license.
+
+=cut