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