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 MooseX::Types::Moose qw/ArrayRef HashRef/;
  20
  21 use namespace::clean -except => [ qw(meta) ];
  22 extends 'Reaction::UI::ViewPort';
  23
  24 #everything is read only right now. Later I can make somethings read-write
  25 #but first I need to figure out what depends on what so we can have decent triggers
  26 has model  => (is => 'ro', isa => IM_Object, required => 1);
  27 has fields => (is => 'ro', isa => ArrayRef, lazy_build => 1);
  28
  29 has field_args    => (is => 'rw');
  30 has field_order   => (is => 'ro', isa => ArrayRef);
  31
  32 has builder_cache   => (is => 'ro', isa => HashRef,  lazy_build => 1);
  33 has excluded_fields => (is => 'ro', isa => ArrayRef, lazy_build => 1);
  34 has included_fields => (is => 'ro', isa => ArrayRef, lazy_build => 1);
  35 has computed_field_order => (is => 'ro', isa => ArrayRef, lazy_build => 1);
  36
  37 has containers => ( is => 'ro', isa => ArrayRef, lazy_build => 1);
  38 has container_layouts => ( is => 'rw', isa => ArrayRef );
  39
  40 sub BUILD {
  41   my ($self, $args) = @_;
  42   if( my $field_args = delete $args->{Field} ){
  43     $self->field_args( $field_args );
  44   }
  45 }
  46
  47 sub _build_builder_cache { {} }
  48 sub _build_excluded_fields { [] }
  49 sub _build_included_fields { [] }
  50
  51 sub _build_containers {
  52   my $self = shift;
  53
  54   my @container_layouts;
  55   if( $self->has_container_layouts ){
  56     #make sure we don't accidentally modify the original
  57     @container_layouts = map { {%$_} }@{ $self->container_layouts };
  58   } #we should always have a '_' container;
  59   unless (grep {$_->{name} eq '_'} @container_layouts ){
  60     unshift(@container_layouts, {name => '_'});
  61   }
  62
  63   my %fields;
  64   my $ordered_field_names = $self->computed_field_order;
  65   @fields{ @$ordered_field_names } = @{ $self->fields };
  66
  67   my %containers;
  68   my @container_order;
  69   for my $layout ( @container_layouts ){
  70     my @container_fields;
  71     my $name = $layout->{name};
  72     push(@container_order, $name);
  73     if( my $field_names = delete $layout->{fields} ){
  74       map{ push(@container_fields, $_) } grep { defined }
  75         map { delete $fields{$_} } @$field_names;
  76     }
  77     $containers{$name} = Container->new(
  78       ctx => $self->ctx,
  79       location => join( '-', $self->location, 'container', $name ),
  80       fields => \@container_fields,
  81       %$layout,
  82     );
  83   }
  84   if( keys %fields ){
  85     my @leftovers = grep { exists $fields{$_} } @$ordered_field_names;
  86     push(@{ $containers{_}->fields }, @fields{@leftovers} );
  87   }
  88
  89   #only return containers with at least one field
  90   return [ grep { scalar(@{ $_->fields }) } @containers{@container_order} ];
  91 }
  92
  93 sub _build_fields {
  94   my ($self) = @_;
  95   my $obj  = $self->model;
  96   my $args = $self->has_field_args ? $self->field_args : {};
  97   my @fields;
  98   my %param_attrs = map { $_->name => $_ } $obj->parameter_attributes;
  99   for my $field_name (@{ $self->computed_field_order }) {
 100     my $attr = $param_attrs{$field_name};
 101     my $meth = $self->builder_cache->{$field_name} ||= $self->get_builder_for($attr);
 102     my $field = $self->$meth($attr, ($args->{$field_name} || {}));
 103     next unless $field;
 104     push(@fields, $field);
 105   }
 106   return \@fields;
 107 }
 108
 109 sub _build_computed_field_order {
 110   my ($self) = @_;
 111   my %excluded = map { $_ => undef } @{ $self->excluded_fields };
 112   my %included = map { $_ => undef } @{ $self->included_fields };
 113   #treat _$field_name as private and exclude fields with no reader
 114   my @names = grep { $_ !~ /^_/ && (!%included || exists( $included{$_}) )
 115     && !exists($excluded{$_}) } map { $_->name }
 116     grep { defined $_->get_read_method } $self->model->parameter_attributes;
 117   return $self->sort_by_spec($self->field_order || [], \@names);
 118 }
 119
 120 override child_event_sinks => sub {
 121   return ( @{shift->fields}, super());
 122 };
 123
 124 #candidate for shared role!
 125 sub get_builder_for {
 126   my ($self, $attr) = @_;
 127   my $attr_name = $attr->name;
 128   my $builder = "_build_fields_for_name_${attr_name}";
 129   return $builder if $self->can($builder);
 130   if ($attr->has_type_constraint) {
 131     my $constraint = $attr->type_constraint;
 132     my $base_name = $constraint->name;
 133     my $tried_isa = 0;
 134     my @tried;
 135   CONSTRAINT: while (defined($constraint)) {
 136       my $name = $constraint->name;
 137       $name = $attr->_isa_metadata if($name eq '__ANON__');
 138       if (eval { $name->can('meta') } && !$tried_isa++) {
 139         foreach my $class ($name->meta->class_precedence_list) {
 140           push(@tried, $class);
 141           my $mangled_name = $class;
 142           $mangled_name =~ s/:+/_/g;
 143           my $builder = "_build_fields_for_type_${mangled_name}";
 144           return $builder if $self->can($builder);
 145         }
 146       }
 147       if (defined($name)) {
 148         push(@tried, $name);
 149         unless (defined($base_name)) {
 150           $base_name = "(anon subtype of ${name})";
 151         }
 152         my $mangled_name = $name;
 153         $mangled_name =~ s/:+/_/g;
 154         my $builder = "_build_fields_for_type_${mangled_name}";
 155         return $builder if $self->can($builder);
 156       }
 157       $constraint = $constraint->parent;
 158     }
 159     if (!defined($constraint)) {
 160       confess "Can't build field ${attr_name} of type ${base_name} without "
 161               ."$builder method or _build_fields_for_type_<type> method "
 162               ."for type or any supertype (tried ".join(', ', @tried).")";
 163     }
 164   } else {
 165     confess "Can't build field ${attr} without $builder method or type constraint";
 166   }
 167 }
 168
 169 sub _build_simple_field {
 170   my ($self, %args) = @_;
 171   my $class = delete $args{class};
 172   confess("Can not build simple field without a viewport class")
 173     unless $class;
 174   confess("Can not build simple field without attribute")
 175     unless defined $args{attribute};
 176
 177   my $field_name = $args{attribute}->name;
 178   return $class->new(
 179     ctx => $self->ctx,
 180     model => $self->model,
 181     location => join('-', $self->location, 'field', $field_name),
 182     %args
 183   );
 184 }
 185
 186 sub _build_fields_for_type_Num {
 187   my ($self, $attr, $args) = @_;
 188   $self->_build_simple_field(attribute => $attr, class => Number, %$args);
 189 }
 190
 191 sub _build_fields_for_type_Int {
 192   my ($self, $attr, $args) = @_;
 193   #XXX
 194   $self->_build_simple_field(attribute => $attr, class => Integer, %$args);
 195 }
 196
 197 sub _build_fields_for_type_Bool {
 198   my ($self,  $attr, $args) = @_;
 199   $self->_build_simple_field(attribute => $attr, class => Boolean, %$args);
 200 }
 201
 202 #XXX
 203 sub _build_fields_for_type_Reaction_Types_Core_Password { return };
 204
 205 sub _build_fields_for_type_Str {
 206   my ($self, $attr, $args) = @_;
 207   #XXX
 208   $self->_build_simple_field(attribute => $attr, class => String, %$args);
 209 }
 210
 211 sub _build_fields_for_type_Reaction_Types_Core_SimpleStr {
 212   my ($self, $attr, $args) = @_;
 213   $self->_build_simple_field(attribute => $attr, class => String, %$args);
 214 }
 215
 216 sub _build_fields_for_type_Reaction_Types_DateTime_DateTime {
 217   my ($self, $attr, $args) = @_;
 218   $self->_build_simple_field(attribute => $attr, class => DateTime, %$args);
 219 }
 220
 221 sub _build_fields_for_type_Enum {
 222   my ($self, $attr, $args) = @_;
 223   #XXX
 224   $self->_build_simple_field(attribute => $attr, class => String, %$args);
 225 }
 226
 227 sub _build_fields_for_type_ArrayRef {
 228   my ($self, $attr, $args) = @_;
 229   $self->_build_simple_field(attribute => $attr, class => Array, %$args);
 230 }
 231
 232 sub _build_fields_for_type_Reaction_Types_File_File {
 233   my ($self, $attr, $args) = @_;
 234   $self->_build_simple_field(attribute => $attr, class => File, %$args);
 235 }
 236
 237 sub _build_fields_for_type_Reaction_InterfaceModel_Object {
 238   my ($self, $attr, $args) = @_;
 239   #XXX
 240   $self->_build_simple_field(attribute => $attr, class => RelatedObject, %$args);
 241 }
 242
 243 sub _build_fields_for_type_Reaction_InterfaceModel_Collection {
 244   my ($self, $attr, $args) = @_;
 245   $self->_build_simple_field(attribute => $attr, class => Collection, %$args);
 246 }
 247
 248 sub _build_fields_for_type_MooseX_Types_Common_String_SimpleStr {
 249   my ($self, $attr, $args) = @_;
 250   $self->_build_simple_field(attribute => $attr, class => String, %$args);
 251 }
 252
 253 sub _build_fields_for_type_MooseX_Types_Common_String_Password {
 254   return;
 255 }
 256
 257 sub _build_fields_for_type_MooseX_Types_DateTime_DateTime {
 258   my ($self, $attr, $args) = @_;
 259   $self->_build_simple_field(attribute => $attr, class => DateTime, %$args);
 260 }
 261
 262 sub _build_fields_for_type_DateTime {
 263   my ($self, $attr, $args) = @_;
 264   $self->_build_simple_field(attribute => $attr, class => DateTime, %$args);
 265 }
 266
 267 __PACKAGE__->meta->make_immutable;
 268
 269 1;
 270
 271 __END__;
 272
 273 =head1 NAME
 274
 275 Reaction::UI::ViewPort::Object - Display an InterfaceModel::Object
 276
 277 =head1 SYNOPSIS
 278
 279   use aliased 'Reaction::UI::ViewPort::Object';
 280
 281   ...
 282   $controller->push_viewport(Object,
 283     model           => $person_interface_model_object,
 284     fields_order    => [qw( firstname lastname )],
 285     excluded_fields => [qw( password )],
 286   );
 287
 288 =head1 DESCRIPTION
 289
 290 Takes a L<Reaction::InterfaceModel::Object> class and displays the
 291 configured fields.
 292
 293 =head1 ATTRIBUTES
 294
 295 =head2 model
 296
 297 Required L<Reaction::InterfaceModel::Object>.
 298
 299 =head2 fields
 300
 301 Initialised via L</_build_fields>
 302
 303 =head2 field_args
 304
 305 Hash reference keyed by field names. Values are hash references containing
 306 arguments to the field builder method of the attribute.
 307
 308 =head2 field_order
 309
 310 Array reference of strings defining the order of all fields (including
 311 the ones that might be excluded).
 312
 313 =head2 builder_cache
 314
 315 Hash reference containing resolved builder method names per field. Utilised
 316 by L</_build_fields>
 317
 318 =head2 excluded_fields
 319
 320 Array reference of strings naming fields to exclude from the interface.
 321
 322 =head2 included_fields
 323
 324 List of field names to include. If both C<included_fields> and
 325 C<excluded_fields> are specified the result is those fields which
 326 are in C<included_fields> and not in C<excluded_fields>.
 327
 328 =head2 computed_field_order
 329
 330 Array reference of strings Initialised by the L</_computed_field_order> method.
 331 Contains the fields to show in the correct order.
 332
 333 =head2 containers
 334
 335 Array reference populated by L</_build_containers>.
 336
 337 =head2 container_layouts
 338
 339 Array reference containing container layout specifications.
 340
 341 =head1 INTERNAL METHODS
 342
 343 These methods, although stable, are subject to change without notice. These are meant
 344 to be used only by developers. End users should refrain from using these methods to
 345 avoid potential breakages.
 346
 347 =head2 BUILD
 348
 349 Takes the value of the C<Field> constructor argument, if true, and sets it as
 350 the new L</field_args> hash reference.
 351
 352 =head2 get_builder_for
 353
 354 Takes an attribute object as argument and returns a string containing
 355 the name of the method that builds the fields for this attribute.
 356
 357 If the viewport implements it, C<_build_fields_for_name_${attr_name}> will be used.
 358
 359 If that is not available, it will take the C<isa> information of the type constraint
 360 and see if it is a loaded class implementing C<meta>. If it is, every class in its
 361 C<class_precedence_list> will be taken and used to try to find a
 362 C<_build_fields_for_type_${mangled_class_name}> method on the viewport.
 363
 364 "mangled" means here that every C<:*> will be replaced with C<_>. For example:
 365 C<Foo::Bar> would become C<Foo_Bar>.
 366
 367 If the C<isa> information was not obtainable or no fitting method was found, it will
 368 try the type name in a method named C<_build_fields_for_type_${mangled_type_name}>.
 369
 370 If could be found on this constraint, it will make the same attempts to find a
 371 method on its parent type constraint.
 372
 373 This method will die if it can't locate a method to build a field for this
 374 attribute.
 375
 376 =head2 _build_containers
 377
 378 Uses L</container_layouts> to build a list of L<Reaction::UI::ViewPort::Field::Container>
 379 objects.
 380
 381 =head2 _build_fields
 382
 383 Takes the L</model>s C<parameter_attributes> to build fields via L</get_builder_for>.
 384 They will be ordered as specified in L</computed_field_order>.
 385
 386 =head2 _build_computed_field_order
 387
 388 Takes the names of the L</model>s C<parameter_attributes>' reader methods and assumes
 389 them as field names. Then it uses L</field_order> and L</excluded_fields> to calculate
 390 the order of all included fields and returns those names.
 391
 392 =head2 _build_simple_field
 393
 394   $self->_build_simple_field(
 395     attribute => $attribute_object,
 396     class     => $field_class,
 397     %field_attrs,
 398   );
 399
 400 Takes an attribute meta object, a field class (a L<Reaction::UI::ViewPort::Field> subclass)
 401 and an additional set of arguments to pass to the field constructor and returns the new
 402 field. Field classes themselves are L<Reaction::UI::ViewPort> subclasses.
 403
 404 =head2 _build_fields_for_type_Num
 405
 406 =head2 _build_fields_for_type_Int
 407
 408 =head2 _build_fields_for_type_Bool
 409
 410 =head2 _build_fields_for_type_Password
 411
 412 =head2 _build_fields_for_type_Str
 413
 414 =head2 _build_fields_for_type_SimpleStr
 415
 416 =head2 _build_fields_for_type_DateTime
 417
 418 =head2 _build_fields_for_type_Enum
 419
 420 =head2 _build_fields_for_type_ArrayRef
 421
 422 =head2 _build_fields_for_type_Reaction_InterfaceModel_Object
 423
 424 =head2 _build_fields_for_type_Reaction_InterfaceModel_Collection
 425
 426 =head1 FIELD TYPES
 427
 428 L<Text|Reaction::UI::ViewPort::Field::Text>,
 429 L<Number|Reaction::UI::ViewPort::Field::Number>,
 430 L<Integer|Reaction::UI::ViewPort::Field::Integer>,
 431 L<Boolean|Reaction::UI::ViewPort::Field::Boolean>,
 432 L<String|Reaction::UI::ViewPort::Field::String>,
 433 L<DateTime|Reaction::UI::ViewPort::Field::DateTime>,
 434 L<RelatedObject|Reaction::UI::ViewPort::Field::RelatedObject>,
 435 L<Array|Reaction::UI::ViewPort::Field::Array>,
 436 L<Collection|Reaction::UI::ViewPort::Field::Collection>,
 437 L<File|Reaction::UI::ViewPort::Field::File>,
 438 L<Container|Reaction::UI::ViewPort::Field::Container>
 439
 440 =head1 AUTHORS
 441
 442 See L<Reaction::Class> for authors.
 443
 444 =head1 LICENSE
 445
 446 See L<Reaction::Class> for the license.
 447
 448 =cut