sql/generic-odbc.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; $Id$
   5 ;;;;
   6 ;;;; Generic ODBC layer, used by db-odbc and db-aodbc backends
   7 ;;;;
   8 ;;;; This file is part of CLSQL.
   9 ;;;;
  10 ;;;; CLSQL users are granted the rights to distribute and use this software
  11 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  12 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  13 ;;;; *************************************************************************
  14
  15 (in-package #:clsql-sys)
  16
  17 (defclass generic-odbc-database (database)
  18   ((dbi-package :initarg :dbi-package :reader dbi-package)
  19    (odbc-conn :initarg :odbc-conn :initform nil :accessor odbc-conn)
  20    (disconnect-fn :reader disconnect-fn)
  21    (sql-fn :reader sql-fn)
  22    (close-query-fn :reader close-query-fn)
  23    (fetch-row :reader fetch-row-fn)
  24    (list-all-database-tables-fn :reader list-all-database-tables-fn)
  25    (list-all-table-columns-fn :reader list-all-table-columns-fn))
  26   (:documentation "Encapsulate same behavior across odbc and aodbc backends."))
  27
  28 (defmethod initialize-instance :after ((db generic-odbc-database)
  29                                         &rest all-keys)
  30   (unless (slot-boundp db 'dbi-package)
  31     (error "dbi-package not specified."))
  32   (let ((pkg (slot-value db 'dbi-package)))
  33     (unless pkg
  34       (error "dbi-package is nil."))
  35     (setf (slot-value db 'disconnect-fn)
  36           (intern (symbol-name '#:disconnect) pkg)
  37           (slot-value db 'sql-fn)
  38           (intern (symbol-name '#:sql) pkg)
  39           (slot-value db 'close-query-fn)
  40           (intern (symbol-name '#:close-query) pkg)
  41           (slot-value db 'fetch-row)
  42           (intern (symbol-name '#:fetch-row) pkg)
  43           (slot-value db 'list-all-database-tables-fn)
  44           (intern (symbol-name '#:list-all-database-tables) pkg)
  45           (slot-value db 'list-all-table-columns-fn)
  46           (intern (symbol-name '#:list-all-table-columns) pkg))))
  47
  48 ;;; Object methods
  49
  50 (defmethod read-sql-value (val (type (eql 'boolean))
  51                            (database generic-odbc-database)
  52                            (db-type (eql :postgresql)))
  53   (if (string= "0" val) nil t))
  54
  55
  56 ;;; Backend methods
  57
  58 (defmethod database-disconnect ((database generic-odbc-database))
  59   (funcall (disconnect-fn database) (odbc-conn database))
  60   (setf (odbc-conn database) nil)
  61   t)
  62
  63 (defmethod database-query (query-expression (database generic-odbc-database)
  64                            result-types field-names)
  65   (handler-case
  66       (funcall (sql-fn database)
  67                query-expression :db (odbc-conn database)
  68                :result-types result-types
  69                :column-names field-names)
  70     #+ignore
  71     (error ()
  72       (error 'sql-database-data-error
  73              :database database
  74              :expression query-expression
  75              :message "Query failed"))))
  76
  77
  78 (defmethod database-execute-command (sql-expression (database generic-odbc-database))
  79   (handler-case
  80       (funcall (sql-fn database)
  81                sql-expression :db (odbc-conn database))
  82     #+ignore
  83     (sql-error (e)
  84       (error e))
  85     #+ignore
  86     (error ()
  87       (error 'sql-database-data-error
  88              :database database
  89              :expression sql-expression
  90              :message "Execute command failed"))))
  91
  92
  93 (defstruct odbc-result-set
  94   (query nil)
  95   (types nil)
  96   (full-set nil :type boolean))
  97
  98
  99
 100
 101 (defmethod database-query-result-set ((query-expression string)
 102                                       (database generic-odbc-database)
 103                                       &key full-set result-types)
 104   (handler-case
 105       (multiple-value-bind (query column-names)
 106           (funcall (sql-fn database)
 107                    query-expression
 108                    :db (odbc-conn database)
 109                    :row-count nil
 110                    :column-names t
 111                    :query t
 112                    :result-types result-types)
 113         (values
 114          (make-odbc-result-set :query query :full-set full-set
 115                                :types result-types)
 116          (length column-names)
 117          nil ;; not able to return number of rows with odbc
 118          ))
 119     (error ()
 120       (error 'sql-database-data-error
 121              :database database
 122              :expression query-expression
 123              :message "Query result set failed"))))
 124
 125 (defmethod database-dump-result-set (result-set (database generic-odbc-database))
 126   (funcall (close-query-fn database) (odbc-result-set-query result-set))
 127   t)
 128
 129 (defmethod database-store-next-row (result-set
 130                                     (database generic-odbc-database)
 131                                     list)
 132   (let ((row (funcall (fetch-row-fn database)
 133                       (odbc-result-set-query result-set) nil 'eof)))
 134     (if (eq row 'eof)
 135         nil
 136       (progn
 137         (loop for elem in row
 138             for rest on list
 139             do
 140               (setf (car rest) elem))
 141         list))))
 142
 143 (defmethod database-list-tables ((database generic-odbc-database)
 144                                  &key (owner nil))
 145   (declare (ignore owner))
 146   (multiple-value-bind (rows col-names)
 147       (funcall (list-all-database-tables-fn database) :db (odbc-conn database))
 148     (declare (ignore col-names))
 149     ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 150     ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 151     (loop for row in rows
 152           when (and (not (string-equal "information_schema" (nth 1 row)))
 153                     (string-equal "TABLE" (nth 3 row)))
 154           collect (nth 2 row))))
 155
 156
 157 (defmethod database-list-views ((database generic-odbc-database)
 158                                  &key (owner nil))
 159   (declare (ignore owner))
 160   (multiple-value-bind (rows col-names)
 161       (funcall (list-all-database-tables-fn database) :db (odbc-conn database))
 162     (declare (ignore col-names))
 163     ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 164     ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 165     (loop for row in rows
 166           when (and (not (string-equal "information_schema" (nth 1 row)))
 167                     (string-equal "VIEW" (nth 3 row)))
 168           collect (nth 2 row))))
 169
 170
 171 (defmethod database-list-attributes ((table string) (database generic-odbc-database)
 172                                      &key (owner nil))
 173   (declare (ignore owner))
 174   (multiple-value-bind (rows col-names)
 175       (funcall (list-all-table-columns-fn database) table
 176                :db (odbc-conn database))
 177     (declare (ignore col-names))
 178     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 179     (loop for row in rows
 180         collect (fourth row))))
 181
 182 (defmethod database-attribute-type ((attribute string) (table string) (database generic-odbc-database)
 183                                     &key (owner nil))
 184   (declare (ignore owner))
 185   (multiple-value-bind (rows col-names)
 186       (funcall (list-all-table-columns-fn database) table
 187                :db (odbc-conn database))
 188     (declare (ignore col-names))
 189     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 190     ;; TYPE_NAME is the sixth column
 191     ;; PRECISION/COLUMN_SIZE is the seventh column
 192     ;; SCALE/DECIMAL_DIGITS is the ninth column
 193     ;; NULLABLE is the eleventh column
 194     (loop for row in rows
 195         when (string-equal attribute (fourth row))
 196         do
 197         (let ((size (seventh row))
 198               (precision (ninth row))
 199               (scale (nth 10 row)))
 200           (return (values (ensure-keyword (sixth row))
 201                           (when size (parse-integer size))
 202                           (when precision (parse-integer precision))
 203                           (when scale (parse-integer scale))))))))