db-sqlite/sqlite-api-clisp.lisp

   1 ;; sqlite.lisp  --- CLISP FFI for SQLite (http://www.sqlite.org).
   2
   3 ;; Copyright (C) 2003 Aurelio Bignoli
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU General Public License as
   7 ;; published by the Free Software Foundation; either version 2 of
   8 ;; the License, or (at your option) any later version.
   9
  10 ;; This program is distributed in the hope that it will be
  11 ;; useful, but WITHOUT ANY WARRANTY; without even the implied
  12 ;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  13 ;; PURPOSE.  See the GNU General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU General Public
  16 ;; License along with this program; if not, write to the Free
  17 ;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
  18 ;; MA 02111-1307 USA
  19
  20 ;; $Id$
  21
  22 (in-package #:cl-user)
  23
  24 (defpackage #:sqlite
  25   (:use #:common-lisp #:ffi)
  26   (:export
  27            ;;; Conditions
  28            #:sqlite-error
  29            #:sqlite-error-code
  30            #:sqlite-error-message
  31
  32            ;;; Core API.
  33            #:sqlite-open
  34            #:sqlite-close
  35
  36            ;;; New API.
  37            #:sqlite-compile
  38            #:sqlite-step
  39            #:sqlite-finalize
  40
  41            ;;; Extended API.
  42            #:sqlite-get-table
  43            #:sqlite-version             ; Defined as constant.
  44            #:sqlite-encoding            ; Defined as constant.
  45            #:sqlite-last-insert-rowid
  46
  47            ;;; Utility functions (used by CLSQL)
  48            #:make-null-row
  49            #:null-row-p
  50
  51            ;;; Macros.
  52            #:with-open-sqlite-db
  53            #:with-sqlite-vm
  54
  55            ;;; Compatibility with clsql-sql-uffi.lisp
  56            #:sqlite-aref
  57            #:sqlite-free-table
  58            #:make-null-vm
  59            #:make-null-row
  60            ))
  61
  62 (in-package #:sqlite)
  63
  64 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65 ;;;;
  66 ;;;; Return values for sqlite_exec() and sqlite_step()
  67 ;;;;
  68 (defconstant SQLITE-OK           0   "Successful result")
  69 (defconstant SQLITE-ERROR        1   "SQL error or missing database")
  70 (defconstant SQLITE-INTERNAL     2   "An internal logic error in SQLite")
  71 (defconstant SQLITE-PERM         3   "Access permission denied")
  72 (defconstant SQLITE-ABORT        4   "Callback routine requested an abort")
  73 (defconstant SQLITE-BUSY         5   "The database file is locked")
  74 (defconstant SQLITE-LOCKED       6   "A table in the database is locked")
  75 (defconstant SQLITE-NOMEM        7   "A malloc() failed")
  76 (defconstant SQLITE-READONLY     8   "Attempt to write a readonly database")
  77 (defconstant SQLITE-INTERRUPT    9   "Operation terminated by sqlite_interrupt()")
  78 (defconstant SQLITE-IOERR       10   "Some kind of disk I/O error occurred")
  79 (defconstant SQLITE-CORRUPT     11   "The database disk image is malformed")
  80 (defconstant SQLITE-NOTFOUND    12   "(Internal Only) Table or record not found")
  81 (defconstant SQLITE-FULL        13   "Insertion failed because database is full")
  82 (defconstant SQLITE-CANTOPEN    14   "Unable to open the database file")
  83 (defconstant SQLITE-PROTOCOL    15   "Database lock protocol error")
  84 (defconstant SQLITE-EMPTY       16   "(Internal Only) Database table is empty")
  85 (defconstant SQLITE-SCHEMA      17   "The database schema changed")
  86 (defconstant SQLITE-TOOBIG      18   "Too much data for one row of a table")
  87 (defconstant SQLITE-CONSTRAINT  19   "Abort due to contraint violation")
  88 (defconstant SQLITE-MISMATCH    20   "Data type mismatch")
  89 (defconstant SQLITE-MISUSE      21   "Library used incorrectly")
  90 (defconstant SQLITE-NOLFS       22   "Uses OS features not supported on host")
  91 (defconstant SQLITE-AUTH        23   "Authorization denied")
  92 (defconstant SQLITE-FORMAT      24   "Auxiliary database format error")
  93 (defconstant SQLITE-ROW         100  "sqlite_step() has another row ready")
  94 (defconstant SQLITE-DONE        101  "sqlite_step() has finished executing")
  95
  96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97 ;;;;
  98 ;;;; C types.
  99 ;;;;
 100 (def-c-type sqlite-db c-pointer)
 101 (def-c-type sqlite-vm c-pointer)
 102 (def-c-type error-message (c-ptr c-pointer))
 103                                         ; It is not NULL only in case of error.
 104
 105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 106 ;;;;
 107 ;;;; Conditions.
 108 ;;;;
 109 (define-condition sqlite-error ()
 110   ((message :initarg :message :reader sqlite-error-message :initform "")
 111    (code :initarg :code :reader sqlite-error-code))
 112   (:report (lambda (condition stream)
 113              (let ((code (sqlite-error-code condition)))
 114                (format stream "SQLite error [~A] - ~A : ~A"
 115                        code (error-string code)
 116                        (sqlite-error-message condition))))))
 117
 118 (defun signal-sqlite-error (code message)
 119   (let ((condition
 120          (make-condition 'sqlite-error
 121                          :code code
 122                          :message
 123                          (typecase message
 124                              (string message)
 125                              (t (error-message-as-string message))))))
 126     (unless (signal condition)
 127       (invoke-debugger condition))))
 128
 129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 130 ;;;;
 131 ;;;; Library functions.
 132 ;;;;
 133 (defmacro def-sqlite-call-out (name &rest args)
 134   `(def-call-out ,name
 135     (:language :stdc)
 136     (:library "libsqlite.so")
 137     ,@args))
 138
 139 (def-sqlite-call-out error-string
 140     (:name "sqlite_error_string")
 141   (:arguments
 142    (error-code int :in))
 143   (:return-type c-string))
 144
 145 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 146 ;;;;
 147 ;;;; Core API.
 148 ;;;;
 149 (def-sqlite-call-out %open
 150     (:name "sqlite_open")
 151   (:arguments
 152    (dbname c-string :in)
 153    (mode int :in)
 154    (errmsg error-message :out))
 155   (:return-type sqlite-db))
 156
 157 (def-sqlite-call-out sqlite-close
 158     (:name "sqlite_close")
 159   (:arguments (db sqlite-db :in))
 160   (:return-type nil))
 161
 162 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 163 ;;;;
 164 ;;;; New API.
 165 ;;;;
 166 (def-sqlite-call-out %compile
 167     (:name "sqlite_compile")
 168   (:arguments
 169    (db sqlite-db :in)
 170    (sql c-string :in)
 171    (sql-tail (c-ptr c-string) :out)
 172    (vm (c-ptr sqlite-vm) :out)
 173    (errmsg error-message :out))
 174   (:return-type int))
 175
 176 (def-sqlite-call-out %step
 177     (:name "sqlite_step")
 178   (:arguments
 179    (vm sqlite-vm :in)
 180    (cols-n (c-ptr int) :out)
 181    (cols (c-ptr c-pointer) :out)
 182    (col-names (c-ptr c-pointer) :out))
 183   (:return-type int))
 184
 185 (def-sqlite-call-out %finalize
 186     (:name "sqlite_finalize")
 187   (:arguments
 188    (vm sqlite-vm :in)
 189    (errmsg error-message :out))
 190   (:return-type int))
 191
 192 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 193 ;;;;
 194 ;;;; Extended API.
 195 ;;;;
 196 (def-sqlite-call-out sqlite-last-insert-rowid
 197     (:name "sqlite_last_insert_rowid")
 198   (:arguments
 199    (db sqlite-db :in))
 200   (:return-type int))
 201
 202 (def-sqlite-call-out %get-table
 203     (:name "sqlite_get_table")
 204   (:arguments
 205    (db sqlite-db :in)
 206    (sql c-string :in)
 207    (result (c-ptr c-pointer) :out)
 208    (n-row (c-ptr int) :out)
 209    (n-column (c-ptr int) :out)
 210    (errmsg error-message :out))
 211   (:return-type int))
 212
 213 (def-sqlite-call-out %free-table
 214     (:name "sqlite_free_table")
 215   (:arguments
 216    (rows c-pointer :in))
 217   (:return-type nil))
 218
 219 (def-c-var %version
 220     (:name "sqlite_version")
 221   (:library "libsqlite.so")
 222   (:type (c-array-max char 32))
 223   (:read-only t))
 224
 225 (def-c-var %encoding
 226     (:name "sqlite_encoding")
 227   (:library "libsqlite.so")
 228   (:type (c-array-max char 32))
 229   (:read-only t))
 230
 231 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 232 ;;;;
 233 ;;;; Wrapper functions.
 234 ;;;;
 235 (defconstant sqlite-version
 236   (ext:convert-string-from-bytes %version custom:*terminal-encoding*))
 237
 238 (defconstant sqlite-encoding
 239   (ext:convert-string-from-bytes %encoding custom:*terminal-encoding*))
 240
 241 (defun error-message-as-string (p)
 242   (with-c-var (p1 'c-pointer p)
 243     (prog1
 244         (cast p1 'c-string)
 245       (foreign-free p1))))
 246
 247 (defun sqlite-open (db-name &optional (mode 0))
 248   (multiple-value-bind (db error-message)
 249       (%open db-name mode)
 250     (if db
 251         db
 252         (signal-sqlite-error SQLITE-ERROR error-message))))
 253
 254 (defun c-pointer-to-string-array (p element-n)
 255   (if (null p)
 256       p
 257       (with-c-var (p1 'c-pointer p)
 258         (cast p1 `(c-ptr (c-array c-string ,element-n))))))
 259
 260 (defun sqlite-compile (db sql)
 261   (multiple-value-bind (result sql-tail vm error-message)
 262       (%compile db sql)
 263     (declare (ignore sql-tail))
 264     (if (= result SQLITE-OK)
 265         vm
 266         (signal-sqlite-error result error-message))))
 267
 268 (defun sqlite-step (vm)
 269   (multiple-value-bind (result n-col cols col-names)
 270       (%step vm)
 271     (cond
 272       ((= result SQLITE-ROW)
 273        (values n-col (c-pointer-to-string-array cols n-col)
 274                (c-pointer-to-string-array col-names (* 2 n-col))))
 275       ((= result SQLITE-DONE) (values 0 nil nil))
 276       (t (signal-sqlite-error result "sqlite-step")))))
 277
 278 (defun sqlite-finalize (vm)
 279   (multiple-value-bind (result error-message)
 280       (%finalize vm)
 281     (if (= result SQLITE-OK)
 282         t
 283         (signal-sqlite-error result error-message))))
 284
 285 (defun sqlite-get-table (db sql)
 286   (multiple-value-bind (result rows n-row n-col error-message)
 287       (%get-table db sql)
 288     (if (= result SQLITE-OK)
 289         (let ((x (c-pointer-to-string-array rows (* (1+ n-row) n-col))))
 290           (%free-table rows)
 291           (values x n-row n-col))
 292       (signal-sqlite-error result error-message))))
 293
 294 (defmacro with-open-sqlite-db ((db dbname &key (mode 0)) &body body)
 295   (let ((error-message (gensym)))
 296     `(multiple-value-bind (,db ,error-message)
 297       (sqlite-open ,dbname ,mode)
 298       (if (null ,db)
 299           (signal-sqlite-error SQLITE-ERROR ,error-message)
 300           (unwind-protect
 301                (progn ,@body)
 302             (sqlite-close ,db))))))
 303
 304 (defmacro with-sqlite-vm ((vm db sql) &body body)
 305   `(let ((,vm (sqlite-compile ,db ,sql)))
 306     (unwind-protect
 307          (progn ,@body)
 308       (sqlite-finalize ,vm))))
 309
 310 (declaim (inline null-row-p))
 311 (defun null-row-p (row)
 312   (null row))
 313
 314 (declaim (inline make-null-row))
 315 (defun make-null-row ()
 316   nil)
 317
 318 #+nil
 319 (defun test-function (db-name)
 320   (with-open-sqlite-db (db db-name)
 321     (let ((x (sqlite-get-table db "select * from sqlite_master;")))
 322       (with-sqlite-vm (vm db "select * from sqlite_master;")
 323         (let ((error-n 0))
 324           (loop  for i = 1 then (1+ i)
 325                  do (multiple-value-bind (n-col cols col-names)
 326                         (sqlite-step vm)
 327                       (declare (ignore col-names))
 328                       (if (= n-col 0)
 329                           (return-from nil)
 330                           (loop for j from 0 to (1- n-col)
 331                                 for j1 = (* n-col i) then (1+ j1)
 332                                 do
 333                                 (when (string/= (aref x j1) (aref cols j))
 334                                   (format t "~&row=~A, col=~A: ~A - ~A~%"
 335                                           i j
 336                                           (aref x j1) (aref cols j))
 337                                   (incf error-n))))))
 338           (if (= error-n 0)
 339               (format t "~&Test passed!~%")
 340               (format t "~&Test not passed. ~A errors" error-n)))))))
 341
 342 (defun get-column-types (db-name table-name)
 343   (with-open-sqlite-db (db db-name)
 344     (with-sqlite-vm (vm db (format nil "pragma table_info('~A')" table-name))
 345       (loop
 346        (multiple-value-bind (n-col cols col-names)
 347            (sqlite-step vm)
 348          (declare (ignore col-names))
 349          (if (= n-col 0)
 350              (return-from nil)
 351              (format t "~&column name = ~A, type = ~A~%"
 352                      (aref cols 1) (aref cols 2))))))))
 353
 354 ;;; Compatibility with sqlite-api-uffi.lisp
 355
 356 (defun sqlite-aref (row i)
 357   (aref row i))
 358
 359 (defun sqlite-free-table (table)
 360   (declare (ignore table))
 361   )
 362
 363 (defun make-null-vm ()
 364   nil)
 365
 366 (defun make-null-row ()
 367   nil)
 368
 369 \f
 370 ;;;; Local Variables:
 371 ;;;; Mode: lisp
 372 ;;;; Syntax: ANSI-Common-Lisp
 373 ;;;; Package: sqlite
 374 ;;;; End: