removed warning which caused error
[clinton/lisp-on-lines.git] / src / relational-attributes.lisp
1 (in-package :lisp-on-lines)
2
3 ;;;; * Relational Attributes
4
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
26 ;;;; ** Has-Many attribute
27
28 (defattribute has-many ()
29 ()
30 (:default-properties
31 :add-new-label "Add New"
32 :sort-arguments (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x))))
33 (:default-initargs
34 :type 'lol::one-line))
35
36
37 (define-layered-method
38 attribute-value (object (has-many has-many))
39 (slot-value object (slot-name has-many)))
40
41 (defdisplay ((attribute has-many) object)
42 ;
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))))))))
53
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
67
68
69 (defdisplay ((attribute many-to-many) object)
70 (<:as-html "ASDASD"))
71
72 #+nil(let ((instances (select-instances object t))
73 new-instance)
74 (<:ul
75 (<:li (<ucw:button :action (add-new-relation component object (.get slot-name))
76 (<:as-html "Add New")))
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)))))
91 ;(display component (mapcar #'car (slot-value object (.get :slot-name))))
92