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 use aliased 'Reaction::UI::ViewPort::Field::File';
  15 use aliased 'Reaction::UI::ViewPort::Field::Container';
  16
  17 use aliased 'Reaction::InterfaceModel::Object' => 'IM_Object';
  18
  19 use namespace::clean -except => [ qw(meta) ];
  20 extends 'Reaction::UI::ViewPort';
  21
  22 #everything is read only right now. Later I can make somethings read-write
  23 #but first I need to figure out what depends on what so we can have decent triggers
  24 has model  => (is => 'ro', isa => IM_Object, required => 1);
  25 has fields => (is => 'ro', isa => 'ArrayRef', lazy_build => 1);
  26
  27 has field_args    => (is => 'rw');
  28 has field_order   => (is => 'ro', isa => 'ArrayRef');
  29
  30 has builder_cache   => (is => 'ro', isa => 'HashRef',  lazy_build => 1);
  31 has excluded_fields => (is => 'ro', isa => 'ArrayRef', lazy_build => 1);
  32 has computed_field_order => (is => 'ro', isa => 'ArrayRef', lazy_build => 1);
  33
  34 has containers => ( is => 'ro', isa => 'ArrayRef', lazy_build => 1);
  35 has container_layouts => ( is => 'rw', isa => 'ArrayRef' );
  36
  37 sub BUILD {
  38   my ($self, $args) = @_;
  39   if( my $field_args = delete $args->{Field} ){
  40     $self->field_args( $field_args );
  41   }
  42 }
  43
  44 sub _build_builder_cache { {} }
  45 sub _build_excluded_fields { [] }
  46
  47 sub _build_containers {
  48   my $self = shift;
  49
  50   my @container_layouts;
  51   if( $self->has_container_layouts ){
  52     #make sure we don't accidentally modify the original
  53     @container_layouts = map { {%$_} }@{ $self->container_layouts };
  54   } #we should always have a '_' container;
  55   unless (grep {$_->{name} eq '_'} @container_layouts ){
  56     unshift(@container_layouts, {name => '_'});
  57   }
  58
  59   my %fields;
  60   my $ordered_field_names = $self->computed_field_order;
  61   @fields{ @$ordered_field_names } = @{ $self->fields };
  62
  63   my %containers;
  64   my @container_order;
  65   for my $layout ( @container_layouts ){
  66     my @container_fields;
  67     my $name = $layout->{name};
  68     push(@container_order, $name);
  69     if( my $field_names = delete $layout->{fields} ){
  70       map{ push(@container_fields, $_) } grep { defined }
  71         map { delete $fields{$_} } @$field_names;
  72     }
  73     $containers{$name} = Container->new(
  74       ctx => $self->ctx,
  75       location => join( '-', $self->location, 'container', $name ),
  76       fields => \@container_fields,
  77       %$layout,
  78     );
  79   }
  80   if( keys %fields ){
  81     my @leftovers = grep { exists $fields{$_} } @$ordered_field_names;
  82     push(@{ $containers{_}->fields }, @fields{@leftovers} );
  83   }
  84
  85   #only return containers with at least one field
  86   return [ grep { scalar(@{ $_->fields }) } @containers{@container_order} ];
  87 }
  88
  89 sub _build_fields {
  90   my ($self) = @_;
  91   my $obj  = $self->model;
  92   my $args = $self->has_field_args ? $self->field_args : {};
  93   my @fields;
  94   my %param_attrs = map { $_->name => $_ } $obj->parameter_attributes;
  95   for my $field_name (@{ $self->computed_field_order }) {
  96     my $attr = $param_attrs{$field_name};
  97     my $meth = $self->builder_cache->{$field_name} ||= $self->get_builder_for($attr);
  98     my $field = $self->$meth($attr, ($args->{$field_name} || {}));
  99     next unless $field;
 100     push(@fields, $field);
 101   }
 102   return \@fields;
 103 }
 104
 105 sub _build_computed_field_order {
 106   my ($self) = @_;
 107   my %excluded = map { $_ => undef } @{ $self->excluded_fields };
 108   #treat _$field_name as private and exclude fields with no reader
 109   my @names = grep { $_ !~ /^_/ && !exists($excluded{$_})} map { $_->name }
 110     grep { defined $_->get_read_method } $self->model->parameter_attributes;
 111   return $self->sort_by_spec($self->field_order || [], \@names);
 112 }
 113
 114 override child_event_sinks => sub {
 115   return ( @{shift->fields}, super());
 116 };
 117
 118 #candidate for shared role!
 119 sub get_builder_for {
 120   my ($self, $attr) = @_;
 121   my $attr_name = $attr->name;
 122   my $builder = "_build_fields_for_name_${attr_name}";
 123   return $builder if $self->can($builder);
 124   if ($attr->has_type_constraint) {
 125     my $constraint = $attr->type_constraint;
 126     my $base_name = $constraint->name;
 127     my $tried_isa = 0;
 128     my @tried;
 129   CONSTRAINT: while (defined($constraint)) {
 130       my $name = $constraint->name;
 131       $name = $attr->_isa_metadata if($name eq '__ANON__');
 132       if (eval { $name->can('meta') } && !$tried_isa++) {
 133         foreach my $class ($name->meta->class_precedence_list) {
 134           push(@tried, $class);
 135           my $mangled_name = $class;
 136           $mangled_name =~ s/:+/_/g;
 137           my $builder = "_build_fields_for_type_${mangled_name}";
 138           return $builder if $self->can($builder);
 139         }
 140       }
 141       if (defined($name)) {
 142         push(@tried, $name);
 143         unless (defined($base_name)) {
 144           $base_name = "(anon subtype of ${name})";
 145         }
 146         my $mangled_name = $name;
 147         $mangled_name =~ s/:+/_/g;
 148         my $builder = "_build_fields_for_type_${mangled_name}";
 149         return $builder if $self->can($builder);
 150       }
 151       $constraint = $constraint->parent;
 152     }
 153     if (!defined($constraint)) {
 154       confess "Can't build field ${attr_name} of type ${base_name} without "
 155               ."$builder method or _build_fields_for_type_<type> method "
 156               ."for type or any supertype (tried ".join(', ', @tried).")";
 157     }
 158   } else {
 159     confess "Can't build field ${attr} without $builder method or type constraint";
 160   }
 161 }
 162
 163 sub _build_simple_field {
 164   my ($self, %args) = @_;
 165   my $class = delete $args{class};
 166   confess("Can not build simple field without a viewport class")
 167     unless $class;
 168   confess("Can not build simple field without attribute")
 169     unless defined $args{attribute};
 170
 171   my $field_name = $args{attribute}->name;
 172   return $class->new(
 173     ctx => $self->ctx,
 174     model => $self->model,
 175     location => join('-', $self->location, 'field', $field_name),
 176     %args
 177   );
 178 }
 179
 180 sub _build_fields_for_type_Num {
 181   my ($self, $attr, $args) = @_;
 182   $self->_build_simple_field(attribute => $attr, class => Number, %$args);
 183 }
 184
 185 sub _build_fields_for_type_Int {
 186   my ($self, $attr, $args) = @_;
 187   #XXX
 188   $self->_build_simple_field(attribute => $attr, class => Integer, %$args);
 189 }
 190
 191 sub _build_fields_for_type_Bool {
 192   my ($self,  $attr, $args) = @_;
 193   $self->_build_simple_field(attribute => $attr, class => Boolean, %$args);
 194 }
 195
 196 #XXX
 197 sub _build_fields_for_type_Reaction_Types_Core_Password { return };
 198
 199 sub _build_fields_for_type_Str {
 200   my ($self, $attr, $args) = @_;
 201   #XXX
 202   $self->_build_simple_field(attribute => $attr, class => String, %$args);
 203 }
 204
 205 sub _build_fields_for_type_Reaction_Types_Core_SimpleStr {
 206   my ($self, $attr, $args) = @_;
 207   $self->_build_simple_field(attribute => $attr, class => String, %$args);
 208 }
 209
 210 sub _build_fields_for_type_Reaction_Types_DateTime_DateTime {
 211   my ($self, $attr, $args) = @_;
 212   $self->_build_simple_field(attribute => $attr, class => DateTime, %$args);
 213 }
 214
 215 sub _build_fields_for_type_Enum {
 216   my ($self, $attr, $args) = @_;
 217   #XXX
 218   $self->_build_simple_field(attribute => $attr, class => String, %$args);
 219 }
 220
 221 sub _build_fields_for_type_ArrayRef {
 222   my ($self, $attr, $args) = @_;
 223   $self->_build_simple_field(attribute => $attr, class => Array, %$args);
 224 }
 225
 226 sub _build_fields_for_type_Reaction_Types_File_File {
 227   my ($self, $attr, $args) = @_;
 228   $self->_build_simple_field(attribute => $attr, class => File, %$args);
 229 }
 230
 231 sub _build_fields_for_type_Reaction_InterfaceModel_Object {
 232   my ($self, $attr, $args) = @_;
 233   #XXX
 234   $self->_build_simple_field(attribute => $attr, class => RelatedObject, %$args);
 235 }
 236
 237 sub _build_fields_for_type_Reaction_InterfaceModel_Collection {
 238   my ($self, $attr, $args) = @_;
 239   $self->_build_simple_field(attribute => $attr, class => Collection, %$args);
 240 }
 241
 242 __PACKAGE__->meta->make_immutable;
 243
 244 1;
 245
 246 __END__;
 247
 248 =head1 NAME
 249
 250 Reaction::UI::ViewPort::Object
 251
 252 =head1 DESCRIPTION
 253
 254 =head1 ATTRIBUTES
 255
 256 =head2 model
 257
 258 =head2 fields
 259
 260 =head2 field_args
 261
 262 =head2 field_order
 263
 264 =head2 builder_cache
 265
 266 =head2 excluded_fields
 267
 268 =head2 computed_field_order
 269
 270 =head1 INTERNAL METHODS
 271
 272 These methods, although stable, are subject to change without notice. These are meant
 273 to be used only by developers. End users should refrain from using these methods to
 274 avoid potential breakages.
 275
 276 =head2 BUILD
 277
 278 =head2 get_builder_for
 279
 280 =head2 _build_simple_field
 281
 282 =head2 _build_fields_for_type_Num
 283
 284 =head2 _build_fields_for_type_Int
 285
 286 =head2 _build_fields_for_type_Bool
 287
 288 =head2 _build_fields_for_type_Password
 289
 290 =head2 _build_fields_for_type_Str
 291
 292 =head2 _build_fields_for_type_SimpleStr
 293
 294 =head2 _build_fields_for_type_DateTime
 295
 296 =head2 _build_fields_for_type_Enum
 297
 298 =head2 _build_fields_for_type_ArrayRef
 299
 300 =head2 _build_fields_for_type_Reaction_InterfaceModel_Object
 301
 302 =head2 _build_fields_for_type_Reaction_InterfaceModel_Collection
 303
 304 =head1 AUTHORS
 305
 306 See L<Reaction::Class> for authors.
 307
 308 =head1 LICENSE
 309
 310 See L<Reaction::Class> for the license.
 311
 312 =cut