:accessor view-class-qualifier
:initarg :qualifier
:initform nil))
- (:documentation "VIEW-CLASS metaclass."))
+ (:documentation "Metaclass for all CLSQL View Classes."))
;;; Lispworks 4.2 and before requires special processing of extra slot and class options
(nth (1+ pos) list)))))
(mapcar #'extract keys)))
+(defvar *impl-type-attrib-name* #-clisp 'type #+clisp 'clos::$type)
+
(defun describe-db-layout (class)
(flet ((not-db-col (col)
(not (member (nth 2 col) '(nil :base :key))))
(frob-slot (slot)
- (let ((type (slot-value slot 'type)))
+ (let ((type (slot-value slot *impl-type-attrib-name*)))
(if (eq type t)
(setq type nil))
(list (slot-value slot 'name)
:initarg :db-constraints
:initform nil
:documentation
- "A single constraint or list of constraints for this column")
+ "A keyword symbol representing a single SQL column constraint or list of such symbols.")
(void-value
:accessor view-class-slot-void-value
:initarg :void-value
:initform nil
:documentation
- "Value to store is the SQL value is NULL. Default is NIL.")
+ "Value to store if the SQL value is NULL. Default is NIL.")
(db-info
:accessor view-class-slot-db-info
:initarg :db-info
((and (symbolp (car specified-type))
(string-equal (symbol-name (car specified-type)) "string"))
'string)
+ ((and (symbolp (car specified-type))
+ (string-equal (symbol-name (car specified-type)) "varchar"))
+ 'string)
+ ((and (symbolp (car specified-type))
+ (string-equal (symbol-name (car specified-type)) "char"))
+ 'string)
(t
specified-type)))
((eq (ensure-keyword specified-type) :bigint)
'integer)
+ ((eq (ensure-keyword specified-type) :char)
+ 'character)
+ ((eq (ensure-keyword specified-type) :varchar)
+ 'string)
((and specified-type
(not (eql :not-null (slot-value slotd 'db-constraints))))
`(or null ,specified-type))
(car list)
list))
-(declaim (inline delistify))
+(declaim (inline delistify-dsd))
(defun delistify-dsd (list)
"Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
(if (and (listp list) (null (cdr list)))
(null (specified-type dsd)))
(setf (specified-type dsd)
(slot-definition-type dsd))
- (setf (slot-value dsd 'type)
+ (setf (slot-value dsd *impl-type-attrib-name*)
(compute-lisp-type-from-slot-specification
dsd (slot-definition-type dsd))))