braino that was in the archive somehow but not in my tree.
[clinton/lisp-on-lines.git] / src / relational-attributes.lisp
1 (in-package :lol)
2
3 (defun find-many-to-many-class (slot-name instance)
4 (let* ((imd (getf (meta-model::find-slot-metadata instance slot-name)
5 :db-info))
6 (jc (make-instance (getf imd :join-class)))
7 (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
8 :db-info)))
9 (getf jcmd :join-class)))
10
11
12 (defattribute many-to-many ()
13 ())
14
15
16
17 (defdisplay (:description (attribute many-to-many))
18 (let ((instances (select-instances object t))
19 new-instance)
20 (<:ul
21 (<:li (<ucw:button :action (add-new-relation component object (getp slot-name))
22 (<:as-html "Add New")))
23 (<:li (<ucw:button :action (add-new-relation component object new-instance)
24 (<:as-html "Add:"))
25 (<ucw:select :accessor new-instance
26 (arnesi:dolist* (i instances)
27 (<ucw:option
28 :value i
29 (display component i :type 'one-line)))))
30 (dolist* (i (attribute-value object attribute))
31 (<:li
32 (<ucw:a :action (call-view ((car i) (action-view slot) (ucw::parent slot)))
33 (<:as-html "(view) "))
34 (<ucw:a :action (delete-relationship slot (second i) instance)
35 (<:as-html "(remove) "))
36 (display component object)))))
37 (display component (mapcar #'car (slot-value object (getp :slot-name)))))
38