{"id":119,"date":"2005-03-09T09:00:32","date_gmt":"2005-03-09T07:00:32","guid":{"rendered":"http:\/\/blogs.bl0rg.net\/netzstaub\/?p=119"},"modified":"2005-03-09T09:00:32","modified_gmt":"2005-03-09T07:00:32","slug":"a-short-practical-overview-of-mop-part-2","status":"publish","type":"post","link":"https:\/\/blogs.bl0rg.net\/netzstaub\/2005\/03\/09\/a-short-practical-overview-of-mop-part-2\/","title":{"rendered":"A short practical overview of MOP: part 2"},"content":{"rendered":"

\nThis 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<\/a>, 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.\n<\/p>\n

<\/p>\n

Seeing our slot definitions in action<\/strong><\/p>\n

Before going deeper into slot access control, I want to show you
\nhow the slot definition objects we created in the first part work.
\nWe will create a simple class USER, with a single slot NAME. We
\nwill trace the few methods we overloaded in the first posting:
\nDIRECT-SLOT-DEFINITION-CLASS, EFFECTIVE-SLOT-DEFINITION-CLASS,
\nCOMPUTE-EFFECTIVE-SLOT-DEFINITION and COMPUTE-SLOTS (I edited out
\nunnecessary information):<\/p>\n

\nINDICES> (trace direct-slot-definition-class effective-slot-definition-class\n                compute-effective-slot-definition compute-slots)\n(COMPUTE-SLOTS COMPUTE-EFFECTIVE-SLOT-DEFINITION\n               EFFECTIVE-SLOT-DEFINITION-CLASS\n               DIRECT-SLOT-DEFINITION-CLASS)\nINDICES> (defclass user ()\n  ((name :initarg :name\n         :reader user-name \n         :index-type string-unique-index\n         :index-values all-users\n         :index-reader user-with-name))\n  (:metaclass indexed-class))\n  \n 0[6]: (DIRECT-SLOT-DEFINITION-CLASS #<INDEXED-CLASS USER> :CLASS\n         #<INDEXED-CLASS USER> :NAME NAME :INITARGS (:NAME) :READERS\n         (USER-NAME) :INDEX-TYPE STRING-UNIQUE-INDEX :INDEX-VALUES\n         ALL-USERS :INDEX-READER USER-WITH-NAME)\n 0[6]: returned INDEX-DIRECT-SLOT-DEFINITION\n<\/pre>\n
\n 0[6]: (COMPUTE-SLOTS #<INDEXED-CLASS USER>)\n   1[6]: (COMPUTE-EFFECTIVE-SLOT-DEFINITION #<INDEXED-CLASS USER> NAME\n           (#<INDEX-DIRECT-SLOT-DEFINITION NAME @ #x604e17a>))\n     2[6]: (EFFECTIVE-SLOT-DEFINITION-CLASS #<INDEXED-CLASS USER> :NAME\n             NAME :INITFORM NIL :INITFUNCTION NIL :INITARGS (:NAME)\n             :ALLOCATION :INSTANCE :TYPE T :DOCUMENTATION NIL\n             :FIXED-LOCATION NIL)\n     2[6]: returned INDEX-EFFECTIVE-SLOT-DEFINITION\n   1[6]: returned #<INDEX-EFFECTIVE-SLOT-DEFINITION NAME @ #x604e6a2>\n 0[6]: returned\n         (#<INDEX-EFFECTIVE-SLOT-DEFINITION DESTROYED-P @ #x6055582>\n          #<INDEX-EFFECTIVE-SLOT-DEFINITION NAME @ #x604e6a2>)\n<\/pre>\n
\n#<INDEXED-CLASS USER>\n<\/pre>\n
We can see that COMPUTE-SLOT calls
\nCOMPUTE-EFFECTIVE-SLOT-DEFINITION, which in turn calls
\nEFFECTIVE-SLOT-DEFINITION-CLASS. The effective slot definition
\nclass is then used to create the new effective slot definition
\nobject, which will be filled with the indices computed from the
\ndirect slot definitions objects created while parsing the DEFCLASS
\nform. Finally, COMPUTE-SLOTS adds the new slot definition
\nDESTROYED-P to the list of slots.<\/p>\n
Controlling slot access<\/strong><\/p>\n
Most indexed classes (classes with the metaclass INDEXED-CLASS)
\nhave a set of indexed slots. For example, we can index users using
\nthe NAME slot of the USER class.<\/p>\n
\nINDICES> (make-instance 'user :name \"manuel\")\n#<USER @ #x605d2ba>\nINDICES> (make-instance 'user :name \"andrew\")\n#<USER @ #x605f44a>\nINDICES> (make-instance 'user :name \"cordula\")\n#<USER @ #x605fba2>\nINDICES> (all-users)\n(#<USER @ #x605f44a> #<USER @ #x605fba2> #<USER @ #x605d2ba>)\nINDICES> (user-with-name \"manuel\")\n#<USER @ #x605d2ba>\nT\n<\/pre>\n
When the value of an indexed slot is changed, the appropriate
\nindex should be updated too. If I change the name of the user
\n“manuel” to “joseph”, I want the query (USER-WITH-NAME “manuel”) to
\nreturn nothing and the query (USER-WITH-NAME “joseph”) to return
\nthe user. We can do this by overloading the accessor for the slot
\nNAME, but that would be error-prone and tedious. We could still use
\nthe function (SETF SLOT-VALUE) to change the slot value, and the
\nindex won’t be updated. MOP allows us to catch slot accesses by
\noverloading the method (SETF SLOT-VALUE-USING-CLASS). This is
\nexactly what we do for our indices. Beware, that method is a tad
\nlong.<\/p>\n
\n(defmethod (setf slot-value-using-class) :around\n    (newvalue (class indexed-class) object (slot index-effective-slot-definition))\n  (declare (ignore newvalue))\n<\/pre>\n
\n  (when (eql (slot-definition-name slot) 'destroyed-p)\n    (return-from slot-value-using-class  (call-next-method)))\n<\/pre>\n
\n  (when *in-make-instance-p*\n    (return-from slot-value-using-class (call-next-method)))\n  \n  (let* ((indices (index-effective-slot-definition-indices slot))\n     (slot-name (slot-definition-name slot))\n     (previous-slot-boundp (slot-boundp object slot-name))\n     (previous-slot-value (when previous-slot-boundp\n                (slot-value object slot-name))))\n<\/pre>\n
\n    #+nil\n    (format t \"indices ~A~%\" indices)\n<\/pre>\n
\n    (when (and previous-slot-boundp\n           *indices-remove-p*)\n      (let ((changed-indices)\n        (error t))\n    (unwind-protect\n         (progn \n           (dolist (index indices)\n         (index-remove index object)\n         (push index changed-indices))\n           (setf error nil))\n      (when error\n        (dolist (index changed-indices)\n          (index-add index object))))))\n    \n    (let ((result (call-next-method)))\n      #+nil\n      (format t \"set slot ~A of ~a to ~A, value is ~a~%\"\n          (slot-definition-name slot)\n          object newvalue\n          (slot-value object (slot-definition-name slot)))\n      \n      (when (slot-boundp object (slot-definition-name slot))\n    (let ((error t)\n          (changed-indices nil))\n      (unwind-protect\n           (progn\n         (dolist (index indices)\n           (index-add index object)\n           (push index changed-indices))\n         (setf error nil))\n        (when error\n          (dolist (index changed-indices)\n        (index-remove index object))\n          (let ((*indices-remove-p* nil))\n        (if previous-slot-boundp\n            (setf (slot-value object slot-name) previous-slot-value)\n            (slot-makunbound object slot-name)))))))\n      result)))\n<\/pre>\n
What we do here is first to check for some special cases. If the
\nslot is named DESTROYED-P, we have to handle it in “the normal
\nway”, as this slot is never indexed. The same goes for slot-access
\nwhile the object is being created, so if we are in a MAKE-INSTANCE,
\nwe call the normal method. The variable *IN-MAKE-INSTANCE-P* is
\nbound by a wrapper around INITIALIZE-INSTANCE. The next step in our
\nmethod is to get the previous value of the slot and the new value
\nof the slot. We also retrieve the indices that are affected by the
\nslot change. We then remove the object from all the indices
\naffected, change the slot value, and reinsert the object into the
\nindices. This bit is quite lengthy because we do alot of
\nerror-checking to avoid the corruption of the index structures if
\nan error happens.<\/p>\n
In a very similar way, MOP allows us to control slot
\n“destruction”. When we want to unbind a slot of an object, MOP
\ncalls the method SLOT-MAKUNBOUND-USING-CLASS. When a slot is
\nunbound, we want the object to be removed from all the affected
\nindices. Here is SLOT-MAKUNBOUND-USING-CLASS:<\/p>\n
\n(defmethod slot-makunbound-using-class\n    ((class indexed-class) object (slot index-effective-slot-definition))\n  (let* ((slot-name (slot-definition-name slot))\n     (previous-slot-boundp (slot-boundp object slot-name))\n     (indices (index-effective-slot-definition-indices slot)))\n    (when (and previous-slot-boundp\n           *indices-remove-p*)\n      (let ((changed-indices nil)\n        (error t))\n    (unwind-protect\n         (progn\n           (dolist (index indices)\n         (index-remove index object)\n         (push index changed-indices))\n           (setf error nil))\n      (when error\n        (dolist (index changed-indices)\n          (index-add index object))))))\n    (call-next-method)))\n<\/pre>\n
Controlling access to destroyed objects<\/strong><\/p>\n
All these slot access methods are used to control access to
\ndestroyed objects. When an object is destroyed, every slot access,
\nslot updated and slot unbinding is prohibited and should throw an
\nerror. We do this by simply adding a bunch of BEFORE methods on the
\nslot access methods. Again, the slot DESTROYED-P has to be handled
\nin a special way (else we would recurse infinitely here).<\/p>\n
\n(defmethod slot-value-using-class :before\n    ((class indexed-class) object slot)\n  (when (and (not (eql (slot-definition-name slot) 'destroyed-p))\n         (slot-value object 'destroyed-p)\n         (not *indexed-class-override*))\n    (error \"Can not get slot ~A of destroyed object of class ~a.\"\n       (slot-definition-name slot) (class-name (class-of object)))))\n<\/pre>\n
\n(defmethod (setf slot-value-using-class) :before\n    (newvalue (class indexed-class) object slot)\n  (declare (ignore newvalue))\n  (when (and (not (eql (slot-definition-name slot) 'destroyed-p))\n         (slot-value object 'destroyed-p)\n         (not *indexed-class-override*))\n    (error \"Can not set slot ~A of destroyed object ~a.\" \n       (slot-definition-name slot) (class-name (class-of object)))))\n<\/pre>\n
\n(defmethod slot-makunbound-using-class :before ((class indexed-class) object slot)\n  (when (and (not (eql (if (symbolp slot)\n               slot\n               (slot-definition-name slot)) 'destroyed-p))\n         (slot-value object 'destroyed-p)\n         (not *indexed-class-override*))\n    (error \"Can not MAKUNBOUND slot ~A of destroyed object ~a.\" \n       (slot-definition-name slot) (class-name (class-of object)))))\n<\/pre>\n
I leave it to you to trace the slot access methods and to play
\nwith the indixed objects around a bit to see what happens \ud83d\ude42 The
\ntraces would be too long here…<\/p>\n
To be continued…<\/strong><\/p>\n
That’s it for this time. In the next posting, we will see how we
\ncan control instance creation and instance updating using MOP.<\/p>\n","protected":false},"excerpt":{"rendered":"
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 … Continue reading →<\/span><\/a><\/p>\n","protected":false},"author":1,"featured_media":0,"comment_status":"open","ping_status":"closed","sticky":false,"template":"","format":"standard","meta":{"footnotes":""},"categories":[19,3],"tags":[],"class_list":["post-119","post","type-post","status-publish","format-standard","hentry","category-english","category-lispstaub"],"_links":{"self":[{"href":"https:\/\/blogs.bl0rg.net\/netzstaub\/wp-json\/wp\/v2\/posts\/119","targetHints":{"allow":["GET"]}}],"collection":[{"href":"https:\/\/blogs.bl0rg.net\/netzstaub\/wp-json\/wp\/v2\/posts"}],"about":[{"href":"https:\/\/blogs.bl0rg.net\/netzstaub\/wp-json\/wp\/v2\/types\/post"}],"author":[{"embeddable":true,"href":"https:\/\/blogs.bl0rg.net\/netzstaub\/wp-json\/wp\/v2\/users\/1"}],"replies":[{"embeddable":true,"href":"https:\/\/blogs.bl0rg.net\/netzstaub\/wp-json\/wp\/v2\/comments?post=119"}],"version-history":[{"count":0,"href":"https:\/\/blogs.bl0rg.net\/netzstaub\/wp-json\/wp\/v2\/posts\/119\/revisions"}],"wp:attachment":[{"href":"https:\/\/blogs.bl0rg.net\/netzstaub\/wp-json\/wp\/v2\/media?parent=119"}],"wp:term":[{"taxonomy":"category","embeddable":true,"href":"https:\/\/blogs.bl0rg.net\/netzstaub\/wp-json\/wp\/v2\/categories?post=119"},{"taxonomy":"post_tag","embeddable":true,"href":"https:\/\/blogs.bl0rg.net\/netzstaub\/wp-json\/wp\/v2\/tags?post=119"}],"curies":[{"name":"wp","href":"https:\/\/api.w.org\/{rel}","templated":true}]}}