Major patch touching a lot, representing the new lol. is mostly drop-in backwards...
[clinton/lisp-on-lines.git] / src / relational-attributes.lisp
CommitLineData
91f2ab7b
DC
1(in-package :lisp-on-lines)
2
3;;;; * Relational Attributes
4
2b0fd9c8
DC
5
6;;;; ** has-a
7
8(defattribute has-a ()
9 ()
10 (:default-properties
11 :has-a nil))
12
13(define-layered-method attribute-value (object (attribute has-a))
14 (meta-model:explode-foreign-key object (slot-name attribute) :nilp t))
15
16(defdisplay ((attribute has-a) object)
17 (let ((args (plist-union (description.properties attribute) (has-a attribute)))
18 (val (attribute-value object attribute)))
19 (when val
20 (setf (getf args :type)
21 'lol::one-line))
22 (apply #'display* val
23 args)))
24
25
91f2ab7b
DC
26;;;; ** Has-Many attribute
27
28(defattribute has-many ()
29 ()
30 (:default-properties
31 :add-new-label "Add New"
2b0fd9c8
DC
32 :sort-arguments (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x))))
33 (:default-initargs
34 :type 'lol::one-line))
35
91f2ab7b 36
2b0fd9c8
DC
37(define-layered-method
38 attribute-value (object (has-many has-many))
39 (slot-value object (slot-name has-many)))
91f2ab7b 40
2b0fd9c8 41(defdisplay ((attribute has-many) object)
91f2ab7b 42 ;
2b0fd9c8
DC
43 ;(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label attribute))
44
45 (<:div :style "clear:both;"
46 (let* ((i (apply #'sort (slot-value object (slot-name attribute))
47 (sort-arguments attribute))))
48 (<:ul
49 (dolist* (x i)
50 (<:li (display* x
51 :type 'lol::one-line
52 :layers '(+ wrap-link - label-attributes))))))))
91f2ab7b 53
dee565d0
DC
54
55(defun find-many-to-many-class (slot-name instance)
56 (let* ((imd (getf (meta-model::find-slot-metadata instance slot-name)
57 :db-info))
58 (jc (make-instance (getf imd :join-class)))
59 (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
60 :db-info)))
61 (getf jcmd :join-class)))
62
63
64(defattribute many-to-many ()
65 ())
66
14a7e1bc 67
dee565d0 68
2b0fd9c8 69(defdisplay ((attribute many-to-many) object)
91f2ab7b
DC
70 (<:as-html "ASDASD"))
71
72 #+nil(let ((instances (select-instances object t))
dee565d0
DC
73 new-instance)
74 (<:ul
2b0fd9c8 75 (<:li (<ucw:button :action (add-new-relation component object (.get slot-name))
d2882889 76 (<:as-html "Add New")))
dee565d0
DC
77 (<:li (<ucw:button :action (add-new-relation component object new-instance)
78 (<:as-html "Add:"))
79 (<ucw:select :accessor new-instance
80 (arnesi:dolist* (i instances)
81 (<ucw:option
82 :value i
83 (display component i :type 'one-line)))))
84 (dolist* (i (attribute-value object attribute))
85 (<:li
86 (<ucw:a :action (call-view ((car i) (action-view slot) (ucw::parent slot)))
87 (<:as-html "(view) "))
88 (<ucw:a :action (delete-relationship slot (second i) instance)
89 (<:as-html "(remove) "))
90 (display component object)))))
2b0fd9c8 91 ;(display component (mapcar #'car (slot-value object (.get :slot-name))))
dee565d0 92