X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=9e2706c9f4477375b3d8dcc5caab573aa0f54813;hb=647d539c69157228c414905a06253e5d3b193718;hp=b34541c11d7982647d1638cda566bd52fb438b38;hpb=667978ba6ecf4a4cf509aace0d8f0bf4b5666a3d;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index b34541c..9e2706c 100644 --- a/mop.lisp +++ b/mop.lisp @@ -11,10 +11,9 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: mop.lisp,v 1.69 2003/05/06 22:19:09 kevin Exp $ -;;;; -;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; $Id: mop.lisp,v 1.73 2003/05/15 06:30:19 kevin Exp $ ;;;; +;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package :hyperobject) @@ -29,6 +28,9 @@ (user-name :initarg :user-name :type string :initform nil :accessor user-name :documentation "User name for class") + (user-name-plural :initarg :user-name-plural :type string :initform nil + :accessor user-name-plural + :documentation "Plural user name for class") (default-print-slots :initarg :default-print-slots :type list :initform nil :accessor default-print-slots :documentation "Defaults slots for a view") @@ -237,6 +239,7 @@ :hyperlink-parameters (slot-value dsd 'hyperlink-parameters) :description (slot-value dsd 'description) :user-name (slot-value dsd 'user-name) + :user-name-plural (slot-value dsd 'user-name-plural) :index (slot-value dsd 'index) :value-constraint (slot-value dsd 'value-constraint) :null-allowed (slot-value dsd 'null-allowed) @@ -252,8 +255,8 @@ (setf (slot-value esd 'length) length) (setf (slot-value esd 'type) (value-type-to-lisp-type value-type)) (setf (slot-value esd 'value-type) value-type) - (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters description user-name - value-constraint index null-allowed)) + (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters + description value-constraint index null-allowed user-name)) (setf (slot-value esd name) (slot-value dsd name))) esd))) @@ -368,6 +371,38 @@ ':function (compile nil method-lambda) init-args-values))))) +#+(or allegro scl) +(progn + ;; One entry for each class with lazy readers defined. The value is a plist mapping + ;; slot-name to a lazy reader, each of which is a list of a function and slot-names. + (defvar *lazy-readers* (make-hash-table)) + +(defmethod slot-unbound :around ((class hyperobject-class) instance slot-name) + (let ((lazy-reader (loop for super in (class-precedence-list class) + as lazy-reader = (getf (gethash super *lazy-readers*) slot-name) + when lazy-reader return it))) + (if lazy-reader + (setf (slot-value instance slot-name) + (apply (car lazy-reader) + (loop for arg-slot-name in (cdr lazy-reader) + collect (slot-value instance arg-slot-name)))) + ;; No lazy reader -- defer to regular slot-unbound handling. + (call-next-method)))) + + ;; The reader is a function and the reader-keys are slot names. The slot is lazily set to + ;; the result of applying the function to the slot-values of those slots, and that value + ;; is also returned. + (defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys) + (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name) + (list* reader (copy-list reader-keys)))) + + (defun remove-lazy-reader (class-name slot-name) + (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name) + nil)) + + ) ;; #+(or allegro scl) + + (defun finalize-subobjects (cl) "Process class subobjects slot" (setf (subobjects cl) @@ -386,12 +421,12 @@ nil (cdr subobj-def))))) (unless (eq (lookup subobject) t) - #-(or sbcl cmu lispworks) + #+ignore ;; #-(or sbcl cmu lispworks) (eval `(hyperobject::def-lazy-reader ,(name-class subobject) ,(name-slot subobject) ,(lookup subobject) ,@(lookup-keys subobject))) - #+(or sbcl cmu lispworks) + #+(or sbcl cmu lispworks allegro scl) (apply #'ensure-lazy-reader (name-class subobject) (name-slot subobject) (lookup subobject) (lookup-keys subobject))) @@ -402,19 +437,29 @@ #-(or cmu sbcl) (nreverse subobjects) ))) + +(defun finalize-class-slots (cl) + "Make sure all class slots have an expected value" + (unless (user-name cl) + (setf (user-name cl) (format nil "~:(~A~)" (class-name cl)))) + + (setf (user-name-plural cl) + (if (and (consp (user-name cl)) (cadr (user-name cl))) + (cadr (user-name cl)) + (format nil "~A~P" (if (consp (user-name cl)) + (car (user-name cl)) + (user-name cl)) + 2))) + + (dolist (name '(user-name description)) + (awhen (slot-value cl name) + (setf (slot-value cl name) + (etypecase (slot-value cl name) + (cons (car it)) + ((or string symbol) it)))))) + (defun finalize-documentation (cl) "Calculate class documentation slot" - (awhen (slot-value cl 'user-name) - (setf (slot-value cl 'user-name) - (etypecase (slot-value cl 'user-name) - (cons (car it)) - ((or string symbol) it)))) - (awhen (slot-value cl 'description) - (setf (slot-value cl 'description) - (etypecase (slot-value cl 'description) - (cons (car it)) - ((or string symbol) it)))) - (let ((*print-circle* nil)) (setf (documentation (class-name cl) 'class) (format nil "Hyperobject~A~A~A~A" @@ -450,6 +495,7 @@ (finalize-hyperlinks cl) (finalize-sql cl) (finalize-rules cl) + (finalize-class-slots cl) (finalize-documentation cl)) @@ -461,10 +507,10 @@ (find name (class-slots cl) :key #'slot-definition-name)) (defun hyperobject-class-user-name (obj) - (awhen (user-name (class-of obj)) - (if (consp it) - (car it) - it))) + (user-name (class-of obj))) + +(defun hyperobject-class-user-name-plural (obj) + (user-name-plural (class-of obj))) (defun hyperobject-class-subobjects (obj) (subobjects (class-of obj)))