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