;;;; 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.7 2002/12/06 16:18:49 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
(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
"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)
((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)))
(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
: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)))
- )
+ ia))))
(defun ho-type-to-lisp-type (ho-type)
(check-type ho-type symbol)
(:string
'string)
(:fixnum
- 'fixnum)
+ 'integer)
(:boolean
'boolean)
(:integer
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)
+(defun finalize-subobjects (cl)
"Process class subobjects slot"
(setf (slot-value cl 'subobjects)
(let ((subobjects '()))
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)))
+ (setf (slot-value cl 'title)
+ (etypecase (slot-value cl 'title)
+ (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"
(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))
;;;; *************************************************************************
(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))