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 (defmethod read-sql-value (val (type (eql 'generalized-boolean))
  56                            (database generic-odbc-database)
  57                            (db-type (eql :postgresql)))
  58   (if (string= "0" val) nil t))
  59
  60
  61 ;;; Backend methods
  62
  63 (defmethod database-disconnect ((database generic-odbc-database))
  64   (funcall (disconnect-fn database) (odbc-conn database))
  65   (setf (odbc-conn database) nil)
  66   t)
  67
  68 (defmethod database-query (query-expression (database generic-odbc-database)
  69                            result-types field-names)
  70   (handler-case
  71       (funcall (sql-fn database)
  72                query-expression :db (odbc-conn database)
  73                :result-types result-types
  74                :column-names field-names)
  75     #+ignore
  76     (error ()
  77       (error 'sql-database-data-error
  78              :database database
  79              :expression query-expression
  80              :message "Query failed"))))
  81
  82
  83 (defmethod database-execute-command (sql-expression (database generic-odbc-database))
  84   (handler-case
  85       (funcall (sql-fn database)
  86                sql-expression :db (odbc-conn database))
  87     #+ignore
  88     (sql-error (e)
  89       (error e))
  90     #+ignore
  91     (error ()
  92       (error 'sql-database-data-error
  93              :database database
  94              :expression sql-expression
  95              :message "Execute command failed"))))
  96
  97
  98 (defstruct odbc-result-set
  99   (query nil)
 100   (types nil)
 101   (full-set nil :type boolean))
 102
 103
 104
 105
 106 (defmethod database-query-result-set ((query-expression string)
 107                                       (database generic-odbc-database)
 108                                       &key full-set result-types)
 109   (handler-case
 110       (multiple-value-bind (query column-names)
 111           (funcall (sql-fn database)
 112                    query-expression
 113                    :db (odbc-conn database)
 114                    :row-count nil
 115                    :column-names t
 116                    :query t
 117                    :result-types result-types)
 118         (values
 119          (make-odbc-result-set :query query :full-set full-set
 120                                :types result-types)
 121          (length column-names)
 122          nil ;; not able to return number of rows with odbc
 123          ))
 124     (error ()
 125       (error 'sql-database-data-error
 126              :database database
 127              :expression query-expression
 128              :message "Query result set failed"))))
 129
 130 (defmethod database-dump-result-set (result-set (database generic-odbc-database))
 131   (funcall (close-query-fn database) (odbc-result-set-query result-set))
 132   t)
 133
 134 (defmethod database-store-next-row (result-set
 135                                     (database generic-odbc-database)
 136                                     list)
 137   (let ((row (funcall (fetch-row-fn database)
 138                       (odbc-result-set-query result-set) nil 'eof)))
 139     (if (eq row 'eof)
 140         nil
 141       (progn
 142         (loop for elem in row
 143             for rest on list
 144             do
 145               (setf (car rest) elem))
 146         list))))
 147
 148 (defmethod database-list-tables ((database generic-odbc-database)
 149                                  &key (owner nil))
 150   (declare (ignore owner))
 151   (multiple-value-bind (rows col-names)
 152       (funcall (list-all-database-tables-fn database) :db (odbc-conn database))
 153     (declare (ignore col-names))
 154     ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 155     ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 156     (loop for row in rows
 157           when (and (not (string-equal "information_schema" (nth 1 row)))
 158                     (string-equal "TABLE" (nth 3 row)))
 159           collect (nth 2 row))))
 160
 161
 162 (defmethod database-list-views ((database generic-odbc-database)
 163                                  &key (owner nil))
 164   (declare (ignore owner))
 165   (multiple-value-bind (rows col-names)
 166       (funcall (list-all-database-tables-fn database) :db (odbc-conn database))
 167     (declare (ignore col-names))
 168     ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 169     ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 170     (loop for row in rows
 171           when (and (not (string-equal "information_schema" (nth 1 row)))
 172                     (string-equal "VIEW" (nth 3 row)))
 173           collect (nth 2 row))))
 174
 175
 176 (defmethod database-list-attributes ((table string) (database generic-odbc-database)
 177                                      &key (owner nil))
 178   (declare (ignore owner))
 179   (multiple-value-bind (rows col-names)
 180       (funcall (list-all-table-columns-fn database) table
 181                :db (odbc-conn database))
 182     (declare (ignore col-names))
 183     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 184     (loop for row in rows
 185         collect (fourth row))))
 186
 187 (defmethod database-attribute-type ((attribute string) (table string) (database generic-odbc-database)
 188                                     &key (owner nil))
 189   (declare (ignore owner))
 190   (multiple-value-bind (rows col-names)
 191       (funcall (list-all-table-columns-fn database) table
 192                :db (odbc-conn database))
 193     (declare (ignore col-names))
 194     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 195     ;; TYPE_NAME is the sixth column
 196     ;; PRECISION/COLUMN_SIZE is the seventh column
 197     ;; SCALE/DECIMAL_DIGITS is the ninth column
 198     ;; NULLABLE is the eleventh column
 199     (loop for row in rows
 200         when (string-equal attribute (fourth row))
 201         do
 202         (let ((size (seventh row))
 203               (precision (ninth row))
 204               (scale (nth 10 row)))
 205           (return (values (ensure-keyword (sixth row))
 206                           (when size (parse-integer size))
 207                           (when precision (parse-integer precision))
 208                           (when scale (parse-integer scale))))))))