X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=db-sqlite%2Fsqlite-sql.lisp;h=e0c7464628ea7d0e8f51a6f3de0e611f54a1fd52;hp=befc8850e497b850a7a579923b9f679ac480034a;hb=e567409d9fff3f7231c2a0bb69b345e19de2b246;hpb=e7359cb3f285d3a53b768b13484caf11bc6f47b1 diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index befc885..e0c7464 100644 --- a/db-sqlite/sqlite-sql.lisp +++ b/db-sqlite/sqlite-sql.lisp @@ -32,7 +32,7 @@ (check-connection-spec connection-spec :sqlite (name))) (defmethod database-name-from-spec (connection-spec - (database-type (eql :sqlite))) + (database-type (eql :sqlite))) (check-sqlite-connection-spec connection-spec) (first connection-spec)) @@ -40,16 +40,16 @@ (check-sqlite-connection-spec connection-spec) (handler-case (make-instance 'sqlite-database - :name (database-name-from-spec connection-spec :sqlite) - :database-type :sqlite - :connection-spec connection-spec - :sqlite-db (sqlite:sqlite-open (first connection-spec))) + :name (database-name-from-spec connection-spec :sqlite) + :database-type :sqlite + :connection-spec connection-spec + :sqlite-db (sqlite:sqlite-open (first connection-spec))) (sqlite:sqlite-error (err) - (error 'clsql-connect-error - :database-type database-type - :connection-spec connection-spec - :errno (sqlite:sqlite-error-code err) - :error (sqlite:sqlite-error-message err))))) + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (sqlite:sqlite-error-code err) + :message (sqlite:sqlite-error-message err))))) (defmethod database-disconnect ((database sqlite-database)) (sqlite:sqlite-close (sqlite-db database)) @@ -59,179 +59,192 @@ (defmethod database-execute-command (sql-expression (database sqlite-database)) (handler-case (multiple-value-bind (data row-n col-n) - (sqlite:sqlite-get-table (sqlite-db database) sql-expression) - (sqlite:sqlite-free-table data) - (unless (= row-n 0) - (error 'clsql-simple-warning - :format-control - "Result set not empty: ~@(~A~) row~:P, ~@(~A~) column~:P " - :format-arguments (list row-n col-n)))) + (sqlite:sqlite-get-table (sqlite-db database) sql-expression) + (sqlite:sqlite-free-table data) + (unless (= row-n 0) + (error 'sql-warning + :format-control + "Result set not empty: ~@(~A~) row~:P, ~@(~A~) column~:P " + :format-arguments (list row-n col-n)))) (sqlite:sqlite-error (err) - (error 'clsql-sql-error - :database database - :expression sql-expression - :errno (sqlite:sqlite-error-code err) - :error (sqlite:sqlite-error-message err)))) + (error 'sql-database-data-error + :database database + :expression sql-expression + :error-id (sqlite:sqlite-error-code err) + :message (sqlite:sqlite-error-message err)))) t) (defstruct sqlite-result-set (vm (sqlite:make-null-vm) - #-clisp :type - #-clisp sqlite:sqlite-vm-pointer) + :type sqlite:sqlite-vm-pointer) (first-row (sqlite:make-null-row) - #-clisp :type - #-clisp sqlite:sqlite-row-pointer-type) + :type sqlite:sqlite-row-pointer-type) (col-names (sqlite:make-null-row) - #-clisp :type - #-clisp sqlite:sqlite-row-pointer-type) + :type 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 (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))) + (let ((vm (sqlite:sqlite-compile (sqlite-db database) + query-expression)) + (rows '()) + (col-names '())) + (unwind-protect + ;; Read the first row to get column number and names. + (multiple-value-bind (n-col new-row sqlite-col-names) + (sqlite:sqlite-step vm) + (declare (type sqlite:sqlite-row-pointer-type new-row)) + (when (> n-col 0) + (when field-names + (setf col-names (loop for i from 0 below n-col + collect (sqlite:sqlite-aref sqlite-col-names i)))) + (let ((canonicalized-result-types + (canonicalize-result-types result-types n-col sqlite-col-names))) + (flet ((extract-row-data (row) + (declare (type sqlite:sqlite-row-pointer-type row)) + (loop for i from 0 below n-col + collect (clsql-uffi:convert-raw-field + (sqlite:sqlite-raw-aref row i) + canonicalized-result-types i)))) + (push (extract-row-data new-row) rows) + + ;; Read subsequent rows. + (do () (nil) + (multiple-value-bind (n-col new-row) + (sqlite:sqlite-step vm) + (declare (type sqlite:sqlite-row-pointer-type new-row)) + (if (> n-col 0) + (push (extract-row-data new-row) rows) + (return)))))))) + (sqlite:sqlite-finalize vm)) + (values (nreverse rows) col-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))))) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (sqlite:sqlite-error-code err) + :message (sqlite:sqlite-error-message err))))) (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) - (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 - :expression query-expression - :errno (sqlite:sqlite-error-code err) - :error (sqlite:sqlite-error-message err))))) + (database sqlite-database) + &key result-types full-set) + (let ((vm nil)) + (handler-case + (progn + (setf 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 (type sqlite:sqlite-row-pointer-type cols)) + (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) + (progn + (when vm + ;; The condition was thrown by sqlite-step, vm must be + ;; deallocated. + (ignore-errors + (sqlite:sqlite-finalize vm))) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (sqlite:sqlite-error-code err) + :message (sqlite:sqlite-error-message err))11))))) (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 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) - :int32) - ((:float :double) - :double) - ((:numeric) - :number) - (otherwise - :string)))))) + collect + (case type + ((:int :integer :tinyint) + :int32) + (:long #+(or x86-64 64bit) :int64 #-(or x86-64 64bit) :int32) + (:bigint + :int64) + ((: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)) (sqlite:sqlite-error (err) - (error 'clsql-simple-error - :format-control "Error finalizing SQLite VM: ~A" - :format-arguments (list (sqlite:sqlite-error-message err)))))) + (error 'sql-database-error + :message + (format nil "Error finalizing SQLite VM: ~A" + (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)) - (result-types (sqlite-result-set-result-types result-set))) + (result-types (sqlite-result-set-result-types result-set))) (if (= n-col 0) - ;; empty result set - nil - (let ((row (sqlite-result-set-first-row result-set))) - (if (sqlite:null-row-p row) - ;; First row already used. fetch another row from DB. - (handler-case - (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)) - (if (sqlite:null-row-p new-row) - (return-from database-store-next-row nil) - (setf row new-row))) - (sqlite:sqlite-error (err) - (error 'clsql-simple-error - :format-control "Error in sqlite-step: ~A" - :format-arguments - (list (sqlite:sqlite-error-message err))))) - - ;; Use the row previously read by database-query-result-set. - (setf (sqlite-result-set-first-row result-set) - (sqlite:make-null-row))) - (loop for i = 0 then (1+ i) - for rest on list - do (setf (car rest) - #-clisp - (clsql-uffi:convert-raw-field - (uffi:deref-array - (uffi:deref-pointer row 'sqlite:sqlite-row-pointer) '(:array (* :char)) i) - result-types - i) - #+clisp - (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 val) - 'double-float))))))) - (sqlite:sqlite-free-row row) - t)))) + ;; empty result set + nil + (let ((row (sqlite-result-set-first-row result-set))) + (if (sqlite:null-row-p row) + ;; First row already used. fetch another row from DB. + (handler-case + (multiple-value-bind (n new-row col-names) + (sqlite:sqlite-step (sqlite-result-set-vm result-set)) + (declare (ignore n col-names) + (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))) + (sqlite:sqlite-error (err) + (error 'sql-database-error + :message + (format nil "Error in sqlite-step: ~A" + (sqlite:sqlite-error-message err))))) + + ;; Use the row previously read by database-query-result-set. + (setf (sqlite-result-set-first-row result-set) + (sqlite:make-null-row))) + (loop for i = 0 then (1+ i) + for rest on list + do (setf (car rest) + (clsql-uffi:convert-raw-field + (sqlite:sqlite-raw-aref row i) + result-types + i))) + (sqlite:sqlite-free-row row) + t)))) ;;; Object listing -(defmethod database-list-tables ((database sqlite-database) &key owner) +(defmethod database-list-tables-and-sequences ((database sqlite-database) &key owner) (declare (ignore owner)) ;; Query is copied from .table command of sqlite comamnd line utility. + (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 nil nil))) + +(defmethod database-list-tables ((database sqlite-database) &key owner) (remove-if #'(lambda (s) (and (>= (length s) 11) (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 nil nil)))) + (database-list-tables-and-sequences database :owner owner))) (defmethod database-list-views ((database sqlite-database) &key (owner nil)) @@ -248,124 +261,49 @@ database nil nil))) (defmethod database-list-table-indexes (table (database sqlite-database) - &key (owner nil)) + &key (owner nil)) (declare (ignore owner)) (let ((*print-circle* nil)) - (mapcar #'car - (database-query - (format - 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 nil)))) + (mapcar #'car + (database-query + (format + 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 nil)))) (declaim (inline sqlite-table-info)) (defun sqlite-table-info (table database) (database-query (format nil "PRAGMA table_info('~A')" table) - database nil nil)) + database nil nil)) (defmethod database-list-attributes (table (database sqlite-database) &key (owner nil)) (declare (ignore owner)) (mapcar #'(lambda (table-info) (second table-info)) - (sqlite-table-info table database))) + (sqlite-table-info table database))) -(defmethod database-attribute-type (attribute table - (database sqlite-database) +(defmethod database-attribute-type (attribute table + (database sqlite-database) &key (owner nil)) (declare (ignore owner)) (loop for field-info in (sqlite-table-info table database) 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))) - -(defun %table-name-to-sequence-name (table-name) - (and (>= (length table-name) 11) - (string= (subseq table-name 0 11) "_CLSQL_SEQ_") - (subseq table-name 11))) - - -(defmethod database-create-sequence (sequence-name - (database sqlite-database)) - (let ((table-name (%sequence-name-to-table-name sequence-name))) - (database-execute-command - (concatenate 'string "CREATE TABLE " table-name - " (last_value integer PRIMARY KEY, increment_by integer, min_value integer, is_called char(1))") - database) - (database-execute-command - (concatenate 'string "INSERT INTO " table-name - " VALUES (1,1,1,'f')") - database))) - -(defmethod database-drop-sequence (sequence-name - (database sqlite-database)) - (database-execute-command - (concatenate 'string "DROP TABLE " (%sequence-name-to-table-name sequence-name)) - database)) - -(defmethod database-list-sequences ((database sqlite-database) - &key (owner nil)) - (declare (ignore owner)) - (mapcan #'(lambda (s) - (let ((sn (%table-name-to-sequence-name (car s)))) - (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 nil nil))) - -(defmethod database-sequence-next (sequence-name (database sqlite-database)) - (without-interrupts - (let* ((table-name (%sequence-name-to-table-name sequence-name)) - (tuple - (car (database-query - (concatenate 'string "SELECT last_value,is_called FROM " - table-name) - 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) - (car tuple)) - (t - (let ((new-pos (1+ (car tuple)))) - (database-execute-command - (format nil "UPDATE ~A SET last_value=~D" table-name new-pos) - database) - new-pos)))))) - -(defmethod database-sequence-last (sequence-name (database sqlite-database)) - (without-interrupts - (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) - (database sqlite-database)) - (database-execute-command - (format nil "UPDATE ~A SET last_value=~A,is_called='t'" - (%sequence-name-to-table-name sequence-name) - position) - database) - position) + 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))))) (defmethod database-create (connection-spec (type (eql :sqlite))) (declare (ignore connection-spec)) @@ -375,14 +313,14 @@ (defmethod database-destroy (connection-spec (type (eql :sqlite))) (destructuring-bind (name) connection-spec (if (probe-file name) - (delete-file name) - nil))) + (delete-file name) + nil))) (defmethod database-probe (connection-spec (type (eql :sqlite))) (destructuring-bind (name) connection-spec ;; TODO: Add a test that this file is a real sqlite database (or (string-equal ":memory:" name) - (and (probe-file name) t)))) + (and (probe-file name) t)))) ;;; Database capabilities