lib/Reaction/UI/ViewPort/Object.pm

   1 package Reaction::UI::ViewPort::Object;
   2
   3 use Reaction::Class;
   4
   5 use aliased 'Reaction::UI::ViewPort::Field::Text';
   6 use aliased 'Reaction::UI::ViewPort::Field::Number';
   7 use aliased 'Reaction::UI::ViewPort::Field::Integer';
   8 use aliased 'Reaction::UI::ViewPort::Field::Boolean';
   9 use aliased 'Reaction::UI::ViewPort::Field::String';
  10 use aliased 'Reaction::UI::ViewPort::Field::DateTime';
  11 use aliased 'Reaction::UI::ViewPort::Field::RelatedObject';
  12 use aliased 'Reaction::UI::ViewPort::Field::Array';
  13 use aliased 'Reaction::UI::ViewPort::Field::Collection';
  14
  15 use aliased 'Reaction::InterfaceModel::Object' => 'IM_Object';
  16
  17 class Object is 'Reaction::UI::ViewPort', which {
  18
  19   #everything is read only right now. Later I can make somethings read-write
  20   #but first I need to figure out what depends on what so we can have decent triggers
  21   has model  => (is => 'ro', isa => IM_Object, required => 1);
  22   has fields => (is => 'ro', isa => 'ArrayRef', lazy_build => 1);
  23
  24   has field_args    => (is => 'ro');
  25   has field_order   => (is => 'ro', isa => 'ArrayRef');
  26
  27   has builder_cache   => (is => 'ro', isa => 'HashRef',  lazy_build => 1);
  28   has ordered_fields  => (is => 'ro', isa => 'ArrayRef', lazy_build => 1);
  29   has excluded_fields => (is => 'ro', isa => 'ArrayRef', lazy_build => 1);
  30
  31   implements BUILD => as {
  32     my ($self, $args) = @_;
  33     my $field_args = delete $args->{Field};
  34     $self->field_args( $field_args ) if ref $field_args;
  35   };
  36
  37   implements _build_excluded_fields => as { [] };
  38   implements _build_builder_cache   => as { {} };
  39
  40   implements _build_fields => as {
  41     my ($self) = @_;
  42     my $obj  = $self->model;
  43     my $args = $self->has_field_args ? $self->field_args : {};
  44     my @fields;
  45     for my $field_name (@{ $self->field_order }) {
  46       my $attr = $obj->meta->find_attribute_by_name($field_name);
  47       my $meth = $self->builder_cache->{$field_name} ||= $self->get_builder_for($attr);
  48       my $field = $self->$meth($obj, $attr, ($args->{$field_name} || {}));
  49       push(@fields, $field) if $field;
  50     }
  51     return \@fields;
  52   };
  53
  54   implements _build_ordered_fields => as {
  55     my ($self) = @_;
  56     my %excluded = map { $_ => undef } @{ $self->excluded_fields };
  57     #treat _$field_name as private and exclude fields with no reader
  58     my @names = grep { $_ !~ /^_/ && !exists($excluded{$_})} map { $_->name }
  59       grep { defined $_->get_read_method } $self->model->meta->parameter_attributes;
  60     return $self->sort_by_spec($self->field_order, \@names);
  61   };
  62
  63   override child_event_sinks => sub {
  64     return ( shift->fields, super());
  65   };
  66
  67   #candidate for shared role!
  68   implements get_builder_for => as {
  69     my ($self, $attr) = @_;
  70     my $attr_name = $attr->name;
  71     my $builder = "_build_fields_for_name_${attr_name}";
  72     return $builder if $self->can($builder);
  73     if ($attr->has_type_constraint) {
  74       my $constraint = $attr->type_constraint;
  75       my $base_name = $constraint->name;
  76       my $tried_isa = 0;
  77     CONSTRAINT: while (defined($constraint)) {
  78         my $name = $constraint->name;
  79         $name = $attr->_isa_metadata if($name eq '__ANON__');
  80         if (eval { $name->can('meta') } && !$tried_isa++) {
  81           foreach my $class ($name->meta->class_precedence_list) {
  82             my $mangled_name = $class;
  83             $mangled_name =~ s/:+/_/g;
  84             my $builder = "_build_fields_for_type_${mangled_name}";
  85             return $builder if $self->can($builder);
  86           }
  87         }
  88         if (defined($name)) {
  89           unless (defined($base_name)) {
  90             $base_name = "(anon subtype of ${name})";
  91           }
  92           my $mangled_name = $name;
  93           $mangled_name =~ s/:+/_/g;
  94           my $builder = "_build_fields_for_type_${mangled_name}";
  95           return $builder if $self->can($builder);
  96         }
  97         $constraint = $constraint->parent;
  98       }
  99       if (!defined($constraint)) {
 100         confess "Can't build field ${attr_name} of type ${base_name} without $builder method or _build_fields_for_type_<type> method for type or any supertype";
 101       }
 102     } else {
 103       confess "Can't build field ${attr} without $builder method or type constraint";
 104     }
 105   };
 106
 107   implements _build_simple_field => as {
 108     my ($self, %args) = @_;
 109     my $class = delete $args{class};
 110     confess("Can not build simple field without a viewport class")
 111       unless $class;
 112     confess("Can not build simple field without attribute")
 113       unless defined $args{attribute};
 114
 115     my $field_name = $args{attribute}->name;
 116     return $class->new(
 117                        ctx       => $self->ctx,
 118                        model     => $self->model,
 119                        location  => join('-', $self->location, 'field', $field_name),
 120                        %args
 121                       );
 122   };
 123
 124   implements _build_fields_for_type_Num => as {
 125     my ($self, $attr, $args) = @_;
 126     $self->_build_simple_field(attribute => $attr, class => Number, %$args);
 127   };
 128
 129   implements _build_fields_for_type_Int => as {
 130     my ($self, $attr, $args) = @_;
 131     #XXX
 132     $self->_build_simple_field(attribute => $attr, class => Integer, %$args);
 133   };
 134
 135   implements _build_fields_for_type_Bool => as {
 136     my ($self,  $attr, $args) = @_;
 137     $self->_build_simple_field(attribute => $attr, class => Boolean, %$args);
 138   };
 139
 140   #XXX
 141   implements _build_fields_for_type_Password => as { return };
 142
 143   implements _build_fields_for_type_Str => as {
 144     my ($self, $attr, $args) = @_;
 145     #XXX
 146     $self->_build_simple_field(attribute => $attr, class => String, %$args);
 147   };
 148
 149   implements _build_fields_for_type_SimpleStr => as {
 150     my ($self, $attr, $args) = @_;
 151     $self->_build_simple_field(attribute => $attr, class => String, %$args);
 152   };
 153
 154   implements _build_fields_for_type_DateTime => as {
 155     my ($self, $attr, $args) = @_;
 156     $self->_build_simple_field(attribute => $attr, class => DateTime, %$args);
 157   };
 158
 159   implements _build_fields_for_type_Enum => as {
 160     my ($self, $attr, $args) = @_;
 161     #XXX
 162     $self->_build_simple_field(attribute => $attr, class => String, %$args);
 163   };
 164
 165   implements _build_fields_for_type_ArrayRef => as {
 166     my ($self, $attr, $args) = @_;
 167     $self->_build_simple_field(attribute => $attr, class => Array, %$args);
 168   };
 169
 170   implements _build_fields_for_type_Reaction_InterfaceModel_Object => as {
 171     my ($self, $attr, $args) = @_;
 172     #XXX
 173     $self->_build_simple_field(attribute => $attr, class => RelatedObject, %$args);
 174   };
 175
 176   implements _build_fields_for_type_Reaction_InterfaceModel_Collection => as {
 177     my ($self, $attr, $args) = @_;
 178     $self->_build_simple_field(attribute => $attr, class => Collection, %$args);
 179   };
 180
 181 };
 182
 183 1;