projects
/
hyperobject.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
r3576: *** empty log message ***
[hyperobject.git]
/
mop.lisp
diff --git
a/mop.lisp
b/mop.lisp
index 1e83ae30e4ab47f2642dd275859fa4ae2bf14a73..45e704aee09c17929079473bf4d0d99c7e7e2a62 100644
(file)
--- a/
mop.lisp
+++ b/
mop.lisp
@@
-11,7
+11,7
@@
;;;; in Text, HTML, and XML formats. This includes hyperlinking
;;;; capability and sub-objects.
;;;;
;;;; in Text, HTML, and XML formats. This includes hyperlinking
;;;; capability and sub-objects.
;;;;
-;;;; $Id: mop.lisp,v 1.
3 2002/11/29 23:14:31
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
;;;;
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
@@
-20,7
+20,7
@@
(in-package :hyperobject)
(eval-when (:compile-toplevel :execute)
(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
;; Main class
@@
-34,6
+34,7
@@
:documentation "Class description")
(version :initarg :version :initform nil
:documentation "Version number for class")
:documentation "Class description")
(version :initarg :version :initform nil
:documentation "Version number for class")
+ (sql-name :initarg :table-name :initform nil :reader sql-name)
;;; The remainder of these fields are calculated one time
;;; in finalize-inheritence.
;;; The remainder of these fields are calculated one time
;;; in finalize-inheritence.
@@
-45,6
+46,10
@@
(class-id :type integer :initform nil :documentation
"Unique ID for the class")
(class-id :type integer :initform nil :documentation
"Unique ID for the class")
+ (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)
(value-func :initform nil :type function)
(xmlvalue-func :initform nil :type function)
(fmtstr-text :initform nil :type string)
@@
-150,10
+155,11
@@
((cl hyperobject-class) #+(or allegro lispworks) name dsds)
#+allergo (declare (ignore name))
(let* ((dsd (car dsds))
((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 '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 '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
(let ((ia (compute-effective-slot-definition-initargs
cl #+lispworks name dsds)))
(apply
@@
-163,9
+169,9
@@
:print-formatter (slot-value dsd 'print-formatter)
:subobject (slot-value dsd 'subobject)
:hyperlink (slot-value dsd 'hyperlink)
: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)
:description (slot-value dsd 'description)
- ia)))
- )
+ ia))))
(defun ho-type-to-lisp-type (ho-type)
(check-type ho-type symbol)
(defun ho-type-to-lisp-type (ho-type)
(check-type ho-type symbol)
@@
-193,7
+199,7
@@
(:string
'string)
(:fixnum
(:string
'string)
(:fixnum
- '
fixnum
)
+ '
integer
)
(:boolean
'boolean)
(:integer
(:boolean
'boolean)
(:integer
@@
-207,9
+213,10
@@
(otherwise
ho-type)))
(otherwise
ho-type)))
+
;;;; Class initialization function
;;;; Class initialization function
-(defun
process
-subobjects (cl)
+(defun
finalize
-subobjects (cl)
"Process class subobjects slot"
(setf (slot-value cl 'subobjects)
(let ((subobjects '()))
"Process class subobjects slot"
(setf (slot-value cl 'subobjects)
(let ((subobjects '()))
@@
-222,13
+229,19
@@
subobjects)))
subobjects)))
subobjects)))
subobjects)))
-(defun
process
-documentation (cl)
+(defun
finalize
-documentation (cl)
"Calculate class documentation slot"
(awhen (slot-value cl 'title)
"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)
(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"
(let ((*print-circle* nil))
(setf (documentation (class-name cl) 'class)
(format nil "Hyperobject~A~A~A~A"
@@
-244,9
+257,11
@@
(defun init-hyperobject-class (cl)
"Initialize a hyperobject class. Calculates all class slots"
(defun init-hyperobject-class (cl)
"Initialize a hyperobject class. Calculates all class slots"
- (process-subobjects cl)
- (process-views cl)
- (process-documentation cl))
+ (finalize-subobjects cl)
+ (finalize-views cl)
+ (finalize-hyperlinks cl)
+ (finalize-sql cl)
+ (finalize-documentation cl))
;;;; *************************************************************************
;;;; *************************************************************************
@@
-297,6
+312,9
@@
(defun hyperobject-class-fields (obj)
(class-slots (class-of obj)))
(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-html-ref (obj)
(slot-value (class-of obj) 'fmtstr-html-ref))