;;;; * Relational Attributes
+
+;;;; ** has-a
+;;;; Used for foreign keys, currently only works with clsql.
+
+(defattribute has-a ()
+ ()
+ (:default-properties
+ :has-a nil
+ :test 'meta-model::generic-equal))
+
+;;
+(define-layered-method attribute-value (object (attribute has-a))
+ (meta-model:explode-foreign-key object (slot-name attribute) :nilp t))
+
+(define-layered-method (setf attribute-value) ((value standard-object) object (attribute has-a))
+ (let ((val (slot-value value (find-if (curry #'primary-key-p value) (list-keys value)))))
+ (setf (attribute-value object attribute) val)))
+
+
+
+(define-layered-function find-all-foreign-objects (o a))
+
+(define-layered-method find-all-foreign-objects (object (attribute has-a))
+ (select (meta-model:find-join-class object (slot-name attribute)) :flatp t))
+
+(defdisplay ((attribute has-a) object)
+ (let ((args (plist-union (description.properties attribute) (has-a attribute)))
+ (val (attribute-value object attribute)))
+ (when val
+ (setf (getf args :type)
+ 'lol::one-line))
+ (apply #'display* val
+ args)))
+
+
+(defdisplay
+ :in-layer editor ((attribute has-a) object)
+ (<ucw:select
+ :accessor (attribute-value object attribute)
+
+ :test (test attribute)
+ (dolist* (obj (find-all-foreign-objects object attribute))
+ (<ucw:option
+ :value obj
+ (display* obj :type 'as-string)))))
+
+
;;;; ** Has-Many attribute
(defattribute has-many ()
()
(:default-properties
:add-new-label "Add New"
- :sort-arguments (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x)))))
+ :sort-arguments (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x))))
+ (:default-initargs
+ :type 'lol::one-line))
+(define-layered-method
+ attribute-value (object (has-many has-many))
+ (slot-value object (slot-name has-many)))
-(defdisplay object (:description (attribute has-many))
+(defdisplay ((attribute has-many) object)
;
- (<ucw:submit :action (add-to-has-many slot instance) :value (getp :add-new-label))
- (let* ((i (apply #'sort (slot-value object (getp :slot-name))
- (getp :sort-arguments))))
- (display component i
- :type'lol::one-line
- :layers '(+ wrap-link))))
+ ;(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label attribute))
+
+ (<:div :style "clear:both;"
+ (let* ((i (apply #'sort (slot-value object (slot-name attribute))
+ (sort-arguments attribute))))
+ (<:ul
+ (dolist* (x i)
+ (<:li (display* x
+ :type 'lol::one-line
+ :layers '(+ wrap-link - label-attributes))))))))
(defun find-many-to-many-class (slot-name instance)
-(defdisplay object (:description (attribute many-to-many))
+(defdisplay ((attribute many-to-many) object)
(<:as-html "ASDASD"))
#+nil(let ((instances (select-instances object t))
new-instance)
(<:ul
- (<:li (<ucw:button :action (add-new-relation component object (getp slot-name))
+ (<:li (<ucw:button :action (add-new-relation component object (.get slot-name))
(<:as-html "Add New")))
(<:li (<ucw:button :action (add-new-relation component object new-instance)
(<:as-html "Add:"))
(<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))))
+ ;(display component (mapcar #'car (slot-value object (.get :slot-name))))
\ No newline at end of file