;; Utilities
-(defun database-identifier (name)
+(defun database-identifier (name database)
(sql-escape (etypecase name
(string
- (string-upcase name))
+ (convert-to-db-default-case name database))
(sql-ident
- (sql-output name))
+ (sql-output name database))
(symbol
- (sql-output name)))))
+ (sql-output name database)))))
;; Tables
*DEFAULT-DATABASE*. If the table does not exist and IF-DOES-NOT-EXIST
is :ignore then DROP-TABLE returns nil whereas an error is signalled
if IF-DOES-NOT-EXIST is :error."
- (let ((table-name (database-identifier name)))
+ (let ((table-name (database-identifier name database)))
(ecase if-does-not-exist
(:ignore
(unless (table-exists-p table-name :database database)
tables are considered. If OWNER is a string, this denotes a username
and only tables owned by OWNER are considered. Table names are
returned as a list of strings."
- (when (member (database-identifier name)
+ (when (member (database-identifier name database)
(list-tables :owner owner :database database)
:test #'string-equal)
t))
*DEFAULT-DATABASE*. If the view does not exist and IF-DOES-NOT-EXIST
is :ignore then DROP-VIEW returns nil whereas an error is signalled if
IF-DOES-NOT-EXIST is :error."
- (let ((view-name (database-identifier name)))
+ (let ((view-name (database-identifier name database)))
(ecase if-does-not-exist
(:ignore
(unless (view-exists-p view-name :database database)
considered. If OWNER is a string, this denotes a username and only
views owned by OWNER are considered. View names are returned as a list
of strings."
- (when (member (database-identifier name)
+ (when (member (database-identifier name database)
(list-views :owner owner :database database)
:test #'string-equal)
t))
UNIQUE to T includes UNIQUE in the SQL index command, specifying that
the columns indexed must contain unique values. The default value of
UNIQUE is nil. The default value of DATABASE is *DEFAULT-DATABASE*."
- (let* ((index-name (database-identifier name))
- (table-name (database-identifier on))
- (attributes (mapcar #'database-identifier (listify attributes)))
+ (let* ((index-name (database-identifier name database))
+ (table-name (database-identifier on database))
+ (attributes (mapcar #'(lambda (a) (database-identifier a database)) (listify attributes)))
(stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})"
(if unique "UNIQUE" "")
index-name table-name attributes)))
is :ignore then DROP-INDEX returns nil whereas an error is signalled
if IF-DOES-NOT-EXIST is :error. The argument ON allows the optional
specification of a table to drop the index from."
- (let ((index-name (database-identifier name)))
+ (let ((index-name (database-identifier name database)))
(ecase if-does-not-exist
(:ignore
(unless (index-exists-p index-name :database database)
(return-from drop-index)))
(:error t))
- (unless (db-type-use-column-on-drop-index? (database-underlying-type database))
+ (unless (db-type-use-column-on-drop-index?
+ (database-underlying-type database))
(setq on nil))
(execute-command (format nil "DROP INDEX ~A~A" index-name
(if (null on) ""
(concatenate 'string " ON "
- (database-identifier on))))
+ (database-identifier on database))))
:database database)))
(defun list-indexes (&key (owner nil) (database *default-database*))
*default-database*. If OWNER is :all , all indexs are considered. If
OWNER is a string, this denotes a username and only indexs owned by
OWNER are considered. Index names are returned as a list of strings."
- (database-list-table-indexes (database-identifier table)
+ (database-list-table-indexes (database-identifier table database)
database :owner owner))
(defun index-exists-p (name &key (owner nil) (database *default-database*))
considered. If OWNER is a string, this denotes a username and only
indexs owned by OWNER are considered. Index names are returned as a
list of strings."
- (when (member (database-identifier name)
+ (when (member (database-identifier name database)
(list-indexes :owner owner :database database)
:test #'string-equal)
t))
;; Attributes
+(defvar *cache-table-queries-default* "Default atribute type caching behavior.")
+
+(defun cache-table-queries (table &key (action nil) (database *default-database*))
+ "Provides per-table control on the caching in a particular database
+connection of attribute type information using during update
+operations. If TABLE is a string, it is the name of the table for
+which caching is to be altered. If TABLE is t, then the action applies
+to all tables. If TABLE is :default, then the default caching action
+is set for those tables which do not have an explicit setting. ACTION
+specifies the caching action. The value t means cache the attribute
+type information. The value nil means do not cache the attribute type
+information. If TABLE is :default, the setting applies to all tables
+which do not have an explicit setup. The value :flush means remove any
+existing cache for table in database, but continue to cache. This
+function should be called with action :flush when the attribute
+specifications in table have changed."
+ (with-slots (attribute-cache) database
+ (cond
+ ((stringp table)
+ (multiple-value-bind (val found) (gethash table attribute-cache)
+ (cond
+ ((and found (eq action :flush))
+ (setf (gethash table attribute-cache) (list t nil)))
+ ((and found (eq action t))
+ (setf (gethash table attribute-cache) (list t (second val))))
+ ((and found (null action))
+ (setf (gethash table attribute-cache) (list nil nil)))
+ ((not found)
+ (setf (gethash table attribute-cache) (list action nil))))))
+ ((eq table t)
+ (maphash (lambda (k v)
+ (cond
+ ((eq action :flush)
+ (setf (gethash k attribute-cache) (list t nil)))
+ ((null action)
+ (setf (gethash k attribute-cache) (list nil nil)))
+ ((eq t action)
+ (setf (gethash k attribute-cache) (list t (second v))))))
+ attribute-cache))
+ ((eq table :default)
+ (maphash (lambda (k v)
+ (when (eq (first v) :unspecified)
+ (cond
+ ((eq action :flush)
+ (setf (gethash k attribute-cache) (list t nil)))
+ ((null action)
+ (setf (gethash k attribute-cache) (list nil nil)))
+ ((eq t action)
+ (setf (gethash k attribute-cache) (list t (second v)))))))
+ attribute-cache))))
+ (values))
+
+
(defun list-attributes (name &key (owner nil) (database *default-database*))
"List the attributes of a attribute called NAME in DATABASE which
defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned
username and only attributes owned by OWNER are considered. Attribute
names are returned as a list of strings. Attributes are returned as a
list of strings."
- (database-list-attributes (database-identifier name) database :owner owner))
+ (database-list-attributes (database-identifier name database) database :owner owner))
(defun attribute-type (attribute table &key (owner nil)
(database *default-database*))
considered. If OWNER is a string, this denotes a username and only
attributes owned by OWNER are considered. Attribute names are returned
as a list of strings. Attributes are returned as a list of strings."
- (database-attribute-type (database-identifier attribute)
- (database-identifier table)
+ (database-attribute-type (database-identifier attribute database)
+ (database-identifier table database)
database
:owner owner))
considered. Returns a list in which each element is a list (attribute
datatype). Attribute is a string denoting the atribute name. Datatype
is the vendor-specific type returned by ATTRIBUTE-TYPE."
- (mapcar #'(lambda (type)
- (list type (attribute-type type table :database database
- :owner owner)))
- (list-attributes table :database database :owner owner)))
-
-;(defun add-attribute (table attribute &key (database *default-database*))
-; (database-add-attribute table attribute database))
-
-;(defun rename-attribute (table oldatt newname
-; &key (database *default-database*))
-; (error "(rename-attribute ~a ~a ~a ~a) is not implemented"
-; table oldatt newname database))
-
+ (with-slots (attribute-cache) database
+ (let ((table-ident (database-identifier table database)))
+ (multiple-value-bind (val found) (gethash table-ident attribute-cache)
+ (if (and found (second val))
+ (second val)
+ (let ((types (mapcar #'(lambda (attribute)
+ (cons attribute
+ (multiple-value-list
+ (database-attribute-type
+ (database-identifier attribute database)
+ table-ident
+ database
+ :owner owner))))
+ (list-attributes table :database database :owner owner))))
+ (cond
+ ((and (not found) (eq t *cache-table-queries-default*))
+ (setf (gethash table-ident attribute-cache) (list :unspecified types)))
+ ((and found (eq t (first val))
+ (setf (gethash table-ident attribute-cache) (list t types)))))
+ types))))))
+
;; Sequences
(defun create-sequence (name &key (database *default-database*))
"Create a sequence called NAME in DATABASE which defaults to
*DEFAULT-DATABASE*."
- (let ((sequence-name (database-identifier name)))
+ (let ((sequence-name (database-identifier name database)))
(database-create-sequence sequence-name database))
(values))
*DEFAULT-DATABASE*. If the sequence does not exist and
IF-DOES-NOT-EXIST is :ignore then DROP-SEQUENCE returns nil whereas an
error is signalled if IF-DOES-NOT-EXIST is :error."
- (let ((sequence-name (database-identifier name)))
+ (let ((sequence-name (database-identifier name database)))
(ecase if-does-not-exist
(:ignore
(unless (sequence-exists-p sequence-name :database database)
(database *default-database*))
"Test for existence of a sequence called NAME in DATABASE which
defaults to *DEFAULT-DATABASE*."
- (when (member (database-identifier name)
+ (when (member (database-identifier name database)
(list-sequences :owner owner :database database)
:test #'string-equal)
t))
(defun sequence-next (name &key (database *default-database*))
"Return the next value in the sequence NAME in DATABASE."
- (database-sequence-next (database-identifier name) database))
+ (database-sequence-next (database-identifier name database) database))
(defun set-sequence-position (name position &key (database *default-database*))
"Explicitly set the the position of the sequence NAME in DATABASE to
POSITION."
- (database-set-sequence-position (database-identifier name) position database))
+ (database-set-sequence-position (database-identifier name database) position database))
(defun sequence-last (name &key (database *default-database*))
"Return the last value of the sequence NAME in DATABASE."
- (database-sequence-last (database-identifier name) database))
+ (database-sequence-last (database-identifier name database) database))
+
+;;; Remote Joins
+
+(defvar *default-update-objects-max-len* nil
+ "The default maximum number of objects supplying data for a query when updating remote joins.")
+
projects / clsql.git / blobdiff