db-sqlite3/sqlite3-sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:     sqlite-sql.lisp
   6 ;;;; Purpose:  High-level SQLite3 interface
   7 ;;;; Authors:  Aurelio Bignoli
   8 ;;;; Created:  Oct 2004
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2004 by Aurelio Bignoli
  13 ;;;;
  14 ;;;; CLSQL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:clsql-sqlite3)
  20
  21 (defclass sqlite3-database (database)
  22   ((sqlite3-db :initarg :sqlite3-db :accessor sqlite3-db)))
  23
  24 (defmethod database-type ((database sqlite3-database))
  25   :sqlite3)
  26
  27 (defmethod database-initialize-database-type ((database-type (eql :sqlite3)))
  28   t)
  29
  30 (defun check-sqlite3-connection-spec (connection-spec)
  31   (check-connection-spec connection-spec :sqlite3 (name &optional init-foreign-func)))
  32
  33 (defmethod database-name-from-spec (connection-spec
  34                                     (database-type (eql :sqlite3)))
  35   (check-sqlite3-connection-spec connection-spec)
  36   (first connection-spec))
  37
  38 (defmethod database-connect (connection-spec (database-type (eql :sqlite3)))
  39   (check-sqlite3-connection-spec connection-spec)
  40     (handler-case
  41         (let ((db (sqlite3:sqlite3-open (first connection-spec)))
  42               (init-foreign-func (second connection-spec)))
  43           (declare (type sqlite3:sqlite3-db-type db))
  44           (when init-foreign-func
  45             (handler-case
  46                 (funcall init-foreign-func db)
  47               (condition (c)
  48                 (progn
  49                   (sqlite3:sqlite3-close db)
  50                   (error c)))))
  51           (make-instance 'sqlite3-database
  52                          :name (database-name-from-spec connection-spec :sqlite3)
  53                          :database-type :sqlite3
  54                          :connection-spec connection-spec
  55                          :sqlite3-db db))
  56       (sqlite3:sqlite3-error (err)
  57         (error 'sql-connection-error
  58                :database-type database-type
  59                :connection-spec connection-spec
  60                :error-id (sqlite3:sqlite3-error-code err)
  61                :message (sqlite3:sqlite3-error-message err)))))
  62
  63 (defmethod database-disconnect ((database sqlite3-database))
  64   (sqlite3:sqlite3-close (sqlite3-db database))
  65   (setf (sqlite3-db database) nil)
  66   t)
  67
  68 (defmethod database-execute-command (sql-expression (database sqlite3-database))
  69   (handler-case
  70       (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database) sql-expression)))
  71         (declare (type sqlite3:sqlite3-stmt-type stmt))
  72         (when stmt
  73           (unwind-protect
  74                (sqlite3:sqlite3-step stmt)
  75             (sqlite3:sqlite3-finalize stmt))))
  76     (sqlite3:sqlite3-error (err)
  77       (error 'sql-database-data-error
  78              :database database
  79              :expression sql-expression
  80              :error-id (sqlite3:sqlite3-error-code err)
  81              :message (sqlite3:sqlite3-error-message err))))
  82   t)
  83
  84 (defstruct sqlite3-result-set
  85   (stmt sqlite3:null-stmt
  86         :type sqlite3:sqlite3-stmt-type)
  87   (n-col 0 :type fixnum)
  88   (col-names '())
  89   (result-types '()))
  90
  91 (declaim (ftype (function (sqlite3:sqlite3-stmt-type fixnum t) list) get-result-types))
  92 (defun get-result-types (stmt n-col result-types)
  93   (declare (type sqlite3:sqlite3-stmt-type stmt) (type fixnum n-col))
  94   (if (eq :auto result-types)
  95       (loop for n from 0 below n-col
  96             collect (let ((column-type (sqlite3:sqlite3-column-type stmt n)))
  97                       (cond
  98                         ((= column-type sqlite3:SQLITE-INTEGER) :int64)
  99                         ((= column-type sqlite3:SQLITE-FLOAT) :double)
 100                         ((= column-type sqlite3:SQLITE-TEXT) :string)
 101                         ((= column-type sqlite3:SQLITE-BLOB) :blob)
 102                         ((= column-type sqlite3:SQLITE-NULL) :string)
 103                         (t :string))))
 104       (loop for type in result-types
 105             collect (case type
 106                       ((:int :integer :tinyint :long) :int32)
 107                       (:bigint :int64)
 108                       ((:float :double) :double)
 109                       ((:numeric) :number)
 110                       (otherwise :string)))))
 111
 112 (defmethod database-query-result-set ((query-expression string)
 113                                       (database sqlite3-database)
 114                                       &key result-types full-set)
 115   (let ((stmt sqlite3:null-stmt))
 116     (declare (type sqlite3:sqlite3-stmt-type stmt))
 117     (handler-case
 118         (progn
 119           (setf stmt (sqlite3:sqlite3-prepare (sqlite3-db database)
 120                                               query-expression))
 121           (let* ((n-col (if (sqlite3:sqlite3-step stmt)
 122                             ;; Non empty result set.
 123                             (sqlite3:sqlite3-column-count stmt)
 124                             ;; Empty result set.
 125                             0))
 126                  (result-set (make-sqlite3-result-set
 127                               :stmt stmt
 128                               :n-col n-col
 129                               :col-names (loop for n from 0 below n-col
 130                                                collect (sqlite3:sqlite3-column-name stmt n))
 131                               :result-types (when (> n-col 0)
 132                                               (get-result-types stmt n-col result-types)))))
 133             (if full-set
 134                 (values result-set n-col nil)
 135                 (values result-set n-col))))
 136     (sqlite3:sqlite3-error (err)
 137         (progn
 138           (unless (eq stmt sqlite3:null-stmt)
 139             (ignore-errors
 140               (sqlite3:sqlite3-finalize stmt)))
 141           (error 'sql-database-data-error
 142                  :database database
 143                  :expression query-expression
 144                  :error-id (sqlite3:sqlite3-error-code err)
 145                  :message (sqlite3:sqlite3-error-message err)))))))
 146
 147 (defmethod database-dump-result-set (result-set (database sqlite3-database))
 148   (handler-case
 149       (sqlite3:sqlite3-finalize (sqlite3-result-set-stmt result-set))
 150     (sqlite3:sqlite3-error (err)
 151       (error 'sql-database-error
 152              :message
 153              (format nil "Error finalizing SQLite3 statement: ~A"
 154                      (sqlite3:sqlite3-error-message err))))))
 155
 156 (defmethod database-store-next-row (result-set (database sqlite3-database) list)
 157   (let ((n-col (sqlite3-result-set-n-col result-set)))
 158     (if (= n-col 0)
 159         ;; empty result set.
 160         nil
 161         ;; Non-empty set.
 162         (let ((stmt (sqlite3-result-set-stmt result-set)))
 163           (declare (type sqlite3:sqlite3-stmt-type stmt))
 164           ;; Store row in list.
 165           (loop for i = 0 then (1+ i)
 166                 for rest on list
 167                 for types = (sqlite3-result-set-result-types result-set) then (rest types)
 168                 do (setf (car rest)
 169                          (if (eq (first types) :blob)
 170                              (clsql-uffi:convert-raw-field
 171                               (sqlite3:sqlite3-column-blob stmt i)
 172                               types 0
 173                               (sqlite3:sqlite3-column-bytes stmt i))
 174                              (clsql-uffi:convert-raw-field
 175                               (sqlite3:sqlite3-column-text stmt i)
 176                               types 0))))
 177           ;; Advance result set cursor.
 178           (handler-case
 179               (unless (sqlite3:sqlite3-step stmt)
 180                 (setf (sqlite3-result-set-n-col result-set) 0))
 181             (sqlite3:sqlite3-error (err)
 182               (error 'sql-database-error
 183                      :message "Error in sqlite3-step: ~A"
 184                      (sqlite3:sqlite3-error-message err))))
 185           t))))
 186
 187
 188 (defmethod database-query (query-expression (database sqlite3-database) result-types field-names)
 189   (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
 190   (handler-case
 191       (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database)
 192                                            query-expression))
 193             (rows '())
 194             (col-names '()))
 195         (declare (type sqlite3:sqlite3-stmt-type stmt))
 196         (unwind-protect
 197              (when (sqlite3:sqlite3-step stmt)
 198                (let ((n-col (sqlite3:sqlite3-column-count stmt)))
 199                  (flet ((extract-row-data ()
 200                           (loop for i from 0 below n-col
 201                                 for types = (get-result-types stmt n-col result-types) then (rest types)
 202                                 collect (if (eq (first types) :blob)
 203                                             (clsql-uffi:convert-raw-field
 204                                              (sqlite3:sqlite3-column-blob stmt i)
 205                                              types 0
 206                                              (sqlite3:sqlite3-column-bytes stmt i))
 207                                             (clsql-uffi:convert-raw-field
 208                                              (sqlite3:sqlite3-column-text stmt i)
 209                                              types 0)))))
 210                    (when field-names
 211                      (setf col-names (loop for n from 0 below n-col
 212                                            collect (sqlite3:sqlite3-column-name stmt n))))
 213                    (push (extract-row-data) rows)
 214                    (do* () (nil)
 215                      (if (sqlite3:sqlite3-step stmt)
 216                          (push (extract-row-data) rows)
 217                          (return))))))
 218                (sqlite3:sqlite3-finalize stmt))
 219         (values (nreverse rows) col-names))
 220     (sqlite3:sqlite3-error (err)
 221       (error 'sql-database-data-error
 222              :database database
 223              :expression query-expression
 224              :error-id (sqlite3:sqlite3-error-code err)
 225              :message (sqlite3:sqlite3-error-message err)))))
 226
 227 ;;; Object listing
 228
 229 (defmethod database-list-tables-and-sequences ((database sqlite3-database) &key owner)
 230   (declare (ignore owner))
 231   ;; Query is copied from .table command of sqlite3 command line utility.
 232   (mapcar #'car (database-query
 233                  "SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name"
 234                  database nil nil)))
 235
 236 (defmethod database-list-tables ((database sqlite3-database) &key owner)
 237   (remove-if #'(lambda (s)
 238                  (and (>= (length s) 11)
 239                       (string-equal (subseq s 0 11) "_CLSQL_SEQ_")))
 240              (database-list-tables-and-sequences database :owner owner)))
 241
 242 (defmethod database-list-views ((database sqlite3-database)
 243                                 &key (owner nil))
 244   (declare (ignore owner))
 245   (mapcar #'car (database-query
 246                  "SELECT name FROM sqlite_master WHERE type='view' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='view' ORDER BY name"
 247                  database nil nil)))
 248
 249 (defmethod database-list-indexes ((database sqlite3-database)
 250                                   &key (owner nil))
 251   (declare (ignore owner))
 252   (mapcar #'car (database-query
 253                  "SELECT name FROM sqlite_master WHERE type='index' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' ORDER BY name"
 254                  database nil nil)))
 255
 256 (defmethod database-list-table-indexes (table (database sqlite3-database)
 257                                         &key (owner nil))
 258   (declare (ignore owner))
 259   (let ((*print-circle* nil))
 260     (mapcar #'car
 261             (database-query
 262              (format
 263               nil
 264               "SELECT name FROM sqlite_master WHERE type='index' AND tbl_name='~A' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' AND tbl_name='~A' ORDER BY name"
 265               table table)
 266              database nil nil))))
 267
 268 (declaim (inline sqlite3-table-info))
 269 (defun sqlite3-table-info (table database)
 270   (database-query (format nil "PRAGMA table_info('~A')" table)
 271                   database nil nil))
 272
 273 (defmethod database-list-attributes (table (database sqlite3-database)
 274                                            &key (owner nil))
 275   (declare (ignore owner))
 276   (mapcar #'(lambda (table-info) (second table-info))
 277           (sqlite3-table-info table database)))
 278
 279 (defmethod database-attribute-type (attribute table
 280                                     (database sqlite3-database)
 281                                     &key (owner nil))
 282   (declare (ignore owner))
 283   (loop for field-info in (sqlite3-table-info table database)
 284       when (string= attribute (second field-info))
 285       return
 286         (let* ((raw-type (third field-info))
 287                (start-length (position #\( raw-type))
 288                (type (if start-length
 289                          (subseq raw-type 0 start-length)
 290                        raw-type))
 291                (length (if start-length
 292                            (parse-integer (subseq raw-type (1+ start-length))
 293                                           :junk-allowed t)
 294                          nil)))
 295           (values (when type (ensure-keyword type))
 296                   length
 297                   nil
 298                   (if (string-equal (fourth field-info) "0")
 299                       1 0)))))
 300
 301 (defmethod database-create (connection-spec (type (eql :sqlite3)))
 302   (declare (ignore connection-spec))
 303   ;; databases are created automatically by Sqlite3
 304   t)
 305
 306 (defmethod database-destroy (connection-spec (type (eql :sqlite3)))
 307   (destructuring-bind (name) connection-spec
 308     (if (probe-file name)
 309         (delete-file name)
 310         nil)))
 311
 312 (defmethod database-probe (connection-spec (type (eql :sqlite3)))
 313   (destructuring-bind (name) connection-spec
 314     ;; TODO: Add a test that this file is a real sqlite3 database
 315     (or (string-equal ":memory:" name)
 316         (and (probe-file name) t))))
 317
 318 ;;; Database capabilities
 319
 320 (defmethod db-type-has-boolean-where? ((db-type (eql :sqlite3)))
 321   nil)