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