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 (defmethod database-list-tables ((database generic-odbc-database)
 211                                  &key (owner nil))
 212   (declare (ignore owner))
 213   (multiple-value-bind (rows col-names)
 214       (funcall (list-all-database-tables-fn database) :db (odbc-conn database))
 215     (declare (ignore col-names))
 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 row in rows
 219           when (and (not (string-equal "information_schema" (nth 1 row)))
 220                     (string-equal "TABLE" (nth 3 row))
 221                     (not (and (eq :mssql (database-underlying-type database))
 222                               (string-equal "dtproperties" (nth 2 row)))))
 223           collect (nth 2 row))))
 224
 225
 226 (defmethod database-list-views ((database generic-odbc-database)
 227                                  &key (owner nil))
 228   (declare (ignore owner))
 229   (multiple-value-bind (rows col-names)
 230       (funcall (list-all-database-tables-fn database) :db (odbc-conn database))
 231     (declare (ignore col-names))
 232     ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 233     ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 234     (loop for row in rows
 235           when (and (not (string-equal "information_schema" (nth 1 row)))
 236                     (string-equal "VIEW" (nth 3 row))
 237                     (not (and (eq :mssql (database-underlying-type database))
 238                               (member (nth 2 row) '("sysconstraints" "syssegments") :test #'string-equal))))
 239           collect (nth 2 row))))
 240
 241
 242 (defmethod database-list-attributes ((table string) (database generic-odbc-database)
 243                                      &key (owner nil))
 244   (declare (ignore owner))
 245   (multiple-value-bind (rows col-names)
 246       (funcall (list-all-table-columns-fn database) table
 247                :db (odbc-conn database))
 248     (declare (ignore col-names))
 249     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 250     (loop for row in rows
 251         collect (fourth row))))
 252
 253 (defmethod database-attribute-type ((attribute string) (table string) (database generic-odbc-database)
 254                                     &key (owner nil))
 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))))))))