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