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