1 (in-package :lisp-on-lines
)
3 ;;;; * Relational Attributes
6 (defvar *parent-relations
* nil
)
9 ;;;; Used for foreign keys, currently only works with clsql.
11 (defattribute relational-attribute
()
14 (defdisplay :wrap-around
((attribute relational-attribute
) object
)
15 (print (cons "parent-r" *parent-relations
*))
16 (dletf (((value attribute
) (attribute-value object attribute
)))
17 (unless (find (value attribute
) *parent-relations
* :test
#'meta-model
::generic-equal
)
20 (defattribute has-a
(relational-attribute)
24 :test
'meta-model
::generic-equal
))
27 (define-layered-method attribute-value
(object (attribute has-a
))
28 (multiple-value-bind (obj key class
)
29 (meta-model:explode-foreign-key object
(slot-name attribute
) :nilp t
)
30 (if (persistentp object
)
33 :where
[= [slot-value class key
] (call-next-method)]
37 (define-layered-method (setf attribute-value
) ((value standard-object
) object
(attribute has-a
))
38 (let ((val (slot-value value
(find-if (curry #'primary-key-p value
) (list-keys value
)))))
39 (setf (attribute-value object attribute
) val
)))
41 (define-layered-function find-all-foreign-objects
(o a
))
43 (define-layered-method find-all-foreign-objects
(object (attribute has-a
))
44 (select (meta-model:find-join-class object
(slot-name attribute
)) :flatp t
))
46 (defdisplay ((attribute has-a
) object
)
47 (let ((args (plist-union (description.properties attribute
) (has-a attribute
)))
48 (val (attribute-value object attribute
)))
50 (setf (getf args
:type
)
57 :in-layer editor
((attribute has-a
) object
)
59 :accessor
(attribute-value object attribute
)
61 :test
(test attribute
)
62 (dolist* (obj (find-all-foreign-objects object attribute
))
65 (display* obj
:layers
'(+ as-string
))))))
67 ;;;; ** Has-Many attribute
69 (defattribute has-many
()
72 :add-new-label
"Add New"
74 :sort-arguments
(list #'< :key
#'(lambda (x) (funcall (car (list-keys x
)) x
))))
76 :type
'lol
::one-line
))
78 (define-layered-method
79 attribute-value
(object (has-many has-many
))
80 (slot-value object
(slot-name has-many
)))
83 (defdisplay ((attribute has-many
) object
)
85 ;(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label attribute))
87 (<:div
:style
"clear:both;"
88 (let* ((i (apply #'sort
(slot-value object
(slot-name attribute
))
89 (sort-arguments attribute
)))
90 (*parent-relations
* (cons object
*parent-relations
*)))
92 (apply #'display
* i
(has-many attribute
)))))
95 (defun find-many-to-many-class (slot-name instance
)
96 (let* ((imd (getf (meta-model::find-slot-metadata instance slot-name
)
98 (jc (make-instance (getf imd
:join-class
)))
99 (jcmd (getf (meta-model::find-slot-metadata jc
(getf imd
:target-slot
))
101 (getf jcmd
:join-class
)))
104 (defattribute many-to-many
()
109 (defdisplay ((attribute many-to-many
) object
)
110 (<:as-html
"ASDASD"))
112 #+nil
(let ((instances (select-instances object t
))
115 (<:li
(<ucw
:button
:action
(add-new-relation component object
(.get slot-name
))
116 (<:as-html
"Add New")))
117 (<:li
(<ucw
:button
:action
(add-new-relation component object new-instance
)
119 (<ucw
:select
:accessor new-instance
120 (arnesi:dolist
* (i instances
)
123 (display component i
:type
'one-line
)))))
124 (dolist* (i (attribute-value object attribute
))
126 (<ucw
:a
:action
(call-view ((car i
) (action-view slot
) (ucw::parent slot
)))
127 (<:as-html
"(view) "))
128 (<ucw
:a
:action
(delete-relationship slot
(second i
) instance
)
129 (<:as-html
"(remove) "))
130 (display component object
)))))
131 ;(display component (mapcar #'car (slot-value object (.get :slot-name))))