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