diff options
Diffstat (limited to 'lib/Reaction/Meta/InterfaceModel')
5 files changed, 274 insertions, 0 deletions
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 |