;;;; 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.9 2002/12/09 19:37:54 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
: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)
(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
'single-float)
(:double-float
'double-float)
- (:nil
+ (nil
t)
(otherwise
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))
+ (case ho-type
((or :string :cdata)
'string)
(:fixnum
'single-float)
(:double-float
'double-float)
- (:nil
+ (nil
t)
(otherwise
ho-type)))
(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))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: package.lisp,v 1.17 2002/12/09 10:36:15 kevin Exp $
+;;;; $Id: package.lisp,v 1.18 2002/12/09 19:37:54 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;; *************************************************************************
#:package
#:hyperobject
#:hyperobject-class
- #:hyperobject-class-title
+ #:hyperobject-class-user-name
#:load-all-subobjects
#:view
#:fmt-comma-integer