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