added files referenced by previous patch

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

diff --git a/src/relational-attributes.lisp b/src/relational-attributes.lisp
new file mode 100644 (file)
index 0000000..8766be2
--- /dev/null
+++ b/src/relational-attributes.lisp
@@ -0,0 +1,39 @@
+(in-package :lol)
+
+(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 ()
+  ())
+
+(define-layered-method attribute-value (object (attribute many-to-many))
+  (call-next-method))
+
+(defdisplay (:description (attribute many-to-many))
+    (let ((instances (select-instances object))
+       new-instance)
+    (<:ul
+     (<:li (<ucw:button :action (add-new-relation component object (getp 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 (getp :slot-name)))))
+                     
\ No newline at end of file