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 (defmethod database-get-type-specifier ((type (eql 'date)) args database
  80                                         (db-type (eql :mssql)))
  81   (declare (ignore args database))
  82   "DATETIME")
  83
  84 (defmethod database-get-type-specifier ((type (eql 'boolean)) args database
  85                                         (db-type (eql :mssql)))
  86   (declare (ignore args database))
  87   "BIT")
  88
  89 (defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args database
  90                                         (db-type (eql :mssql)))
  91   (declare (ignore args database))
  92   "BIT")
  93
  94 ;;; Generation of SQL strings from lisp expressions
  95
  96 (defmethod database-output-sql ((tee (eql t)) (database generic-odbc-database))
  97   (case (database-underlying-type database)
  98     (:mssql "1")
  99     (t "'Y'")))
 100
 101 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database
 102                                         (db-type (eql :mssql)))
 103   (declare (ignore database))
 104   (if val 1 0))
 105
 106 (defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database
 107                                         (db-type (eql :mssql)))
 108   (declare (ignore database))
 109   (if val 1 0))
 110
 111 ;;; Database backend capabilities
 112
 113 (defmethod db-type-use-fully-qualified-column-on-drop-index? ((db-type (eql :mssql)))
 114   t)
 115
 116 (defmethod db-type-has-boolean-where? ((db-type (eql :mssql)))
 117   nil)
 118
 119 (defmethod db-type-has-intersect? ((db-type (eql :mssql)))
 120   nil)
 121
 122 (defmethod db-type-has-except? ((db-type (eql :mssql)))
 123   nil)
 124
 125 ;;; Backend methods
 126
 127 (defmethod database-disconnect ((database generic-odbc-database))
 128   (funcall (disconnect-fn database) (odbc-conn database))
 129   (setf (odbc-conn database) nil)
 130   t)
 131
 132 (defmethod database-query (query-expression (database generic-odbc-database)
 133                            result-types field-names)
 134   (handler-case
 135       (funcall (sql-fn database)
 136                query-expression :db (odbc-conn database)
 137                :result-types result-types
 138                :column-names field-names)
 139     #+ignore
 140     (error ()
 141       (error 'sql-database-data-error
 142              :database database
 143              :expression query-expression
 144              :message "Query failed"))))
 145
 146
 147 (defmethod database-execute-command (sql-expression (database generic-odbc-database))
 148   (handler-case
 149       (funcall (sql-fn database)
 150                sql-expression :db (odbc-conn database))
 151     #+ignore
 152     (sql-error (e)
 153       (error e))
 154     #+ignore
 155     (error ()
 156       (error 'sql-database-data-error
 157              :database database
 158              :expression sql-expression
 159              :message "Execute command failed"))))
 160
 161
 162 (defstruct odbc-result-set
 163   (query nil)
 164   (types nil)
 165   (full-set nil :type boolean))
 166
 167
 168
 169
 170 (defmethod database-query-result-set ((query-expression string)
 171                                       (database generic-odbc-database)
 172                                       &key full-set result-types)
 173   (handler-case
 174       (multiple-value-bind (query column-names)
 175           (funcall (sql-fn database)
 176                    query-expression
 177                    :db (odbc-conn database)
 178                    :row-count nil
 179                    :column-names t
 180                    :query t
 181                    :result-types result-types)
 182         (values
 183          (make-odbc-result-set :query query :full-set full-set
 184                                :types result-types)
 185          (length column-names)
 186          nil ;; not able to return number of rows with odbc
 187          ))
 188     (error ()
 189       (error 'sql-database-data-error
 190              :database database
 191              :expression query-expression
 192              :message "Query result set failed"))))
 193
 194 (defmethod database-dump-result-set (result-set (database generic-odbc-database))
 195   (funcall (close-query-fn database) (odbc-result-set-query result-set))
 196   t)
 197
 198 (defmethod database-store-next-row (result-set
 199                                     (database generic-odbc-database)
 200                                     list)
 201   (let ((row (funcall (fetch-row-fn database)
 202                       (odbc-result-set-query result-set) nil 'eof)))
 203     (if (eq row 'eof)
 204         nil
 205       (progn
 206         (loop for elem in row
 207             for rest on list
 208             do
 209               (setf (car rest) elem))
 210         list))))
 211
 212
 213 (defun %database-list-* (database type owner)
 214   "Internal function used by database-list-tables and
 215 database-list-views"
 216   (multiple-value-bind (rows col-names)
 217       (funcall (list-all-database-tables-fn database) :db (odbc-conn database))
 218     (declare (ignore col-names))
 219     ;; http://msdn.microsoft.com/en-us/library/ms711831%28VS.85%29.aspx
 220     ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 221     ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 222     (loop for (category schema name ttype . rest) in rows
 223           when (and (string-equal type ttype)
 224                     (or (null owner) (string-equal owner schema))
 225                     ;; unless requesting by name, skip system schema
 226                     (not (and (null owner)
 227                               (member schema '("information_schema" "sys")
 228                                       :test #'string-equal)))
 229                     ;; skip system specific tables in mssql2000
 230                     (not (and (eql :mssql (database-underlying-type database))
 231                               (member name '("dtproperties" "sysconstraints"
 232                                              "syssegments")
 233                                       :test #'string-equal))))
 234             collect name)))
 235
 236 (defmethod database-list-tables ((database generic-odbc-database)
 237                                  &key (owner nil))
 238   "Since ODBC doesn't expose the owner we use that parameter to filter
 239 on schema since that's what tends to be exposed. Some DBs like mssql
 240 2000 conflate the two so at least there it works nicely."
 241   (%database-list-* database "TABLE" owner))
 242
 243
 244 (defmethod database-list-views ((database generic-odbc-database)
 245                                 &key (owner nil))
 246   "Since ODBC doesn't expose the owner we use that parameter to filter
 247 on schema since that's what tends to be exposed. Some DBs like mssql
 248 2000 conflate the two so at least there it works nicely."
 249   (%database-list-* database "VIEW" owner))
 250
 251
 252 (defmethod database-list-attributes ((table string) (database generic-odbc-database)
 253                                      &key (owner nil))
 254   (declare (ignore owner))
 255   (multiple-value-bind (rows col-names)
 256       (funcall (list-all-table-columns-fn database) table
 257                :db (odbc-conn database))
 258     (declare (ignore col-names))
 259     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 260     (loop for row in rows
 261         collect (fourth row))))
 262
 263 (defmethod database-attribute-type ((attribute string) (table string) (database generic-odbc-database)
 264                                     &key (owner nil))
 265   (declare (ignore owner))
 266   (multiple-value-bind (rows col-names)
 267       (funcall (list-all-table-columns-fn database) table
 268                :db (odbc-conn database))
 269     (declare (ignore col-names))
 270     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 271     ;; TYPE_NAME is the sixth column
 272     ;; PRECISION/COLUMN_SIZE is the seventh column
 273     ;; SCALE/DECIMAL_DIGITS is the ninth column
 274     ;; NULLABLE is the eleventh column
 275     (loop for row in rows
 276         when (string-equal attribute (fourth row))
 277         do
 278         (let ((size (seventh row))
 279               (precision (ninth row))
 280               (scale (nth 10 row)))
 281           (return (values (ensure-keyword (sixth row))
 282                           (when size (parse-integer size))
 283                           (when precision (parse-integer precision))
 284                           (when scale (parse-integer scale))))))))