db-odbc/odbc-sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          odbc-sql.cl
   6 ;;;; Purpose:       Low-level interface for CLSQL ODBC backend
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; $Id: odbc-sql.lisp 8983 2004-04-12 21:16:48Z kevin $
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; CLSQL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (defpackage #:clsql-odbc
  20     (:use #:common-lisp #:clsql-sys)
  21     (:export #:odbc-database)
  22     (:documentation "This is the CLSQL interface to ODBC."))
  23
  24 (in-package #:clsql-odbc)
  25
  26 ;; ODBC interface
  27
  28 (defclass odbc-database (generic-odbc-database)
  29   ((odbc-conn :accessor database-odbc-conn :initarg :odbc-conn)
  30    (odbc-db-type :accessor database-odbc-db-type)))
  31
  32 (defmethod database-name-from-spec (connection-spec
  33                                     (database-type (eql :odbc)))
  34   (check-connection-spec connection-spec database-type (dsn user password))
  35   (destructuring-bind (dsn user password) connection-spec
  36     (declare (ignore password))
  37     (concatenate 'string dsn "/" user)))
  38
  39 (defmethod database-connect (connection-spec (database-type (eql :odbc)))
  40   (check-connection-spec connection-spec database-type (dsn user password))
  41   (destructuring-bind (dsn user password) connection-spec
  42     (handler-case
  43         (let ((db
  44                (make-instance 'odbc-database
  45                  :name (database-name-from-spec connection-spec :odbc)
  46                  :database-type :odbc
  47                  :odbc-conn
  48                  (odbc-dbi:connect :user user
  49                                    :password password
  50                                    :data-source-name dsn))))
  51           (store-type-of-connected-database db)
  52           db)
  53       #+ignore
  54       (sql-condition (e)
  55         (error e))
  56       (error ()         ;; Init or Connect failed
  57         (error 'sql-connection-error
  58                :database-type database-type
  59                :connection-spec connection-spec
  60                :message "Connection failed")))))
  61
  62 (defmethod database-underlying-type ((database odbc-database))
  63   (database-odbc-db-type database))
  64
  65 (defun store-type-of-connected-database (db)
  66   (let* ((odbc-conn (database-odbc-conn db))
  67          (server-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_SERVER_NAME))
  68          (dbms-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_DBMS_NAME))
  69          (type
  70           ;; need SERVER-NAME and DBMS-NAME because many drivers mix this up
  71           (cond
  72            ((or (search "postgresql" server-name :test #'char-equal)
  73                 (search "postgresql" dbms-name :test #'char-equal))
  74             :postgresql)
  75            ((or (search "mysql" server-name :test #'char-equal)
  76                 (search "mysql" dbms-name :test #'char-equal))
  77             :mysql)
  78            ((or (search "oracle" server-name :test #'char-equal)
  79                 (search "oracle" dbms-name :test #'char-equal))
  80             :oracle))))
  81     (setf (database-odbc-db-type db) type)))
  82
  83 (defmethod database-disconnect ((database odbc-database))
  84   (odbc-dbi:disconnect (database-odbc-conn database))
  85   (setf (database-odbc-conn database) nil)
  86   t)
  87
  88 (defmethod database-query (query-expression (database odbc-database)
  89                            result-types field-names)
  90   (handler-case
  91       (odbc-dbi:sql query-expression :db (database-odbc-conn database)
  92                     :result-types result-types
  93                     :column-names field-names)
  94     #+ignore
  95     (sql-error (e)
  96       (error e))
  97     (error ()
  98       (error 'sql-database-data-error
  99              :database database
 100              :expression query-expression
 101              :message "Query failed"))))
 102
 103 (defmethod database-execute-command (sql-expression
 104                                      (database odbc-database))
 105   (handler-case
 106       (odbc-dbi:sql sql-expression :db (database-odbc-conn database))
 107     #+ignore
 108     (sql-error (e)
 109       (error e))
 110     (error ()
 111       (error 'sql-database-data-error
 112              :database database
 113              :expression sql-expression
 114              :message "Execute command failed"))))
 115
 116 (defstruct odbc-result-set
 117   (query nil)
 118   (types nil)
 119   (full-set nil :type boolean))
 120
 121 (defmethod database-query-result-set ((query-expression string)
 122                                       (database odbc-database)
 123                                       &key full-set result-types)
 124   (handler-case
 125       (multiple-value-bind (query column-names)
 126           (odbc-dbi:sql query-expression
 127                    :db (database-odbc-conn database)
 128                    :row-count nil
 129                    :column-names t
 130                    :query t
 131                    :result-types result-types)
 132         (values
 133          (make-odbc-result-set :query query :full-set full-set
 134                                 :types result-types)
 135          (length column-names)
 136          nil ;; not able to return number of rows with odbc
 137          ))
 138     (error ()
 139       (error 'sql-database-data-error
 140              :database database
 141              :expression query-expression
 142              :message "Query result set failed"))))
 143
 144 (defmethod database-dump-result-set (result-set (database odbc-database))
 145   (odbc-dbi:close-query (odbc-result-set-query result-set))
 146   t)
 147
 148 (defmethod database-store-next-row (result-set
 149                                     (database odbc-database)
 150                                     list)
 151   (let ((row (odbc-dbi:fetch-row (odbc-result-set-query result-set) nil 'eof)))
 152     (if (eq row 'eof)
 153         nil
 154       (progn
 155         (loop for elem in row
 156             for rest on list
 157             do
 158               (setf (car rest) elem))
 159         list))))
 160
 161 ;;; Sequence functions
 162
 163 (defun %sequence-name-to-table (sequence-name)
 164   (concatenate 'string "_CLSQL_SEQ_" (sql-escape sequence-name)))
 165
 166 (defun %table-name-to-sequence-name (table-name)
 167   (and (>= (length table-name) 11)
 168        (string-equal (subseq table-name 0 11) "_CLSQL_SEQ_")
 169        (subseq table-name 11)))
 170
 171 (defmethod database-create-sequence (sequence-name
 172                                      (database odbc-database))
 173   (let ((table-name (%sequence-name-to-table sequence-name)))
 174     (database-execute-command
 175      (concatenate 'string "CREATE TABLE " table-name
 176                   " (last_value int NOT NULL PRIMARY KEY, increment_by int, min_value int, is_called char(1))")
 177      database)
 178     (database-execute-command
 179      (concatenate 'string "INSERT INTO " table-name
 180                   " VALUES (1,1,1,'f')")
 181      database)))
 182
 183 (defmethod database-drop-sequence (sequence-name
 184                                    (database odbc-database))
 185   (database-execute-command
 186    (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
 187    database))
 188
 189 (defmethod database-list-sequences ((database odbc-database)
 190                                     &key (owner nil))
 191   (declare (ignore owner))
 192   ;; FIXME: Underlying database backend stuff should come from that backend
 193
 194   (case (database-odbc-db-type database)
 195     (:mysql
 196      (mapcan #'(lambda (s)
 197                  (let ((sn (%table-name-to-sequence-name (car s))))
 198                    (and sn (list sn))))
 199              (database-query "SHOW TABLES" database nil nil)))
 200     ((:postgresql :postgresql-socket)
 201      (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
 202             (database-query "SELECT RELNAME FROM pg_class WHERE RELNAME LIKE '%clsql_seq%'"
 203                             database nil nil)))))
 204
 205 (defmethod database-list-tables ((database odbc-database)
 206                                  &key (owner nil))
 207   (declare (ignore owner))
 208     (multiple-value-bind (rows col-names)
 209         (odbc-dbi:list-all-database-tables :db (database-odbc-conn database))
 210       (declare (ignore col-names))
 211       ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 212       ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 213       (loop for row in rows
 214           when (and (not (string-equal "information_schema" (nth 1 row)))
 215                     (string-equal "TABLE" (nth 3 row)))
 216           collect (nth 2 row))))
 217
 218 (defmethod database-list-views ((database odbc-database)
 219                                  &key (owner nil))
 220   (declare (ignore owner))
 221     (multiple-value-bind (rows col-names)
 222         (odbc-dbi:list-all-database-tables :db (database-odbc-conn database))
 223       (declare (ignore col-names))
 224       ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 225       ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 226       (loop for row in rows
 227           when (and (not (string-equal "information_schema" (nth 1 row)))
 228                     (string-equal "VIEW" (nth 3 row)))
 229           collect (nth 2 row))))
 230
 231 (defmethod database-list-attributes ((table string) (database odbc-database)
 232                                      &key (owner nil))
 233   (declare (ignore owner))
 234   (multiple-value-bind (rows col-names)
 235       (odbc-dbi:list-all-table-columns table :db (database-odbc-conn database))
 236     (declare (ignore col-names))
 237     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 238     (loop for row in rows
 239         collect (fourth row))))
 240
 241 (defmethod database-attribute-type ((attribute string) (table string) (database odbc-database)
 242                                      &key (owner nil))
 243   (declare (ignore owner))
 244   (multiple-value-bind (rows col-names)
 245       (odbc-dbi:list-all-table-columns table :db (database-odbc-conn database))
 246     (declare (ignore col-names))
 247     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 248     ;; TYPE_NAME is the sixth column
 249     ;; PRECISION/COLUMN_SIZE is the seventh column
 250     ;; SCALE/DECIMAL_DIGITS is the ninth column
 251     ;; NULLABLE is the eleventh column
 252     (loop for row in rows
 253         when (string-equal attribute (fourth row))
 254         do
 255         (let ((size (seventh row))
 256               (precision (ninth row))
 257               (scale (nth 10 row)))
 258           (return (values (ensure-keyword (sixth row))
 259                           (when size (parse-integer size))
 260                           (when precision (parse-integer precision))
 261                           (when scale (parse-integer scale))))))))
 262
 263 (defmethod database-set-sequence-position (sequence-name
 264                                            (position integer)
 265                                            (database odbc-database))
 266   (database-execute-command
 267    (format nil "UPDATE ~A SET last_value=~A,is_called='t'"
 268            (%sequence-name-to-table sequence-name)
 269            position)
 270    database)
 271   position)
 272
 273 (defmethod database-sequence-next (sequence-name (database odbc-database))
 274   (without-interrupts
 275    (let* ((table-name (%sequence-name-to-table sequence-name))
 276           (tuple
 277            (car (database-query
 278                  (concatenate 'string "SELECT last_value,is_called FROM "
 279                               table-name)
 280                  database :auto nil))))
 281      (cond
 282        ((char-equal (schar (second tuple) 0) #\f)
 283         (database-execute-command
 284          (format nil "UPDATE ~A SET is_called='t'" table-name)
 285          database)
 286         (car tuple))
 287        (t
 288         (let ((new-pos (1+ (car tuple))))
 289          (database-execute-command
 290           (format nil "UPDATE ~A SET last_value=~D" table-name new-pos)
 291           database)
 292          new-pos))))))
 293
 294 (defmethod database-sequence-last (sequence-name (database odbc-database))
 295   (without-interrupts
 296    (caar (database-query
 297           (concatenate 'string "SELECT last_value FROM "
 298                        (%sequence-name-to-table sequence-name))
 299           database :auto nil))))
 300
 301 (defmethod database-create (connection-spec (type (eql :odbc)))
 302   (declare (ignore connection-spec))
 303   (warn "Not implemented."))
 304
 305 (defmethod database-destroy (connection-spec (type (eql :odbc)))
 306   (declare (ignore connection-spec))
 307   (warn "Not implemented."))
 308
 309 (defmethod database-probe (connection-spec (type (eql :odbc)))
 310   (when (find (car connection-spec) (database-list connection-spec type)
 311               :test #'string-equal)
 312     t))
 313
 314 (defmethod database-list (connection-spec (type (eql :odbc)))
 315   (declare (ignore connection-spec))
 316   (odbc-dbi:list-all-data-sources))
 317
 318 (defmethod database-list-indexes ((database odbc-database)
 319                                   &key (owner nil))
 320   (let ((result '()))
 321     (dolist (table (database-list-tables database :owner owner) result)
 322       (setq result
 323         (append (database-list-table-indexes table database :owner owner)
 324                 result)))))
 325
 326 (defmethod database-list-table-indexes (table (database odbc-database)
 327                                         &key (owner nil))
 328   (declare (ignore owner))
 329   (odbc-list-table-indexes table database))
 330
 331 (defun odbc-list-table-indexes (table database)
 332   (multiple-value-bind (rows col-names)
 333       (odbc-dbi:list-table-indexes
 334        table
 335        :db (database-odbc-conn database))
 336     (declare (ignore col-names))
 337     ;; INDEX_NAME is hard-coded in sixth position by ODBC driver
 338     ;; FIXME: ??? is hard-coded in the fourth position
 339     (do ((results nil)
 340          (loop-rows rows (cdr loop-rows)))
 341         ((null loop-rows) (nreverse results))
 342       (let* ((row (car loop-rows))
 343              (col (nth 5 row)))
 344         (unless (find col results :test #'string-equal)
 345           (push col results))))))
 346
 347 ;;; Database capabilities
 348
 349 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :odbc)))
 350   nil)
 351
 352
 353 (defmethod database-initialize-database-type ((database-type (eql :odbc)))
 354   ;; nothing to do
 355   t)
 356
 357 (when (clsql-sys:database-type-library-loaded :odbc)
 358   (clsql-sys:initialize-database-type :database-type :odbc))