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 sub _build_fields_for_type_MooseX_Types_Common_String_SimpleStr {
 243   my ($self, $attr, $args) = @_;
 244   $self->_build_simple_field(attribute => $attr, class => String, %$args);
 245 }
 246
 247 sub _build_fields_for_type_MooseX_Types_Common_String_Password {
 248   return;
 249 }
 250
 251 sub _build_fields_for_type_MooseX_Types_DateTime_DateTime {
 252   my ($self, $attr, $args) = @_;
 253   $self->_build_simple_field(attribute => $attr, class => DateTime, %$args);
 254 }
 255
 256 sub _build_fields_for_type_DateTime {
 257   my ($self, $attr, $args) = @_;
 258   $self->_build_simple_field(attribute => $attr, class => DateTime, %$args);
 259 }
 260
 261 __PACKAGE__->meta->make_immutable;
 262
 263 1;
 264
 265 __END__;
 266
 267 =head1 NAME
 268
 269 Reaction::UI::ViewPort::Object
 270
 271 =head1 DESCRIPTION
 272
 273 =head1 ATTRIBUTES
 274
 275 =head2 model
 276
 277 =head2 fields
 278
 279 =head2 field_args
 280
 281 =head2 field_order
 282
 283 =head2 builder_cache
 284
 285 =head2 excluded_fields
 286
 287 =head2 computed_field_order
 288
 289 =head1 INTERNAL METHODS
 290
 291 These methods, although stable, are subject to change without notice. These are meant
 292 to be used only by developers. End users should refrain from using these methods to
 293 avoid potential breakages.
 294
 295 =head2 BUILD
 296
 297 =head2 get_builder_for
 298
 299 =head2 _build_simple_field
 300
 301 =head2 _build_fields_for_type_Num
 302
 303 =head2 _build_fields_for_type_Int
 304
 305 =head2 _build_fields_for_type_Bool
 306
 307 =head2 _build_fields_for_type_Password
 308
 309 =head2 _build_fields_for_type_Str
 310
 311 =head2 _build_fields_for_type_SimpleStr
 312
 313 =head2 _build_fields_for_type_DateTime
 314
 315 =head2 _build_fields_for_type_Enum
 316
 317 =head2 _build_fields_for_type_ArrayRef
 318
 319 =head2 _build_fields_for_type_Reaction_InterfaceModel_Object
 320
 321 =head2 _build_fields_for_type_Reaction_InterfaceModel_Collection
 322
 323 =head1 AUTHORS
 324
 325 See L<Reaction::Class> for authors.
 326
 327 =head1 LICENSE
 328
 329 See L<Reaction::Class> for the license.
 330
 331 =cut