db-sqlite/sqlite-api.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:     sqlite-api-uffi.lisp
   6 ;;;; Purpose:  Low-level SQLite interface using UFFI
   7 ;;;; Authors:  Aurelio Bignoli and Kevin Rosenberg
   8 ;;;; Created:  Nov 2003
   9 ;;;;
  10 ;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli
  11 ;;;; and Copyright (c) 2003-2004 by Kevin Rosenberg
  12 ;;;;
  13 ;;;; CLSQL users are granted the rights to distribute and use this software
  14 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  15 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  16 ;;;; *************************************************************************
  17
  18 (in-package #:cl-user)
  19
  20 (defpackage #:sqlite
  21   (:use #:common-lisp #:uffi)
  22     (:export
  23            ;;; Conditions
  24            #:sqlite-error
  25            #:sqlite-error-code
  26            #:sqlite-error-message
  27
  28            ;;; Core API.
  29            #:sqlite-open
  30            #:sqlite-close
  31
  32            ;;; New API.
  33            #:sqlite-compile
  34            #:sqlite-step
  35            #:sqlite-finalize
  36
  37            ;;; Extended API.
  38            #:sqlite-get-table
  39            #:sqlite-free-table
  40            #:sqlite-version             ; Defined as constant.
  41            #:sqlite-encoding            ; Defined as constant.
  42            #:sqlite-last-insert-rowid
  43
  44            ;;; Utility functions.
  45            #:make-null-row
  46            #:make-null-vm
  47            #:null-row-p
  48            #:sqlite-aref
  49            #:sqlite-raw-aref
  50            #:sqlite-free-row
  51
  52            ;;; Types.
  53            #:sqlite-row
  54            #:sqlite-row-pointer
  55            #:sqlite-row-pointer-type
  56            #:sqlite-vm-pointer))
  57
  58 (in-package #:sqlite)
  59
  60 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61 ;;;;
  62 ;;;; Return values for sqlite_exec() and sqlite_step()
  63 ;;;;
  64 (defconstant SQLITE-OK            0  "Successful result")
  65 (defconstant SQLITE-ERROR         1  "SQL error or missing database")
  66 (defconstant SQLITE-ROW         100  "sqlite_step() has another row ready")
  67 (defconstant SQLITE-DONE        101  "sqlite_step() has finished executing")
  68
  69 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70 ;;;;
  71 ;;;; Conditions.
  72 ;;;;
  73 (define-condition sqlite-error ()
  74   ((message :initarg :message :reader sqlite-error-message :initform "")
  75    (code :initarg :code :reader sqlite-error-code))
  76   (:report (lambda (condition stream)
  77              (let ((code (sqlite-error-code condition)))
  78                (format stream "SQLite error [~A]: ~A"
  79                        code (sqlite-error-message condition))))))
  80
  81 (defun signal-sqlite-error (code &optional message)
  82   (let ((condition
  83          (make-condition 'sqlite-error
  84                          :code code
  85                          :message (if message
  86                                       message
  87                                     (uffi:convert-from-cstring
  88                                      (sqlite-error-string code))))))
  89     (unless (signal condition)
  90       (invoke-debugger condition))))
  91
  92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93 ;;;;
  94 ;;;; Foreign types definitions.
  95 ;;;;
  96 (def-foreign-type errmsg (* :unsigned-char))
  97 (def-foreign-type sqlite-db :pointer-void)
  98 (def-foreign-type sqlite-vm :pointer-void)
  99 (def-foreign-type string-pointer (* (* :unsigned-char)))
 100 (def-foreign-type sqlite-row-pointer (* (* :unsigned-char)))
 101
 102 (defvar +null-errmsg-pointer+ (make-null-pointer 'errmsg))
 103 (defvar +null-string-pointer-pointer+ (make-null-pointer 'string-pointer))
 104
 105
 106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 107 ;;;
 108 ;;; Lisp types used in declarations.
 109 ;;;;
 110 (def-type sqlite-db-type sqlite-db)
 111 (def-type sqlite-row string-pointer)
 112 (def-type sqlite-row-pointer-type (* string-pointer))
 113 (def-type sqlite-vm-pointer (* sqlite-vm))
 114
 115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 116 ;;;;
 117 ;;;; Library functions.
 118 ;;;;
 119 (defmacro def-sqlite-function (name args &key (returning :void))
 120   `(def-function ,name ,args
 121     :module "sqlite"
 122     :returning ,returning))
 123
 124 (def-sqlite-function
 125     "sqlite_error_string"
 126     ((error-code :int))
 127   :returning :cstring)
 128
 129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 130 ;;;;
 131 ;;;; Core API.
 132 ;;;;
 133 (declaim (inline %open))
 134 (def-sqlite-function
 135     ("sqlite_open" %open)
 136     ((dbname :cstring)
 137      (mode :int)
 138      (error-message (* errmsg)))
 139   :returning sqlite-db)
 140
 141 (declaim (inline sqlite-close))
 142 (def-sqlite-function
 143     "sqlite_close"
 144     ((db sqlite-db)))
 145
 146 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 147 ;;;;
 148 ;;;; New API.
 149 ;;;;
 150 (declaim (inline %compile))
 151 (def-sqlite-function
 152     ("sqlite_compile" %compile)
 153     ((db sqlite-db)
 154      (sql :cstring)
 155      (sql-tail (* (* :unsigned-char)))
 156      (vm (* sqlite-vm))
 157      (error-message (* errmsg)))
 158   :returning :int)
 159
 160 (declaim (inline %step))
 161 (def-sqlite-function
 162     ("sqlite_step" %step)
 163     ((vm sqlite-vm)
 164      (cols-n (* :int))
 165      (cols (* (* (* :unsigned-char))))
 166      (col-names (* (* (* :unsigned-char)))))
 167   :returning :int)
 168
 169 (declaim (inline %finalize))
 170 (def-sqlite-function
 171     ("sqlite_finalize" %finalize)
 172     ((vm sqlite-vm)
 173      (error-message (* errmsg)))
 174   :returning :int)
 175
 176 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 177 ;;;;
 178 ;;;; Extended API.
 179 ;;;;
 180 (declaim (inline sqlite-last-insert-rowid))
 181 (def-sqlite-function
 182     "sqlite_last_insert_rowid"
 183     ((db sqlite-db))
 184   :returning :int)
 185
 186 (declaim (inline %get-table))
 187 (def-sqlite-function
 188     ("sqlite_get_table" %get-table)
 189     ((db sqlite-db)
 190      (sql :cstring)
 191      (result (* (* (* :unsigned-char))))
 192      (rows-n (* :int))
 193      (cols-n (* :int))
 194      (error-message (* errmsg)))
 195   :returning :int)
 196
 197 (declaim (inline %free-table))
 198 (def-sqlite-function
 199     ("sqlite_free_table" %free-table)
 200     ((rows :pointer-void)))
 201
 202 (declaim (inline sqlite-libversion))
 203 (def-sqlite-function
 204     "sqlite_libversion"
 205     ()
 206   :returning :cstring)
 207
 208 (declaim (inline sqlite-libencoding))
 209 (def-sqlite-function
 210     "sqlite_libencoding"
 211     ()
 212   :returning :cstring)
 213
 214 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 215 ;;;;
 216 ;;;; Wrapper functions.
 217 ;;;;
 218 (defparameter sqlite-version (sqlite-libversion))
 219 (defparameter sqlite-encoding (sqlite-libencoding))
 220
 221 (defun sqlite-open (db-name &optional (mode 0))
 222   (with-cstring (db-name-native db-name)
 223     (let ((db (%open db-name-native mode +null-errmsg-pointer+)))
 224       (if (null-pointer-p db)
 225           (signal-sqlite-error SQLITE-ERROR
 226                                (format nil "unable to open ~A" db-name))
 227           db))))
 228
 229 (defun sqlite-compile (db sql)
 230   (with-cstring (sql-native sql)
 231     (let ((vm (allocate-foreign-object 'sqlite-vm)))
 232       (with-foreign-object (sql-tail '(* :unsigned-char))
 233         (let ((result (%compile db sql-native sql-tail vm +null-errmsg-pointer+)))
 234           (if (= result SQLITE-OK)
 235               vm
 236               (progn
 237                 (free-foreign-object vm)
 238                 (signal-sqlite-error result))))))))
 239
 240 (defun sqlite-step (vm)
 241   (declare (type sqlite-vm-pointer vm))
 242   (with-foreign-object (cols-n :int)
 243     (let ((cols (allocate-foreign-object '(* (* :unsigned-char))))
 244           (col-names (allocate-foreign-object '(* (* :unsigned-char)))))
 245       (declare (type sqlite-row-pointer-type cols col-names))
 246       (let ((result (%step (deref-pointer vm 'sqlite-vm)
 247                            cols-n cols col-names)))
 248         (cond
 249           ((= result SQLITE-ROW)
 250            (let ((n (deref-pointer cols-n :int)))
 251              (values n cols col-names)))
 252           ((= result SQLITE-DONE)
 253            (free-foreign-object cols)
 254            (free-foreign-object col-names)
 255            (values 0 +null-string-pointer-pointer+ +null-string-pointer-pointer+))
 256           (t
 257            (free-foreign-object cols)
 258            (free-foreign-object col-names)
 259            (signal-sqlite-error result)))))))
 260
 261 (defun sqlite-finalize (vm)
 262   (declare (type sqlite-vm-pointer vm))
 263   (let ((result (%finalize (deref-pointer vm 'sqlite-vm) +null-errmsg-pointer+)))
 264     (if (= result SQLITE-OK)
 265         (progn
 266           (free-foreign-object vm)
 267           t)
 268         (signal-sqlite-error result))))
 269
 270 (defun sqlite-get-table (db sql)
 271   (declare (type sqlite-db-type db))
 272   (with-cstring (sql-native sql)
 273     (let ((rows (allocate-foreign-object '(* (* :unsigned-char)))))
 274       (declare (type sqlite-row-pointer-type rows))
 275       (with-foreign-object (rows-n :int)
 276         (with-foreign-object (cols-n :int)
 277           (let ((result (%get-table db sql-native rows rows-n cols-n +null-errmsg-pointer+)))
 278             (if (= result SQLITE-OK)
 279                 (let ((cn (deref-pointer cols-n :int))
 280                       (rn (deref-pointer rows-n :int)))
 281                   (values rows rn cn))
 282                 (progn
 283                   (free-foreign-object rows)
 284                   (signal-sqlite-error result)))))))))
 285
 286 (declaim (inline sqlite-free-table))
 287 (defun sqlite-free-table (table)
 288   (declare (type sqlite-row-pointer-type table))
 289   (%free-table (deref-pointer table 'sqlite-row-pointer)))
 290
 291 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 292 ;;;;
 293 ;;;; Utility functions.
 294 ;;;;
 295 (declaim (inline make-null-row))
 296 (defun make-null-row ()
 297   +null-string-pointer-pointer+)
 298
 299 (declaim (inline make-null-vm))
 300 (defun make-null-vm ()
 301   (uffi:make-null-pointer 'sqlite-vm))
 302
 303 (declaim (inline null-row-p))
 304 (defun null-row-p (row)
 305   (null-pointer-p row))
 306
 307 (declaim (inline sqlite-aref))
 308 (defun sqlite-aref (a n)
 309   (declare (type sqlite-row-pointer-type a))
 310   (convert-from-foreign-string
 311    (deref-array (deref-pointer a 'sqlite-row-pointer) '(:array (* :unsigned-char)) n)))
 312
 313 (declaim (inline sqlite-raw-aref))
 314 (defun sqlite-raw-aref (a n)
 315   (declare (type sqlite-row-pointer-type a))
 316   (deref-array (deref-pointer a 'sqlite-row-pointer) '(:array (* :unsigned-char)) n))
 317
 318 (declaim (inline sqlite-free-row))
 319 (defun sqlite-free-row (row)
 320   (declare (type sqlite-row-pointer-type row))
 321   (free-foreign-object row))