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