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
GENERAL
-* test on mcl. SCL no longer affordable to individuals;
* implement remaining functions for CLSQL AODBC backend;
* port Oracle backend to UFFI.
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
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
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
(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."))
(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)))
(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 ()
;;; 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
(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)
(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
(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)
(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)
(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))))))
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)
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
;;;; *************************************************************************
;;;; 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
;;;; (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
(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))
;;;; *************************************************************************
;;;; 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
(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)
: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))
(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)
(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
(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)))
: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)
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
: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*))
projects / clsql.git / commitdiff