sql/generic-odbc.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; Generic ODBC layer, used by db-odbc and db-aodbc backends
   5 ;;;;
   6 ;;;; This file is part of CLSQL.
   7 ;;;;
   8 ;;;; CLSQL users are granted the rights to distribute and use this software
   9 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  10 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  11 ;;;; *************************************************************************
  12
  13 (in-package #:clsql-sys)
  14
  15 (defclass generic-odbc-database (database)
  16   ((dbi-package :initarg :dbi-package :reader dbi-package)
  17    (odbc-conn :initarg :odbc-conn :initform nil :accessor odbc-conn)
  18    (disconnect-fn :reader disconnect-fn)
  19    (sql-fn :reader sql-fn)
  20    (close-query-fn :reader close-query-fn)
  21    (fetch-row :reader fetch-row-fn)
  22    (list-all-database-tables-fn :reader list-all-database-tables-fn)
  23    (list-all-table-columns-fn :reader list-all-table-columns-fn))
  24   (:documentation "Encapsulate same behavior across odbc and aodbc backends."))
  25
  26 (defmethod initialize-instance :after ((db generic-odbc-database)
  27                                         &rest all-keys)
  28   (declare (ignore all-keys))
  29   (unless (slot-boundp db 'dbi-package)
  30     (error "dbi-package not specified."))
  31   (let ((pkg (slot-value db 'dbi-package)))
  32     (unless pkg
  33       (error "dbi-package is nil."))
  34     (setf (slot-value db 'disconnect-fn)
  35           (intern (symbol-name '#:disconnect) pkg)
  36           (slot-value db 'sql-fn)
  37           (intern (symbol-name '#:sql) pkg)
  38           (slot-value db 'close-query-fn)
  39           (intern (symbol-name '#:close-query) pkg)
  40           (slot-value db 'fetch-row)
  41           (intern (symbol-name '#:fetch-row) pkg)
  42           (slot-value db 'list-all-database-tables-fn)
  43           (intern (symbol-name '#:list-all-database-tables) pkg)
  44           (slot-value db 'list-all-table-columns-fn)
  45           (intern (symbol-name '#:list-all-table-columns) pkg))))
  46
  47 ;;; Object methods
  48
  49 (defmethod read-sql-value (val (type (eql 'boolean))
  50                            (database generic-odbc-database)
  51                            (db-type (eql :postgresql)))
  52   (if (string= "0" val) nil t))
  53
  54 (defmethod read-sql-value (val (type (eql 'generalized-boolean))
  55                            (database generic-odbc-database)
  56                            (db-type (eql :postgresql)))
  57   (if (string= "0" val) nil t))
  58
  59 (defmethod read-sql-value (val (type (eql 'boolean)) database
  60                            (db-type (eql :mssql)))
  61   (declare (ignore database))
  62   (etypecase val
  63     (string (if (string= "0" val) nil t))
  64     (integer (if (zerop val) nil t))))
  65
  66 (defmethod read-sql-value (val (type (eql 'generalized-boolean)) database
  67                            (db-type (eql :mssql)))
  68   (declare (ignore database))
  69   (etypecase val
  70     (string (if (string= "0" val) nil t))
  71     (integer (if (zerop val) nil t))))
  72
  73 ;;; Type methods
  74
  75 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database
  76                                         (db-type (eql :mssql)))
  77   (declare (ignore args database))
  78   "DATETIME")
  79
  80 (defmethod database-get-type-specifier ((type (eql 'date)) args database
  81                                         (db-type (eql :mssql)))
  82   (declare (ignore args database))
  83   "SMALLDATETIME")
  84
  85 (defmethod database-get-type-specifier ((type (eql 'boolean)) args database
  86                                         (db-type (eql :mssql)))
  87   (declare (ignore args database))
  88   "BIT")
  89
  90 (defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args database
  91                                         (db-type (eql :mssql)))
  92   (declare (ignore args database))
  93   "BIT")
  94
  95 ;;; Generation of SQL strings from lisp expressions
  96
  97 (defmethod database-output-sql ((tee (eql t)) (database generic-odbc-database))
  98   (case (database-underlying-type database)
  99     (:mssql "1")
 100     (t "'Y'")))
 101
 102 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database
 103                                         (db-type (eql :mssql)))
 104   (declare (ignore database))
 105   (if val 1 0))
 106
 107 (defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database
 108                                         (db-type (eql :mssql)))
 109   (declare (ignore database))
 110   (if val 1 0))
 111
 112 ;;; Database backend capabilities
 113
 114 (defmethod db-type-use-fully-qualified-column-on-drop-index? ((db-type (eql :mssql)))
 115   t)
 116
 117 (defmethod db-type-has-boolean-where? ((db-type (eql :mssql)))
 118   nil)
 119
 120 (defmethod db-type-has-intersect? ((db-type (eql :mssql)))
 121   nil)
 122
 123 (defmethod db-type-has-except? ((db-type (eql :mssql)))
 124   nil)
 125
 126 ;;; Backend methods
 127
 128 (defmethod database-disconnect ((database generic-odbc-database))
 129   (funcall (disconnect-fn database) (odbc-conn database))
 130   (setf (odbc-conn database) nil)
 131   t)
 132
 133 (defmethod database-query (query-expression (database generic-odbc-database)
 134                            result-types field-names)
 135   (handler-case
 136       (funcall (sql-fn database)
 137                query-expression :db (odbc-conn database)
 138                :result-types result-types
 139                :column-names field-names)
 140     #+ignore
 141     (error ()
 142       (error 'sql-database-data-error
 143              :database database
 144              :expression query-expression
 145              :message "Query failed"))))
 146
 147
 148 (defmethod database-execute-command (sql-expression (database generic-odbc-database))
 149   (handler-case
 150       (funcall (sql-fn database)
 151                sql-expression :db (odbc-conn database))
 152     #+ignore
 153     (sql-error (e)
 154       (error e))
 155     #+ignore
 156     (error ()
 157       (error 'sql-database-data-error
 158              :database database
 159              :expression sql-expression
 160              :message "Execute command failed"))))
 161
 162
 163 (defstruct odbc-result-set
 164   (query nil)
 165   (types nil)
 166   (full-set nil :type boolean))
 167
 168
 169
 170
 171 (defmethod database-query-result-set ((query-expression string)
 172                                       (database generic-odbc-database)
 173                                       &key full-set result-types)
 174   (handler-case
 175       (multiple-value-bind (query column-names)
 176           (funcall (sql-fn database)
 177                    query-expression
 178                    :db (odbc-conn database)
 179                    :row-count nil
 180                    :column-names t
 181                    :query t
 182                    :result-types result-types)
 183         (values
 184          (make-odbc-result-set :query query :full-set full-set
 185                                :types result-types)
 186          (length column-names)
 187          nil ;; not able to return number of rows with odbc
 188          ))
 189     (error ()
 190       (error 'sql-database-data-error
 191              :database database
 192              :expression query-expression
 193              :message "Query result set failed"))))
 194
 195 (defmethod database-dump-result-set (result-set (database generic-odbc-database))
 196   (funcall (close-query-fn database) (odbc-result-set-query result-set))
 197   t)
 198
 199 (defmethod database-store-next-row (result-set
 200                                     (database generic-odbc-database)
 201                                     list)
 202   (let ((row (funcall (fetch-row-fn database)
 203                       (odbc-result-set-query result-set) nil 'eof)))
 204     (if (eq row 'eof)
 205         nil
 206       (progn
 207         (loop for elem in row
 208             for rest on list
 209             do
 210               (setf (car rest) elem))
 211         list))))
 212
 213
 214 (defun %database-list-* (database type owner)
 215   "Internal function used by database-list-tables and
 216 database-list-views"
 217   (multiple-value-bind (rows col-names)
 218       (funcall (list-all-database-tables-fn database) :db (odbc-conn database))
 219     (declare (ignore col-names))
 220     ;; http://msdn.microsoft.com/en-us/library/ms711831%28VS.85%29.aspx
 221     ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 222     ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 223     (loop for (category schema name ttype . rest) in rows
 224           when (and (string-equal type ttype)
 225                     (or (null owner) (string-equal owner schema))
 226                     ;; unless requesting by name, skip system schema
 227                     (not (and (null owner)
 228                               (member schema '("information_schema" "sys")
 229                                       :test #'string-equal)))
 230                     ;; skip system specific tables in mssql2000
 231                     (not (and (eql :mssql (database-underlying-type database))
 232                               (member name '("dtproperties" "sysconstraints"
 233                                              "syssegments")
 234                                       :test #'string-equal))))
 235             collect name)))
 236
 237 (defmethod database-list-tables ((database generic-odbc-database)
 238                                  &key (owner nil))
 239   "Since ODBC doesn't expose the owner we use that parameter to filter
 240 on schema since that's what tends to be exposed. Some DBs like mssql
 241 2000 conflate the two so at least there it works nicely."
 242   (%database-list-* database "TABLE" owner))
 243
 244
 245 (defmethod database-list-views ((database generic-odbc-database)
 246                                 &key (owner nil))
 247   "Since ODBC doesn't expose the owner we use that parameter to filter
 248 on schema since that's what tends to be exposed. Some DBs like mssql
 249 2000 conflate the two so at least there it works nicely."
 250   (%database-list-* database "VIEW" owner))
 251
 252
 253 (defmethod database-list-attributes ((table %database-identifier) (database generic-odbc-database)
 254                                      &key (owner nil)
 255                                      &aux (table (unescaped-database-identifier table)))
 256   (declare (ignore owner))
 257   (multiple-value-bind (rows col-names)
 258       (funcall (list-all-table-columns-fn database) table
 259                :db (odbc-conn database))
 260     (declare (ignore col-names))
 261     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 262     (loop for row in rows
 263         collect (fourth row))))
 264
 265 (defmethod database-attribute-type ((attribute %database-identifier) (table %database-identifier)
 266                                     (database generic-odbc-database)
 267                                     &key (owner nil)
 268                                     &aux (table (unescaped-database-identifier table))
 269                                     (attribute (unescaped-database-identifier attribute)))
 270   (declare (ignore owner))
 271   (multiple-value-bind (rows col-names)
 272       (funcall (list-all-table-columns-fn database) table
 273                :db (odbc-conn database))
 274     (declare (ignore col-names))
 275     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 276     ;; TYPE_NAME is the sixth column
 277     ;; PRECISION/COLUMN_SIZE is the seventh column
 278     ;; SCALE/DECIMAL_DIGITS is the ninth column
 279     ;; NULLABLE is the eleventh column
 280     (loop for row in rows
 281         when (string-equal attribute (fourth row))
 282         do
 283         (let ((size (seventh row))
 284               (precision (ninth row))
 285               (scale (nth 10 row)))
 286           (return (values (ensure-keyword (sixth row))
 287                           (when size (parse-integer size))
 288                           (when precision (parse-integer precision))
 289                           (when scale (parse-integer scale))))))))