db-sqlite/sqlite-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 SQLite interface
   7 ;;;; Programmers:   Aurelio Bignoli
   8 ;;;; Date Started:  Aug 2003
   9 ;;;;
  10 ;;;; $Id: sqlite-sql.lisp,v 1.5 2004/03/09 20:57:44 aurelio Exp $
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2003 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 (declaim (optimize (speed 3) (debug 0) (safety 0)))
  20
  21 (in-package :clsql-sqlite)
  22
  23 (defclass sqlite-database (database)
  24   ((sqlite-db :initarg :sqlite-db :accessor sqlite-db)))
  25
  26 (defmethod database-type ((database sqlite-database))
  27   :sqlite)
  28
  29 (defmethod database-initialize-database-type ((database-type (eql :sqlite)))
  30   t)
  31
  32 (defun check-sqlite-connection-spec (connection-spec)
  33   (check-connection-spec connection-spec :sqlite (name)))
  34
  35 (defmethod database-name-from-spec (connection-spec
  36                                     (database-type (eql :sqlite)))
  37   (check-sqlite-connection-spec connection-spec)
  38   (first connection-spec))
  39
  40 (defmethod database-connect (connection-spec (database-type (eql :sqlite)))
  41   (check-sqlite-connection-spec connection-spec)
  42   (handler-case
  43       (make-instance 'sqlite-database
  44                      :name (database-name-from-spec connection-spec :sqlite)
  45                      :sqlite-db (sqlite:sqlite-open (first connection-spec)))
  46     (sqlite:sqlite-error (err)
  47       (error 'clsql-connect-error
  48              :database-type database-type
  49              :connection-spec connection-spec
  50              :errno (sqlite:sqlite-error-code err)
  51              :error (sqlite:sqlite-error-message err)))))
  52
  53 (defmethod database-disconnect ((database sqlite-database))
  54   (sqlite:sqlite-close (sqlite-db database))
  55   (setf (sqlite-db database) nil)
  56   t)
  57
  58 (defmethod database-execute-command (sql-expression (database sqlite-database))
  59   (handler-case
  60       (multiple-value-bind (data row-n col-n)
  61           (sqlite:sqlite-get-table (sqlite-db database) sql-expression)
  62         #+clisp (declare (ignore data))
  63         #-clisp (sqlite:sqlite-free-table data)
  64         (unless (= row-n 0)
  65           (error 'clsql-simple-warning
  66                  :format-control
  67                  "Result set not empty: ~@(~A~) row~:P, ~@(~A~) column~:P "
  68                  :format-arguments (list row-n col-n))))
  69     (sqlite:sqlite-error (err)
  70       (error 'clsql-sql-error
  71              :database database
  72              :expression sql-expression
  73              :errno (sqlite:sqlite-error-code err)
  74              :error (sqlite:sqlite-error-message err))))
  75   t)
  76
  77 (defmethod database-query (query-expression (database sqlite-database) types)
  78   (declare (ignore types))              ; SQLite is typeless!
  79   (handler-case
  80       (multiple-value-bind (data row-n col-n)
  81           (sqlite:sqlite-get-table (sqlite-db database) query-expression)
  82         #-clisp (declare (type sqlite:sqlite-row-pointer data))
  83         (if (= row-n 0)
  84             nil
  85             (prog1
  86                 ;; The first col-n elements are column names.
  87                 (loop for i from col-n below (* (1+ row-n) col-n) by col-n
  88                       collect (loop for j from 0 below col-n
  89                                     collect
  90                                     (#+clisp aref
  91                                      #-clisp sqlite:sqlite-aref
  92                                              data (+ i j))))
  93                 #-clisp (sqlite:sqlite-free-table data))
  94               ))
  95     (sqlite:sqlite-error (err)
  96       (error 'clsql-sql-error
  97              :database database
  98              :expression query-expression
  99              :errno (sqlite:sqlite-error-code err)
 100              :error (sqlite:sqlite-error-message err)))))
 101
 102 #-clisp
 103 (defstruct sqlite-result-set
 104   (vm (sqlite:make-null-vm)
 105       :type sqlite:sqlite-vm-pointer)
 106   (first-row (sqlite:make-null-row)
 107              :type sqlite:sqlite-row-pointer)
 108   (n-col 0 :type fixnum))
 109 #+clisp
 110 (defstruct sqlite-result-set
 111   (vm nil)
 112   (first-row nil)
 113   (n-col 0 :type fixnum))
 114
 115 (defmethod database-query-result-set
 116     (query-expression (database sqlite-database) &key full-set types)
 117   (declare (ignore full-set types))
 118   (handler-case
 119       (let* ((vm (sqlite:sqlite-compile (sqlite-db database)
 120                                         query-expression))
 121              (result-set (make-sqlite-result-set :vm vm)))
 122         #-clisp (declare (type sqlite:sqlite-vm-pointer vm))
 123
 124         ;;; To obtain column number we have to read the first row.
 125         (multiple-value-bind (n-col cols col-names)
 126             (sqlite:sqlite-step vm)
 127           (declare (ignore col-names)
 128                    #-clisp (type sqlite:sqlite-row-pointer cols)
 129                    )
 130           (setf (sqlite-result-set-first-row result-set) cols
 131                 (sqlite-result-set-n-col result-set) n-col)
 132           (values result-set n-col nil)))
 133     (sqlite:sqlite-error (err)
 134       (error 'clsql-sql-error
 135              :database database
 136              :expression query-expression
 137              :errno (sqlite:sqlite-error-code err)
 138              :error (sqlite:sqlite-error-message err)))))
 139
 140 (defmethod database-dump-result-set (result-set (database sqlite-database))
 141   (declare (ignore database))
 142   (handler-case
 143       (sqlite:sqlite-finalize (sqlite-result-set-vm result-set))
 144     (sqlite:sqlite-error (err)
 145       (error 'clsql-simple-error
 146              :format-control "Error finalizing SQLite VM: ~A"
 147              :format-arguments (list (sqlite:sqlite-error-message err))))))
 148
 149 (defmethod database-store-next-row (result-set (database sqlite-database) list)
 150   (let ((n-col (sqlite-result-set-n-col result-set)))
 151     (if (= n-col 0)
 152         ;; empty result set
 153         nil
 154         (let ((row (sqlite-result-set-first-row result-set)))
 155           (if (sqlite:null-row-p row)
 156               ;; First row already used. fetch another row from DB.
 157               (handler-case
 158                   (multiple-value-bind (n new-row col-names)
 159                       (sqlite:sqlite-step (sqlite-result-set-vm result-set))
 160                     (declare (ignore n col-names)
 161                              #-clisp (type sqlite:sqlite-row-pointer new-row)
 162                              )
 163                     (if (sqlite:null-row-p new-row)
 164                         (return-from database-store-next-row nil)
 165                         (setf row new-row)))
 166                 (sqlite:sqlite-error (err)
 167                   (error 'clsql-simple-error
 168                          :format-control "Error in sqlite-step: ~A"
 169                          :format-arguments
 170                          (list (sqlite:sqlite-error-message err)))))
 171
 172               ;; Use the row previously read by database-query-result-set.
 173               (setf (sqlite-result-set-first-row result-set)
 174                     (sqlite:make-null-row)))
 175           (loop for i = 0 then (1+ i)
 176                 for rest on list
 177                 do (setf (car rest)
 178                          (#+clisp aref
 179                           #-clisp sqlite:sqlite-aref
 180                           row i)))
 181           #-clisp (sqlite:sqlite-free-row row)
 182           t))))