X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=327c76bd259c8f995ec5953ee2d58795898274df;hb=9e616a490d6d4f03682a7bd7e9ea6587fecf2015;hp=39e58b9b4c49bc4c007ae42d5bdf02539c1309ae;hpb=d7f427eeebf7e6404ad2d1ebabbc8ebaa064898c;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index 39e58b9..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.4 2002/12/01 21:07:28 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 ;;;; @@ -20,21 +20,21 @@ (in-package :hyperobject) (eval-when (:compile-toplevel :execute) - (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) + (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2)))) ;; Main class (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. @@ -47,7 +47,7 @@ "Unique ID for the class") (create-table-cmd :initform nil :reader create-table-cmd) - (create-index-cmds :initform nil :reader create-index-cmds) + (create-indices-cmds :initform nil :reader create-index-cmds) (drop-table-cmd :initform nil :reader drop-table-cmd) (value-func :initform nil :type function) @@ -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) @@ -155,121 +160,149 @@ ((cl hyperobject-class) #+(or allegro lispworks) name dsds) #+allergo (declare (ignore name)) (let* ((dsd (car dsds)) - (ho-type (slot-value dsd 'type))) + (ho-type (slot-value dsd '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)) - (setf (slot-value dsd 'sql-type) (ho-type-to-sql-type ho-type)) (let ((ia (compute-effective-slot-definition-initargs cl #+lispworks name dsds))) (apply #'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) - ia))) - ) + :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 - 'fixnum) + 'integer) (: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 (sqltype) - (ecase sqltype - (:string - 'string) - (:fixnum - 'fixnum) - (:bigint - 'integer) - (:short-float - 'short-float) - (:long - 'long-float) - (:text - 'string))) - ;;;; Class initialization function -(defun process-subobjects (cl) +;; 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 process-documentation (cl) +(defun finalize-documentation (cl) "Calculate class documentation slot" - (awhen (slot-value cl 'title) - (setf (slot-value cl 'title) (car it))) + (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) (car it))) - + (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" - (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) "") )))) (defun init-hyperobject-class (cl) "Initialize a hyperobject class. Calculates all class slots" - (process-subobjects cl) - (process-views cl) - (process-sql cl) - (process-documentation cl)) + (finalize-subobjects cl) + (finalize-views cl) + (finalize-hyperlinks cl) + (finalize-sql cl) + (finalize-documentation cl)) ;;;; ************************************************************************* @@ -305,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)))) @@ -320,6 +353,9 @@ (defun hyperobject-class-fields (obj) (class-slots (class-of obj))) +(defun hyperobject-class-print-slots (obj) + (slot-value (class-of obj) 'print-slots)) + (defun hyperobject-class-fmtstr-html-ref (obj) (slot-value (class-of obj) 'fmtstr-html-ref))