sql/generic-odbc.lisp

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