From cda49a13fa66d935f4d7db644364cc741b9c1c4c Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 29 Nov 2002 05:05:29 +0000 Subject: [PATCH] r3518: *** empty log message *** --- hyperobject.asd | 5 +- metaclass.lisp | 29 +++++++ mop.lisp | 210 +++++++++--------------------------------------- package.lisp | 39 ++++++++- views.lisp | 130 +++++++++++++++++++++++++++++- 5 files changed, 235 insertions(+), 178 deletions(-) create mode 100644 metaclass.lisp diff --git a/hyperobject.asd b/hyperobject.asd index e26fe0e..d3134d4 100644 --- a/hyperobject.asd +++ b/hyperobject.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: hyperobject.asd,v 1.9 2002/11/29 04:07:52 kevin Exp $ +;;;; $Id: hyperobject.asd,v 1.10 2002/11/29 05:05:29 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -20,7 +20,8 @@ (pushnew :hyperobject cl:*features*)) :components ((:file "package") - (:file "mop" :depends-on ("package")) + (:file "metaclass" :depends-on ("package")) + (:file "mop" :depends-on ("metaclass")) (:file "views" :depends-on ("mop")) (:file "base-class" :depends-on ("views")) ) diff --git a/metaclass.lisp b/metaclass.lisp new file mode 100644 index 0000000..b46ab98 --- /dev/null +++ b/metaclass.lisp @@ -0,0 +1,29 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: metaclass.lisp +;;;; Purpose: Define options for hyperobject metaclass +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; +;;;; $Id: metaclass.lisp,v 1.1 2002/11/29 05:05:29 kevin Exp $ +;;;; +;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :hyperobject) + +(defparameter *class-options* + '(:title :print-slots :description :version :sql-name) + "List of class options for hyperobjects.") +(defparameter *slot-options* + '(:print-formatter :description :sql-name + :index :subobject :hyperlink :inverse) + "Slot options that can appear as an initarg") +(defparameter *slot-options-no-initarg* + '(:ho-type :sql-type) + "Slot options that do not have an initarg") + diff --git a/mop.lisp b/mop.lisp index 151baf2..9601951 100644 --- a/mop.lisp +++ b/mop.lisp @@ -2,8 +2,8 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: hyperobject.lisp -;;;; Purpose: Hyper Object Metaclass +;;;; Name: mop.lisp +;;;; Purpose: Metaobject Protocol Interface ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: mop.lisp,v 1.1 2002/11/29 04:07:52 kevin Exp $ +;;;; $Id: mop.lisp,v 1.2 2002/11/29 05:05:29 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -22,43 +22,6 @@ (eval-when (:compile-toplevel :execute) (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (shadowing-import - #+allegro - `(mop::class-slots mop::slot-definition-name mop:finalize-inheritance - mop::standard-direct-slot-definition mop::standard-effective-slot-definition - mop:direct-slot-definition-class mop:compute-effective-slot-definition - excl::compute-effective-slot-definition-initargs) - #+lispworks - `(clos:class-slots clos::slot-definition-name clos:finalize-inheritance - clos::standard-direct-slot-definition clos::standard-effective-slot-definition - clos:direct-slot-definition-class clos:compute-effective-slot-definition - clos::compute-effective-slot-definition-initargs) - #+sbcl - `(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl::standard-class - sb-pcl::slot-definition-name sb-pcl:finalize-inheritance - sb-pcl::standard-direct-slot-definition - sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass - sb-pcl:direct-slot-definition-class sb-pcl:compute-effective-slot-definition - sb-pcl::compute-effective-slot-definition-initargs) - #+cmu - `(pcl:class-of pcl:class-name pcl:class-slots pcl::standard-class - pcl::slot-definition-name pcl:finalize-inheritance - pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition - pcl::validate-superclass pcl:direct-slot-definition-class - pcl:compute-effective-slot-definition - pcl::compute-effective-slot-definition-initargs) - #+scl - `(class-of class-name clos:class-slots clos::standard-class - clos::slot-definition-name clos:finalize-inheritance - clos::standard-direct-slot-definition clos::standard-effective-slot-definition - clos::validate-superclass clos:direct-slot-definition-class - clos:compute-effective-slot-definition - clos::compute-effective-slot-definition-initargs) - - :hyperobject)) - - ;; Main class (defclass hyperobject-class (standard-class) @@ -156,16 +119,6 @@ (declare (ignore slot-name)) ) - (defparameter *class-options* - '(:title :print-slots :description :version :sql-name) - "List of class options for hyperobjects.") - (defparameter *slot-options* - '(:print-formatter :subobject :reference :description :unique :sql-name) - "List of slot options that can appear as an initarg") - (defparameter *slot-options-no-initarg* - '(:ho-type) - "List of slot options that do not have an initarg") - (dolist (option *class-options*) (eval `(process-class-option ,option))) (dolist (option *slot-options*) @@ -199,12 +152,14 @@ (let* ((dsd (car dsds)) (ho-type (slot-value dsd 'type))) (setf (slot-value dsd 'ho-type) ho-type) - (setf (slot-value dsd 'type) (convert-ho-type ho-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 :print-formatter (slot-value dsd 'print-formatter) :subobject (slot-value dsd 'subobject) :reference (slot-value dsd 'reference) @@ -212,7 +167,7 @@ ia))) ) -(defun convert-ho-type (ho-type) +(defun ho-type-to-lisp-type (ho-type) (check-type ho-type symbol) (case (intern (symbol-name ho-type) (symbol-name :keyword)) (:string @@ -232,11 +187,27 @@ (otherwise ho-type))) -;;;; Class initialization function - -(defun find-slot-by-name (cl name) - (find name (class-slots cl) :key #'slot-definition-name)) +(defun ho-type-to-sql-type (ho-type) + (check-type ho-type symbol) + (case (intern (symbol-name ho-type) (symbol-name :keyword)) + (:string + 'string) + (:fixnum + 'fixnum) + (:boolean + 'boolean) + (:integer + 'integer) + (:cdata + 'string) + (:float + 'float) + (:nil + t) + (otherwise + ho-type))) +;;;; Class initialization function (defun process-subobjects (cl) "Process class subobjects slot" @@ -271,130 +242,20 @@ (format nil "~%Print-slots:~{ ~A~}" it) "") )))) -(defun process-views (cl) - "Calculate all view slots for a hyperobject class" - (let ((fmtstr-text "") - (fmtstr-html "") - (fmtstr-xml "") - (fmtstr-text-labels "") - (fmtstr-html-labels "") - (fmtstr-xml-labels "") - (fmtstr-html-ref "") - (fmtstr-xml-ref "") - (fmtstr-html-ref-labels "") - (fmtstr-xml-ref-labels "") - (first-field t) - (value-func '()) - (xmlvalue-func '()) - (classname (class-name cl)) - (package (symbol-package (class-name cl))) - (references nil)) - (declare (ignore classname)) - (check-type (slot-value cl 'print-slots) list) - (dolist (slot-name (slot-value cl 'print-slots)) - (let ((slot (find-slot-by-name cl slot-name))) - (unless slot - (error "Slot ~A is not found in class ~S" slot-name cl)) - (let ((name (slot-definition-name slot)) - (namestr (symbol-name (slot-definition-name slot))) - (namestr-lower (string-downcase (symbol-name (slot-definition-name slot)))) - (type (slot-value slot 'ho-type)) - (print-formatter (slot-value slot 'print-formatter)) - (value-fmt "~a") - (plain-value-func nil) - html-str xml-str html-label-str xml-label-str) - - (when (or (eql type :integer) (eql type :fixnum)) - (setq value-fmt "~d")) - - (when (eql type :boolean) - (setq value-fmt "~a")) - - (if first-field - (setq first-field nil) - (progn - (string-append fmtstr-text " ") - (string-append fmtstr-html " ") - (string-append fmtstr-xml " ") - (string-append fmtstr-text-labels " ") - (string-append fmtstr-html-labels " ") - (string-append fmtstr-xml-labels " ") - (string-append fmtstr-html-ref " ") - (string-append fmtstr-xml-ref " ") - (string-append fmtstr-html-ref-labels " ") - (string-append fmtstr-xml-ref-labels " "))) - - (setq html-str (concatenate 'string "" value-fmt "")) - (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "")) - (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt "")) - (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) - - (string-append fmtstr-text value-fmt) - (string-append fmtstr-html html-str) - (string-append fmtstr-xml xml-str) - (string-append fmtstr-text-labels namestr-lower " " value-fmt) - (string-append fmtstr-html-labels html-label-str) - (string-append fmtstr-xml-labels xml-label-str) - - (if (slot-value slot 'reference) - (progn - (string-append fmtstr-html-ref "<~~a>" value-fmt "") - (string-append fmtstr-xml-ref "<~~a>" value-fmt "") - (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") - (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "") - (push (make-instance 'reference :name name - :lookup (slot-value slot 'reference)) - references)) - (progn - (string-append fmtstr-html-ref html-str) - (string-append fmtstr-xml-ref xml-str) - (string-append fmtstr-html-ref-labels html-label-str) - (string-append fmtstr-xml-ref-labels xml-label-str))) - - (if print-formatter - (setq plain-value-func - (list `(,print-formatter (slot-value x ',(intern namestr package))))) - (setq plain-value-func - (list `(slot-value x ',(intern namestr package))))) - (setq value-func (append value-func plain-value-func)) - - (if (eql type :cdata) - (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) - (setq xmlvalue-func (append xmlvalue-func plain-value-func))) - ))) - - (setf (slot-value cl 'references) references) - - (if value-func - (setq value-func `(lambda (x) (values ,@value-func))) - (setq value-func `(lambda () (values)))) - (setq value-func (compile nil (eval value-func))) - - (if xmlvalue-func - (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func))) - (setq xmlvalue-func `(lambda () (values)))) - (setq xmlvalue-func (compile nil (eval xmlvalue-func))) - - (setf (slot-value cl 'fmtstr-text) fmtstr-text) - (setf (slot-value cl 'fmtstr-html) fmtstr-html) - (setf (slot-value cl 'fmtstr-xml) fmtstr-xml) - (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels) - (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels) - (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels) - (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref) - (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref) - (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels) - (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels) - (setf (slot-value cl 'value-func) value-func) - (setf (slot-value cl 'xmlvalue-func) xmlvalue-func)) - (values)) - (defun init-hyperobject-class (cl) "Initialize a hyperobject class. Calculates all class slots" (process-subobjects cl) (process-views cl) (process-documentation cl)) + +;;;; ************************************************************************* +;;;; Metaclass Slot Accessors +;;;; ************************************************************************* + +(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)) @@ -420,6 +281,7 @@ (slot-value (class-of obj) 'xmlvalue-func)) (eval-when (:compile-toplevel :load-toplevel :execute) + (defun hyperobject-class-title (obj) (awhen (slot-value (class-of obj) 'title) (if (consp it) diff --git a/package.lisp b/package.lisp index 3cccf37..c2f3f5b 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.12 2002/11/25 07:45:35 kevin Exp $ +;;;; $Id: package.lisp,v 1.13 2002/11/29 05:05:29 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -32,4 +32,41 @@ (:nicknames #:ho-user) (:use #:hyperobject #:cl #:cl-user)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (shadowing-import + #+allegro + `(mop::class-slots mop::slot-definition-name mop:finalize-inheritance + mop::standard-direct-slot-definition mop::standard-effective-slot-definition + mop:direct-slot-definition-class mop:compute-effective-slot-definition + excl::compute-effective-slot-definition-initargs) + #+lispworks + `(clos:class-slots clos::slot-definition-name clos:finalize-inheritance + clos::standard-direct-slot-definition clos::standard-effective-slot-definition + clos:direct-slot-definition-class clos:compute-effective-slot-definition + clos::compute-effective-slot-definition-initargs) + #+sbcl + `(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl::standard-class + sb-pcl::slot-definition-name sb-pcl:finalize-inheritance + sb-pcl::standard-direct-slot-definition + sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass + sb-pcl:direct-slot-definition-class sb-pcl:compute-effective-slot-definition + sb-pcl::compute-effective-slot-definition-initargs) + #+cmu + `(pcl:class-of pcl:class-name pcl:class-slots pcl::standard-class + pcl::slot-definition-name pcl:finalize-inheritance + pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition + pcl::validate-superclass pcl:direct-slot-definition-class + pcl:compute-effective-slot-definition + pcl::compute-effective-slot-definition-initargs) + #+scl + `(class-of class-name clos:class-slots clos::standard-class + clos::slot-definition-name clos:finalize-inheritance + clos::standard-direct-slot-definition clos::standard-effective-slot-definition + clos::validate-superclass clos:direct-slot-definition-class + clos:compute-effective-slot-definition + clos::compute-effective-slot-definition-initargs) + + :hyperobject)) + + diff --git a/views.lisp b/views.lisp index e9a89e3..a62baf0 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.2 2002/11/25 07:45:35 kevin Exp $ +;;;; $Id: views.lisp,v 1.3 2002/11/29 05:05:29 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -18,6 +18,134 @@ (eval-when (:compile-toplevel :execute) (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) + +;;;; ************************************************************************* +;;;; Metaclass Intialization +;;;; ************************************************************************* + +(defun process-views (cl) + "Calculate all view slots for a hyperobject class" + (let ((fmtstr-text "") + (fmtstr-html "") + (fmtstr-xml "") + (fmtstr-text-labels "") + (fmtstr-html-labels "") + (fmtstr-xml-labels "") + (fmtstr-html-ref "") + (fmtstr-xml-ref "") + (fmtstr-html-ref-labels "") + (fmtstr-xml-ref-labels "") + (first-field t) + (value-func '()) + (xmlvalue-func '()) + (classname (class-name cl)) + (package (symbol-package (class-name cl))) + (references nil)) + (declare (ignore classname)) + (check-type (slot-value cl 'print-slots) list) + (dolist (slot-name (slot-value cl 'print-slots)) + (let ((slot (find-slot-by-name cl slot-name))) + (unless slot + (error "Slot ~A is not found in class ~S" slot-name cl)) + (let ((name (slot-definition-name slot)) + (namestr (symbol-name (slot-definition-name slot))) + (namestr-lower (string-downcase (symbol-name (slot-definition-name slot)))) + (type (slot-value slot 'ho-type)) + (print-formatter (slot-value slot 'print-formatter)) + (value-fmt "~a") + (plain-value-func nil) + html-str xml-str html-label-str xml-label-str) + + (when (or (eql type :integer) (eql type :fixnum)) + (setq value-fmt "~d")) + + (when (eql type :boolean) + (setq value-fmt "~a")) + + (if first-field + (setq first-field nil) + (progn + (string-append fmtstr-text " ") + (string-append fmtstr-html " ") + (string-append fmtstr-xml " ") + (string-append fmtstr-text-labels " ") + (string-append fmtstr-html-labels " ") + (string-append fmtstr-xml-labels " ") + (string-append fmtstr-html-ref " ") + (string-append fmtstr-xml-ref " ") + (string-append fmtstr-html-ref-labels " ") + (string-append fmtstr-xml-ref-labels " "))) + + (setq html-str (concatenate 'string "" value-fmt "")) + (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "")) + (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt "")) + (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) + + (string-append fmtstr-text value-fmt) + (string-append fmtstr-html html-str) + (string-append fmtstr-xml xml-str) + (string-append fmtstr-text-labels namestr-lower " " value-fmt) + (string-append fmtstr-html-labels html-label-str) + (string-append fmtstr-xml-labels xml-label-str) + + (if (slot-value slot 'reference) + (progn + (string-append fmtstr-html-ref "<~~a>" value-fmt "") + (string-append fmtstr-xml-ref "<~~a>" value-fmt "") + (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") + (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "") + (push (make-instance 'reference :name name + :lookup (slot-value slot 'reference)) + references)) + (progn + (string-append fmtstr-html-ref html-str) + (string-append fmtstr-xml-ref xml-str) + (string-append fmtstr-html-ref-labels html-label-str) + (string-append fmtstr-xml-ref-labels xml-label-str))) + + (if print-formatter + (setq plain-value-func + (list `(,print-formatter (slot-value x ',(intern namestr package))))) + (setq plain-value-func + (list `(slot-value x ',(intern namestr package))))) + (setq value-func (append value-func plain-value-func)) + + (if (eql type :cdata) + (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) + (setq xmlvalue-func (append xmlvalue-func plain-value-func))) + ))) + + (setf (slot-value cl 'references) references) + + (if value-func + (setq value-func `(lambda (x) (values ,@value-func))) + (setq value-func `(lambda () (values)))) + (setq value-func (compile nil (eval value-func))) + + (if xmlvalue-func + (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func))) + (setq xmlvalue-func `(lambda () (values)))) + (setq xmlvalue-func (compile nil (eval xmlvalue-func))) + + (setf (slot-value cl 'fmtstr-text) fmtstr-text) + (setf (slot-value cl 'fmtstr-html) fmtstr-html) + (setf (slot-value cl 'fmtstr-xml) fmtstr-xml) + (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels) + (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels) + (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels) + (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref) + (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref) + (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels) + (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels) + (setf (slot-value cl 'value-func) value-func) + (setf (slot-value cl 'xmlvalue-func) xmlvalue-func)) + (values)) + + +;;;; ************************************************************************* +;;;; View Data Format Section +;;;; ************************************************************************* + (defparameter *default-textformat* nil) (defparameter *default-htmlformat* nil) (defparameter *default-htmlrefformat* nil) -- 2.34.1