X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/1e5d67977972cc7fd12fe9011ad8f5b35a5e11b2..a4e6154d961ff4b606aa534bd4e1570565cab351:/src/relational-attributes.lisp

diff --git a/src/relational-attributes.lisp b/src/relational-attributes.lisp
index 2566023..58014f4 100644
--- a/src/relational-attributes.lisp
+++ b/src/relational-attributes.lisp
@@ -4,14 +4,28 @@
 
 
 ;;;; ** has-a
+;;;; Used for foreign keys, currently only works with clsql.
 
 (defattribute has-a ()
   ()
   (:default-properties
-      :has-a nil))
+      :has-a nil
+    :test 'meta-model::generic-equal))
 
+;;
 (define-layered-method attribute-value (object (attribute has-a))
  (meta-model:explode-foreign-key object (slot-name attribute) :nilp t))		       
+
+(define-layered-method (setf attribute-value) ((value standard-object) object (attribute has-a))
+  (let ((val (slot-value value (find-if (curry #'primary-key-p value) (list-keys value)))))
+    (setf (attribute-value object attribute) val)))
+
+
+
+(define-layered-function find-all-foreign-objects (o a))
+
+(define-layered-method find-all-foreign-objects (object (attribute has-a))
+  (select (meta-model:find-join-class object (slot-name attribute)) :flatp t))
 		       
 (defdisplay ((attribute has-a) object)
   (let ((args (plist-union (description.properties attribute) (has-a attribute)))
@@ -23,6 +37,18 @@
 	   args)))
 
 
+(defdisplay
+  :in-layer editor ((attribute has-a) object)
+ (<ucw:select
+  :accessor (attribute-value object attribute)
+
+  :test (test attribute)
+  (dolist* (obj (find-all-foreign-objects object attribute))
+    (<ucw:option
+     :value obj
+     (display* obj :type 'as-string)))))
+
+
 ;;;; ** Has-Many attribute
 
 (defattribute has-many ()
@@ -33,10 +59,9 @@
   (:default-initargs
       :type 'lol::one-line))
 
-
 (define-layered-method
     attribute-value (object (has-many has-many))
-  (slot-value object (slot-name has-many)))
+    (slot-value object (slot-name has-many)))
 
 (defdisplay ((attribute has-many) object)
     ;