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-base-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 (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     (clsql-error (e)
  54       (error e))
  55     #+ignore
  56     (error ()   ;; Init or Connect failed
  57       (error 'clsql-connect-error
  58              :database-type database-type
  59              :connection-spec connection-spec
  60              :errno nil
  61              :error "Connection failed")))))
  62
  63 (defmethod database-underlying-type ((database odbc-database))
  64   (database-odbc-db-type database))
  65
  66 (defun store-type-of-connected-database (db)
  67   (let* ((odbc-conn (database-odbc-conn db))
  68          (server-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_SERVER_NAME))
  69          (dbms-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_DBMS_NAME))
  70          (type
  71           ;; need SERVER-NAME and DBMS-NAME because many drivers mix this up
  72           (cond
  73            ((or (search "postgresql" server-name :test #'char-equal)
  74                 (search "postgresql" dbms-name :test #'char-equal))
  75             :postgresql)
  76            ((or (search "mysql" server-name :test #'char-equal)
  77                 (search "mysql" dbms-name :test #'char-equal))
  78             :mysql)
  79            ((or (search "oracle" server-name :test #'char-equal)
  80                 (search "oracle" dbms-name :test #'char-equal))
  81             :oracle))))
  82     (setf (database-odbc-db-type db) type)))
  83
  84 (defmethod database-disconnect ((database odbc-database))
  85   (odbc-dbi:disconnect (database-odbc-conn database))
  86   (setf (database-odbc-conn database) nil)
  87   t)
  88
  89 (defmethod database-query (query-expression (database odbc-database)
  90                            result-types)
  91   (handler-case
  92       (odbc-dbi:sql query-expression :db (database-odbc-conn database)
  93                     :result-types result-types)
  94     (clsql-error (e)
  95       (error e))
  96     #+ignore
  97     (error ()
  98       (error 'clsql-sql-error
  99              :database database
 100              :expression query-expression
 101              :errno nil
 102              :error "Query failed"))))
 103
 104 (defmethod database-execute-command (sql-expression
 105                                      (database odbc-database))
 106   (handler-case
 107       (odbc-dbi:sql sql-expression :db (database-odbc-conn database))
 108     (clsql-error (e)
 109       (error e))
 110     #+ignore
 111     (error ()
 112       (error 'clsql-sql-error
 113              :database database
 114              :expression sql-expression
 115              :errno nil
 116              :error "Execute command failed"))))
 117
 118 (defstruct odbc-result-set
 119   (query nil)
 120   (types nil)
 121   (full-set nil :type boolean))
 122
 123 (defmethod database-query-result-set ((query-expression string)
 124                                       (database odbc-database)
 125                                       &key full-set result-types)
 126   (handler-case
 127       (multiple-value-bind (query column-names)
 128           (odbc-dbi:sql query-expression
 129                    :db (database-odbc-conn database)
 130                    :row-count nil
 131                    :column-names t
 132                    :query t
 133                    :result-types result-types)
 134         (values
 135          (make-odbc-result-set :query query :full-set full-set
 136                                 :types result-types)
 137          (length column-names)
 138          nil ;; not able to return number of rows with odbc
 139          ))
 140     #+ignore
 141     (error ()
 142       (error 'clsql-sql-error
 143              :database database
 144              :expression query-expression
 145              :errno nil
 146              :error "Query result set failed"))))
 147
 148 (defmethod database-dump-result-set (result-set (database odbc-database))
 149   (odbc-dbi:close-query (odbc-result-set-query result-set))
 150   t)
 151
 152 (defmethod database-store-next-row (result-set
 153                                     (database odbc-database)
 154                                     list)
 155   (let ((row (odbc-dbi:fetch-row (odbc-result-set-query result-set) nil 'eof)))
 156     (if (eq row 'eof)
 157         nil
 158       (progn
 159         (loop for elem in row
 160             for rest on list
 161             do
 162               (setf (car rest) elem))
 163         list))))
 164
 165 ;;; Sequence functions
 166
 167 (defun %sequence-name-to-table (sequence-name)
 168   (concatenate 'string "_CLSQL_SEQ_" (sql-escape sequence-name)))
 169
 170 (defun %table-name-to-sequence-name (table-name)
 171   (and (>= (length table-name) 11)
 172        (string-equal (subseq table-name 0 11) "_CLSQL_SEQ_")
 173        (subseq table-name 11)))
 174
 175 (defmethod database-create-sequence (sequence-name
 176                                      (database odbc-database))
 177   (let ((table-name (%sequence-name-to-table sequence-name)))
 178     (database-execute-command
 179      (concatenate 'string "CREATE TABLE " table-name
 180                   " (last_value int NOT NULL PRIMARY KEY, increment_by int, min_value int, is_called char(1))")
 181      database)
 182     (database-execute-command
 183      (concatenate 'string "INSERT INTO " table-name
 184                   " VALUES (1,1,1,'f')")
 185      database)))
 186
 187 (defmethod database-drop-sequence (sequence-name
 188                                    (database odbc-database))
 189   (database-execute-command
 190    (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
 191    database))
 192
 193 (defmethod database-list-sequences ((database odbc-database)
 194                                     &key (owner nil))
 195   (declare (ignore owner))
 196   ;; FIXME: Underlying database backend stuff should come from that backend
 197
 198   (case (database-odbc-db-type database)
 199     (:mysql
 200      (mapcan #'(lambda (s)
 201                  (let ((sn (%table-name-to-sequence-name (car s))))
 202                    (and sn (list sn))))
 203              (database-query "SHOW TABLES" database nil)))
 204     ((:postgresql :postgresql-socket)
 205      (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
 206             (database-query "SELECT RELNAME FROM pg_class WHERE RELNAME LIKE '%clsql_seq%'"
 207                             database nil)))))
 208
 209 (defmethod database-list-tables ((database odbc-database)
 210                                  &key (owner nil))
 211   (declare (ignore owner))
 212     (multiple-value-bind (rows col-names)
 213         (odbc-dbi:list-all-database-tables :db (database-odbc-conn database))
 214       (declare (ignore col-names))
 215       ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 216       ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 217       (loop for row in rows
 218           when (and (not (string-equal "information_schema" (nth 1 row)))
 219                     (string-equal "TABLE" (nth 3 row)))
 220           collect (nth 2 row))))
 221
 222 (defmethod database-list-views ((database odbc-database)
 223                                  &key (owner nil))
 224   (declare (ignore owner))
 225     (multiple-value-bind (rows col-names)
 226         (odbc-dbi:list-all-database-tables :db (database-odbc-conn database))
 227       (declare (ignore col-names))
 228       ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 229       ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 230       (loop for row in rows
 231           when (and (not (string-equal "information_schema" (nth 1 row)))
 232                     (string-equal "VIEW" (nth 3 row)))
 233           collect (nth 2 row))))
 234
 235 (defmethod database-list-attributes ((table string) (database odbc-database)
 236                                      &key (owner nil))
 237   (declare (ignore owner))
 238   (multiple-value-bind (rows col-names)
 239       (odbc-dbi:list-all-table-columns table :db (database-odbc-conn database))
 240     (let ((pos (position "COLUMN_NAME" col-names :test #'string-equal)))
 241       (when pos
 242         (loop for row in rows
 243             collect (nth pos row))))))
 244
 245 (defmethod database-attribute-type ((attribute string) (table string) (database odbc-database)
 246                                      &key (owner nil))
 247   (declare (ignore owner))
 248   (multiple-value-bind (rows col-names)
 249       (odbc-dbi:list-all-table-columns table :db (database-odbc-conn database))
 250     (let ((pos (position "TYPE_NAME" col-names :test #'string-equal)))
 251       (when pos
 252         (loop for row in rows
 253             collect (nth pos row))))))
 254
 255 (defmethod database-set-sequence-position (sequence-name
 256                                            (position integer)
 257                                            (database odbc-database))
 258   (database-execute-command
 259    (format nil "UPDATE ~A SET last_value=~A,is_called='t'"
 260            (%sequence-name-to-table sequence-name)
 261            position)
 262    database)
 263   position)
 264
 265 (defmethod database-sequence-next (sequence-name (database odbc-database))
 266   (without-interrupts
 267    (let* ((table-name (%sequence-name-to-table sequence-name))
 268           (tuple
 269            (car (database-query
 270                  (concatenate 'string "SELECT last_value,is_called FROM "
 271                               table-name)
 272                  database
 273                  :auto))))
 274      (cond
 275        ((char-equal (schar (second tuple) 0) #\f)
 276         (database-execute-command
 277          (format nil "UPDATE ~A SET is_called='t'" table-name)
 278          database)
 279         (car tuple))
 280        (t
 281         (let ((new-pos (1+ (car tuple))))
 282          (database-execute-command
 283           (format nil "UPDATE ~A SET last_value=~D" table-name new-pos)
 284           database)
 285          new-pos))))))
 286
 287 (defmethod database-sequence-last (sequence-name (database odbc-database))
 288   (without-interrupts
 289    (caar (database-query
 290           (concatenate 'string "SELECT last_value FROM "
 291                        (%sequence-name-to-table sequence-name))
 292           database
 293           :auto))))
 294
 295 (defmethod database-create (connection-spec (type (eql :odbc)))
 296   (warn "Not implemented."))
 297
 298 (defmethod database-destroy (connection-spec (type (eql :odbc)))
 299   (warn "Not implemented."))
 300
 301 (defmethod database-probe (connection-spec (type (eql :odbc)))
 302   (when (find (car connection-spec) (database-list connection-spec type)
 303               :test #'string-equal)
 304     t))
 305
 306 (defmethod database-list (connection-spec (type (eql :odbc)))
 307   (declare (ignore connection-spec))
 308   (odbc-dbi:list-all-data-sources))
 309
 310 (defmethod database-list-indexes ((database odbc-database)
 311                                   &key (owner nil))
 312   (let ((result '()))
 313     (dolist (table (database-list-tables database :owner owner) result)
 314       (setq result
 315         (append (database-list-table-indexes table database :owner owner)
 316                 result)))))
 317
 318 (defmethod database-list-table-indexes (table (database odbc-database)
 319                                         &key (owner nil))
 320   (declare (ignore owner))
 321   (odbc-list-table-indexes table database))
 322
 323 (defun odbc-list-table-indexes (table database)
 324   (multiple-value-bind (rows col-names)
 325       (odbc-dbi:list-table-indexes
 326        table
 327        :db (database-odbc-conn database))
 328     (declare (ignore col-names))
 329     ;; INDEX_NAME is hard-coded in sixth position by ODBC driver
 330     ;; FIXME: ??? is hard-coded in the fourth position
 331     (do ((results nil)
 332          (loop-rows rows (cdr loop-rows)))
 333         ((null loop-rows) (nreverse results))
 334       (let* ((row (car loop-rows))
 335              (col (nth 5 row)))
 336         (unless (find col results :test #'string-equal)
 337           (push col results))))))
 338
 339 ;;; Database capabilities
 340
 341 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :odbc)))
 342   nil)
 343
 344
 345 (defmethod database-initialize-database-type ((database-type (eql :odbc)))
 346   ;; nothing to do
 347   t)
 348
 349 (when (clsql-base-sys:database-type-library-loaded :odbc)
 350   (clsql-base-sys:initialize-database-type :database-type :odbc))