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