[hmmm... did you get my other response? This is a diff question, but you did not mention my other so I am concenred.]
Frank Goenninger wrote:
... and again a question related to this:
Suppose I have :
(defmd kid-test-2 (family) (a-slot (c-in nil)) :kids (list (make-instance 'my-kid) (make-instance 'my-kid)))
Now - this completely bypasses the control mechanism inserted into fm- kid-add - which is not what I wanted ;-)
Good point, another hole. In ACL and any CL supporting a full MOP, btw, you can supply an around method to (setf slot-value-using-class) which is the implementation of (setf slot-value) and /really/ control access. Anyway...
So, I am asking myself if it would be better to insert the check into the .kids observer ...
One big concern I have is, is this too late? Do you have any requirement to stop these sooner? ie, If you want to signal a condition that is fine, but recovering from it means also backing out the change and /that/ would be a lot of work at the late stage when the observer gets called.
I now have:
(defmodel family (model) ((.kid-slots :cell nil :initform nil :accessor kid-slots :initarg :kid-slots) (.kids :initform (c-in nil) ;; most useful :owning t :accessor kids :initarg :kids) (registry? :cell nil :initform nil :initarg :registry? :accessor registry?) (registry :cell nil :initform nil :accessor registry) ;; added: frgo, 2008-10-30 (control-hooks :cell nil :accessor control-hooks :initform (make-hash-table :test 'eql) :initarg :control-hooks)))
(defmethod get-control-hooks ((self family) hook-id) (gethash hook-id (control-hooks self)))
(defmethod add-hook ((self family) id hook) (setf (gethash id (control-hooks self)) hook))
(defun call-control-hook (hook self &rest args) ;;; to be completed here )
(eval-when (:compile-time :load-toplevel) (proclaim '(inline mklist)) (if (not (fboundp 'mklist)) (defun mklist (obj) (if (listp obj) obj (list obj)))))
(defun run-control-hooks (id self &rest args) (c-assert (typep self 'family)) (let ((hooks (get-control-hooks self id))) (if hooks (loop for hook in (get-control-hooks self id) collect (call-control-hook hook self args) into result finally (return (mklist result))) (mklist t))))
and
(define-condition cells-adding-kid-not-allowed-error (error) ((text :initarg :text :reader text)))
(defun kid-add-allowed? (fm-parent kid) (notany #'null (run-control-hooks 'fm-kid-add-control fm-parent kid)))
(defun fm-kid-add (fm-parent kid &optional before) (c-assert (or (null (fm-parent kid)) (eql fm-parent (fm-parent kid)))) (c-assert (typep fm-parent 'family)) ;; Added: frgo, 2008-10-30 (if (kid-add-allowed? fm-parent kid) (progn ;; (trc "Adding kid to parent" kid fm-parent) (setf (fm-parent kid) fm-parent) (fm-kid-insert kid before)) (error 'cells-adding-kid-not-allowed-error :text (format nil "ERROR: Kid ~s not allowed for parent ~s." kid fm-parent))))
- which is incomplete, of course, but shows the basic idea, or so I hope.
Any thoughts if I should use the observer or do some clever slot trickery using MOP ?
Ah, you were way ahead of me. The observer might be too late if you want this to be recoverable.
kt