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