X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=1094c56f0fd4595ab9b97dc7db90a14f6be3bd71;hb=da95022a6396191e772e59cd7622c7c5919ce605;hp=327c76bd259c8f995ec5953ee2d58795898274df;hpb=9e616a490d6d4f03682a7bd7e9ea6587fecf2015;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index 327c76b..1094c56 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.8 2002/12/09 10:39:38 kevin Exp $ +;;;; $Id: mop.lisp,v 1.10 2002/12/13 05:44:19 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -28,8 +28,8 @@ ( ;; slots initialized in defclass (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") + (default-print-slots :initarg :default-print-slots :type list :initform nil + :documentation "Defaults slots for a view") (description :initarg :description :initform nil :documentation "Class description") (version :initarg :version :initform nil @@ -45,23 +45,16 @@ "List of fields that have hyperlinks") (class-id :type integer :initform nil :documentation "Unique ID for the class") - + + ;; SQL commands (create-table-cmd :initform nil :reader create-table-cmd) (create-indices-cmds :initform nil :reader create-index-cmds) (drop-table-cmd :initform nil :reader drop-table-cmd) - (value-func :initform nil :type function) - (xmlvalue-func :initform nil :type function) - (fmtstr-text :initform nil :type string) - (fmtstr-html :initform nil :type string) - (fmtstr-xml :initform nil :type string) - (fmtstr-text-labels :initform nil :type string) - (fmtstr-html-labels :initform nil :type string) - (fmtstr-xml-labels :initform nil :type string) - (fmtstr-html-ref :initform nil :type string) - (fmtstr-xml-ref :initform nil :type string) - (fmtstr-html-ref-labels :initform nil :type string) - (fmtstr-xml-ref-labels :initform nil :type string) + (views :type list :initform nil :initarg :views :accessor views + :documentation "List of views") + (default-view :initform nil :initarg :default-view :accessor default-view + :documentation "The default view for a class") ) (:documentation "Metaclass for Markup Language classes.")) @@ -93,7 +86,8 @@ t) (defmethod finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) + (init-hyperobject-class cl) + ) ;; Slot definitions (defmethod direct-slot-definition-class ((cl hyperobject-class) @@ -155,12 +149,25 @@ :initform nil)) (append *slot-options* *slot-options-no-initarg*))))) ) ;; eval-when - + +(defun intern-in-keyword (obj) + (cond + ((null obj) + nil) + ((eq t obj) + t) + ((atom obj) + (intern (symbol-name obj) (find-package 'keyword))) + ((consp obj) + (cons (intern-in-keyword (car obj) ) (intern-in-keyword (cdr obj)))) + (t + obj))) + (defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+(or allegro lispworks) name dsds) #+allergo (declare (ignore name)) (let* ((dsd (car dsds)) - (ho-type (slot-value dsd 'type)) + (ho-type (intern-in-keyword (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) @@ -186,7 +193,7 @@ (when (consp ho-type) (setq ho-type (car ho-type))) (check-type ho-type symbol) - (case (intern (symbol-name ho-type) (symbol-name :keyword)) + (case ho-type ((or :string :cdata :varchar :char) 'string) (:character @@ -201,7 +208,7 @@ 'single-float) (:double-float 'double-float) - (:nil + (nil t) (otherwise ho-type))) @@ -210,7 +217,7 @@ (when (consp ho-type) (setq ho-type (car ho-type))) (check-type ho-type symbol) - (case (intern (symbol-name ho-type) (symbol-name :keyword)) + (case ho-type ((or :string :cdata) 'string) (:fixnum @@ -223,7 +230,7 @@ 'single-float) (:double-float 'double-float) - (:nil + (nil t) (otherwise ho-type))) @@ -292,10 +299,22 @@ (format nil "~%Class description: ~A" it) "") (aif (slot-value cl 'subobjects) (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "") - (aif (slot-value cl 'print-slots) - (format nil "~%Print-slots:~{ ~A~}" it) "") + (aif (slot-value cl 'default-print-slots) + (format nil "~%Default print slots:~{ ~A~}" it) "") )))) +(defun finalize-hyperlinks (cl) + (let ((hyperlinks '())) + (dolist (esd (class-slots cl)) + (awhen (slot-value esd 'hyperlink) + (push + (make-instance 'hyperlink + :name (slot-definition-name esd) + :lookup it + :link-parameters (slot-value esd 'hyperlink-parameters)) + hyperlinks))) + (setf (slot-value cl 'hyperlinks) hyperlinks))) + (defun init-hyperobject-class (cl) "Initialize a hyperobject class. Calculates all class slots" (finalize-subobjects cl) @@ -312,37 +331,11 @@ (defun find-slot-by-name (cl name) (find name (class-slots cl) :key #'slot-definition-name)) -(defun hyperobject-class-fmtstr-text (obj) - (slot-value (class-of obj) 'fmtstr-text)) - -(defun hyperobject-class-fmtstr-html (obj) - (slot-value (class-of obj) 'fmtstr-html)) - -(defun hyperobject-class-fmtstr-xml (obj) - (slot-value (class-of obj) 'fmtstr-xml)) - -(defun hyperobject-class-fmtstr-text-labels (obj) - (slot-value (class-of obj) 'fmtstr-text-labels)) - -(defun hyperobject-class-fmtstr-html-labels (obj) - (slot-value (class-of obj) 'fmtstr-html-labels)) - -(defun hyperobject-class-fmtstr-xml-labels (obj) - (slot-value (class-of obj) 'fmtstr-xml-labels)) - -(defun hyperobject-class-value-func (obj) - (slot-value (class-of obj) 'value-func)) - -(defun hyperobject-class-xmlvalue-func (obj) - (slot-value (class-of obj) 'xmlvalue-func)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - - (defun hyperobject-class-user-name (obj) - (awhen (slot-value (class-of obj) 'user-name) - (if (consp it) - (car it) - it)))) +(defun hyperobject-class-user-name (obj) + (awhen (slot-value (class-of obj) 'user-name) + (if (consp it) + (car it) + it))) (defun hyperobject-class-subobjects (obj) (slot-value (class-of obj) 'subobjects)) @@ -353,18 +346,3 @@ (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)) - -(defun hyperobject-class-fmtstr-xml-ref (obj) - (slot-value (class-of obj) 'fmtstr-xml-ref)) - -(defun hyperobject-class-fmtstr-html-ref-labels (obj) - (slot-value (class-of obj) 'fmtstr-html-ref-labels)) - -(defun hyperobject-class-fmtstr-xml-ref-labels (obj) - (slot-value (class-of obj) 'fmtstr-xml-ref-labels)) -