PageRenderTime 44ms CodeModel.GetById 2ms app.highlight 35ms RepoModel.GetById 1ms app.codeStats 0ms

/sqlite.lisp

http://github.com/dmitryvk/cl-sqlite
Lisp | 507 lines | 439 code | 67 blank | 1 comment | 24 complexity | b556d686eef5c94a06b99cfd07d05451 MD5 | raw file
  1(defpackage :sqlite
  2  (:use :cl :iter)
  3  (:export :sqlite-error
  4           :sqlite-constraint-error
  5           :sqlite-error-db-handle
  6           :sqlite-error-code
  7           :sqlite-error-message
  8           :sqlite-error-sql
  9           :sqlite-handle
 10           :connect
 11           :set-busy-timeout
 12           :disconnect
 13           :sqlite-statement
 14           :prepare-statement
 15           :finalize-statement
 16           :step-statement
 17           :reset-statement
 18           :clear-statement-bindings
 19           :statement-column-value
 20           :statement-column-names
 21           :statement-bind-parameter-names
 22           :bind-parameter
 23           :execute-non-query
 24           :execute-to-list
 25           :execute-single
 26           :execute-single/named
 27           :execute-one-row-m-v/named
 28           :execute-to-list/named
 29           :execute-non-query/named
 30           :execute-one-row-m-v
 31           :last-insert-rowid
 32           :with-transaction
 33           :with-open-database))
 34
 35(in-package :sqlite)
 36
 37(define-condition sqlite-error (simple-error)
 38  ((handle     :initform nil :initarg :db-handle
 39               :reader sqlite-error-db-handle)
 40   (error-code :initform nil :initarg :error-code
 41               :reader sqlite-error-code)
 42   (error-msg  :initform nil :initarg :error-msg
 43               :reader sqlite-error-message)
 44   (statement  :initform nil :initarg :statement
 45               :reader sqlite-error-statement)
 46   (sql        :initform nil :initarg :sql
 47               :reader sqlite-error-sql)))
 48
 49(define-condition sqlite-constraint-error (sqlite-error)
 50  ())
 51
 52(defun sqlite-error (error-code message &key
 53                     statement
 54                     (db-handle (if statement (db statement)))
 55                     (sql-text (if statement (sql statement))))
 56  (error (if (eq error-code :constraint)
 57             'sqlite-constraint-error
 58             'sqlite-error)
 59         :format-control (if (listp message) (first message) message)
 60         :format-arguments (if (listp message) (rest message))
 61         :db-handle db-handle
 62         :error-code error-code
 63         :error-msg (if (and db-handle error-code)
 64                        (sqlite-ffi:sqlite3-errmsg (handle db-handle)))
 65         :statement statement
 66         :sql sql-text))
 67
 68(defmethod print-object :after ((obj sqlite-error) stream)
 69  (unless *print-escape*
 70    (when (or (and (sqlite-error-code obj)
 71                   (not (eq (sqlite-error-code obj) :ok)))
 72              (sqlite-error-message obj))
 73      (format stream "~&Code ~A: ~A."
 74              (or (sqlite-error-code obj) :OK)
 75              (or (sqlite-error-message obj) "no message")))
 76    (when (sqlite-error-db-handle obj)
 77      (format stream "~&Database: ~A"
 78              (database-path (sqlite-error-db-handle obj))))
 79    (when (sqlite-error-sql obj)
 80      (format stream "~&SQL: ~A" (sqlite-error-sql obj)))))
 81
 82;(declaim (optimize (speed 3) (safety 0) (debug 0)))
 83
 84(defclass sqlite-handle ()
 85  ((handle :accessor handle)
 86   (database-path :accessor database-path)
 87   (cache :accessor cache)
 88   (statements :initform nil :accessor sqlite-handle-statements))
 89  (:documentation "Class that encapsulates the connection to the database. Use connect and disconnect."))
 90
 91(defmethod initialize-instance :after ((object sqlite-handle) &key (database-path ":memory:") &allow-other-keys)
 92  (cffi:with-foreign-object (ppdb 'sqlite-ffi:p-sqlite3)
 93    (let ((error-code (sqlite-ffi:sqlite3-open database-path ppdb)))
 94      (if (eq error-code :ok)
 95          (setf (handle object) (cffi:mem-ref ppdb 'sqlite-ffi:p-sqlite3)
 96                (database-path object) database-path)
 97          (sqlite-error error-code (list "Could not open sqlite3 database ~A" database-path)))))
 98  (setf (cache object) (make-instance 'sqlite.cache:mru-cache :cache-size 16 :destructor #'really-finalize-statement)))
 99
100(defun connect (database-path &key busy-timeout)
101  "Connect to the sqlite database at the given DATABASE-PATH. Returns the SQLITE-HANDLE connected to the database. Use DISCONNECT to disconnect.
102   Operations will wait for locked databases for up to BUSY-TIMEOUT milliseconds; if BUSY-TIMEOUT is NIL, then operations on locked databases will fail immediately."
103  (let ((db (make-instance 'sqlite-handle
104                           :database-path (etypecase database-path
105                                            (string database-path)
106                                            (pathname (namestring database-path))))))
107    (when busy-timeout
108      (set-busy-timeout db busy-timeout))
109    db))
110
111(defun set-busy-timeout (db milliseconds)
112  "Sets the maximum amount of time to wait for a locked database."
113  (sqlite-ffi:sqlite3-busy-timeout (handle db) milliseconds))
114
115(defun disconnect (handle)
116  "Disconnects the given HANDLE from the database. All further operations on the handle are invalid."
117  (sqlite.cache:purge-cache (cache handle))
118  (iter (with statements = (copy-list (sqlite-handle-statements handle)))
119        (declare (dynamic-extent statements))
120        (for statement in statements)
121        (really-finalize-statement statement))
122  (let ((error-code (sqlite-ffi:sqlite3-close (handle handle))))
123    (unless (eq error-code :ok)
124      (sqlite-error error-code "Could not close sqlite3 database." :db-handle handle))
125    (slot-makunbound handle 'handle)))
126
127(defclass sqlite-statement ()
128  ((db :reader db :initarg :db)
129   (handle :accessor handle)
130   (sql :reader sql :initarg :sql)
131   (columns-count :accessor resultset-columns-count)
132   (columns-names :accessor resultset-columns-names :reader statement-column-names)
133   (parameters-count :accessor parameters-count)
134   (parameters-names :accessor parameters-names :reader statement-bind-parameter-names))
135  (:documentation "Class that represents the prepared statement."))
136
137(defmethod initialize-instance :after ((object sqlite-statement) &key &allow-other-keys)
138  (cffi:with-foreign-object (p-statement 'sqlite-ffi:p-sqlite3-stmt)
139    (cffi:with-foreign-object (p-tail '(:pointer :char))
140      (cffi:with-foreign-string (sql (sql object))
141        (let ((error-code (sqlite-ffi:sqlite3-prepare (handle (db object)) sql -1 p-statement p-tail)))
142          (unless (eq error-code :ok)
143            (sqlite-error error-code "Could not prepare an sqlite statement."
144                          :db-handle (db object) :sql-text (sql object)))
145          (unless (zerop (cffi:mem-ref (cffi:mem-ref p-tail '(:pointer :char)) :uchar))
146            (sqlite-error nil "SQL string contains more than one SQL statement." :sql-text (sql object)))
147          (setf (handle object) (cffi:mem-ref p-statement 'sqlite-ffi:p-sqlite3-stmt)
148                (resultset-columns-count object) (sqlite-ffi:sqlite3-column-count (handle object))
149                (resultset-columns-names object) (loop
150                                                    for i below (resultset-columns-count object)
151                                                    collect (sqlite-ffi:sqlite3-column-name (handle object) i))
152                (parameters-count object) (sqlite-ffi:sqlite3-bind-parameter-count (handle object))
153                (parameters-names object) (loop
154                                             for i from 1 to (parameters-count object)
155                                             collect (sqlite-ffi:sqlite3-bind-parameter-name (handle object) i))))))))
156
157(defun prepare-statement (db sql)
158  "Prepare the statement to the DB that will execute the commands that are in SQL.
159
160Returns the SQLITE-STATEMENT.
161
162SQL must contain exactly one statement.
163SQL may have some positional (not named) parameters specified with question marks.
164
165Example:
166
167 select name from users where id = ?"
168  (or (let ((statement (sqlite.cache:get-from-cache (cache db) sql)))
169        (when statement
170          (clear-statement-bindings statement))
171        statement)
172      (let ((statement (make-instance 'sqlite-statement :db db :sql sql)))
173        (push statement (sqlite-handle-statements db))
174        statement)))
175
176(defun really-finalize-statement (statement)
177  (setf (sqlite-handle-statements (db statement))
178        (delete statement (sqlite-handle-statements (db statement))))
179  (sqlite-ffi:sqlite3-finalize (handle statement))
180  (slot-makunbound statement 'handle))
181
182(defun finalize-statement (statement)
183  "Finalizes the statement and signals that associated resources may be released.
184Note: does not immediately release resources because statements are cached."
185  (reset-statement statement)
186  (sqlite.cache:put-to-cache (cache (db statement)) (sql statement) statement))
187
188(defun step-statement (statement)
189  "Steps to the next row of the resultset of STATEMENT.
190Returns T is successfully advanced to the next row and NIL if there are no more rows."
191  (let ((error-code (sqlite-ffi:sqlite3-step (handle statement))))
192    (case error-code
193      (:done nil)
194      (:row t)
195      (t
196       (sqlite-error error-code "Error while stepping an sqlite statement." :statement statement)))))
197
198(defun reset-statement (statement)
199  "Resets the STATEMENT and prepare it to be called again."
200  (let ((error-code (sqlite-ffi:sqlite3-reset (handle statement))))
201    (unless (eq error-code :ok)
202      (sqlite-error error-code "Error while resetting an sqlite statement." :statement statement))))
203
204(defun clear-statement-bindings (statement)
205  "Sets all binding values to NULL."
206  (let ((error-code (sqlite-ffi:sqlite3-clear-bindings (handle statement))))
207    (unless (eq error-code :ok)
208      (sqlite-error error-code "Error while clearing bindings of an sqlite statement."
209                    :statement statement))))
210
211(defun statement-column-value (statement column-number)
212  "Returns the COLUMN-NUMBER-th column's value of the current row of the STATEMENT. Columns are numbered from zero.
213Returns:
214 * NIL for NULL
215 * INTEGER for integers
216 * DOUBLE-FLOAT for floats
217 * STRING for text
218 * (SIMPLE-ARRAY (UNSIGNED-BYTE 8)) for BLOBs"
219  (let ((type (sqlite-ffi:sqlite3-column-type (handle statement) column-number)))
220    (ecase type
221      (:null nil)
222      (:text (sqlite-ffi:sqlite3-column-text (handle statement) column-number))
223      (:integer (sqlite-ffi:sqlite3-column-int64 (handle statement) column-number))
224      (:float (sqlite-ffi:sqlite3-column-double (handle statement) column-number))
225      (:blob (let* ((blob-length (sqlite-ffi:sqlite3-column-bytes (handle statement) column-number))
226                    (result (make-array (the fixnum blob-length) :element-type '(unsigned-byte 8)))
227                    (blob (sqlite-ffi:sqlite3-column-blob (handle statement) column-number)))
228               (loop
229                  for i below blob-length
230                  do (setf (aref result i) (cffi:mem-aref blob :unsigned-char i)))
231               result)))))
232
233(defmacro with-prepared-statement (statement-var (db sql parameters-var) &body body)
234  (let ((i-var (gensym "I"))
235        (value-var (gensym "VALUE")))
236    `(let ((,statement-var (prepare-statement ,db ,sql)))
237       (unwind-protect
238            (progn
239              (iter (for ,i-var from 1)
240                    (declare (type fixnum ,i-var))
241                    (for ,value-var in ,parameters-var)
242                    (bind-parameter ,statement-var ,i-var ,value-var))
243              ,@body)
244         (finalize-statement ,statement-var)))))
245
246(defmacro with-prepared-statement/named (statement-var (db sql parameters-var) &body body)
247  (let ((name-var (gensym "NAME"))
248        (value-var (gensym "VALUE")))
249    `(let ((,statement-var (prepare-statement ,db ,sql)))
250       (unwind-protect
251            (progn
252              (iter (for (,name-var ,value-var) on ,parameters-var by #'cddr)
253                    (bind-parameter ,statement-var (string ,name-var) ,value-var))
254              ,@body)
255         (finalize-statement ,statement-var)))))
256
257(defun execute-non-query (db sql &rest parameters)
258  "Executes the query SQL to the database DB with given PARAMETERS. Returns nothing.
259
260Example:
261
262\(execute-non-query db \"insert into users (user_name, real_name) values (?, ?)\" \"joe\" \"Joe the User\")
263
264See BIND-PARAMETER for the list of supported parameter types."
265  (declare (dynamic-extent parameters))
266  (with-prepared-statement statement (db sql parameters)
267    (step-statement statement)))
268
269(defun execute-non-query/named (db sql &rest parameters)
270  "Executes the query SQL to the database DB with given PARAMETERS. Returns nothing.
271
272PARAMETERS is a list of alternating parameter names and values.
273
274Example:
275
276\(execute-non-query db \"insert into users (user_name, real_name) values (:name, :real_name)\" \":name\" \"joe\" \":real_name\" \"Joe the User\")
277
278See BIND-PARAMETER for the list of supported parameter types."
279  (declare (dynamic-extent parameters))
280  (with-prepared-statement/named statement (db sql parameters)
281    (step-statement statement)))
282
283(defun execute-to-list (db sql &rest parameters)
284  "Executes the query SQL to the database DB with given PARAMETERS. Returns the results as list of lists.
285
286Example:
287
288\(execute-to-list db \"select id, user_name, real_name from users where user_name = ?\" \"joe\")
289=>
290\((1 \"joe\" \"Joe the User\")
291 (2 \"joe\" \"Another Joe\")) 
292
293See BIND-PARAMETER for the list of supported parameter types."
294  (declare (dynamic-extent parameters))
295  (with-prepared-statement stmt (db sql parameters)
296    (let (result)
297      (loop (if (step-statement stmt)
298                (push (iter (for i from 0 below (the fixnum (sqlite-ffi:sqlite3-column-count (handle stmt))))
299                            (declare (type fixnum i))
300                            (collect (statement-column-value stmt i)))
301                      result)
302                (return)))
303      (nreverse result))))
304
305(defun execute-to-list/named (db sql &rest parameters)
306  "Executes the query SQL to the database DB with given PARAMETERS. Returns the results as list of lists.
307
308PARAMETERS is a list of alternating parameters names and values.
309
310Example:
311
312\(execute-to-list db \"select id, user_name, real_name from users where user_name = :user_name\" \":user_name\" \"joe\")
313=>
314\((1 \"joe\" \"Joe the User\")
315 (2 \"joe\" \"Another Joe\")) 
316
317See BIND-PARAMETER for the list of supported parameter types."
318  (declare (dynamic-extent parameters))
319  (with-prepared-statement/named stmt (db sql parameters)
320    (let (result)
321      (loop (if (step-statement stmt)
322                (push (iter (for i from 0 below (the fixnum (sqlite-ffi:sqlite3-column-count (handle stmt))))
323                            (declare (type fixnum i))
324                            (collect (statement-column-value stmt i)))
325                      result)
326                (return)))
327      (nreverse result))))
328
329(defun execute-one-row-m-v (db sql &rest parameters)
330  "Executes the query SQL to the database DB with given PARAMETERS. Returns the first row as multiple values.
331
332Example:
333\(execute-one-row-m-v db \"select id, user_name, real_name from users where id = ?\" 1)
334=>
335\(values 1 \"joe\" \"Joe the User\")
336
337See BIND-PARAMETER for the list of supported parameter types."
338  (with-prepared-statement stmt (db sql parameters)
339    (if (step-statement stmt)
340        (return-from execute-one-row-m-v
341          (values-list (iter (for i from 0 below (the fixnum (sqlite-ffi:sqlite3-column-count (handle stmt))))
342                             (declare (type fixnum i))
343                             (collect (statement-column-value stmt i)))))
344        (return-from execute-one-row-m-v
345          (values-list (loop repeat (the fixnum (sqlite-ffi:sqlite3-column-count (handle stmt))) collect nil))))))
346
347(defun execute-one-row-m-v/named (db sql &rest parameters)
348  "Executes the query SQL to the database DB with given PARAMETERS. Returns the first row as multiple values.
349
350PARAMETERS is a list of alternating parameters names and values.
351
352Example:
353\(execute-one-row-m-v db \"select id, user_name, real_name from users where id = :id\" \":id\" 1)
354=>
355\(values 1 \"joe\" \"Joe the User\")
356
357See BIND-PARAMETER for the list of supported parameter types."
358  (with-prepared-statement/named stmt (db sql parameters)
359    (if (step-statement stmt)
360        (return-from execute-one-row-m-v/named
361          (values-list (iter (for i from 0 below (the fixnum (sqlite-ffi:sqlite3-column-count (handle stmt))))
362                             (declare (type fixnum i))
363                             (collect (statement-column-value stmt i)))))
364        (return-from execute-one-row-m-v/named
365          (values-list (loop repeat (the fixnum (sqlite-ffi:sqlite3-column-count (handle stmt))) collect nil))))))
366
367(defun statement-parameter-index (statement parameter-name)
368  (sqlite-ffi:sqlite3-bind-parameter-index (handle statement) parameter-name))
369
370(defun bind-parameter (statement parameter value)
371  "Sets the PARAMETER-th parameter in STATEMENT to the VALUE.
372PARAMETER may be parameter index (starting from 1) or parameters name.
373Supported types:
374 * NULL. Passed as NULL
375 * INTEGER. Passed as an 64-bit integer
376 * STRING. Passed as a string
377 * FLOAT. Passed as a double
378 * (VECTOR (UNSIGNED-BYTE 8)) and VECTOR that contains integers in range [0,256). Passed as a BLOB"
379  (let ((index (etypecase parameter
380                 (integer parameter)
381                 (string (statement-parameter-index statement parameter)))))
382    (declare (type fixnum index))
383    (let ((error-code (typecase value
384                        (null (sqlite-ffi:sqlite3-bind-null (handle statement) index))
385                        (integer (sqlite-ffi:sqlite3-bind-int64 (handle statement) index value))
386                        (double-float (sqlite-ffi:sqlite3-bind-double (handle statement) index value))
387                        (real (sqlite-ffi:sqlite3-bind-double (handle statement) index (coerce value 'double-float)))
388                        (string (sqlite-ffi:sqlite3-bind-text (handle statement) index value -1 (sqlite-ffi:destructor-transient)))
389                        ((vector (unsigned-byte 8)) (cffi:with-pointer-to-vector-data (ptr value)
390                                                      (sqlite-ffi:sqlite3-bind-blob (handle statement) index ptr (length value) (sqlite-ffi:destructor-transient))))
391                        (vector (cffi:with-foreign-object (array :unsigned-char (length value))
392                                  (loop
393                                     for i from 0 below (length value)
394                                     do (setf (cffi:mem-aref array :unsigned-char i) (aref value i)))
395                                  (sqlite-ffi:sqlite3-bind-blob (handle statement) index array (length value) (sqlite-ffi:destructor-transient))))
396                        (t
397                         (sqlite-error nil
398                                       (list "Do not know how to pass value ~A of type ~A to sqlite."
399                                             value (type-of value))
400                                       :statement statement)))))
401      (unless (eq error-code :ok)
402        (sqlite-error error-code
403                      (list "Error when binding parameter ~A to value ~A." parameter value)
404                      :statement statement)))))
405
406(defun execute-single (db sql &rest parameters)
407  "Executes the query SQL to the database DB with given PARAMETERS. Returns the first column of the first row as single value.
408
409Example:
410\(execute-single db \"select user_name from users where id = ?\" 1)
411=>
412\"joe\"
413
414See BIND-PARAMETER for the list of supported parameter types."
415  (declare (dynamic-extent parameters))
416  (with-prepared-statement stmt (db sql parameters)
417    (if (step-statement stmt)
418        (statement-column-value stmt 0)
419        nil)))
420
421(defun execute-single/named (db sql &rest parameters)
422  "Executes the query SQL to the database DB with given PARAMETERS. Returns the first column of the first row as single value.
423
424PARAMETERS is a list of alternating parameters names and values.
425
426Example:
427\(execute-single db \"select user_name from users where id = :id\" \":id\" 1)
428=>
429\"joe\"
430
431See BIND-PARAMETER for the list of supported parameter types."
432  (declare (dynamic-extent parameters))
433  (with-prepared-statement/named stmt (db sql parameters)
434    (if (step-statement stmt)
435        (statement-column-value stmt 0)
436        nil)))
437
438(defun last-insert-rowid (db)
439  "Returns the auto-generated ID of the last inserted row on the database connection DB."
440  (sqlite-ffi:sqlite3-last-insert-rowid (handle db)))
441
442(defmacro with-transaction (db &body body)
443  "Wraps the BODY inside the transaction."
444  (let ((ok (gensym "TRANSACTION-COMMIT-"))
445        (db-var (gensym "DB-")))
446    `(let (,ok
447           (,db-var ,db))
448       (execute-non-query ,db-var "begin transaction")
449       (unwind-protect
450            (multiple-value-prog1
451                (progn ,@body)
452              (setf ,ok t))
453         (if ,ok
454             (execute-non-query ,db-var "commit transaction")
455             (execute-non-query ,db-var "rollback transaction"))))))
456
457(defmacro with-open-database ((db path &key busy-timeout) &body body)
458  `(let ((,db (connect ,path :busy-timeout ,busy-timeout)))
459     (unwind-protect
460          (progn ,@body)
461       (disconnect ,db))))
462
463(defmacro-driver (FOR vars IN-SQLITE-QUERY query-expression ON-DATABASE db &optional WITH-PARAMETERS parameters)
464  (let ((statement (gensym "STATEMENT-"))
465        (kwd (if generate 'generate 'for)))
466    `(progn (with ,statement = (prepare-statement ,db ,query-expression))
467            (finally-protected (when ,statement (finalize-statement ,statement)))
468            ,@(when parameters
469                    (list `(initially ,@(iter (for i from 1)
470                                              (for value in parameters)
471                                              (collect `(sqlite:bind-parameter ,statement ,i ,value))))))
472            (,kwd ,(if (symbolp vars)
473                       `(values ,vars)
474                       `(values ,@vars))
475                  next (progn (if (step-statement ,statement)
476                                  (values ,@(iter (for i from 0 below (if (symbolp vars) 1 (length vars)))
477                                                  (collect `(statement-column-value ,statement ,i))))
478                                  (terminate)))))))
479
480(defmacro-driver (FOR vars IN-SQLITE-QUERY/NAMED query-expression ON-DATABASE db &optional WITH-PARAMETERS parameters)
481  (let ((statement (gensym "STATEMENT-"))
482        (kwd (if generate 'generate 'for)))
483    `(progn (with ,statement = (prepare-statement ,db ,query-expression))
484            (finally-protected (when ,statement (finalize-statement ,statement)))
485            ,@(when parameters
486                    (list `(initially ,@(iter (for (name value) on parameters by #'cddr)
487                                              (collect `(sqlite:bind-parameter ,statement ,name ,value))))))
488            (,kwd ,(if (symbolp vars)
489                       `(values ,vars)
490                       `(values ,@vars))
491                  next (progn (if (step-statement ,statement)
492                                  (values ,@(iter (for i from 0 below (if (symbolp vars) 1 (length vars)))
493                                                  (collect `(statement-column-value ,statement ,i))))
494                                  (terminate)))))))
495
496
497(defmacro-driver (FOR vars ON-SQLITE-STATEMENT statement)
498  (let ((statement-var (gensym "STATEMENT-"))
499        (kwd (if generate 'generate 'for)))
500    `(progn (with ,statement-var = ,statement)
501            (,kwd ,(if (symbolp vars)
502                       `(values ,vars)
503                       `(values ,@vars))
504                  next (progn (if (step-statement ,statement-var)
505                                  (values ,@(iter (for i from 0 below (if (symbolp vars) 1 (length vars)))
506                                                  (collect `(statement-column-value ,statement-var ,i))))
507                                  (terminate)))))))