X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=db-sqlite%2Fsqlite-sql.lisp;h=d07be2a5f13e3814c22694d23d003ebf3476003d;hb=7cdc9aa48baa3c52923d61da6fa632eb47ac0b5d;hp=9b7a8fceae594b08d404e4541d544fa0d1a23e6c;hpb=cc92d162f24648d65ad872098353305a5baf91d7;p=clsql.git diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index 9b7a8fc..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,24 +74,36 @@ :error (sqlite:sqlite-error-message err)))) t) -(defmethod database-query (query-expression (database sqlite-database) result-types) - (declare (ignore result-types)) ; SQLite is typeless! +(defstruct sqlite-result-set + (vm (sqlite:make-null-vm) + #-clisp :type + #-clisp sqlite:sqlite-vm-pointer) + (first-row (sqlite:make-null-row) + #-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 (query-expression (database sqlite-database) result-types field-names) + (declare (optimize (speed 3) (safety 0) (debug 0) (space 0))) (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)) - (if (= row-n 0) - 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)) - )) + (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 @@ -100,37 +111,28 @@ :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) - (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) - (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-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)) - (result-set (make-sqlite-result-set :vm vm))) - #-clisp (declare (type sqlite:sqlite-vm-pointer vm)) - - ;;; To obtain column number we have to read the first row. + (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 @@ -138,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)) @@ -147,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 @@ -158,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))) @@ -175,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 @@ -188,24 +221,24 @@ ;; Query is copied from .table command of sqlite comamnd line utility. (remove-if #'(lambda (s) (and (>= (length s) 11) - (string= (subseq s 0 11) "_CLSQL_SEQ_"))) + (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)) @@ -217,12 +250,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)) @@ -235,8 +268,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))) @@ -273,7 +320,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 @@ -282,16 +329,15 @@ (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 (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) @@ -299,12 +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))))) + (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)