--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: metaclasses.lisp
+;;;; Updated: <04/04/2004 12:08:11 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; CLSQL-USQL metaclass for standard-db-objects created in the OODDL.
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-sys)
+
+
+;; ------------------------------------------------------------
+;; metaclass: view-class
+
+(defclass standard-db-class (standard-class)
+ ((view-table
+ :accessor view-table
+ :initarg :view-table)
+ (definition
+ :accessor object-definition
+ :initarg :definition
+ :initform nil)
+ (version
+ :accessor object-version
+ :initarg :version
+ :initform 0)
+ (key-slots
+ :accessor key-slots
+ :initform nil)
+ (class-qualifier
+ :accessor view-class-qualifier
+ :initarg :qualifier
+ :initform nil))
+ (:documentation "VIEW-CLASS metaclass."))
+
+#+lispworks
+(defmacro push-on-end (value location)
+ `(setf ,location (nconc ,location (list ,value))))
+
+;; As Heiko Kirscke (author of PLOB!) would say: !@##^@%! Lispworks!
+#+lispworks
+(defconstant +extra-slot-options+ '(:column :db-kind :db-reader :nulls-ok
+ :db-writer :db-type :db-info))
+
+#+lispworks
+(define-setf-expander assoc (key alist &environment env)
+ (multiple-value-bind (temps vals stores store-form access-form)
+ (get-setf-expansion alist env)
+ (let ((new-value (gensym "NEW-VALUE-"))
+ (keyed (gensym "KEYED-"))
+ (accessed (gensym "ACCESSED-"))
+ (store-new-value (car stores)))
+ (values (cons keyed temps)
+ (cons key vals)
+ `(,new-value)
+ `(let* ((,accessed ,access-form)
+ (,store-new-value (assoc ,keyed ,accessed)))
+ (if ,store-new-value
+ (rplacd ,store-new-value ,new-value)
+ (progn
+ (setq ,store-new-value
+ (acons ,keyed ,new-value ,accessed))
+ ,store-form))
+ ,new-value)
+ `(assoc ,new-value ,access-form)))))
+
+#+lispworks
+(defmethod clos::canonicalize-defclass-slot :around
+ ((prototype standard-db-class) slot)
+ "\\lw\\ signals an error on unknown slot options; so this method
+removes any extra allowed options before calling the default method
+and returns the canonicalized extra options concatenated to the result
+of the default method. The extra allowed options are the value of the
+\\fcite{+extra-slot-options+}."
+ (let ((extra-slot-options ())
+ (rest-options ())
+ (result ()))
+ (do ((olist (cdr slot) (cddr olist)))
+ ((null olist))
+ (let ((option (car olist)))
+ (cond
+ ((find option +extra-slot-options+)
+ ;;(push (cons option (cadr olist)) extra-slot-options))
+ (setf (assoc option extra-slot-options) (cadr olist)))
+ (t
+ (push (cadr olist) rest-options)
+ (push (car olist) rest-options)))))
+ (setf result (call-next-method prototype (cons (car slot) rest-options)))
+ (dolist (option extra-slot-options)
+ (push-on-end (car option) result)
+ (push-on-end `(quote ,(cdr option)) result))
+ result))
+
+#+lispworks
+(defconstant +extra-class-options+ '(:base-table :version :schemas))
+
+#+lispworks
+(defmethod clos::canonicalize-class-options :around
+ ((prototype standard-db-class) class-options)
+ "\\lw\\ signals an error on unknown class options; so this method
+removes any extra allowed options before calling the default method
+and returns the canonicalized extra options concatenated to the result
+of the default method. The extra allowed options are the value of the
+\\fcite{+extra-class-options+}."
+ (let ((extra-class-options nil)
+ (rest-options ())
+ (result ()))
+ (dolist (o class-options)
+ (let ((option (car o)))
+ (cond
+ ((find option +extra-class-options+)
+ ;;(push (cons option (cadr o)) extra-class-options))
+ (setf (assoc option extra-class-options) (cadr o)))
+ (t
+ (push o rest-options)))))
+ (setf result (call-next-method prototype rest-options))
+ (dolist (option extra-class-options)
+ (push-on-end (car option) result)
+ (push-on-end `(quote ,(cdr option)) result))
+ result))
+
+
+(defmethod validate-superclass ((class standard-class)
+ (superclass standard-db-class))
+ t)
+
+(defmethod validate-superclass ((class standard-db-class)
+ (superclass standard-class))
+ t)
+
+
+(defun table-name-from-arg (arg)
+ (cond ((symbolp arg)
+ arg)
+ ((typep arg 'sql-ident)
+ (slot-value arg 'name))
+ ((stringp arg)
+ (intern (string-upcase arg)))))
+
+(defun column-name-from-arg (arg)
+ (cond ((symbolp arg)
+ arg)
+ ((typep arg 'sql-ident)
+ (slot-value arg 'name))
+ ((stringp arg)
+ (intern (string-upcase arg)))))
+
+
+(defun remove-keyword-arg (arglist akey)
+ (let ((mylist arglist)
+ (newlist ()))
+ (labels ((pop-arg (alist)
+ (let ((arg (pop alist))
+ (val (pop alist)))
+ (unless (equal arg akey)
+ (setf newlist (append (list arg val) newlist)))
+ (when alist (pop-arg alist)))))
+ (pop-arg mylist))
+ newlist))
+
+(defmethod initialize-instance :around ((class standard-db-class)
+ &rest all-keys
+ &key direct-superclasses base-table
+ schemas version qualifier
+ &allow-other-keys)
+ (let ((root-class (find-class 'standard-db-object nil))
+ (vmc (find-class 'standard-db-class)))
+ (setf (view-class-qualifier class)
+ (car qualifier))
+ (if root-class
+ (if (member-if #'(lambda (super)
+ (eq (class-of super) vmc)) direct-superclasses)
+ (call-next-method)
+ (apply #'call-next-method
+ class
+ :direct-superclasses (append (list root-class)
+ direct-superclasses)
+ (remove-keyword-arg all-keys :direct-superclasses)))
+ (call-next-method))
+ (setf (view-table class)
+ (table-name-from-arg (sql-escape (or (and base-table
+ (if (listp base-table)
+ (car base-table)
+ base-table))
+ (class-name class)))))
+ (setf (object-version class) version)
+ (mapc (lambda (schema)
+ (pushnew (class-name class) (gethash schema *object-schemas*)))
+ (if (listp schemas) schemas (list schemas)))
+ (register-metaclass class (nth (1+ (position :direct-slots all-keys))
+ all-keys))))
+
+(defmethod reinitialize-instance :around ((class standard-db-class)
+ &rest all-keys
+ &key base-table schemas version
+ direct-superclasses qualifier
+ &allow-other-keys)
+ (let ((root-class (find-class 'standard-db-object nil))
+ (vmc (find-class 'standard-db-class)))
+ (setf (view-table class)
+ (table-name-from-arg (sql-escape (or (and base-table
+ (if (listp base-table)
+ (car base-table)
+ base-table))
+ (class-name class)))))
+ (setf (view-class-qualifier class)
+ (car qualifier))
+ (if (and root-class (not (equal class root-class)))
+ (if (member-if #'(lambda (super)
+ (eq (class-of super) vmc)) direct-superclasses)
+ (call-next-method)
+ (apply #'call-next-method
+ class
+ :direct-superclasses (append (list root-class)
+ direct-superclasses)
+ (remove-keyword-arg all-keys :direct-superclasses)))
+ (call-next-method)))
+ (setf (object-version class) version)
+ (mapc (lambda (schema)
+ (pushnew (class-name class) (gethash schema *object-schemas*)))
+ (if (listp schemas) schemas (list schemas)))
+ (register-metaclass class (nth (1+ (position :direct-slots all-keys))
+ all-keys)))
+
+
+(defun get-keywords (keys list)
+ (flet ((extract (key)
+ (let ((pos (position key list)))
+ (when pos
+ (nth (1+ pos) list)))))
+ (mapcar #'extract keys)))
+
+(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)))
+ (if (eq type t)
+ (setq type nil))
+ (list (slot-value slot 'name)
+ type
+ (slot-value slot 'db-kind)
+ (and (slot-boundp slot 'column)
+ (slot-value slot 'column))))))
+ (let ((all-slots (mapcar #'frob-slot (class-slots class))))
+ (setq all-slots (remove-if #'not-db-col all-slots))
+ (setq all-slots (stable-sort all-slots #'string< :key #'car))
+ ;;(mapcar #'dink-type all-slots)
+ all-slots)))
+
+(defun register-metaclass (class slots)
+ (labels ((not-db-col (col)
+ (not (member (nth 2 col) '(nil :base :key))))
+ (frob-slot (slot)
+ (get-keywords '(:name :type :db-kind :column) slot)))
+ (let ((all-slots (mapcar #'frob-slot slots)))
+ (setq all-slots (remove-if #'not-db-col all-slots))
+ (setq all-slots (stable-sort all-slots #'string< :key #'car))
+ (setf (object-definition class) all-slots
+ (key-slots class) (remove-if-not (lambda (slot)
+ (eql (slot-value slot 'db-kind)
+ :key))
+ (class-slots class))))))
+
+;; return the deepest view-class ancestor for a given view class
+
+(defun base-db-class (classname)
+ (let* ((class (find-class classname))
+ (db-class (find-class 'standard-db-object)))
+ (loop
+ (let ((cds (class-direct-superclasses class)))
+ (cond ((null cds)
+ (error "not a db class"))
+ ((member db-class cds)
+ (return (class-name class))))
+ (setq class (car cds))))))
+
+(defun db-ancestors (classname)
+ (let ((class (find-class classname))
+ (db-class (find-class 'standard-db-object)))
+ (labels ((ancestors (class)
+ (let ((scs (class-direct-superclasses class)))
+ (if (member db-class scs)
+ (list class)
+ (append (list class) (mapcar #'ancestors scs))))))
+ (ancestors class))))
+
+(defclass view-class-slot-definition-mixin ()
+ ((column
+ :accessor view-class-slot-column
+ :initarg :column
+ :documentation
+ "The name of the SQL column this slot is stored in. Defaults to
+the slot name.")
+ (db-kind
+ :accessor view-class-slot-db-kind
+ :initarg :db-kind
+ :initform :base
+ :type keyword
+ :documentation
+ "The kind of DB mapping which is performed for this slot. :base
+indicates the slot maps to an ordinary column of the DB view. :key
+indicates that this slot corresponds to part of the unique keys for
+this view, :join indicates ... and :virtual indicates that this slot
+is an ordinary CLOS slot. Defaults to :base.")
+ (db-reader
+ :accessor view-class-slot-db-reader
+ :initarg :db-reader
+ :initform nil
+ :documentation
+ "If a string, then when reading values from the DB, the string
+will be used for a format string, with the only value being the value
+from the database. The resulting string will be used as the slot
+value. If a function then it will take one argument, the value from
+the database, and return the value that should be put into the slot.")
+ (db-writer
+ :accessor view-class-slot-db-writer
+ :initarg :db-writer
+ :initform nil
+ :documentation
+ "If a string, then when reading values from the slot for the DB,
+the string will be used for a format string, with the only value being
+the value of the slot. The resulting string will be used as the
+column value in the DB. If a function then it will take one argument,
+the value of the slot, and return the value that should be put into
+the database.")
+ (db-type
+ :accessor view-class-slot-db-type
+ :initarg :db-type
+ :initform nil
+ :documentation
+ "A string which will be used as the type specifier for this slots
+column definition in the database.")
+ (db-constraints
+ :accessor view-class-slot-db-constraints
+ :initarg :db-constraints
+ :initform nil
+ :documentation
+ "A single constraint or list of constraints for this column")
+ (nulls-ok
+ :accessor view-class-slot-nulls-ok
+ :initarg :nulls-ok
+ :initform nil
+ :documentation
+ "If t, all sql NULL values retrieved from the database become nil; if nil,
+all NULL values retrieved are converted by DATABASE-NULL-VALUE")
+ (db-info
+ :accessor view-class-slot-db-info
+ :initarg :db-info
+ :documentation "Description of the join.")))
+
+(defparameter *db-info-lambda-list*
+ '(&key join-class
+ home-key
+ foreign-key
+ (key-join nil)
+ (target-slot nil)
+ (retrieval :immmediate)
+ (set nil)))
+
+(defun parse-db-info (db-info-list)
+ (destructuring-bind
+ (&key join-class home-key key-join foreign-key (delete-rule nil)
+ (target-slot nil) (retrieval :deferred) (set nil))
+ db-info-list
+ (let ((ih (make-hash-table :size 6)))
+ (if join-class
+ (setf (gethash :join-class ih) join-class)
+ (error "Must specify :join-class in :db-info"))
+ (if home-key
+ (setf (gethash :home-key ih) home-key)
+ (error "Must specify :home-key in :db-info"))
+ (when delete-rule
+ (setf (gethash :delete-rule ih) delete-rule))
+ (if foreign-key
+ (setf (gethash :foreign-key ih) foreign-key)
+ (error "Must specify :foreign-key in :db-info"))
+ (when key-join
+ (setf (gethash :key-join ih) t))
+ (when target-slot
+ (setf (gethash :target-slot ih) target-slot))
+ (when set
+ (setf (gethash :set ih) set))
+ (when retrieval
+ (progn
+ (setf (gethash :retrieval ih) retrieval)
+ (if (eql retrieval :immediate)
+ (setf (gethash :set ih) nil))))
+ ih)))
+
+(defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
+ standard-direct-slot-definition)
+ ())
+
+(defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
+ standard-effective-slot-definition)
+ ())
+
+(defmethod direct-slot-definition-class ((class standard-db-class)
+ #-cmu &rest
+ initargs)
+ (declare (ignore initargs))
+ (find-class 'view-class-direct-slot-definition))
+
+(defmethod effective-slot-definition-class ((class standard-db-class)
+ #-cmu &rest
+ initargs)
+ (declare (ignore initargs))
+ (find-class 'view-class-effective-slot-definition))
+
+;; Compute the slot definition for slots in a view-class. Figures out
+;; what kind of database value (if any) is stored there, generates and
+;; verifies the column name.
+
+(defmethod compute-effective-slot-definition ((class standard-db-class)
+ #-cmu slot-name
+ direct-slots)
+ ;(declare (ignore #-cmu slot-name direct-slots))
+ (declare (ignore #-cmu slot-name))
+ (let ((slotd (call-next-method))
+ (sd (car direct-slots)))
+
+ (typecase sd
+ (view-class-slot-definition-mixin
+ ;; Use the specified :column argument if it is supplied, otherwise
+ ;; the column slot is filled in with the slot-name, but transformed
+ ;; to be sql safe, - to _ and such.
+ (setf (slot-value slotd 'column)
+ (column-name-from-arg
+ (if (slot-boundp sd 'column)
+ (view-class-slot-column sd)
+ (column-name-from-arg
+ (sql-escape (slot-definition-name sd))))))
+
+ (setf (slot-value slotd 'db-type)
+ (when (slot-boundp sd 'db-type)
+ (view-class-slot-db-type sd)))
+
+
+ (setf (slot-value slotd 'nulls-ok)
+ (view-class-slot-nulls-ok sd))
+
+ ;; :db-kind slot value defaults to :base (store slot value in
+ ;; database)
+
+ (setf (slot-value slotd 'db-kind)
+ (if (slot-boundp sd 'db-kind)
+ (view-class-slot-db-kind sd)
+ :base))
+
+ (setf (slot-value slotd 'db-writer)
+ (when (slot-boundp sd 'db-writer)
+ (view-class-slot-db-writer sd)))
+ (setf (slot-value slotd 'db-constraints)
+ (when (slot-boundp sd 'db-constraints)
+ (view-class-slot-db-constraints sd)))
+
+
+ ;; I wonder if this slot option and the previous could be merged,
+ ;; so that :base and :key remain keyword options, but :db-kind
+ ;; :join becomes :db-kind (:join <db info .... >)?
+
+ (setf (slot-value slotd 'db-info)
+ (when (slot-boundp sd 'db-info)
+ (if (listp (view-class-slot-db-info sd))
+ (parse-db-info (view-class-slot-db-info sd))
+ (view-class-slot-db-info sd)))))
+ ;; all other slots
+ (t
+ (change-class slotd 'view-class-effective-slot-definition)
+ (setf (slot-value slotd 'column)
+ (column-name-from-arg
+ (sql-escape (slot-definition-name sd))))
+
+ (setf (slot-value slotd 'db-info) nil)
+ (setf (slot-value slotd 'db-kind)
+ :virtual)))
+ slotd))
+
+(defun slotdefs-for-slots-with-class (slots class)
+ (let ((result nil))
+ (dolist (s slots)
+ (let ((c (slotdef-for-slot-with-class s class)))
+ (if c (setf result (cons c result)))))
+ result))
+
+(defun slotdef-for-slot-with-class (slot class)
+ (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
+ (class-slots class)))
+
projects / clsql.git / blobdiff