rewrite IM predicates

diff --git a/lib/Reaction/InterfaceModel/Action.pm b/lib/Reaction/InterfaceModel/Action.pm
index 52b94f8..55cdfbe 100644 (file)
--- a/lib/Reaction/InterfaceModel/Action.pm
+++ b/lib/Reaction/InterfaceModel/Action.pm
@@ -23,7 +23,7 @@ class Action which {
     my %params;
     foreach my $attr ($self->parameter_attributes) {
       my $reader = $attr->get_read_method;
-      my $predicate = $attr->predicate;
+      my $predicate = $attr->get_predicate_method;
       next if defined($predicate) && !$self->$predicate;
       $params{$attr->name} = $self->$reader;
     }
@@ -33,7 +33,7 @@ class Action which {
   implements can_apply => as {
     my ($self) = @_;
     foreach my $attr ($self->parameter_attributes) {
-      my $predicate = $attr->predicate;
+      my $predicate = $attr->get_predicate_method;
       if ($self->attribute_is_required($attr)) {
         return 0 unless $self->$predicate;
       }
@@ -61,7 +61,7 @@ class Action which {
   implements error_for_attribute => as {
     my ($self, $attr) = @_;
     my $reader = $attr->get_read_method;
-    my $predicate = $attr->predicate;
+    my $predicate = $attr->get_predicate_method;
     if ($self->attribute_is_required($attr)) {
       unless ($self->$predicate) {
         return $attr->name." is required";

diff --git a/lib/Reaction/InterfaceModel/Action/User/Login.pm b/lib/Reaction/InterfaceModel/Action/User/Login.pm
index 0bc3d97..46dddea 100644 (file)
--- a/lib/Reaction/InterfaceModel/Action/User/Login.pm
+++ b/lib/Reaction/InterfaceModel/Action/User/Login.pm
@@ -13,7 +13,7 @@ class Login, is Action, which {
     my $super = shift;
     my ($self, $attr) = @_;
     my $result = $super->(@_);
-    my $predicate = $attr->predicate;
+    my $predicate = $attr->get_predicate_method;
     if (defined $result && $self->$predicate) {
       return 'Invalid username or password';
     }

diff --git a/lib/Reaction/InterfaceModel/Reflector/DBIC.pm b/lib/Reaction/InterfaceModel/Reflector/DBIC.pm
index 120ddb1..2c34cdf 100644 (file)
--- a/lib/Reaction/InterfaceModel/Reflector/DBIC.pm
+++ b/lib/Reaction/InterfaceModel/Reflector/DBIC.pm
@@ -676,7 +676,10 @@ class DBIC, which {
     #default options. lazy build but no outsider method
     my %attr_opts = ( is => 'ro', lazy => 1, required => 1,
                       clearer   => "_clear_${attr_name}",
-                      predicate => "has_${attr_name}",
+                      predicate => {
+                          "has_${attr_name}" =>
+                              sub { defined(shift->$dm_name->$attr_name) }
+                      },
                       domain_model   => $dm_name,
                       orig_attr_name => $attr_name,
                     );
@@ -706,8 +709,11 @@ class DBIC, which {
         #type constraint is the foreign IM object, default inflates it
         $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker);
         $attr_opts{default} = sub {
-          shift->$dm_name
-            ->find_related($attr_name, {},{result_class => $attr_opts{isa}});
+          if (defined(my $o = shift->$dm_name->$attr_name)) {
+            return $attr_opts{isa}->inflate_result($o->result_source, { $o->get_columns });
+          }
+          return undef;
+            #->find_related($attr_name, {},{result_class => $attr_opts{isa}});
         };
       }
     } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) {

diff --git a/lib/Reaction/Meta/Attribute.pm b/lib/Reaction/Meta/Attribute.pm
index 16e5ed9..a925982 100644 (file)
--- a/lib/Reaction/Meta/Attribute.pm
+++ b/lib/Reaction/Meta/Attribute.pm
@@ -30,6 +30,36 @@ around _process_options => sub {
     $super->($class, $name, $options);
 };
 
+foreach my $type (qw(clearer predicate)) {
+
+  my $value_meth = do {
+    if ($type eq 'clearer') {
+      'clear_value'
+    } elsif ($type eq 'predicate') {
+      'has_value'
+    } else {
+      confess "NOTREACHED";
+    }
+  };
+
+  __PACKAGE__->meta->add_method("get_${type}_method" => sub {
+    my $self = shift;
+    my $info = $self->$type;
+    return $info unless ref $info;
+    my ($name) = %$info;
+    return $name;
+  });
+
+  __PACKAGE__->meta->add_method("get_${type}_method_ref" => sub {
+    my $self = shift;
+    if ((my $name = $self->${\"get_${type}_method"}) && $self->associated_class) {
+        return $self->associated_class->get_method($name);
+    } else {
+        return sub { $self->$value_meth(@_); }
+    }
+  });
+}
+
 __PACKAGE__->meta->make_immutable(inline_constructor => 0);
 
 1;

diff --git a/lib/Reaction/UI/ViewPort/Field.pm b/lib/Reaction/UI/ViewPort/Field.pm
index 3b8c641..1ccc99c 100644 (file)
--- a/lib/Reaction/UI/ViewPort/Field.pm
+++ b/lib/Reaction/UI/ViewPort/Field.pm
@@ -28,11 +28,11 @@ class Field is 'Reaction::UI::ViewPort', which {
 
   implements _model_has_value => as {
     my ($self) = @_;
-    my $predicate = $self->attribute->predicate;
+    my $predicate = $self->attribute->get_predicate_method;
 
     if (!$predicate || $self->model->$predicate
-        || ($self->attribute->is_lazy
-            && !$self->attribute->is_lazy_fail)
+        #|| ($self->attribute->is_lazy
+        #    && !$self->attribute->is_lazy_fail)
       ) {
       # either model attribute has a value now or can build it
       return 1;

diff --git a/lib/Reaction/UI/ViewPort/Field/Role/Mutable.pm b/lib/Reaction/UI/ViewPort/Field/Role/Mutable.pm
index 0d39eec..010ea07 100644 (file)
--- a/lib/Reaction/UI/ViewPort/Field/Role/Mutable.pm
+++ b/lib/Reaction/UI/ViewPort/Field/Role/Mutable.pm
@@ -66,10 +66,10 @@ role Mutable, which {
       confess "No writer for attribute" unless defined($writer);
       $self->model->$writer($value);
     } else {
-      my $predicate = $attr->predicate;
+      my $predicate = $attr->get_predicate_method;
       confess "No predicate for attribute" unless defined($predicate);
       if ($self->model->$predicate) {
-        my $clearer = $attr->clearer;
+        my $clearer = $attr->get_clearer_method;
         confess "${predicate} returned true but no clearer for attribute"
           unless defined($clearer);
         $self->model->$clearer;