From f716bb1161cf9e89a96945c4a444244f9d303691 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 1 May 2004 10:31:08 +0000 Subject: [PATCH] r9186: add attribute caching, improve inititialize-database-type --- ChangeLog | 23 ++++- TODO | 14 +-- base/basic-sql.lisp | 4 +- base/classes.lisp | 6 +- base/database.lisp | 3 + base/db-interface.lisp | 5 +- base/initialize.lisp | 18 ++-- base/package.lisp | 5 +- base/utils.lisp | 24 ++--- db-mysql/mysql-sql.lisp | 34 ++++--- db-odbc/odbc-dbi.lisp | 5 +- db-odbc/odbc-sql.lisp | 36 ++++--- .../postgresql-socket-api.lisp | 3 +- .../postgresql-socket-sql.lisp | 57 ++++++------ db-postgresql/postgresql-sql.lisp | 58 ++++++------ db-sqlite/sqlite-sql.lisp | 70 ++++++++------ debian/changelog | 6 ++ doc/ref_clsql.xml | 11 ++- sql/package.lisp | 7 +- sql/table.lisp | 93 ++++++++++++++++--- tests/test-fddl.lisp | 19 ++++ tests/test-fdml.lisp | 11 ++- tests/test-init.lisp | 2 +- tests/utils.lisp | 8 -- 24 files changed, 326 insertions(+), 196 deletions(-) diff --git a/ChangeLog b/ChangeLog index a6d358e..a3593e8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,12 +1,31 @@ 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 diff --git a/TODO b/TODO index bc42595..9d5e76d 100644 --- a/TODO +++ b/TODO @@ -1,26 +1,18 @@ 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)? @@ -34,10 +26,8 @@ COMMONSQL SPEC 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 diff --git a/base/basic-sql.lisp b/base/basic-sql.lisp index 4546f4e..055e33a 100644 --- a/base/basic-sql.lisp +++ b/base/basic-sql.lisp @@ -38,7 +38,9 @@ that expression and a list of field names selected in sql-exp.")) (mapcar #'car rows) rows))) (record-sql-action result :result database) - (values result names)))) + (if field-names + (values result names) + result)))) ;;; Execute diff --git a/base/classes.lisp b/base/classes.lisp index 7281f55..92254f5 100644 --- a/base/classes.lisp +++ b/base/classes.lisp @@ -36,7 +36,11 @@ (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.")) diff --git a/base/database.lisp b/base/database.lisp index cc26d71..f3c72b6 100644 --- a/base/database.lisp +++ b/base/database.lisp @@ -85,6 +85,9 @@ to the new connection, otherwise *default-database is not changed. If 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))) diff --git a/base/db-interface.lisp b/base/db-interface.lisp index cfae08a..3b84d95 100644 --- a/base/db-interface.lisp +++ b/base/db-interface.lisp @@ -186,7 +186,8 @@ the given lisp type and parameters.")) (: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.")) @@ -278,7 +279,7 @@ the given lisp type and parameters.")) (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))) diff --git a/base/initialize.lisp b/base/initialize.lisp index 1d96a8f..75d9a0d 100644 --- a/base/initialize.lisp +++ b/base/initialize.lisp @@ -43,10 +43,16 @@ to initialize-database-type.") (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)) diff --git a/base/package.lisp b/base/package.lisp index f57ea7e..56cdd57 100644 --- a/base/package.lisp +++ b/base/package.lisp @@ -62,7 +62,6 @@ #:database-list-table-indexes #:database-list-views - ;; Large objects (Marc B) #:database-create-large-object #:database-write-large-object @@ -82,6 +81,7 @@ #:command-output #:symbol-name-default-case #:convert-to-db-default-case + #:ensure-keyword ;; Shared exports for re-export by CLSQL-BASE . @@ -146,7 +146,8 @@ #:view-classes #:database-type #:database-state - + #:attribute-cache + ;; utils.lisp #:number-to-sql-string #:float-to-sql-string diff --git a/base/utils.lisp b/base/utils.lisp index 0968f96..2e46d7b 100644 --- a/base/utils.lisp +++ b/base/utils.lisp @@ -257,23 +257,6 @@ returns (VALUES string-output error-output exit-status)" )) -(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) @@ -351,3 +334,10 @@ list of characters and replacement strings." ;; 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))))) diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index e62dcbd..0f24ffb 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -28,7 +28,7 @@ (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))) @@ -40,7 +40,7 @@ (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 @@ -298,7 +298,7 @@ (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)))) @@ -311,23 +311,27 @@ (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 diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp index c81f084..4bafb1f 100644 --- a/db-odbc/odbc-dbi.lisp +++ b/db-odbc/odbc-dbi.lisp @@ -334,7 +334,7 @@ the query against." )) (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))) @@ -469,6 +469,7 @@ This makes the functions db-execute-command and db-query thread safe." (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))))) @@ -492,7 +493,7 @@ This makes the functions db-execute-command and db-query thread safe." 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)) diff --git a/db-odbc/odbc-sql.lisp b/db-odbc/odbc-sql.lisp index bfc6d89..b43a322 100644 --- a/db-odbc/odbc-sql.lisp +++ b/db-odbc/odbc-sql.lisp @@ -201,11 +201,11 @@ (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)) @@ -238,20 +238,28 @@ (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) @@ -270,8 +278,7 @@ (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 @@ -290,13 +297,14 @@ (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))) diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp index fe31ced..936f6db 100644 --- a/db-postgresql-socket/postgresql-socket-api.lisp +++ b/db-postgresql-socket/postgresql-socket-api.lisp @@ -560,8 +560,7 @@ connection, if it is still open." (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)) diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index 626e4f1..07032b8 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -228,12 +228,7 @@ doesn't depend on UFFI." :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)) @@ -339,7 +334,7 @@ doesn't depend on UFFI." "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)) @@ -363,15 +358,14 @@ doesn't depend on UFFI." "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) @@ -388,7 +382,7 @@ doesn't depend on UFFI." (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" @@ -404,21 +398,22 @@ doesn't depend on UFFI." (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)) @@ -442,7 +437,7 @@ doesn't depend on UFFI." (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)) @@ -451,7 +446,7 @@ doesn't depend on UFFI." (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 @@ -459,7 +454,7 @@ doesn't depend on UFFI." (caar (database-query (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')") - database nil))))) + database nil nil))))) (defmethod database-create (connection-spec (type (eql :postgresql-socket))) @@ -493,7 +488,7 @@ doesn't depend on UFFI." (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)))))) @@ -508,7 +503,7 @@ doesn't depend on UFFI." and a.attrelid = c.oid and a.atttypid = t.oid" (sql-escape (string-downcase table))) - database :auto)) + database :auto nil)) ;; Database capabilities @@ -519,7 +514,7 @@ doesn't depend on UFFI." (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) diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp index 2f0ae75..156e11e 100644 --- a/db-postgresql/postgresql-sql.lisp +++ b/db-postgresql/postgresql-sql.lisp @@ -192,7 +192,7 @@ (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)) @@ -394,7 +394,7 @@ "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)) @@ -418,15 +418,14 @@ "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) @@ -443,7 +442,7 @@ (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" @@ -459,21 +458,22 @@ (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)) @@ -497,7 +497,7 @@ (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)) @@ -506,7 +506,7 @@ (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 @@ -514,7 +514,7 @@ (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 @@ -565,7 +565,7 @@ (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)))))) @@ -579,7 +579,7 @@ 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 @@ -591,15 +591,15 @@ 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)) diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index ca6124a..703eb94 100644 --- a/db-sqlite/sqlite-sql.lisp +++ b/db-sqlite/sqlite-sql.lisp @@ -81,24 +81,22 @@ (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 @@ -197,21 +195,21 @@ (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)) @@ -223,12 +221,12 @@ 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)) @@ -241,8 +239,22 @@ &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))) @@ -279,7 +291,7 @@ (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 @@ -288,8 +300,7 @@ (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 @@ -309,8 +320,7 @@ (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) diff --git a/debian/changelog b/debian/changelog index adbb0d6..57f9b33 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-sql (2.10.1-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Sat, 1 May 2004 04:13:12 -0600 + cl-sql (2.9.6-1) unstable; urgency=low * New upstream diff --git a/doc/ref_clsql.xml b/doc/ref_clsql.xml index 0d893a6..c24b2ce 100644 --- a/doc/ref_clsql.xml +++ b/doc/ref_clsql.xml @@ -2099,7 +2099,7 @@ Error: While trying to access database localhost/test2/root Syntax - query query-expression &key database result-types => result + query query-expression &key database result-types field-names => result Arguments and Values @@ -2164,6 +2164,15 @@ Error: While trying to access database localhost/test2/root + + field-names + + 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. + + result diff --git a/sql/package.lisp b/sql/package.lisp index c9cce9b..d38c55c 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -159,7 +159,6 @@ ;; initialize #:*loaded-database-types* #:reload-database-types - #:*default-database-type* #:*initialized-database-types* #:initialize-database-type ;; classes @@ -170,6 +169,7 @@ #:database-view-classes #:conn-pool #:print-object + ;; utils #:sql-escape @@ -311,7 +311,8 @@ #: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 @@ -326,7 +327,7 @@ #: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 diff --git a/sql/table.lisp b/sql/table.lisp index 70e6b42..d2a615b 100644 --- a/sql/table.lisp +++ b/sql/table.lisp @@ -212,6 +212,59 @@ list of strings." ;; 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 @@ -246,19 +299,27 @@ denotes a username and only attributes owned by OWNER are 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 @@ -314,3 +375,9 @@ POSITION." (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.") + diff --git a/tests/test-fddl.lisp b/tests/test-fddl.lisp index 0e321f8..c8efdd5 100644 --- a/tests/test-fddl.lisp +++ b/tests/test-fddl.lisp @@ -79,6 +79,25 @@ "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] diff --git a/tests/test-fdml.lisp b/tests/test-fdml.lisp index 929e30d..8d87097 100644 --- a/tests/test-fdml.lisp +++ b/tests/test-fdml.lisp @@ -129,14 +129,17 @@ (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 diff --git a/tests/test-init.lisp b/tests/test-init.lisp index edbb2eb..3e6d85a 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -334,7 +334,7 @@ (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) diff --git a/tests/utils.lisp b/tests/utils.lisp index f73edbc..1928bf4 100644 --- a/tests/utils.lisp +++ b/tests/utils.lisp @@ -58,14 +58,6 @@ (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) -- 2.34.1