+++ /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)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (when (>= (length (generic-function-lambda-list
- (ensure-generic-function
- 'compute-effective-slot-definition)))
- 3)
- (pushnew :kmr-normal-cesd cl:*features*))
-
- (when (>= (length (generic-function-lambda-list
- (ensure-generic-function
- 'direct-slot-definition-class)))
- 3)
- (pushnew :kmr-normal-dsdc cl:*features*))
-
- (when (>= (length (generic-function-lambda-list
- (ensure-generic-function
- 'effective-slot-definition-class)))
- 3)
- (pushnew :kmr-normal-esdc cl:*features*)))
-
-
-;; ------------------------------------------------------------
-;; 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-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))
- #-(or allegro openmcl)
- (setf (key-slots class) (remove-if-not (lambda (slot)
- (eql (slot-value slot 'db-kind)
- :key))
- (class-slots class)))))
-
-#+(or allegro openmcl)
-(defmethod finalize-inheritance :after ((class standard-db-class))
- (setf (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)
- #+kmr-normal-dsdc &rest
- initargs)
- (declare (ignore initargs))
- (find-class 'view-class-direct-slot-definition))
-
-(defmethod effective-slot-definition-class ((class standard-db-class)
- #+kmr-normal-esdc &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)
- #+kmr-normal-cesd slot-name
- direct-slots)
- #+kmr-normal-cesd (declare (ignore 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
- #+allegro :name
- #+allegro (slot-definition-name sd))
- (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)))
-
-#+ignore
-(eval-when (:compile-toplevel :load-toplevel :execute)
- #+kmr-normal-cesd
- (setq cl:*features* (delete :kmr-normal-cesd cl:*features*))
- #+kmr-normal-dsdc
- (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*))
- #+kmr-normal-esdc
- (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
- )
projects / clsql.git / blobdiff