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