From 7cdc9aa48baa3c52923d61da6fa632eb47ac0b5d Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 1 May 2004 18:19:03 +0000 Subject: [PATCH] r9189: implement result-types for sqlite --- ChangeLog | 11 +++ TODO | 7 -- base/database.lisp | 34 ++++--- db-sqlite/sqlite-api-clisp.lisp | 29 +++++- db-sqlite/sqlite-api-uffi.lisp | 1 + db-sqlite/sqlite-sql.lisp | 166 +++++++++++++++++++------------- debian/changelog | 6 ++ tests/test-init.lisp | 9 +- 8 files changed, 167 insertions(+), 96 deletions(-) diff --git a/ChangeLog b/ChangeLog index 25a2fd0..f7bb357 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +1 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.3 + * sql/database.lisp: Conform more to CommonSQL output + for STATUS command [Marcus Pearce] + * sql/sqlite-sql.lisp: Rework to use result-types + * sql/sqlite-api-clisp.lisp: Add compatibility layer + with sqlite-api-uffi.lisp so that sqlite-sql.lisp can + be cleaned up of most clisp reader conditionals + * sql/test-init.lisp: Now run field type tests on sqlite + backend + 30 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.10.2 * base/basic-sql.lisp: Set default value of :result-types diff --git a/TODO b/TODO index 4b160e5..4729d54 100644 --- a/TODO +++ b/TODO @@ -10,13 +10,6 @@ COMMONSQL SPEC * Incompatible - - >> Initialisation and connection - - STATUS - o what is the behaviour in CommonSQL (esp :full parameter)? - - >> The functional sql interface SELECT diff --git a/base/database.lisp b/base/database.lisp index f3c72b6..e4016d3 100644 --- a/base/database.lisp +++ b/base/database.lisp @@ -204,26 +204,38 @@ if the database connection has been lost." output, for the connected databases and initialized database types. If full is T, detailed status information is printed. The default value of full is NIL." - (declare (ignore full)) - ;; TODO: table details if full is true? (flet ((get-data () (let ((data '())) (dolist (db (connected-databases) data) - (push (list (database-name db) - (string (database-type db)) - (when (conn-pool db) "T" "NIL") - (format nil "~A" (length (database-list-tables db))) - (format nil "~A" (length (database-list-views db))) - (if (equal db *default-database*) " *" "")) - data)))) - (compute-sizes (data) + (push + (append + (list (if (equal db *default-database*) "*" "") + (database-name db) + (string-downcase (string (database-type db))) + (cond ((and (command-recording-stream db) + (result-recording-stream db)) + "Both") + ((command-recording-stream db) "Commands") + ((result-recording-stream db) "Results") + (t "nil"))) + (when full + (list + (if (conn-pool db) "t" "nil") + (format nil "~A" (length (database-list-tables db))) + (format nil "~A" (length (database-list-views db)))))) + data)))) + (compute-sizes (data) (mapcar #'(lambda (x) (apply #'max (mapcar #'length x))) (apply #'mapcar (cons #'list data)))) (print-separator (size) (format t "~&~A" (make-string size :initial-element #\-)))) + (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time))) (let ((data (get-data))) (when data - (let* ((titles (list "NAME" "TYPE" "POOLED" "TABLES" "VIEWS" "DEFAULT")) + (let* ((titles (if full + (list "" "DATABASE" "TYPE" "RECORDING" "POOLED" + "TABLES" "VIEWS") + (list "" "DATABASE" "TYPE" "RECORDING"))) (sizes (compute-sizes (cons titles data))) (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles))))) (control-string (format nil "~~&~~{~{~~~AA ~}~~}" sizes))) diff --git a/db-sqlite/sqlite-api-clisp.lisp b/db-sqlite/sqlite-api-clisp.lisp index 7e57fa2..55fee0d 100644 --- a/db-sqlite/sqlite-api-clisp.lisp +++ b/db-sqlite/sqlite-api-clisp.lisp @@ -32,7 +32,7 @@ ;;; Core API. #:sqlite-open #:sqlite-close - + ;;; New API. #:sqlite-compile #:sqlite-step @@ -50,9 +50,16 @@ ;;; Macros. #:with-open-sqlite-db - #:with-sqlite-vm)) + #:with-sqlite-vm + + ;;; Compatibility with clsql-sql-uffi.lisp + #:sqlite-aref + #:sqlite-free-table + #:make-null-vm + #:make-null-row + )) -(in-package :sqlite) +(in-package #:sqlite) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -343,6 +350,22 @@ (return-from nil) (format t "~&column name = ~A, type = ~A~%" (aref cols 1) (aref cols 2)))))))) + +;;; Compatibility with sqlite-api-uffi.lisp + +(defun sqlite-aref (row i) + (aref row i)) + +(defun sqlite-free-table (table) + (declare (ignore table)) + ) + +(defun make-null-vm () + nil) + +(defun make-null-row () + nil) + ;;;; Local Variables: ;;;; Mode: lisp diff --git a/db-sqlite/sqlite-api-uffi.lisp b/db-sqlite/sqlite-api-uffi.lisp index 73a12eb..9396515 100644 --- a/db-sqlite/sqlite-api-uffi.lisp +++ b/db-sqlite/sqlite-api-uffi.lisp @@ -10,6 +10,7 @@ ;;;; $Id$ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli +;;;; and Copyright (c) 2003-2004 by Kevin Rosenberg ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser GNU Public License diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index 703eb94..d07be2a 100644 --- a/db-sqlite/sqlite-sql.lisp +++ b/db-sqlite/sqlite-sql.lisp @@ -4,13 +4,13 @@ ;;;; ;;;; Name: sqlite-sql.lisp ;;;; Purpose: High-level SQLite interface -;;;; Authors: Aurelio Bignoli and Marcus Pearce +;;;; Authors: Aurelio Bignoli, Kevin Rosenberg, Marcus Pearce ;;;; Created: Aug 2003 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli and -;;;; Marcus Pearce +;;;; Copyright (c) 2003-2004 by Kevin Rosenberg and Marcus Pearce. ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser GNU Public License @@ -60,8 +60,7 @@ (handler-case (multiple-value-bind (data row-n col-n) (sqlite:sqlite-get-table (sqlite-db database) sql-expression) - #+clisp (declare (ignore data)) - #-clisp (sqlite:sqlite-free-table data) + (sqlite:sqlite-free-table data) (unless (= row-n 0) (error 'clsql-simple-warning :format-control @@ -75,66 +74,65 @@ :error (sqlite:sqlite-error-message err)))) t) -(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) - (sqlite:sqlite-get-table (sqlite-db database) query-expression) - #-clisp (declare (type sqlite:sqlite-row-pointer-type 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 - :expression query-expression - :errno (sqlite:sqlite-error-code err) - :error (sqlite:sqlite-error-message err))))) - -#-clisp (defstruct sqlite-result-set (vm (sqlite:make-null-vm) - :type sqlite:sqlite-vm-pointer) + #-clisp :type + #-clisp sqlite:sqlite-vm-pointer) (first-row (sqlite:make-null-row) - :type sqlite:sqlite-row-pointer-type) - (n-col 0 :type fixnum)) -#+clisp -(defstruct sqlite-result-set - (vm nil) - (first-row nil) + #-clisp :type + #-clisp sqlite:sqlite-row-pointer-type) + (col-names (sqlite:make-null-row) + #-clisp :type + #-clisp sqlite:sqlite-row-pointer-type) + (result-types nil) (n-col 0 :type fixnum)) -(defmethod database-query-result-set - ((query-expression string) (database sqlite-database) &key full-set result-types) - (declare (ignore full-set result-types)) +(defmethod database-query (query-expression (database sqlite-database) result-types field-names) + (declare (optimize (speed 3) (safety 0) (debug 0) (space 0))) (handler-case - (let* ((vm (sqlite:sqlite-compile (sqlite-db database) - query-expression)) - (result-set (make-sqlite-result-set :vm vm))) - #-clisp (declare (type sqlite:sqlite-vm-pointer vm)) + (multiple-value-bind (result-set n-col) + (database-query-result-set query-expression database + :result-types result-types + :full-set nil) + (do* ((rows nil) + (col-names (when field-names + (loop for j from 0 below n-col + collect (sqlite:sqlite-aref (sqlite-result-set-col-names result-set) j)))) + (new-row (make-list n-col) (make-list n-col)) + (row-ok (database-store-next-row result-set database new-row) + (database-store-next-row result-set database new-row))) + ((not row-ok) + (values (nreverse rows) col-names)) + (push new-row rows))) + (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))))) - ;;; To obtain column number we have to read the first row. +(defmethod database-query-result-set ((query-expression string) + (database sqlite-database) + &key result-types full-set) + (handler-case + (let ((vm (sqlite:sqlite-compile (sqlite-db database) + query-expression))) + ;;; To obtain column number/datatypes we have to read the first row. (multiple-value-bind (n-col cols col-names) (sqlite:sqlite-step vm) - (declare (ignore col-names) - #-clisp (type sqlite:sqlite-row-pointer-type cols) - ) - (setf (sqlite-result-set-first-row result-set) cols - (sqlite-result-set-n-col result-set) n-col) - (values result-set n-col nil))) + (let ((result-set (make-sqlite-result-set + :vm vm + :first-row cols + :n-col n-col + :col-names col-names + :result-types + (canonicalize-result-types + result-types + n-col + col-names)))) + (if full-set + (values result-set n-col nil) + (values result-set n-col))))) (sqlite:sqlite-error (err) (error 'clsql-sql-error :database database @@ -142,6 +140,24 @@ :errno (sqlite:sqlite-error-code err) :error (sqlite:sqlite-error-message err))))) +(defun canonicalize-result-types (result-types n-col col-names) + (when result-types + (let ((raw-types (if (eq :auto result-types) + (loop for j from n-col below (* 2 n-col) + collect (ensure-keyword (sqlite:sqlite-aref col-names j))) + result-types))) + (loop for type in raw-types + collect + (case type + ((:int :integer :tinyint :long :bigint) + :integer) + ((:float :double) + :double) + ((:numeric) + :number) + (otherwise + :string)))))) + (defmethod database-dump-result-set (result-set (database sqlite-database)) (handler-case (sqlite:sqlite-finalize (sqlite-result-set-vm result-set)) @@ -151,7 +167,8 @@ :format-arguments (list (sqlite:sqlite-error-message err)))))) (defmethod database-store-next-row (result-set (database sqlite-database) list) - (let ((n-col (sqlite-result-set-n-col result-set))) + (let ((n-col (sqlite-result-set-n-col result-set)) + (result-types (sqlite-result-set-result-types result-set))) (if (= n-col 0) ;; empty result set nil @@ -162,8 +179,7 @@ (multiple-value-bind (n new-row col-names) (sqlite:sqlite-step (sqlite-result-set-vm result-set)) (declare (ignore n col-names) - #-clisp (type sqlite:sqlite-row-pointer-type new-row) - ) + #-clisp (type sqlite:sqlite-row-pointer-type new-row)) (if (sqlite:null-row-p new-row) (return-from database-store-next-row nil) (setf row new-row))) @@ -179,10 +195,23 @@ (loop for i = 0 then (1+ i) for rest on list do (setf (car rest) - (#+clisp aref - #-clisp sqlite:sqlite-aref - row i))) - #-clisp (sqlite:sqlite-free-row row) + (let ((type (if result-types + (nth i result-types) + :string)) + (val (sqlite:sqlite-aref row i))) + (case type + (:string + val) + (:integer + (when val (parse-integer val))) + (:number + (read-from-string val)) + (:double + (when val + (coerce + (read-from-string (sqlite:sqlite-aref row i)) + 'double-float))))))) + (sqlite:sqlite-free-row row) t)))) ;;; Object listing @@ -306,9 +335,9 @@ (database-execute-command (format nil "UPDATE ~A SET is_called='t'" table-name) database) - (parse-integer (car tuple))) + (car tuple)) (t - (let ((new-pos (1+ (parse-integer (car tuple))))) + (let ((new-pos (1+ (car tuple)))) (database-execute-command (format nil "UPDATE ~A SET last_value=~D" table-name new-pos) database) @@ -316,11 +345,10 @@ (defmethod database-sequence-last (sequence-name (database sqlite-database)) (without-interrupts - (parse-integer - (caar (database-query - (concatenate 'string "SELECT last_value FROM " - (%sequence-name-to-table-name sequence-name)) - database :auto nil))))) + (caar (database-query + (concatenate 'string "SELECT last_value FROM " + (%sequence-name-to-table-name sequence-name)) + database :auto nil)))) (defmethod database-set-sequence-position (sequence-name (position integer) diff --git a/debian/changelog b/debian/changelog index acbd8ac..3e52b31 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-sql (2.10.3-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Sat, 1 May 2004 12:18:35 -0600 + cl-sql (2.10.2-1) unstable; urgency=low * New upstream diff --git a/tests/test-init.lisp b/tests/test-init.lisp index 3e6d85a..6b8dded 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -399,12 +399,9 @@ (defun compute-tests-for-backend (db-type db-underlying-type) (let ((test-forms '()) (skip-tests '())) - (dolist (test-form (append - (if (eq db-type :sqlite) - (test-basic-forms-untyped) - (test-basic-forms)) - *rt-connection* *rt-fddl* *rt-fdml* - *rt-ooddl* *rt-oodml* *rt-syntax*)) + (dolist (test-form (append (test-basic-forms) + *rt-connection* *rt-fddl* *rt-fdml* + *rt-ooddl* *rt-oodml* *rt-syntax*)) (let ((test (second test-form))) (cond ((and (null (db-type-has-views? db-underlying-type)) -- 2.34.1