X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FReaction%2FUI%2FViewPort%2FObject.pm;h=ed68f20888310cc8ca19792df36b39588b9ab90e;hb=91140599186e2a589b4a4a9aa5d2d441fbdd0aee;hp=73facb9d06f76590c16163cdda37f9adcea4f3dd;hpb=56c5a4a1e847761faf792d9f1b3aebc17a85744d;p=catagits%2FReaction.git

diff --git a/lib/Reaction/UI/ViewPort/Object.pm b/lib/Reaction/UI/ViewPort/Object.pm
index 73facb9..ed68f20 100644
--- a/lib/Reaction/UI/ViewPort/Object.pm
+++ b/lib/Reaction/UI/ViewPort/Object.pm
@@ -12,184 +12,234 @@ use aliased 'Reaction::UI::ViewPort::Field::RelatedObject';
 use aliased 'Reaction::UI::ViewPort::Field::Array';
 use aliased 'Reaction::UI::ViewPort::Field::Collection';
 use aliased 'Reaction::UI::ViewPort::Field::File';
+use aliased 'Reaction::UI::ViewPort::Field::Container';
 
 use aliased 'Reaction::InterfaceModel::Object' => 'IM_Object';
 
-class Object is 'Reaction::UI::ViewPort', which {
-
-  #everything is read only right now. Later I can make somethings read-write
-  #but first I need to figure out what depends on what so we can have decent triggers
-  has model  => (is => 'ro', isa => IM_Object, required => 1);
-  has fields => (is => 'ro', isa => 'ArrayRef', lazy_build => 1);
-
-  has field_args    => (is => 'rw');
-  has field_order   => (is => 'ro', isa => 'ArrayRef');
-
-  has builder_cache   => (is => 'ro', isa => 'HashRef',  lazy_build => 1);
-  has excluded_fields => (is => 'ro', isa => 'ArrayRef', lazy_build => 1);
-  has computed_field_order => (is => 'ro', isa => 'ArrayRef', lazy_build => 1);
-
-  implements BUILD => as {
-    my ($self, $args) = @_;
-    my $field_args = delete $args->{Field};
-    $self->field_args( $field_args ) if ref $field_args;
-  };
-
-  implements _build_excluded_fields => as { [] };
-  implements _build_builder_cache   => as { {} };
-
-  implements _build_fields => as {
-    my ($self) = @_;
-    my $obj  = $self->model;
-    my $args = $self->has_field_args ? $self->field_args : {};
-    my @fields;
-    for my $field_name (@{ $self->computed_field_order }) {
-      my $attr = $obj->meta->find_attribute_by_name($field_name);
-      my $meth = $self->builder_cache->{$field_name} ||= $self->get_builder_for($attr);
-      my $field = $self->$meth($attr, ($args->{$field_name} || {}));
-      push(@fields, $field) if $field;
+use namespace::clean -except => [ qw(meta) ];
+extends 'Reaction::UI::ViewPort';
+
+#everything is read only right now. Later I can make somethings read-write
+#but first I need to figure out what depends on what so we can have decent triggers
+has model  => (is => 'ro', isa => IM_Object, required => 1);
+has fields => (is => 'ro', isa => 'ArrayRef', lazy_build => 1);
+
+has field_args    => (is => 'rw');
+has field_order   => (is => 'ro', isa => 'ArrayRef');
+
+has builder_cache   => (is => 'ro', isa => 'HashRef',  lazy_build => 1);
+has excluded_fields => (is => 'ro', isa => 'ArrayRef', lazy_build => 1);
+has computed_field_order => (is => 'ro', isa => 'ArrayRef', lazy_build => 1);
+
+has containers => ( is => 'ro', isa => 'ArrayRef', lazy_build => 1);
+has container_layouts => ( is => 'rw', isa => 'ArrayRef' );
+
+sub BUILD {
+  my ($self, $args) = @_;
+  if( my $field_args = delete $args->{Field} ){
+    $self->field_args( $field_args );
+  }
+}
+
+sub _build_builder_cache { {} }
+sub _build_excluded_fields { [] }
+
+sub _build_containers {
+  my $self = shift;
+
+  my @container_layouts;
+  if( $self->has_container_layouts ){
+    #make sure we don't accidentally modify the original
+    @container_layouts = map { {%$_} }@{ $self->container_layouts };
+  } #we should always have a '_' container;
+  unless (grep {$_->{name} eq '_'} @container_layouts ){
+    unshift(@container_layouts, {name => '_'});
+  }
+
+  my %fields;
+  my $ordered_field_names = $self->computed_field_order;
+  @fields{ @$ordered_field_names } = @{ $self->fields };
+
+  my %containers;
+  my @container_order;
+  for my $layout ( @container_layouts ){
+    my @container_fields;
+    my $name = $layout->{name};
+    push(@container_order, $name);
+    if( my $field_names = delete $layout->{fields} ){
+      map{ push(@container_fields, $_) } grep { defined }
+        map { delete $fields{$_} } @$field_names;
     }
-    return \@fields;
-  };
-
-  implements _build_computed_field_order => as {
-    my ($self) = @_;
-    my %excluded = map { $_ => undef } @{ $self->excluded_fields };
-    #treat _$field_name as private and exclude fields with no reader
-    my @names = grep { $_ !~ /^_/ && !exists($excluded{$_})} map { $_->name }
-      grep { defined $_->get_read_method } $self->model->meta->parameter_attributes;
-    return $self->sort_by_spec($self->field_order || [], \@names);
-  };
-
-  override child_event_sinks => sub {
-    return ( @{shift->fields}, super());
-  };
-
-  #candidate for shared role!
-  implements get_builder_for => as {
-    my ($self, $attr) = @_;
-    my $attr_name = $attr->name;
-    my $builder = "_build_fields_for_name_${attr_name}";
-    return $builder if $self->can($builder);
-    if ($attr->has_type_constraint) {
-      my $constraint = $attr->type_constraint;
-      my $base_name = $constraint->name;
-      my $tried_isa = 0;
-      my @tried;
-    CONSTRAINT: while (defined($constraint)) {
-        my $name = $constraint->name;
-        $name = $attr->_isa_metadata if($name eq '__ANON__');
-        if (eval { $name->can('meta') } && !$tried_isa++) {
-          foreach my $class ($name->meta->class_precedence_list) {
-            push(@tried, $class);
-            my $mangled_name = $class;
-            $mangled_name =~ s/:+/_/g;
-            my $builder = "_build_fields_for_type_${mangled_name}";
-            return $builder if $self->can($builder);
-          }
-        }
-        if (defined($name)) {
-          push(@tried, $name);
-          unless (defined($base_name)) {
-            $base_name = "(anon subtype of ${name})";
-          }
-          my $mangled_name = $name;
+    $containers{$name} = Container->new(
+      ctx => $self->ctx,
+      location => join( '-', $self->location, 'container', $name ),
+      fields => \@container_fields,
+      %$layout,
+    );
+  }
+  if( keys %fields ){
+    my @leftovers = grep { exists $fields{$_} } @$ordered_field_names;
+    push(@{ $containers{_}->fields }, @fields{@leftovers} );
+  }
+
+  #only return containers with at least one field
+  return [ grep { scalar(@{ $_->fields }) } @containers{@container_order} ];
+}
+
+sub _build_fields {
+  my ($self) = @_;
+  my $obj  = $self->model;
+  my $args = $self->has_field_args ? $self->field_args : {};
+  my @fields;
+  my %param_attrs = map { $_->name => $_ } $obj->parameter_attributes;
+  for my $field_name (@{ $self->computed_field_order }) {
+    my $attr = $param_attrs{$field_name};
+    my $meth = $self->builder_cache->{$field_name} ||= $self->get_builder_for($attr);
+    my $field = $self->$meth($attr, ($args->{$field_name} || {}));
+    next unless $field;
+    push(@fields, $field);
+  }
+  return \@fields;
+}
+
+sub _build_computed_field_order {
+  my ($self) = @_;
+  my %excluded = map { $_ => undef } @{ $self->excluded_fields };
+  #treat _$field_name as private and exclude fields with no reader
+  my @names = grep { $_ !~ /^_/ && !exists($excluded{$_})} map { $_->name }
+    grep { defined $_->get_read_method } $self->model->parameter_attributes;
+  return $self->sort_by_spec($self->field_order || [], \@names);
+}
+
+override child_event_sinks => sub {
+  return ( @{shift->fields}, super());
+};
+
+#candidate for shared role!
+sub get_builder_for {
+  my ($self, $attr) = @_;
+  my $attr_name = $attr->name;
+  my $builder = "_build_fields_for_name_${attr_name}";
+  return $builder if $self->can($builder);
+  if ($attr->has_type_constraint) {
+    my $constraint = $attr->type_constraint;
+    my $base_name = $constraint->name;
+    my $tried_isa = 0;
+    my @tried;
+  CONSTRAINT: while (defined($constraint)) {
+      my $name = $constraint->name;
+      $name = $attr->_isa_metadata if($name eq '__ANON__');
+      if (eval { $name->can('meta') } && !$tried_isa++) {
+        foreach my $class ($name->meta->class_precedence_list) {
+          push(@tried, $class);
+          my $mangled_name = $class;
           $mangled_name =~ s/:+/_/g;
           my $builder = "_build_fields_for_type_${mangled_name}";
           return $builder if $self->can($builder);
         }
-        $constraint = $constraint->parent;
       }
-      if (!defined($constraint)) {
-        confess "Can't build field ${attr_name} of type ${base_name} without "
-                ."$builder method or _build_fields_for_type_<type> method "
-                ."for type or any supertype (tried ".join(', ', @tried).")";
+      if (defined($name)) {
+        push(@tried, $name);
+        unless (defined($base_name)) {
+          $base_name = "(anon subtype of ${name})";
+        }
+        my $mangled_name = $name;
+        $mangled_name =~ s/:+/_/g;
+        my $builder = "_build_fields_for_type_${mangled_name}";
+        return $builder if $self->can($builder);
       }
-    } else {
-      confess "Can't build field ${attr} without $builder method or type constraint";
+      $constraint = $constraint->parent;
+    }
+    if (!defined($constraint)) {
+      confess "Can't build field ${attr_name} of type ${base_name} without "
+              ."$builder method or _build_fields_for_type_<type> method "
+              ."for type or any supertype (tried ".join(', ', @tried).")";
     }
-  };
-
-  implements _build_simple_field => as {
-    my ($self, %args) = @_;
-    my $class = delete $args{class};
-    confess("Can not build simple field without a viewport class")
-      unless $class;
-    confess("Can not build simple field without attribute")
-      unless defined $args{attribute};
-
-    my $field_name = $args{attribute}->name;
-    return $class->new(
-                       ctx       => $self->ctx,
-                       model     => $self->model,
-                       location  => join('-', $self->location, 'field', $field_name),
-                       %args
-                      );
-  };
-
-  implements _build_fields_for_type_Num => as {
-    my ($self, $attr, $args) = @_;
-    $self->_build_simple_field(attribute => $attr, class => Number, %$args);
-  };
-
-  implements _build_fields_for_type_Int => as {
-    my ($self, $attr, $args) = @_;
-    #XXX
-    $self->_build_simple_field(attribute => $attr, class => Integer, %$args);
-  };
-
-  implements _build_fields_for_type_Bool => as {
-    my ($self,  $attr, $args) = @_;
-    $self->_build_simple_field(attribute => $attr, class => Boolean, %$args);
-  };
+  } else {
+    confess "Can't build field ${attr} without $builder method or type constraint";
+  }
+}
+
+sub _build_simple_field {
+  my ($self, %args) = @_;
+  my $class = delete $args{class};
+  confess("Can not build simple field without a viewport class")
+    unless $class;
+  confess("Can not build simple field without attribute")
+    unless defined $args{attribute};
+
+  my $field_name = $args{attribute}->name;
+  return $class->new(
+    ctx => $self->ctx,
+    model => $self->model,
+    location => join('-', $self->location, 'field', $field_name),
+    %args
+  );
+}
+
+sub _build_fields_for_type_Num {
+  my ($self, $attr, $args) = @_;
+  $self->_build_simple_field(attribute => $attr, class => Number, %$args);
+}
+
+sub _build_fields_for_type_Int {
+  my ($self, $attr, $args) = @_;
+  #XXX
+  $self->_build_simple_field(attribute => $attr, class => Integer, %$args);
+}
+
+sub _build_fields_for_type_Bool {
+  my ($self,  $attr, $args) = @_;
+  $self->_build_simple_field(attribute => $attr, class => Boolean, %$args);
+}
 
+#XXX
+sub _build_fields_for_type_Reaction_Types_Core_Password { return };
+
+sub _build_fields_for_type_Str {
+  my ($self, $attr, $args) = @_;
   #XXX
-  implements _build_fields_for_type_Reaction_Types_Core_Password => as { return };
-
-  implements _build_fields_for_type_Str => as {
-    my ($self, $attr, $args) = @_;
-    #XXX
-    $self->_build_simple_field(attribute => $attr, class => String, %$args);
-  };
-
-  implements _build_fields_for_type_Reaction_Types_Core_SimpleStr => as {
-    my ($self, $attr, $args) = @_;
-    $self->_build_simple_field(attribute => $attr, class => String, %$args);
-  };
-
-  implements _build_fields_for_type_Reaction_Types_DateTime_DateTimeObject => as {
-    my ($self, $attr, $args) = @_;
-    $self->_build_simple_field(attribute => $attr, class => DateTime, %$args);
-  };
-
-  implements _build_fields_for_type_Enum => as {
-    my ($self, $attr, $args) = @_;
-    #XXX
-    $self->_build_simple_field(attribute => $attr, class => String, %$args);
-  };
-
-  implements _build_fields_for_type_ArrayRef => as {
-    my ($self, $attr, $args) = @_;
-    $self->_build_simple_field(attribute => $attr, class => Array, %$args);
-  };
-
-  implements _build_fields_for_type_File => as {
-    my ($self, $attr, $args) = @_;
-    $self->_build_simple_field(attribute => $attr, class => File, %$args);
-  };
-
-  implements _build_fields_for_type_Reaction_InterfaceModel_Object => as {
-    my ($self, $attr, $args) = @_;
-    #XXX
-    $self->_build_simple_field(attribute => $attr, class => RelatedObject, %$args);
-  };
-
-  implements _build_fields_for_type_Reaction_InterfaceModel_Collection => as {
-    my ($self, $attr, $args) = @_;
-    $self->_build_simple_field(attribute => $attr, class => Collection, %$args);
-  };
+  $self->_build_simple_field(attribute => $attr, class => String, %$args);
+}
 
-};
+sub _build_fields_for_type_Reaction_Types_Core_SimpleStr {
+  my ($self, $attr, $args) = @_;
+  $self->_build_simple_field(attribute => $attr, class => String, %$args);
+}
+
+sub _build_fields_for_type_Reaction_Types_DateTime_DateTime {
+  my ($self, $attr, $args) = @_;
+  $self->_build_simple_field(attribute => $attr, class => DateTime, %$args);
+}
+
+sub _build_fields_for_type_Enum {
+  my ($self, $attr, $args) = @_;
+  #XXX
+  $self->_build_simple_field(attribute => $attr, class => String, %$args);
+}
+
+sub _build_fields_for_type_ArrayRef {
+  my ($self, $attr, $args) = @_;
+  $self->_build_simple_field(attribute => $attr, class => Array, %$args);
+}
+
+sub _build_fields_for_type_Reaction_Types_File_File {
+  my ($self, $attr, $args) = @_;
+  $self->_build_simple_field(attribute => $attr, class => File, %$args);
+}
+
+sub _build_fields_for_type_Reaction_InterfaceModel_Object {
+  my ($self, $attr, $args) = @_;
+  #XXX
+  $self->_build_simple_field(attribute => $attr, class => RelatedObject, %$args);
+}
+
+sub _build_fields_for_type_Reaction_InterfaceModel_Collection {
+  my ($self, $attr, $args) = @_;
+  $self->_build_simple_field(attribute => $attr, class => Collection, %$args);
+}
+
+__PACKAGE__->meta->make_immutable;
 
 1;