Removed most of the old LoL stuff for good.

[clinton/lisp-on-lines.git] / src / attributes / relational-attributes.lisp

diff --git a/src/attributes/relational-attributes.lisp b/src/attributes/relational-attributes.lisp
new file mode 100644 (file)
index 0000000..2b7cdbf
--- /dev/null
+++ b/src/attributes/relational-attributes.lisp
@@ -0,0 +1,124 @@
+(in-package :lisp-on-lines)
+
+;;;; * Relational Attributes
+
+
+;;;; ** has-a
+;;;; Used for foreign keys, currently only works with clsql.
+
+(defattribute has-a ()
+  ()
+  (:default-properties
+      :has-a nil
+    :test 'meta-model::generic-equal))
+
+;;
+(define-layered-method attribute-value (object (attribute has-a))
+ (multiple-value-bind (obj key class)
+     (meta-model:explode-foreign-key object (slot-name attribute) :nilp t)                    
+  (if (persistentp object)
+      obj
+      (first  (select class
+                     :where [= [slot-value class key] (call-next-method)]
+                     :flatp 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)))
+       (val (attribute-value object attribute)))
+    (when val
+      (setf (getf args :type)
+           'lol::one-line))        
+    (apply #'display* val
+          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 :layers '(+ as-string))))))
+
+
+;;;; ** Has-Many attribute
+
+(defattribute has-many ()
+  ()
+  (:default-properties
+      :add-new-label "Add New"
+    :sort-arguments  (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x))))
+  (:default-initargs
+      :type 'lol::one-line))
+
+(define-layered-method
+    attribute-value (object (has-many has-many))
+    (slot-value object (slot-name has-many)))
+
+(defdisplay ((attribute has-many) object)
+    ;
+  ;(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label attribute))
+           
+ (<:div  :style "clear:both;"
+        (let* ((i (apply #'sort (slot-value object (slot-name attribute))
+                         (sort-arguments attribute))))
+          (<:ul 
+           (dolist* (x i)
+             (<:li (display* x
+                             :type 'lol::as-string
+                             :layers '(+ wrap-link - label-attributes))))))))
+
+
+(defun find-many-to-many-class (slot-name instance)
+  (let* ((imd (getf (meta-model::find-slot-metadata instance slot-name)
+                   :db-info))
+        (jc (make-instance (getf imd :join-class)))
+        (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
+                    :db-info)))
+    (getf jcmd :join-class)))
+
+
+(defattribute many-to-many ()
+  ())
+
+
+
+(defdisplay ((attribute many-to-many) object)
+  (<:as-html "ASDASD"))
+
+  #+nil(let ((instances (select-instances object t))
+       new-instance)
+    (<:ul
+     (<:li (<ucw:button :action (add-new-relation component object (.get slot-name))
+                       (<:as-html "Add New")))
+     (<:li  (<ucw:button :action (add-new-relation component object new-instance)
+                        (<:as-html "Add:"))
+           (<ucw:select :accessor new-instance
+                        (arnesi:dolist* (i instances)
+                          (<ucw:option
+                           :value i
+                           (display component i :type 'one-line)))))
+     (dolist* (i (attribute-value object attribute))
+       (<:li
+       (<ucw:a :action (call-view ((car i) (action-view slot) (ucw::parent slot)))
+               (<:as-html "(view) "))
+       (<ucw:a :action (delete-relationship slot (second i) instance)
+               (<:as-html "(remove) "))
+       (display component object)))))
+  ;(display component (mapcar #'car (slot-value object (.get :slot-name))))
+                     
\ No newline at end of file