30 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
- * Version 2.9.7-pre1
+ * Version 2.10.0: New API function: CACHE-TABLE-QUERIES.
* base/basic-sql.lisp, db-*/*-sql.lisp: More CommonSQL conformance.
Return field names as second value for QUERY. This can be overridden
- for efficiency sake with the new keyword :FIELD-NAMES set to NIL
+ for efficiency with the new keyword :FIELD-NAMES set to NIL
in the QUERY invocation.
+ * test/test-fdml.lisp: Add tests for new field-name feature
* sql/metaclass.lisp: Remove old Lispworks cruft
and replace it with invocation of new code in kmr-mop.lisp
which actually works with Lispworks 4.2
+ * doc/ref_clsql.xml: Document new :FIELD-NAMES keyword to
+ QUERY function
+ * base/db-interface.lisp: Document the multiple values
+ returned by DATABASE-ATTRIBUTE-TYPE so matches the
+ undocumented CommonSQL behavior.
+ * sql/table.lisp: Add *CACHE-TABLE-QUERIES-DEFAULT* and
+ *DEFAULT-UPDATE-OBJECTS-MAX-LEN* variables and export them.
+ LIST-ATTRIBUTE-TYPES now conforms to CommonSQL spec.
+ Implement CACHE-TABLE-QUERIES.
+ * db-odbc/odbc-sql.lisp: Fix attribute-type function
+ * test/test-fddl.lisp: Add tests for attribute type
+ * db-mysql/mysql-sql.lisp: Mild optimization in accessing
+ field structures.
+ * base/classes.lisp: Add attribute-cache slot to database clas
+ * base/initialize.lisp: initialize-database-type now automatically
+ loads database-type backend as needed.
+ * base/test-init.lisp: Utilize new initialize-database-type functionality.
+ * TODO: remove items done
30 Apr 2004 Marcus Pearce (m.t.pearce@city.ac.uk)
* Version 2.9.6
GENERAL
-* implement remaining functions for CLSQL AODBC backend;
* port Oracle backend to UFFI.
COMMONSQL SPEC
* Missing:
- CACHE-TABLE-QUERIES
- *CACHE-TABLE-QUERIES-DEFAULT*
- *DEFAULT-UPDATE-OBJECTS-MAX-LEN*
UPDATE-OBJECT-JOINS
-
* Incompatible
>> Initialisation and connection
- INITIALIZE-DATABASE-TYPE
- o should initialise appropriate backend
-
STATUS
o what is the behaviour in CommonSQL (esp :full parameter)?
QUERY
o should coerce values returned as strings to appropriate lisp type
-
- LIST-ATTRIBUTE-TYPES
- o should return list of (attribute datatype precision scale nullable)
-
+ (except for SQLite interface, this works when :result-types is :auto).
+ Perhaps that should be the default?
>> The object-oriented sql interface
(mapcar #'car rows)
rows)))
(record-sql-action result :result database)
- (values result names))))
+ (if field-names
+ (values result names)
+ result))))
;;; Execute
(schema :accessor database-schema :initform nil)
(transaction-level :initform 0 :accessor transaction-level)
(transaction :initform nil :accessor transaction)
- (conn-pool :initform nil :initarg :conn-pool :accessor conn-pool))
+ (conn-pool :initform nil :initarg :conn-pool :accessor conn-pool)
+ (attribute-cache :initform (make-hash-table :size 100 :test 'equal)
+ :accessor attribute-cache
+ :documentation "Internal cache of table attributes. It is keyed by table-name. Values
+are a list of ACTION specified for table and any cached value of list-attributes-types."))
(:documentation
"This class is the supertype of all databases handled by CLSQL."))
pool is t the connection will be taken from the general pool, if pool
is a conn-pool object the connection will be taken from this pool."
+ (unless database-type
+ (error "Must specify a database-type."))
+
(when (stringp connection-spec)
(setq connection-spec (string-to-list-connection-spec connection-spec)))
(:documentation "List all attributes in TABLE."))
(defgeneric database-attribute-type (attribute table database &key owner)
- (:documentation "Return the type of ATTRIBUTE in TABLE."))
+ (:documentation "Return the type of ATTRIBUTE in TABLE. Returns multiple values
+of TYPE_NAME (keyword) PRECISION SCALE NULLABLE."))
(defgeneric database-add-attribute (table attribute database)
(:documentation "Add the attribute to the table."))
(defmethod database-query :before (query-expression (database database)
result-set field-names)
- (declare (ignore query-expression result-set))
+ (declare (ignore query-expression result-set field-names))
(unless (is-database-open database)
(signal-closed-database-error database)))
(defun initialize-database-type (&key (database-type *default-database-type*))
"Initialize the given database-type, if it is not already
initialized, as indicated by `*initialized-database-types*'."
- (if (member database-type *initialized-database-types*)
- database-type
- (when (database-initialize-database-type database-type)
- (push database-type *initialized-database-types*)
- database-type)))
-
+ (when (member database-type *initialized-database-types*)
+ (return-from initialize-database-type database-type))
+
+ (let ((system (intern (concatenate 'string
+ (symbol-name '#:clsql-)
+ (symbol-name database-type)))))
+ (when (not (find-package system))
+ (asdf:operate 'asdf:load-op system)))
+
+ (when (database-initialize-database-type database-type)
+ (push database-type *initialized-database-types*)
+ database-type))
#:database-list-table-indexes
#:database-list-views
-
;; Large objects (Marc B)
#:database-create-large-object
#:database-write-large-object
#:command-output
#:symbol-name-default-case
#:convert-to-db-default-case
+ #:ensure-keyword
;; Shared exports for re-export by CLSQL-BASE
.
#:view-classes
#:database-type
#:database-state
-
+ #:attribute-cache
+
;; utils.lisp
#:number-to-sql-string
#:float-to-sql-string
))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (when (char= #\a (schar (symbol-name '#:a) 0))
- (pushnew :lowercase-reader *features*)))
-
-(defun string-default-case (str)
- #-lowercase-reader
- (string-upcase str)
- #+lowercase-reader
- (string-downcase str))
-
-;; From KMRCL
-(defun ensure-keyword (name)
- "Returns keyword for a name"
- (etypecase name
- (keyword name)
- (string (nth-value 0 (intern (string-default-case name) :keyword)))
- (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
;; From KMRCL
(defmacro in (obj &rest choices)
;; Default CommonSQL behavior is to upcase strings
(string-upcase str)))
+
+(defun ensure-keyword (name)
+ "Returns keyword for a name"
+ (etypecase name
+ (keyword name)
+ (string (nth-value 0 (intern (symbol-name-default-case name) :keyword)))
+ (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
(field-vec (mysql-fetch-fields res-ptr)))
(dotimes (i num-fields)
(declare (fixnum i))
- (let* ((field (uffi:deref-array field-vec '(:array (* mysql-field)) i))
+ (let* ((field (uffi:deref-array field-vec '(:array mysql-field) i))
(name (uffi:convert-from-foreign-string
(uffi:get-slot-value field 'mysql-field 'mysql::name))))
(push name names)))
(field-vec (mysql-fetch-fields res-ptr)))
(dotimes (i num-fields)
(declare (fixnum i))
- (let* ((field (uffi:deref-array field-vec '(:array (* mysql-field)) i))
+ (let* ((field (uffi:deref-array field-vec '(:array mysql-field) i))
(type (uffi:get-slot-value field 'mysql-field 'type)))
(push
(case type
(do ((results nil)
(rows (database-query
(format nil "SHOW INDEX FROM ~A" (string-upcase table))
- database nil)
+ database nil nil)
(cdr rows)))
((null rows) (nreverse results))
(let ((col (nth 2 (car rows))))
(mapcar #'car
(database-query
(format nil "SHOW COLUMNS FROM ~A" table)
- database nil)))
+ database nil nil)))
(defmethod database-attribute-type (attribute (table string)
(database mysql-database)
&key (owner nil))
(declare (ignore owner))
- (let ((result
- (mapcar #'cadr
- (database-query
- (format nil
- "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)
- database nil))))
- (let* ((str (car result))
- (end-str (position #\( str))
- (substr (subseq str 0 end-str)))
- (if substr
- (intern (string-upcase substr) :keyword) nil))))
+ (let ((row (car (database-query
+ (format nil
+ "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)
+ database nil nil))))
+ (let* ((raw-type (second row))
+ (null (third row))
+ (start-length (position #\( raw-type))
+ (type (if start-length
+ (subseq raw-type 0 start-length)
+ raw-type))
+ (length (when start-length
+ (parse-integer (subseq raw-type (1+ start-length))
+ :junk-allowed t))))
+ (when type
+ (values (ensure-keyword type) length nil (if (string-equal null "YES") 1 0))))))
;;; Sequence functions
(if (plusp (column-count free-query)) ;; KMR: Added check for commands that don't return columns
(values
(db-fetch-query-results free-query nil)
- (column-names free-query))
+ (map 'list #'identity (column-names free-query)))
(values
(result-rows-count (hstmt free-query))
nil)))
(dotimes (col-nr count)
(let ((data-ptr (aref column-data-ptrs col-nr))
(out-len-ptr (aref column-out-len-ptrs col-nr)))
+ (declare (ignorable data-ptr out-len-ptr))
;; free-statment :unbind frees these
#+ignore (when data-ptr (uffi:free-foreign-object data-ptr))
#+ignore (when out-len-ptr (uffi:free-foreign-object out-len-ptr)))))
column-data-ptrs column-out-len-ptrs column-precisions
computed-result-types)
query
- (unless (= (SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND)
+ (unless (= (odbc::SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND)
(values
(loop for col-nr from 0 to (- column-count
(if (eq ignore-columns :last) 2 1))
(mapcan #'(lambda (s)
(let ((sn (%table-name-to-sequence-name (car s))))
(and sn (list sn))))
- (database-query "SHOW TABLES" database nil)))
+ (database-query "SHOW TABLES" database nil nil)))
((:postgresql :postgresql-socket)
(mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
(database-query "SELECT RELNAME FROM pg_class WHERE RELNAME LIKE '%clsql_seq%'"
- database nil)))))
+ database nil nil)))))
(defmethod database-list-tables ((database odbc-database)
&key (owner nil))
(declare (ignore owner))
(multiple-value-bind (rows col-names)
(odbc-dbi:list-all-table-columns table :db (database-odbc-conn database))
- (let ((pos (position "COLUMN_NAME" col-names :test #'string-equal)))
- (when pos
- (loop for row in rows
- collect (nth pos row))))))
+ (declare (ignore col-names))
+ ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
+ (loop for row in rows
+ collect (fourth row))))
(defmethod database-attribute-type ((attribute string) (table string) (database odbc-database)
&key (owner nil))
(declare (ignore owner))
(multiple-value-bind (rows col-names)
(odbc-dbi:list-all-table-columns table :db (database-odbc-conn database))
- (let ((pos (position "TYPE_NAME" col-names :test #'string-equal)))
- (when pos
- (loop for row in rows
- collect (nth pos row))))))
+ (declare (ignore col-names))
+ ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
+ ;; TYPE_NAME is the sixth column
+ ;; PRECISION/COLUMN_SIZE is the seventh column
+ ;; SCALE/DECIMAL_DIGITS is the ninth column
+ ;; NULLABLE is the eleventh column
+ (loop for row in rows
+ when (string-equal attribute (fourth row))
+ do (return (values (ensure-keyword (sixth row))
+ (parse-integer (seventh row) :junk-allowed t)
+ (parse-integer (ninth row) :junk-allowed t)
+ (parse-integer (nth 10 row) :junk-allowed t))))))
(defmethod database-set-sequence-position (sequence-name
(position integer)
(car (database-query
(concatenate 'string "SELECT last_value,is_called FROM "
table-name)
- database
- :auto))))
+ database :auto nil))))
(cond
((char-equal (schar (second tuple) 0) #\f)
(database-execute-command
(caar (database-query
(concatenate 'string "SELECT last_value FROM "
(%sequence-name-to-table sequence-name))
- database
- :auto))))
+ database :auto nil))))
(defmethod database-create (connection-spec (type (eql :odbc)))
+ (declare (ignore connection-spec))
(warn "Not implemented."))
(defmethod database-destroy (connection-spec (type (eql :odbc)))
+ (declare (ignore connection-spec))
(warn "Not implemented."))
(defmethod database-probe (connection-spec (type (eql :odbc)))
(force-output (postgresql-connection-socket connection)))
(defun wait-for-query-results (connection)
- (asse
-rt (postgresql-connection-open-p connection))
+ (assert (postgresql-connection-open-p connection))
(let ((socket (postgresql-connection-socket connection))
(cursor-name nil)
(error nil))
:errno 'multiple-results
:error "Received multiple results for query.")))
(when field-names
- (result-field-names cursor)))))))
-
-(defun result-field-names (cursor)
- "Return list of result field names."
- ;; FIXME -- implement
- nil)
+ (mapcar #'car (postgresql-cursor-fields cursor))))))))
(defmethod database-execute-command
(expression (database postgresql-socket-database))
"SELECT relname FROM pg_class WHERE (relkind = '~A')~A"
type
(owner-clause owner))
- database nil)))
+ database nil nil)))
(defmethod database-list-tables ((database postgresql-socket-database)
&key (owner nil))
"select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
(string-downcase table)
(owner-clause owner))
- database :auto))
+ database :auto nil))
(result nil))
(dolist (indexrelid indexrelids (nreverse result))
(push
(caar (database-query
(format nil "select relname from pg_class where relfilenode='~A'"
(car indexrelid))
- database
- nil))
+ database nil nil))
result))))
(defmethod database-list-attributes ((table string)
(format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A"
(string-downcase table)
owner-clause)
- database nil))))
+ database nil nil))))
(if result
(reverse
(remove-if #'(lambda (it) (member it '("cmin"
(defmethod database-attribute-type (attribute (table string)
(database postgresql-socket-database)
&key (owner nil))
- (let* ((owner-clause
- (cond ((stringp owner)
- (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
- ((null owner) " AND (not (relowner=1))")
- (t "")))
- (result
- (mapcar #'car
- (database-query
- (format nil "SELECT pg_type.typname FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A"
+ (let ((row (car (database-query
+ (format nil "SELECT pg_type.typname,pg_attribute.attlen,pg_attribute.atttypmod,pg_attribute.attnotnull FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A"
(string-downcase table)
- (string-downcase attribute)
- owner-clause)
- database nil))))
- (when result
- (intern (string-upcase (car result)) :keyword))))
+ (string-downcase attribute)
+ (owner-clause owner))
+ database nil nil))))
+ (when row
+ (values
+ (ensure-keyword (first row))
+ (if (string= "-1" (second row))
+ (- (parse-integer (third row) :junk-allowed t) 4)
+ (parse-integer (second row)))
+ nil
+ (if (string-equal "f" (fourth row))
+ 1
+ 0)))))
(defmethod database-create-sequence (sequence-name
(database postgresql-socket-database))
(caar
(database-query
(format nil "SELECT SETVAL ('~A', ~A)" name position)
- database nil)))))
+ database nil nil)))))
(defmethod database-sequence-next (sequence-name
(database postgresql-socket-database))
(caar
(database-query
(concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
- database nil)))))
+ database nil nil)))))
(defmethod database-sequence-last (sequence-name (database postgresql-socket-database))
(values
(caar
(database-query
(concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')")
- database nil)))))
+ database nil nil)))))
(defmethod database-create (connection-spec (type (eql :postgresql-socket)))
(progn
(setf (slot-value database 'clsql-base-sys::state) :open)
(mapcar #'car (database-query "select datname from pg_database"
- database :auto)))
+ database :auto nil)))
(progn
(database-disconnect database)
(setf (slot-value database 'clsql-base-sys::state) :closed))))))
and a.attrelid = c.oid
and a.atttypid = t.oid"
(sql-escape (string-downcase table)))
- database :auto))
+ database :auto nil))
;; Database capabilities
(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket)))
t)
-(defmethod db-type-default-case ((db-type (eql :postgresql)))
+(defmethod db-type-default-case ((db-type (eql :postgresql-socket)))
:lower)
(when (clsql-base-sys:database-type-library-loaded :postgresql-socket)
(let ((names '()))
(dotimes (i num-fields (nreverse names))
(declare (fixnum i))
- (push (uffi:convert-from-foreign-string (PQfname res-ptr i)) names))))
+ (push (uffi:convert-from-foreign-string (PQfname result i)) names))))
(defmethod database-execute-command (sql-expression
(database postgresql-database))
"SELECT relname FROM pg_class WHERE (relkind = '~A')~A"
type
(owner-clause owner))
- database nil)))
+ database nil nil)))
(defmethod database-list-tables ((database postgresql-database)
&key (owner nil))
"select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
(string-downcase table)
(owner-clause owner))
- database :auto))
+ database :auto nil))
(result nil))
(dolist (indexrelid indexrelids (nreverse result))
(push
(caar (database-query
(format nil "select relname from pg_class where relfilenode='~A'"
(car indexrelid))
- database
- nil))
+ database nil nil))
result))))
(defmethod database-list-attributes ((table string)
(format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A"
(string-downcase table)
owner-clause)
- database nil))))
+ database nil nil))))
(if result
(reverse
(remove-if #'(lambda (it) (member it '("cmin"
(defmethod database-attribute-type (attribute (table string)
(database postgresql-database)
&key (owner nil))
- (let* ((owner-clause
- (cond ((stringp owner)
- (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
- ((null owner) " AND (not (relowner=1))")
- (t "")))
- (result
- (mapcar #'car
- (database-query
- (format nil "SELECT pg_type.typname FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A"
+ (let ((row (car (database-query
+ (format nil "SELECT pg_type.typname,pg_attribute.attlen,pg_attribute.atttypmod,pg_attribute.attnotnull FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A"
(string-downcase table)
- (string-downcase attribute)
- owner-clause)
- database nil))))
- (when result
- (intern (string-upcase (car result)) :keyword))))
+ (string-downcase attribute)
+ (owner-clause owner))
+ database nil nil))))
+ (when row
+ (values
+ (ensure-keyword (first row))
+ (if (string= "-1" (second row))
+ (- (parse-integer (third row) :junk-allowed t) 4)
+ (parse-integer (second row)))
+ nil
+ (if (string-equal "f" (fourth row))
+ 1
+ 0)))))
(defmethod database-create-sequence (sequence-name
(database postgresql-database))
(caar
(database-query
(format nil "SELECT SETVAL ('~A', ~A)" name position)
- database nil)))))
+ database nil nil)))))
(defmethod database-sequence-next (sequence-name
(database postgresql-database))
(caar
(database-query
(concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
- database nil)))))
+ database nil nil)))))
(defmethod database-sequence-last (sequence-name (database postgresql-database))
(values
(caar
(database-query
(concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')")
- database nil)))))
+ database nil nil)))))
(defmethod database-create (connection-spec (type (eql :postgresql)))
(destructuring-bind (host name user password) connection-spec
(progn
(setf (slot-value database 'clsql-base-sys::state) :open)
(mapcar #'car (database-query "select datname from pg_database"
- database nil)))
+ database nil nil)))
(progn
(database-disconnect database)
(setf (slot-value database 'clsql-base-sys::state) :closed))))))
and a.attrelid = c.oid
and a.atttypid = t.oid"
(sql-escape (string-downcase table)))
- database :auto))
+ database :auto nil))
(defun %pg-database-connection (connection-spec)
(check-connection-spec connection-spec :postgresql
connection-spec
(coerce-string db)
(coerce-string user)
- (let ((connection (pqsetdblogin host port options tty db user password)))
+ (let ((connection (PQsetdbLogin host port options tty db user password)))
(declare (type postgresql::pgsql-conn-ptr connection))
- (unless (eq (pqstatus connection) :connection-ok)
+ (unless (eq (PQstatus connection) :connection-ok)
;; Connect failed
(error 'clsql-connect-error
:database-type :postgresql
:connection-spec connection-spec
- :errno (pqstatus connection)
- :error (pqerrormessage connection)))
+ :errno (PQstatus connection)
+ :error (PQerrorMessage connection)))
connection))))
(defmethod database-reconnect ((database postgresql-database))
(multiple-value-bind (data row-n col-n)
(sqlite:sqlite-get-table (sqlite-db database) query-expression)
#-clisp (declare (type sqlite:sqlite-row-pointer-type data))
- (if (= row-n 0)
- nil
- (prog1
- ;; The first col-n elements are column names.
- (values
- (loop for i from col-n below (* (1+ row-n) col-n) by col-n
- collect (loop for j from 0 below col-n
- collect
- (#+clisp aref
- #-clisp sqlite:sqlite-aref
- data (+ i j))))
- (when field-names
- (loop for i from 0 below col-n
- collect (#+clisp aref
- #-clisp sqlite:sqlite-aref
- data i))))
- #-clisp (sqlite:sqlite-free-table data))
- ))
+ (let ((rows
+ (when (plusp row-n)
+ (loop for i from col-n below (* (1+ row-n) col-n) by col-n
+ collect (loop for j from 0 below col-n
+ collect
+ (#+clisp aref
+ #-clisp sqlite:sqlite-aref
+ data (+ i j))))))
+ (names
+ (when field-names
+ (loop for j from 0 below col-n
+ collect (#+clisp aref
+ #-clisp sqlite:sqlite-aref
+ data j)))))
+ #-clisp (sqlite:sqlite-free-table data)
+ (values rows names)))
(sqlite:sqlite-error (err)
(error 'clsql-sql-error
:database database
(string-equal (subseq s 0 11) "_CLSQL_SEQ_")))
(mapcar #'car (database-query
"SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name"
- database '()))))
+ database nil nil))))
(defmethod database-list-views ((database sqlite-database)
&key (owner nil))
(declare (ignore owner))
(mapcar #'car (database-query
"SELECT name FROM sqlite_master WHERE type='view' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='view' ORDER BY name"
- database nil)))
+ database nil nil)))
(defmethod database-list-indexes ((database sqlite-database)
&key (owner nil))
(declare (ignore owner))
(mapcar #'car (database-query
"SELECT name FROM sqlite_master WHERE type='index' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' ORDER BY name"
- database nil)))
+ database nil nil)))
(defmethod database-list-table-indexes (table (database sqlite-database)
&key (owner nil))
nil
"SELECT name FROM sqlite_master WHERE type='index' AND tbl_name='~A' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' AND tbl_name='~A' ORDER BY name"
table table)
- database nil))))
+ database nil nil))))
(declaim (inline sqlite-table-info))
(defun sqlite-table-info (table database)
(database-query (format nil "PRAGMA table_info('~A')" table)
- database '()))
+ database nil nil))
(defmethod database-list-attributes (table (database sqlite-database)
&key (owner nil))
&key (owner nil))
(declare (ignore owner))
(loop for field-info in (sqlite-table-info table database)
- when (string= attribute (second field-info))
- return (third field-info)))
+ when (string= attribute (second field-info))
+ return
+ (let* ((raw-type (third field-info))
+ (start-length (position #\( raw-type))
+ (type (if start-length
+ (subseq raw-type 0 start-length)
+ raw-type))
+ (length (if start-length
+ (parse-integer (subseq raw-type (1+ start-length))
+ :junk-allowed t)
+ nil)))
+ (values (when type (ensure-keyword type))
+ length
+ nil
+ (if (string-equal (fourth field-info) "0")
+ 1 0)))))
(defun %sequence-name-to-table-name (sequence-name)
(concatenate 'string "_CLSQL_SEQ_" (sql-escape sequence-name)))
(and sn (list sn))))
(database-query
"SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name"
- database '())))
+ database nil nil)))
(defmethod database-sequence-next (sequence-name (database sqlite-database))
(without-interrupts
(car (database-query
(concatenate 'string "SELECT last_value,is_called FROM "
table-name)
- database
- :auto))))
+ database :auto nil))))
(cond
((char-equal (schar (second tuple) 0) #\f)
(database-execute-command
(caar (database-query
(concatenate 'string "SELECT last_value FROM "
(%sequence-name-to-table-name sequence-name))
- database
- :auto)))))
+ database :auto nil)))))
(defmethod database-set-sequence-position (sequence-name
(position integer)
+cl-sql (2.10.1-1) unstable; urgency=low
+
+ * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Sat, 1 May 2004 04:13:12 -0600
+
cl-sql (2.9.6-1) unstable; urgency=low
* New upstream
</refnamediv>
<refsect1>
<title>Syntax</title>
- <synopsis><function>query</function> <replaceable>query-expression</replaceable> &key <replaceable>database</replaceable> <replaceable>result-types</replaceable> => <returnvalue>result</returnvalue></synopsis>
+ <synopsis><function>query</function> <replaceable>query-expression</replaceable> &key <replaceable>database</replaceable> <replaceable>result-types</replaceable> <replaceable>field-names</replaceable> => <returnvalue>result</returnvalue></synopsis>
</refsect1>
<refsect1>
<title>Arguments and Values</title>
</para>
</listitem>
</varlistentry>
+ <varlistentry>
+ <term><parameter>field-names</parameter></term>
+ <para>
+ A boolean with a default value of &t;. When &t;, this
+ function results a second value of a list of field
+ names. When &nil;, this function only returns one value
+ - the list of rows.
+ </para>
+ </varlistentry>
<varlistentry>
<term><returnvalue>result</returnvalue></term>
<listitem>
;; initialize
#:*loaded-database-types*
#:reload-database-types
- #:*default-database-type*
#:*initialized-database-types*
#:initialize-database-type
;; classes
#:database-view-classes
#:conn-pool
#:print-object
+
;; utils
#:sql-escape
#:table-exists-p ; table xx
#:list-attributes ; table xx
#:attribute-type ; table xx
- #:list-attribute-types ; table xx
+ #:list-attribute-types ; table xx
+ #:*cache-table-queries-default*
#:create-view ; table xx
#:drop-view ; table xx
#:create-index ; table xx
#:instance-refreshed ; objects xx
#:update-object-joins ;
#:*default-update-objects-max-len* ;
- #:update-slot-from-record ; objects xx
+ #:update-slot-from-record ; objects xx
#:update-instance-from-records ; objects xx
#:update-records-from-instance ; objects xx
#:update-record-from-slot ; objects xx
;; 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 value))))))
+ 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 value)))))))
+ 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
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 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))
+
+;;; Remote Joins
+
+(defvar *default-update-objects-max-len* nil
+ "The default maximum number of objects supplying data for a query when updating remote joins.")
+
"birthday" "companyid" "email" "emplid" "first_name" "groupid" "height"
"last_name" "managerid" "married")
+;; Attribute types are vendor specific so need to test a range
+(deftest :fddl/attributes/3
+ (and (member (clsql:attribute-type [emplid] [employee]) '(:int :integer :int4)) t)
+ t)
+
+(deftest :fddl/attributes/4
+ (clsql:attribute-type [first-name] [employee])
+ :varchar 30 nil 1)
+
+(deftest :fddl/attributes/5
+ (and (member (clsql:attribute-type [birthday] [employee]) '(:datetime :timestamp)) t)
+ t)
+
+(deftest :fddl/attributes/6
+ (and (member (clsql:attribute-type [height] [employee]) '(:float :float8)) t)
+ t)
+
+
+
;; create a view, test for existence, drop it and test again
(deftest :fddl/view/1
(progn (clsql:create-view [lenins-group]
(deftest :fdml/query/1
- (clsql:query "SELECT COUNT(*) FROM EMPLOYEE WHERE (EMAIL LIKE '%org')")
+ (clsql:query "SELECT COUNT(*) FROM EMPLOYEE WHERE (EMAIL LIKE '%org')" :field-names nil)
(("10")))
(deftest :fdml/query/2
- (clsql:query
- "SELECT FIRST_NAME,LAST_NAME FROM EMPLOYEE WHERE (EMPLID <= 5) ORDER BY LAST_NAME")
+ (multiple-value-bind (rows field-names)
+ (clsql:query
+ "SELECT FIRST_NAME,LAST_NAME FROM EMPLOYEE WHERE (EMPLID <= 5) ORDER BY LAST_NAME")
+ (values rows (mapcar 'string-upcase field-names)))
(("Leonid" "Brezhnev") ("Nikita" "Kruschev") ("Vladamir" "Lenin")
- ("Josef" "Stalin") ("Leon" "Trotsky")))
+ ("Josef" "Stalin") ("Leon" "Trotsky"))
+ ("FIRST_NAME" "LAST_NAME"))
(deftest :fdml/execute-command/1
(defun load-necessary-systems (specs)
(dolist (db-type +all-db-types+)
(when (db-type-spec db-type specs)
- (db-type-ensure-system db-type))))
+ (clsql:initialize-database-type :database-type db-type))))
(defun do-tests-for-backend (db-type spec)
(test-connect-to-database db-type spec)
(defun db-type-spec (db-type specs)
(funcall (spec-fn db-type) specs))
-(defun db-type-ensure-system (db-type)
- (unless (find-package (symbol-name db-type))
- (asdf:operate 'asdf:load-op
- (intern (concatenate 'string
- (symbol-name '#:clsql-)
- (symbol-name db-type))))))
-
-
(defun summarize-test-report (sexp &optional (output *standard-output*))
(flet ((db-title (db-type underlying-db-type)
projects / clsql.git / commitdiff