From 8b5250e14e3280bdc4641c3b35a8dc68ca4dbde7 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 1 May 2004 04:10:50 +0000 Subject: [PATCH] r9185: first effort at support field names in QUERY calls, still needs testing --- ChangeLog | 4 ++ TODO | 5 +- base/basic-sql.lisp | 15 +++-- base/db-interface.lisp | 8 +-- db-aodbc/aodbc-sql.lisp | 5 +- db-mysql/mysql-sql.lisp | 64 +++++++++++-------- db-odbc/odbc-sql.lisp | 5 +- .../postgresql-socket-api.lisp | 25 ++------ .../postgresql-socket-sql.lisp | 43 +++++++------ db-postgresql/postgresql-sql.lisp | 30 ++++++--- db-sqlite/sqlite-sql.lisp | 34 ++++++---- tests/test-init.lisp | 4 +- 12 files changed, 136 insertions(+), 106 deletions(-) diff --git a/ChangeLog b/ChangeLog index 43f4676..a6d358e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,9 @@ 30 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.9.7-pre1 + * 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 + in the QUERY invocation. * 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 diff --git a/TODO b/TODO index e71c4bd..bc42595 100644 --- a/TODO +++ b/TODO @@ -1,6 +1,5 @@ GENERAL -* test on mcl. SCL no longer affordable to individuals; * implement remaining functions for CLSQL AODBC backend; * port Oracle backend to UFFI. @@ -34,7 +33,6 @@ COMMONSQL SPEC o should coerce values returned as strings to appropriate lisp type QUERY - o should return (values result-list field-names) o should coerce values returned as strings to appropriate lisp type LIST-ATTRIBUTE-TYPES @@ -76,9 +74,8 @@ NOTES ABOUT THE BACKENDS MYSQL drop-index: requires a table to be specified with the :from keyword parameter -transactions: don't seem to work views: mysql does not support views -queries: nested subqueries do not seem to work +queries: nested subqueries are not supported SQLITE diff --git a/base/basic-sql.lisp b/base/basic-sql.lisp index 7b54528..4546f4e 100644 --- a/base/basic-sql.lisp +++ b/base/basic-sql.lisp @@ -30,14 +30,15 @@ one result per row. Returns a list of lists of values of the result of that expression and a list of field names selected in sql-exp.")) (defmethod query ((query-expression string) &key (database *default-database*) - (result-types nil) (flatp nil)) + (result-types nil) (flatp nil) (field-names t)) (record-sql-action query-expression :query database) - (let* ((res (database-query query-expression database result-types)) - (res (if (and flatp (= 1 (length (car res)))) - (mapcar #'car res) - res))) - (record-sql-action res :result database) - res)) + (multiple-value-bind (rows names) (database-query query-expression database result-types + field-names) + (let ((result (if (and flatp (= 1 (length (car rows)))) + (mapcar #'car rows) + rows))) + (record-sql-action result :result database) + (values result names)))) ;;; Execute diff --git a/base/db-interface.lisp b/base/db-interface.lisp index 2d52105..cfae08a 100644 --- a/base/db-interface.lisp +++ b/base/db-interface.lisp @@ -52,9 +52,9 @@ was called with the connection-spec.")) (signal-no-database-error database)) (:documentation "Internal generic implementation of disconnect.")) -(defgeneric database-query (query-expression database result-types) - (:method (query-expression (database t) result-types) - (declare (ignore query-expression result-types)) +(defgeneric database-query (query-expression database result-types field-names) + (:method (query-expression (database t) result-types field-names) + (declare (ignore query-expression result-types field-names)) (signal-no-database-error database)) (:documentation "Internal generic implementation of query.")) @@ -277,7 +277,7 @@ the given lisp type and parameters.")) (signal-closed-database-error database))) (defmethod database-query :before (query-expression (database database) - result-set) + result-set field-names) (declare (ignore query-expression result-set)) (unless (is-database-open database) (signal-closed-database-error database))) diff --git a/db-aodbc/aodbc-sql.lisp b/db-aodbc/aodbc-sql.lisp index bffb212..87fd0f3 100644 --- a/db-aodbc/aodbc-sql.lisp +++ b/db-aodbc/aodbc-sql.lisp @@ -74,11 +74,12 @@ (setf (database-aodbc-conn database) nil) t) -(defmethod database-query (query-expression (database aodbc-database) result-types) +(defmethod database-query (query-expression (database aodbc-database) result-types field-names) #+aodbc-v2 (handler-case (dbi:sql query-expression :db (database-aodbc-conn database) - :types result-types) + :types result-types + :column-names field-names) (clsql-error (e) (error e)) (error () diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index 074f24e..e62dcbd 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -22,14 +22,25 @@ ;;; Field conversion functions +(defun result-field-names (num-fields res-ptr) + (declare (fixnum num-fields)) + (let ((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)) + (name (uffi:convert-from-foreign-string + (uffi:get-slot-value field 'mysql-field 'mysql::name)))) + (push name names))) + (nreverse names))) + (defun make-type-list-for-auto (num-fields res-ptr) (declare (fixnum num-fields)) (let ((new-types '()) - #+ignore (field-vec (mysql-fetch-fields res-ptr))) + (field-vec (mysql-fetch-fields res-ptr))) (dotimes (i num-fields) (declare (fixnum i)) - (let* ( (field (mysql-fetch-field-direct res-ptr i)) - #+ignore (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 @@ -127,7 +138,7 @@ (defmethod database-query (query-expression (database mysql-database) - result-types) + result-types field-names) (declare (optimize (speed 3) (safety 0) (debug 0) (space 0))) (let ((mysql-ptr (database-mysql-ptr database))) (uffi:with-cstring (query-native query-expression) @@ -141,23 +152,26 @@ (setq result-types (canonicalize-types result-types num-fields res-ptr)) - (loop for row = (mysql-fetch-row res-ptr) - for lengths = (mysql-fetch-lengths res-ptr) - until (uffi:null-pointer-p row) - collect - (do* ((rlist (make-list num-fields)) - (i 0 (1+ i)) - (pos rlist (cdr pos))) - ((= i num-fields) rlist) - (declare (fixnum i)) - (setf (car pos) - (convert-raw-field - (uffi:deref-array row '(:array - (* :unsigned-char)) - i) - result-types i - (uffi:deref-array lengths '(:array :unsigned-long) - i)))))) + (values + (loop for row = (mysql-fetch-row res-ptr) + for lengths = (mysql-fetch-lengths res-ptr) + until (uffi:null-pointer-p row) + collect + (do* ((rlist (make-list num-fields)) + (i 0 (1+ i)) + (pos rlist (cdr pos))) + ((= i num-fields) rlist) + (declare (fixnum i)) + (setf (car pos) + (convert-raw-field + (uffi:deref-array row '(:array + (* :unsigned-char)) + i) + result-types i + (uffi:deref-array lengths '(:array :unsigned-long) + i))))) + (when field-names + (result-field-names num-fields res-ptr)))) (mysql-free-result res-ptr)) (error 'clsql-sql-error :database database @@ -262,7 +276,7 @@ (remove-if #'(lambda (s) (and (>= (length s) 11) (string-equal (subseq s 0 11) "_CLSQL_SEQ_"))) - (mapcar #'car (database-query "SHOW TABLES" database nil)))) + (mapcar #'car (database-query "SHOW TABLES" database nil nil)))) ;; MySQL 4.1 does not support views (defmethod database-list-views ((database mysql-database) @@ -349,7 +363,7 @@ (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))) (defmethod database-set-sequence-position (sequence-name (position integer) @@ -415,7 +429,7 @@ (unwind-protect (progn (setf (slot-value database 'clsql-base-sys::state) :open) - (mapcar #'car (database-query "show databases" database :auto))) + (mapcar #'car (database-query "show databases" database :auto nil))) (progn (database-disconnect database) (setf (slot-value database 'clsql-base-sys::state) :closed)))))) @@ -437,7 +451,7 @@ nil) (defmethod db-type-transaction-capable? ((db-type (eql :mysql)) database) - (let ((tuple (car (database-query "SHOW VARIABLES LIKE 'HAVE_INNODB'" database :auto)))) + (let ((tuple (car (database-query "SHOW VARIABLES LIKE 'HAVE_INNODB'" database :auto nil)))) (and tuple (string-equal "YES" (second tuple))))) (when (clsql-base-sys:database-type-library-loaded :mysql) diff --git a/db-odbc/odbc-sql.lisp b/db-odbc/odbc-sql.lisp index 3b2d310..bfc6d89 100644 --- a/db-odbc/odbc-sql.lisp +++ b/db-odbc/odbc-sql.lisp @@ -87,10 +87,11 @@ t) (defmethod database-query (query-expression (database odbc-database) - result-types) + result-types field-names) (handler-case (odbc-dbi:sql query-expression :db (database-odbc-conn database) - :result-types result-types) + :result-types result-types + :column-names field-names) (clsql-error (e) (error e)) #+ignore diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp index 40c904f..fe31ced 100644 --- a/db-postgresql-socket/postgresql-socket-api.lisp +++ b/db-postgresql-socket/postgresql-socket-api.lisp @@ -2,16 +2,14 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: postgresql-socket-api.lisp -;;;; Purpose: Low-level PostgreSQL interface using sockets -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; -;;;; Date Started: Feb 2002 +;;;; Name: postgresql-socket-api.lisp +;;;; Purpose: Low-level PostgreSQL interface using sockets +;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai +;;;; Created: Feb 2002 ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software @@ -19,16 +17,6 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* - -;;;; Changes by Kevin Rosenberg -;;;; - Added socket open functions for Allegro and Lispworks -;;;; - Changed CMUCL FFI to UFFI -;;;; - Added necessary (force-output) for socket streams on -;;;; Allegro and Lispworks -;;;; - Added initialization variable -;;;; - Added field type processing - - (in-package #:postgresql-socket) (uffi:def-enum pgsql-ftype @@ -572,7 +560,8 @@ connection, if it is still open." (force-output (postgresql-connection-socket connection))) (defun wait-for-query-results (connection) - (assert (postgresql-connection-open-p connection)) + (asse +rt (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 6a45589..626e4f1 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -2,15 +2,14 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: postgresql-socket-sql.sql -;;;; Purpose: High-level PostgreSQL interface using socket -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; Date Started: Feb 2002 +;;;; Name: postgresql-socket-sql.sql +;;;; Purpose: High-level PostgreSQL interface using socket +;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai +;;;; Created: Feb 2002 ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software @@ -202,7 +201,7 @@ doesn't depend on UFFI." (close-postgresql-connection (database-connection database)) t) -(defmethod database-query (expression (database postgresql-socket-database) result-types) +(defmethod database-query (expression (database postgresql-socket-database) result-types field-names) (let ((connection (database-connection database))) (with-postgresql-handlers (database expression) (start-query-execution connection expression) @@ -216,17 +215,25 @@ doesn't depend on UFFI." :errno 'missing-result :error "Didn't receive result cursor for query.")) (setq result-types (canonicalize-types result-types cursor)) - (loop for row = (read-cursor-row cursor result-types) - while row - collect row - finally - (unless (null (wait-for-query-results connection)) - (close-postgresql-connection connection) - (error 'clsql-sql-error - :database database - :expression expression - :errno 'multiple-results - :error "Received multiple results for query."))))))) + (values + (loop for row = (read-cursor-row cursor result-types) + while row + collect row + finally + (unless (null (wait-for-query-results connection)) + (close-postgresql-connection connection) + (error 'clsql-sql-error + :database database + :expression expression + :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) (defmethod database-execute-command (expression (database postgresql-socket-database)) diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp index dd15e86..2f0ae75 100644 --- a/db-postgresql/postgresql-sql.lisp +++ b/db-postgresql/postgresql-sql.lisp @@ -146,7 +146,7 @@ (setf (database-conn-ptr database) nil) t) -(defmethod database-query (query-expression (database postgresql-database) result-types) +(defmethod database-query (query-expression (database postgresql-database) result-types field-names) (let ((conn-ptr (database-conn-ptr database))) (declare (type pgsql-conn-def conn-ptr)) (uffi:with-cstring (query-native query-expression) @@ -166,15 +166,18 @@ (setq result-types (canonicalize-types result-types num-fields result)) - (loop for tuple-index from 0 below (PQntuples result) - collect - (loop for i from 0 below num-fields - collect - (if (zerop (PQgetisnull result tuple-index i)) - (convert-raw-field - (PQgetvalue result tuple-index i) - result-types i) - nil))))) + (values + (loop for tuple-index from 0 below (PQntuples result) + collect + (loop for i from 0 below num-fields + collect + (if (zerop (PQgetisnull result tuple-index i)) + (convert-raw-field + (PQgetvalue result tuple-index i) + result-types i) + nil))) + (when field-names + (result-field-names num-fields result))))) (t (error 'clsql-sql-error :database database @@ -184,6 +187,13 @@ (PQresultErrorMessage result))))) (PQclear result)))))) +(defun result-field-names (num-fields result) + "Return list of result field names." + (let ((names '())) + (dotimes (i num-fields (nreverse names)) + (declare (fixnum i)) + (push (uffi:convert-from-foreign-string (PQfname res-ptr i)) names)))) + (defmethod database-execute-command (sql-expression (database postgresql-database)) (let ((conn-ptr (database-conn-ptr database))) diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index 8674996..ca6124a 100644 --- a/db-sqlite/sqlite-sql.lisp +++ b/db-sqlite/sqlite-sql.lisp @@ -75,7 +75,7 @@ :error (sqlite:sqlite-error-message err)))) t) -(defmethod database-query (query-expression (database sqlite-database) result-types) +(defmethod database-query (query-expression (database sqlite-database) result-types field-names) (declare (ignore result-types)) ; SQLite is typeless! (handler-case (multiple-value-bind (data row-n col-n) @@ -85,20 +85,26 @@ nil (prog1 ;; The first col-n elements are column names. - (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)))) - #-clisp (sqlite:sqlite-free-table data)) - )) + (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)) + )) (sqlite:sqlite-error (err) - (error 'clsql-sql-error - :database database - :expression query-expression - :errno (sqlite:sqlite-error-code err) - :error (sqlite:sqlite-error-message err))))) + (error 'clsql-sql-error + :database database + :expression query-expression + :errno (sqlite:sqlite-error-code err) + :error (sqlite:sqlite-error-message err))))) #-clisp (defstruct sqlite-result-set diff --git a/tests/test-init.lisp b/tests/test-init.lisp index ca402ce..edbb2eb 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -137,8 +137,8 @@ :make-default t :if-exists :old) - (unless (db-backend-has-create/destroy-db? db-type) - (truncate-database :database *default-database*)) + ;; Ensure database is empty + (truncate-database :database *default-database*) (setf *test-database-underlying-type* (clsql-sys:database-underlying-type *default-database*)) -- 2.34.1