Wednesday, August 13, 2008

A metaclass for weblocks-webapps

defwebapp in weblocks-dev currently does many mysterious things with its keyword arguments. But these are the sorts of things that should be given directly to make-instance, so that you can use your own defclass forms and your own make-instance calls to construct weblocks-webapp instances in creative ways.

I have a few goals for a rewrite of defwebapp:

  1. Trivialize the mapping of the defwebapp form to a defclass form, putting most of the logic in initializing methods and possibly a metaclass (ahem, class metaobject class).
  2. Don't hide the default slot values in class-default-initargs.
  3. On reevaluation of defwebapp, replace the slot values, at least in the trivial case where the hacker allowed the normal autostarter to instantiate the resulting weblocks-webapp subclass.

My first thought, abandoned before I could even start changing defwebapp proper to use it, would have defwebapp fill class-instance slots (not to be confused with instance slots with :allocation :class) instead of default-initargs, then alter the initform and initfunction in compute-effective-slot-definition to copy over those values to each new instance.

(defclass weblocks-webapp-class (standard-class)

(defmethod validate-superclass ((class weblocks-webapp-class) superclass)
(typep (class-name (class-of superclass))
'(member standard-class weblocks-webapp-class)))

(defgeneric class-defaulting-slots (class)
(:method ((self weblocks-webapp-class))
(loop for class in (class-precedence-list self)
while (typep class 'weblocks-webapp-class)
append (class-direct-slots class)))
(:method ((self standard-class)) '()))

(defmethod compute-effective-slot-definition
((self weblocks-webapp-class) name direct-slot-defns)
"Provide a default initform (read the class's version of the slot)
for those without initforms."
(let ((eslot (call-next-method))
(defaulting-slots (class-defaulting-slots self)))
(macrolet ((initfunc () (slot-definition-initfunction eslot)))
(when (and (find name defaulting-slots :key #'slot-definition-name)
(not (initfunc)))
(setf (slot-definition-initform eslot)
`(slot-value (find-class ',(class-name self)) ',name)
(initfunc) (lambda () (slot-value self name)))))

No comments: