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
  62 ;;; Backend methods
  63
  64 (defmethod database-disconnect ((database generic-odbc-database))
  65   (funcall (disconnect-fn database) (odbc-conn database))
  66   (setf (odbc-conn database) nil)
  67   t)
  68
  69 (defmethod database-query (query-expression (database generic-odbc-database)
  70                            result-types field-names)
  71   (handler-case
  72       (funcall (sql-fn database)
  73                query-expression :db (odbc-conn database)
  74                :result-types result-types
  75                :column-names field-names)
  76     #+ignore
  77     (error ()
  78       (error 'sql-database-data-error
  79              :database database
  80              :expression query-expression
  81              :message "Query failed"))))
  82
  83
  84 (defmethod database-execute-command (sql-expression (database generic-odbc-database))
  85   (handler-case
  86       (funcall (sql-fn database)
  87                sql-expression :db (odbc-conn database))
  88     #+ignore
  89     (sql-error (e)
  90       (error e))
  91     #+ignore
  92     (error ()
  93       (error 'sql-database-data-error
  94              :database database
  95              :expression sql-expression
  96              :message "Execute command failed"))))
  97
  98
  99 (defstruct odbc-result-set
 100   (query nil)
 101   (types nil)
 102   (full-set nil :type boolean))
 103
 104
 105
 106
 107 (defmethod database-query-result-set ((query-expression string)
 108                                       (database generic-odbc-database)
 109                                       &key full-set result-types)
 110   (handler-case
 111       (multiple-value-bind (query column-names)
 112           (funcall (sql-fn database)
 113                    query-expression
 114                    :db (odbc-conn database)
 115                    :row-count nil
 116                    :column-names t
 117                    :query t
 118                    :result-types result-types)
 119         (values
 120          (make-odbc-result-set :query query :full-set full-set
 121                                :types result-types)
 122          (length column-names)
 123          nil ;; not able to return number of rows with odbc
 124          ))
 125     (error ()
 126       (error 'sql-database-data-error
 127              :database database
 128              :expression query-expression
 129              :message "Query result set failed"))))
 130
 131 (defmethod database-dump-result-set (result-set (database generic-odbc-database))
 132   (funcall (close-query-fn database) (odbc-result-set-query result-set))
 133   t)
 134
 135 (defmethod database-store-next-row (result-set
 136                                     (database generic-odbc-database)
 137                                     list)
 138   (let ((row (funcall (fetch-row-fn database)
 139                       (odbc-result-set-query result-set) nil 'eof)))
 140     (if (eq row 'eof)
 141         nil
 142       (progn
 143         (loop for elem in row
 144             for rest on list
 145             do
 146               (setf (car rest) elem))
 147         list))))
 148
 149 (defmethod database-list-tables ((database generic-odbc-database)
 150                                  &key (owner nil))
 151   (declare (ignore owner))
 152   (multiple-value-bind (rows col-names)
 153       (funcall (list-all-database-tables-fn database) :db (odbc-conn database))
 154     (declare (ignore col-names))
 155     ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 156     ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 157     (loop for row in rows
 158           when (and (not (string-equal "information_schema" (nth 1 row)))
 159                     (string-equal "TABLE" (nth 3 row)))
 160           collect (nth 2 row))))
 161
 162
 163 (defmethod database-list-views ((database generic-odbc-database)
 164                                  &key (owner nil))
 165   (declare (ignore owner))
 166   (multiple-value-bind (rows col-names)
 167       (funcall (list-all-database-tables-fn database) :db (odbc-conn database))
 168     (declare (ignore col-names))
 169     ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 170     ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 171     (loop for row in rows
 172           when (and (not (string-equal "information_schema" (nth 1 row)))
 173                     (string-equal "VIEW" (nth 3 row)))
 174           collect (nth 2 row))))
 175
 176
 177 (defmethod database-list-attributes ((table string) (database generic-odbc-database)
 178                                      &key (owner nil))
 179   (declare (ignore owner))
 180   (multiple-value-bind (rows col-names)
 181       (funcall (list-all-table-columns-fn database) table
 182                :db (odbc-conn database))
 183     (declare (ignore col-names))
 184     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 185     (loop for row in rows
 186         collect (fourth row))))
 187
 188 (defmethod database-attribute-type ((attribute string) (table string) (database generic-odbc-database)
 189                                     &key (owner nil))
 190   (declare (ignore owner))
 191   (multiple-value-bind (rows col-names)
 192       (funcall (list-all-table-columns-fn database) table
 193                :db (odbc-conn database))
 194     (declare (ignore col-names))
 195     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 196     ;; TYPE_NAME is the sixth column
 197     ;; PRECISION/COLUMN_SIZE is the seventh column
 198     ;; SCALE/DECIMAL_DIGITS is the ninth column
 199     ;; NULLABLE is the eleventh column
 200     (loop for row in rows
 201         when (string-equal attribute (fourth row))
 202         do
 203         (let ((size (seventh row))
 204               (precision (ninth row))
 205               (scale (nth 10 row)))
 206           (return (values (ensure-keyword (sixth row))
 207                           (when size (parse-integer size))
 208                           (when precision (parse-integer precision))
 209                           (when scale (parse-integer scale))))))))