diff options
Diffstat (limited to 'db-sqlite3/sqlite3-sql.lisp')
| -rw-r--r-- | db-sqlite3/sqlite3-sql.lisp | 353 |
1 files changed, 353 insertions, 0 deletions
diff --git a/db-sqlite3/sqlite3-sql.lisp b/db-sqlite3/sqlite3-sql.lisp new file mode 100644 index 0000000..8ce592c --- /dev/null +++ b/db-sqlite3/sqlite3-sql.lisp @@ -0,0 +1,353 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite-sql.lisp +;;;; Purpose: High-level SQLite3 interface +;;;; Authors: Aurelio Bignoli & Kevin Rosenberg +;;;; Created: Oct 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004-2010 by Aurelio Bignoli & 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 +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sqlite3) + +(defclass sqlite3-database (database) + ((sqlite3-db :initarg :sqlite3-db :accessor sqlite3-db))) + +(defmethod database-type ((database sqlite3-database)) + :sqlite3) + +(defmethod database-initialize-database-type ((database-type (eql :sqlite3))) + t) + +(defun check-sqlite3-connection-spec (connection-spec) + (check-connection-spec connection-spec :sqlite3 (name &optional init-foreign-func))) + +(defmethod database-name-from-spec (connection-spec + (database-type (eql :sqlite3))) + (check-sqlite3-connection-spec connection-spec) + (princ-to-string (first connection-spec))) + +(defmethod database-connect (connection-spec (database-type (eql :sqlite3))) + (check-sqlite3-connection-spec connection-spec) + (handler-case + (let ((db (sqlite3:sqlite3-open (first connection-spec))) + (init-foreign-func (second connection-spec))) + (declare (type sqlite3:sqlite3-db-type db)) + (when init-foreign-func + (handler-case + (funcall init-foreign-func db) + (condition (c) + (progn + (sqlite3:sqlite3-close db) + (error c))))) + (make-instance 'sqlite3-database + :name (database-name-from-spec connection-spec :sqlite3) + :database-type :sqlite3 + :connection-spec connection-spec + :sqlite3-db db)) + (sqlite3:sqlite3-error (err) + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (sqlite3:sqlite3-error-code err) + :message (sqlite3:sqlite3-error-message err))))) + +(defmethod database-disconnect ((database sqlite3-database)) + (sqlite3:sqlite3-close (sqlite3-db database)) + (setf (sqlite3-db database) nil) + t) + +(defmethod database-execute-command (sql-expression (database sqlite3-database)) + (handler-case + (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database) sql-expression))) + (declare (type sqlite3:sqlite3-stmt-type stmt)) + (when stmt + (unwind-protect + (sqlite3:sqlite3-step stmt) + (sqlite3:sqlite3-finalize stmt)))) + (sqlite3:sqlite3-error (err) + (error 'sql-database-data-error + :database database + :expression sql-expression + :error-id (sqlite3:sqlite3-error-code err) + :message (sqlite3:sqlite3-error-message err)))) + t) + +(defstruct sqlite3-result-set + (stmt sqlite3:null-stmt + :type sqlite3:sqlite3-stmt-type) + (n-col 0 :type fixnum) + (col-names '()) + (result-types '())) + +(declaim (ftype (function (sqlite3:sqlite3-stmt-type fixnum t) list) get-result-types)) +(defun get-result-types (stmt n-col result-types) + (declare (type sqlite3:sqlite3-stmt-type stmt) (type fixnum n-col)) + (if (eq :auto result-types) + (loop for n from 0 below n-col + collect (let ((column-type (sqlite3:sqlite3-column-type stmt n))) + (cond + ((= column-type sqlite3:SQLITE-INTEGER) :int64) + ((= column-type sqlite3:SQLITE-FLOAT) :double) + ((= column-type sqlite3:SQLITE-TEXT) :string) + ((= column-type sqlite3:SQLITE-BLOB) :blob) + ((= column-type sqlite3:SQLITE-NULL) :string) + (t :string)))) + (loop for type in result-types + 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-query-result-set ((query-expression string) + (database sqlite3-database) + &key result-types full-set) + (let ((stmt sqlite3:null-stmt)) + (declare (type sqlite3:sqlite3-stmt-type stmt)) + (handler-case + (progn + (setf stmt (sqlite3:sqlite3-prepare (sqlite3-db database) + query-expression)) + (let* ((n-col (if (sqlite3:sqlite3-step stmt) + ;; Non empty result set. + (sqlite3:sqlite3-column-count stmt) + ;; Empty result set. + 0)) + (result-set (make-sqlite3-result-set + :stmt stmt + :n-col n-col + :col-names (loop for n from 0 below n-col + collect (sqlite3:sqlite3-column-name stmt n)) + :result-types (when (> n-col 0) + (get-result-types stmt n-col result-types))))) + (if full-set + (values result-set n-col nil) + (values result-set n-col)))) + (sqlite3:sqlite3-error (err) + (progn + (unless (eq stmt sqlite3:null-stmt) + (ignore-errors + (sqlite3:sqlite3-finalize stmt))) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (sqlite3:sqlite3-error-code err) + :message (sqlite3:sqlite3-error-message err))))))) + +(defmethod database-dump-result-set (result-set (database sqlite3-database)) + (handler-case + (sqlite3:sqlite3-finalize (sqlite3-result-set-stmt result-set)) + (sqlite3:sqlite3-error (err) + (error 'sql-database-error + :message + (format nil "Error finalizing SQLite3 statement: ~A" + (sqlite3:sqlite3-error-message err)))))) + +(defmethod database-store-next-row (result-set (database sqlite3-database) list) + (let ((n-col (sqlite3-result-set-n-col result-set))) + (if (= n-col 0) + ;; empty result set. + nil + ;; Non-empty set. + (let ((stmt (sqlite3-result-set-stmt result-set))) + (declare (type sqlite3:sqlite3-stmt-type stmt)) + ;; Store row in list. + (loop for i = 0 then (1+ i) + for rest on list + for types = (sqlite3-result-set-result-types result-set) then (rest types) + do (setf (car rest) + (if (eq (first types) :blob) + (clsql-uffi:convert-raw-field + (sqlite3:sqlite3-column-blob stmt i) + (car types) + :length (sqlite3:sqlite3-column-bytes stmt i) + :encoding (encoding database)) + (clsql-uffi:convert-raw-field + (sqlite3:sqlite3-column-text stmt i) + (car types) + :encoding (encoding database))))) + ;; Advance result set cursor. + (handler-case + (unless (sqlite3:sqlite3-step stmt) + (setf (sqlite3-result-set-n-col result-set) 0)) + (sqlite3:sqlite3-error (err) + (error 'sql-database-error + :message (format nil "Error in sqlite3-step: ~A" + (sqlite3:sqlite3-error-message err))))) + t)))) + + +(defmethod database-query (query-expression (database sqlite3-database) result-types field-names) + (declare (optimize (speed 3) (safety 0) (debug 0) (space 0))) + (handler-case + (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database) + query-expression)) + (rows '()) + (col-names '())) + (declare (type sqlite3:sqlite3-stmt-type stmt)) + (unwind-protect + (when (sqlite3:sqlite3-step stmt) + (let ((n-col (sqlite3:sqlite3-column-count stmt))) + (flet ((extract-row-data () + (loop for i from 0 below n-col + for types = (get-result-types stmt n-col result-types) then (rest types) + collect (if (eq (first types) :blob) + (clsql-uffi:convert-raw-field + (sqlite3:sqlite3-column-blob stmt i) + (car types) + :length (sqlite3:sqlite3-column-bytes stmt i) + :encoding (encoding database)) + (clsql-uffi:convert-raw-field + (sqlite3:sqlite3-column-text stmt i) + (car types) + :encoding (encoding database)))))) + (when field-names + (setf col-names (loop for n from 0 below n-col + collect (sqlite3:sqlite3-column-name stmt n)))) + (push (extract-row-data) rows) + (do* () (nil) + (if (sqlite3:sqlite3-step stmt) + (push (extract-row-data) rows) + (return)))))) + (sqlite3:sqlite3-finalize stmt)) + (values (nreverse rows) col-names)) + (sqlite3:sqlite3-error (err) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (sqlite3:sqlite3-error-code err) + :message (sqlite3:sqlite3-error-message err))))) + +;;; Object listing + +(defmethod database-list-tables-and-sequences ((database sqlite3-database) &key owner) + (declare (ignore owner)) + ;; Query is copied from .table command of sqlite3 command 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 sqlite3-database) &key owner) + (remove-if #'(lambda (s) + (and (>= (length s) 11) + (string-equal (subseq s 0 11) "_CLSQL_SEQ_"))) + (database-list-tables-and-sequences database :owner owner))) + +(defmethod database-list-views ((database sqlite3-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 nil))) + +(defmethod database-list-indexes ((database sqlite3-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 nil))) + +(defmethod database-list-table-indexes (table (database sqlite3-database) + &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)))) + +(declaim (inline sqlite3-table-info)) +(defun sqlite3-table-info (table database) + (let ((sql (format nil "PRAGMA table_info('~A')" + (clsql-sys::unescaped-database-identifier table)))) + (database-query sql database nil nil))) + +(defmethod database-list-attributes (table (database sqlite3-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'(lambda (table-info) (second table-info)) + (sqlite3-table-info table database))) + +(defmethod database-attribute-type (attribute table + (database sqlite3-database) + &key (owner nil)) + (declare (ignore owner)) + + (loop for field-info in (sqlite3-table-info table database) + when (string= (clsql-sys::unescaped-database-identifier attribute) + (second field-info)) + return + (let* ((raw-type (third field-info)) + (start-length (position #\( raw-type)) + (type (string-trim clsql-sys::+whitespace-chars+ + (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-last-auto-increment-id ((database sqlite3-database) table column) + (declare (ignore table column)) + (car (query "SELECT LAST_INSERT_ROWID();" + :flatp t :field-names nil + :database database))) + +(defmethod database-create (connection-spec (type (eql :sqlite3))) + (declare (ignore connection-spec)) + ;; databases are created automatically by Sqlite3 + t) + +(defmethod database-destroy (connection-spec (type (eql :sqlite3))) + (destructuring-bind (name) connection-spec + (if (probe-file name) + (delete-file name) + nil))) + +(defmethod database-probe (connection-spec (type (eql :sqlite3))) + (destructuring-bind (name) connection-spec + ;; TODO: Add a test that this file is a real sqlite3 database + (or (string-equal ":memory:" name) + (and (probe-file name) t)))) + +(defmethod database-get-type-specifier ((type (eql 'integer)) + args database + (db-type (eql :sqlite3))) + (declare (ignore database)) + (if args + (format nil "INTEGER(~A)" (car args)) + "INTEGER")) + +(defmethod database-get-type-specifier ((type (eql 'integer)) + args database + (db-type (eql :sqlite3))) + (declare (ignore database)) + (if args + (format nil "INTEGER(~A)" (car args)) + "INTEGER")) + +;;; Database capabilities + +(defmethod db-type-has-boolean-where? ((db-type (eql :sqlite3))) + nil) + +(defmethod db-type-has-auto-increment? ((db-type (eql :sqlite3))) + t) |