This is the second posting of what will be a series about practical uses of the Metaobject Protocol. The MOP enables introspection and customization of the Common Lisp Object System. In the first posting, we saw how to create custom slot definition objects, and how to add new slots to a class definition. In this posting we will see how we can use these custom slot objects to control slot access to our indexed objects.
Seeing our slot definitions in action
Before going deeper into slot access control, I want to show you
how the slot definition objects we created in the first part work.
We will create a simple class USER, with a single slot NAME. We
will trace the few methods we overloaded in the first posting:
DIRECT-SLOT-DEFINITION-CLASS, EFFECTIVE-SLOT-DEFINITION-CLASS,
COMPUTE-EFFECTIVE-SLOT-DEFINITION and COMPUTE-SLOTS (I edited out
unnecessary information):
INDICES> (trace direct-slot-definition-class effective-slot-definition-class
compute-effective-slot-definition compute-slots)
(COMPUTE-SLOTS COMPUTE-EFFECTIVE-SLOT-DEFINITION
EFFECTIVE-SLOT-DEFINITION-CLASS
DIRECT-SLOT-DEFINITION-CLASS)
INDICES> (defclass user ()
((name :initarg :name
:reader user-name
:index-type string-unique-index
:index-values all-users
:index-reader user-with-name))
(:metaclass indexed-class))
0[6]: (DIRECT-SLOT-DEFINITION-CLASS #<INDEXED-CLASS USER> :CLASS
#<INDEXED-CLASS USER> :NAME NAME :INITARGS (:NAME) :READERS
(USER-NAME) :INDEX-TYPE STRING-UNIQUE-INDEX :INDEX-VALUES
ALL-USERS :INDEX-READER USER-WITH-NAME)
0[6]: returned INDEX-DIRECT-SLOT-DEFINITION
0[6]: (COMPUTE-SLOTS #<INDEXED-CLASS USER>)
1[6]: (COMPUTE-EFFECTIVE-SLOT-DEFINITION #<INDEXED-CLASS USER> NAME
(#<INDEX-DIRECT-SLOT-DEFINITION NAME @ #x604e17a>))
2[6]: (EFFECTIVE-SLOT-DEFINITION-CLASS #<INDEXED-CLASS USER> :NAME
NAME :INITFORM NIL :INITFUNCTION NIL :INITARGS (:NAME)
:ALLOCATION :INSTANCE :TYPE T :DOCUMENTATION NIL
:FIXED-LOCATION NIL)
2[6]: returned INDEX-EFFECTIVE-SLOT-DEFINITION
1[6]: returned #<INDEX-EFFECTIVE-SLOT-DEFINITION NAME @ #x604e6a2>
0[6]: returned
(#<INDEX-EFFECTIVE-SLOT-DEFINITION DESTROYED-P @ #x6055582>
#<INDEX-EFFECTIVE-SLOT-DEFINITION NAME @ #x604e6a2>)
#<INDEXED-CLASS USER>
We can see that COMPUTE-SLOT calls
COMPUTE-EFFECTIVE-SLOT-DEFINITION, which in turn calls
EFFECTIVE-SLOT-DEFINITION-CLASS. The effective slot definition
class is then used to create the new effective slot definition
object, which will be filled with the indices computed from the
direct slot definitions objects created while parsing the DEFCLASS
form. Finally, COMPUTE-SLOTS adds the new slot definition
DESTROYED-P to the list of slots.
Controlling slot access
Most indexed classes (classes with the metaclass INDEXED-CLASS)
have a set of indexed slots. For example, we can index users using
the NAME slot of the USER class.
INDICES> (make-instance 'user :name "manuel") #<USER @ #x605d2ba> INDICES> (make-instance 'user :name "andrew") #<USER @ #x605f44a> INDICES> (make-instance 'user :name "cordula") #<USER @ #x605fba2> INDICES> (all-users) (#<USER @ #x605f44a> #<USER @ #x605fba2> #<USER @ #x605d2ba>) INDICES> (user-with-name "manuel") #<USER @ #x605d2ba> T
When the value of an indexed slot is changed, the appropriate
index should be updated too. If I change the name of the user
“manuel” to “joseph”, I want the query (USER-WITH-NAME “manuel”) to
return nothing and the query (USER-WITH-NAME “joseph”) to return
the user. We can do this by overloading the accessor for the slot
NAME, but that would be error-prone and tedious. We could still use
the function (SETF SLOT-VALUE) to change the slot value, and the
index won’t be updated. MOP allows us to catch slot accesses by
overloading the method (SETF SLOT-VALUE-USING-CLASS). This is
exactly what we do for our indices. Beware, that method is a tad
long.
(defmethod (setf slot-value-using-class) :around
(newvalue (class indexed-class) object (slot index-effective-slot-definition))
(declare (ignore newvalue))
(when (eql (slot-definition-name slot) 'destroyed-p)
(return-from slot-value-using-class (call-next-method)))
(when *in-make-instance-p*
(return-from slot-value-using-class (call-next-method)))
(let* ((indices (index-effective-slot-definition-indices slot))
(slot-name (slot-definition-name slot))
(previous-slot-boundp (slot-boundp object slot-name))
(previous-slot-value (when previous-slot-boundp
(slot-value object slot-name))))
#+nil
(format t "indices ~A~%" indices)
(when (and previous-slot-boundp
*indices-remove-p*)
(let ((changed-indices)
(error t))
(unwind-protect
(progn
(dolist (index indices)
(index-remove index object)
(push index changed-indices))
(setf error nil))
(when error
(dolist (index changed-indices)
(index-add index object))))))
(let ((result (call-next-method)))
#+nil
(format t "set slot ~A of ~a to ~A, value is ~a~%"
(slot-definition-name slot)
object newvalue
(slot-value object (slot-definition-name slot)))
(when (slot-boundp object (slot-definition-name slot))
(let ((error t)
(changed-indices nil))
(unwind-protect
(progn
(dolist (index indices)
(index-add index object)
(push index changed-indices))
(setf error nil))
(when error
(dolist (index changed-indices)
(index-remove index object))
(let ((*indices-remove-p* nil))
(if previous-slot-boundp
(setf (slot-value object slot-name) previous-slot-value)
(slot-makunbound object slot-name)))))))
result)))
What we do here is first to check for some special cases. If the
slot is named DESTROYED-P, we have to handle it in “the normal
way”, as this slot is never indexed. The same goes for slot-access
while the object is being created, so if we are in a MAKE-INSTANCE,
we call the normal method. The variable *IN-MAKE-INSTANCE-P* is
bound by a wrapper around INITIALIZE-INSTANCE. The next step in our
method is to get the previous value of the slot and the new value
of the slot. We also retrieve the indices that are affected by the
slot change. We then remove the object from all the indices
affected, change the slot value, and reinsert the object into the
indices. This bit is quite lengthy because we do alot of
error-checking to avoid the corruption of the index structures if
an error happens.
In a very similar way, MOP allows us to control slot
“destruction”. When we want to unbind a slot of an object, MOP
calls the method SLOT-MAKUNBOUND-USING-CLASS. When a slot is
unbound, we want the object to be removed from all the affected
indices. Here is SLOT-MAKUNBOUND-USING-CLASS:
(defmethod slot-makunbound-using-class
((class indexed-class) object (slot index-effective-slot-definition))
(let* ((slot-name (slot-definition-name slot))
(previous-slot-boundp (slot-boundp object slot-name))
(indices (index-effective-slot-definition-indices slot)))
(when (and previous-slot-boundp
*indices-remove-p*)
(let ((changed-indices nil)
(error t))
(unwind-protect
(progn
(dolist (index indices)
(index-remove index object)
(push index changed-indices))
(setf error nil))
(when error
(dolist (index changed-indices)
(index-add index object))))))
(call-next-method)))
Controlling access to destroyed objects
All these slot access methods are used to control access to
destroyed objects. When an object is destroyed, every slot access,
slot updated and slot unbinding is prohibited and should throw an
error. We do this by simply adding a bunch of BEFORE methods on the
slot access methods. Again, the slot DESTROYED-P has to be handled
in a special way (else we would recurse infinitely here).
(defmethod slot-value-using-class :before
((class indexed-class) object slot)
(when (and (not (eql (slot-definition-name slot) 'destroyed-p))
(slot-value object 'destroyed-p)
(not *indexed-class-override*))
(error "Can not get slot ~A of destroyed object of class ~a."
(slot-definition-name slot) (class-name (class-of object)))))
(defmethod (setf slot-value-using-class) :before
(newvalue (class indexed-class) object slot)
(declare (ignore newvalue))
(when (and (not (eql (slot-definition-name slot) 'destroyed-p))
(slot-value object 'destroyed-p)
(not *indexed-class-override*))
(error "Can not set slot ~A of destroyed object ~a."
(slot-definition-name slot) (class-name (class-of object)))))
(defmethod slot-makunbound-using-class :before ((class indexed-class) object slot)
(when (and (not (eql (if (symbolp slot)
slot
(slot-definition-name slot)) 'destroyed-p))
(slot-value object 'destroyed-p)
(not *indexed-class-override*))
(error "Can not MAKUNBOUND slot ~A of destroyed object ~a."
(slot-definition-name slot) (class-name (class-of object)))))
I leave it to you to trace the slot access methods and to play
with the indixed objects around a bit to see what happens 
The
traces would be too long here…
To be continued…
That’s it for this time. In the next posting, we will see how we
can control instance creation and instance updating using MOP.