X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=327c76bd259c8f995ec5953ee2d58795898274df;hb=9e616a490d6d4f03682a7bd7e9ea6587fecf2015;hp=45e704aee09c17929079473bf4d0d99c7e7e2a62;hpb=26013f0c832eb9ca60310fab0dca0bed8c4a9061;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index 45e704a..327c76b 100644 --- a/mop.lisp +++ b/mop.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: mop.lisp,v 1.7 2002/12/06 16:18:49 kevin Exp $ +;;;; $Id: mop.lisp,v 1.8 2002/12/09 10:39:38 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -26,15 +26,15 @@ (defclass hyperobject-class (standard-class) ( ;; slots initialized in defclass - (title :initarg :title :type string :initform nil - :documentation "Print Title for class") + (user-name :initarg :user-name :type string :initform nil + :documentation "User name for class") (print-slots :initarg :print-slots :type list :initform nil :documentation "List of slots to print") (description :initarg :description :initform nil :documentation "Class description") (version :initarg :version :initform nil :documentation "Version number for class") - (sql-name :initarg :table-name :initform nil :reader sql-name) + (sql-name :initarg :table-name :initform nil) ;;; The remainder of these fields are calculated one time ;;; in finalize-inheritence. @@ -66,8 +66,13 @@ (:documentation "Metaclass for Markup Language classes.")) (defclass subobject () - ((name :type symbol :initform nil :initarg :name :reader name) - (reader :type function :initform nil :initarg :reader :reader reader))) + ((name-class :type symbol :initform nil :initarg :name-class :reader name-class) + (name-slot :type symbol :initform nil :initarg :name-slot :reader name-slot) + (lookup :type symbol :initform nil :initarg :lookup :reader lookup) + (lookup-keys :type list :initform nil :initarg :lookup-keys + :reader lookup-keys)) + (:documentation "Contains subobject information")) + (defmethod print-object ((obj subobject) (s stream)) (print-unreadable-object (obj s :type t :identity t) @@ -156,7 +161,8 @@ #+allergo (declare (ignore name)) (let* ((dsd (car dsds)) (ho-type (slot-value dsd 'type)) - (sql-type (ho-type-to-sql-type ho-type))) + (sql-type (ho-type-to-sql-type ho-type)) + (length (when (consp ho-type) (cadr ho-type)))) (setf (slot-value dsd 'ho-type) ho-type) (setf (slot-value dsd 'sql-type) sql-type) (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type)) @@ -166,37 +172,46 @@ #'make-instance 'hyperobject-esd :ho-type ho-type :sql-type sql-type + :length length :print-formatter (slot-value dsd 'print-formatter) :subobject (slot-value dsd 'subobject) :hyperlink (slot-value dsd 'hyperlink) :hyperlink-parameters (slot-value dsd 'hyperlink-parameters) :description (slot-value dsd 'description) + :user-name (slot-value dsd 'user-name) + :index (slot-value dsd 'index) ia)))) (defun ho-type-to-lisp-type (ho-type) + (when (consp ho-type) + (setq ho-type (car ho-type))) (check-type ho-type symbol) (case (intern (symbol-name ho-type) (symbol-name :keyword)) - (:string + ((or :string :cdata :varchar :char) 'string) + (:character + 'character) (:fixnum 'fixnum) (:boolean 'boolean) (:integer 'integer) - (:cdata - 'string) - (:float - 'float) + ((or :float :single-float) + 'single-float) + (:double-float + 'double-float) (:nil t) (otherwise ho-type))) (defun ho-type-to-sql-type (ho-type) + (when (consp ho-type) + (setq ho-type (car ho-type))) (check-type ho-type symbol) (case (intern (symbol-name ho-type) (symbol-name :keyword)) - (:string + ((or :string :cdata) 'string) (:fixnum 'integer) @@ -204,10 +219,10 @@ 'boolean) (:integer 'integer) - (:cdata - 'string) - (:float - 'float) + ((or :float :single-float) + 'single-float) + (:double-float + 'double-float) (:nil t) (otherwise @@ -216,24 +231,50 @@ ;;;; Class initialization function +;; defines a slot-unbound method for class and slot-name, fills +;; the slot by calling reader function with the slot values of +;; the instance's reader-keys +(defmacro def-lazy-reader (class slot-name reader &rest reader-keys) + (let* ((the-slot-name (gensym)) + (the-class (gensym)) + (the-instance (gensym)) + (keys '())) + (dolist (key reader-keys) + (push (list 'slot-value the-instance (list 'quote key)) keys)) + (setq keys (nreverse keys)) + `(defmethod slot-unbound (,the-class (,the-instance ,class) + (,the-slot-name (eql ',slot-name))) + (declare (ignore ,the-class)) + (setf (slot-value ,the-instance ,the-slot-name) + (,reader ,@keys))))) + (defun finalize-subobjects (cl) "Process class subobjects slot" (setf (slot-value cl 'subobjects) (let ((subobjects '())) (dolist (slot (class-slots cl)) - (when (slot-value slot 'subobject) - (push (make-instance 'subobject :name (slot-definition-name slot) - :reader (if (eq t (slot-value slot 'subobject)) - (slot-definition-name slot) - (slot-value slot 'subobject))) - subobjects))) + (let-when (subobj-def (slot-value slot 'subobject)) + (let ((subobject (make-instance 'subobject + :name-class (class-name cl) + :name-slot (slot-definition-name slot) + :lookup (if (atom subobj-def) + subobj-def + (car subobj-def)) + :lookup-keys (if (atom subobj-def) + nil + (cdr subobj-def))))) + (unless (eq (lookup subobject) t) + (eval `(def-lazy-reader ,(name-class subobject) + ,(name-slot subobject) ,(lookup subobject) + ,@(lookup-keys subobject)))) + (push subobject subobjects)))) subobjects))) (defun finalize-documentation (cl) "Calculate class documentation slot" - (awhen (slot-value cl 'title) - (setf (slot-value cl 'title) - (etypecase (slot-value cl 'title) + (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) @@ -245,12 +286,12 @@ (let ((*print-circle* nil)) (setf (documentation (class-name cl) 'class) (format nil "Hyperobject~A~A~A~A" - (aif (slot-value cl 'title) + (aif (slot-value cl 'user-name) (format nil ": ~A" it "")) (aif (slot-value cl 'description) (format nil "~%Class description: ~A" it) "") (aif (slot-value cl 'subobjects) - (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "") + (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "") (aif (slot-value cl 'print-slots) (format nil "~%Print-slots:~{ ~A~}" it) "") )))) @@ -297,8 +338,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) - (defun hyperobject-class-title (obj) - (awhen (slot-value (class-of obj) 'title) + (defun hyperobject-class-user-name (obj) + (awhen (slot-value (class-of obj) 'user-name) (if (consp it) (car it) it))))