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)
  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 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 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     (declare (ignore col-names))
 242     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 243     (loop for row in rows
 244         collect (fourth 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     (declare (ignore col-names))
 252     ;; COLUMN_NAME is hard-coded by odbc spec as fourth position
 253     ;; TYPE_NAME is the sixth column
 254     ;; PRECISION/COLUMN_SIZE is the seventh column
 255     ;; SCALE/DECIMAL_DIGITS is the ninth column
 256     ;; NULLABLE is the eleventh column
 257     (loop for row in rows
 258         when (string-equal attribute (fourth row))
 259         do (return (values (ensure-keyword (sixth row))
 260                            (parse-integer (seventh row) :junk-allowed t)
 261                            (parse-integer (ninth row) :junk-allowed t)
 262                            (parse-integer (nth 10 row) :junk-allowed t))))))
 263
 264 (defmethod database-set-sequence-position (sequence-name
 265                                            (position integer)
 266                                            (database odbc-database))
 267   (database-execute-command
 268    (format nil "UPDATE ~A SET last_value=~A,is_called='t'"
 269            (%sequence-name-to-table sequence-name)
 270            position)
 271    database)
 272   position)
 273
 274 (defmethod database-sequence-next (sequence-name (database odbc-database))
 275   (without-interrupts
 276    (let* ((table-name (%sequence-name-to-table sequence-name))
 277           (tuple
 278            (car (database-query
 279                  (concatenate 'string "SELECT last_value,is_called FROM "
 280                               table-name)
 281                  database :auto nil))))
 282      (cond
 283        ((char-equal (schar (second tuple) 0) #\f)
 284         (database-execute-command
 285          (format nil "UPDATE ~A SET is_called='t'" table-name)
 286          database)
 287         (car tuple))
 288        (t
 289         (let ((new-pos (1+ (car tuple))))
 290          (database-execute-command
 291           (format nil "UPDATE ~A SET last_value=~D" table-name new-pos)
 292           database)
 293          new-pos))))))
 294
 295 (defmethod database-sequence-last (sequence-name (database odbc-database))
 296   (without-interrupts
 297    (caar (database-query
 298           (concatenate 'string "SELECT last_value FROM "
 299                        (%sequence-name-to-table sequence-name))
 300           database :auto nil))))
 301
 302 (defmethod database-create (connection-spec (type (eql :odbc)))
 303   (declare (ignore connection-spec))
 304   (warn "Not implemented."))
 305
 306 (defmethod database-destroy (connection-spec (type (eql :odbc)))
 307   (declare (ignore connection-spec))
 308   (warn "Not implemented."))
 309
 310 (defmethod database-probe (connection-spec (type (eql :odbc)))
 311   (when (find (car connection-spec) (database-list connection-spec type)
 312               :test #'string-equal)
 313     t))
 314
 315 (defmethod database-list (connection-spec (type (eql :odbc)))
 316   (declare (ignore connection-spec))
 317   (odbc-dbi:list-all-data-sources))
 318
 319 (defmethod database-list-indexes ((database odbc-database)
 320                                   &key (owner nil))
 321   (let ((result '()))
 322     (dolist (table (database-list-tables database :owner owner) result)
 323       (setq result
 324         (append (database-list-table-indexes table database :owner owner)
 325                 result)))))
 326
 327 (defmethod database-list-table-indexes (table (database odbc-database)
 328                                         &key (owner nil))
 329   (declare (ignore owner))
 330   (odbc-list-table-indexes table database))
 331
 332 (defun odbc-list-table-indexes (table database)
 333   (multiple-value-bind (rows col-names)
 334       (odbc-dbi:list-table-indexes
 335        table
 336        :db (database-odbc-conn database))
 337     (declare (ignore col-names))
 338     ;; INDEX_NAME is hard-coded in sixth position by ODBC driver
 339     ;; FIXME: ??? is hard-coded in the fourth position
 340     (do ((results nil)
 341          (loop-rows rows (cdr loop-rows)))
 342         ((null loop-rows) (nreverse results))
 343       (let* ((row (car loop-rows))
 344              (col (nth 5 row)))
 345         (unless (find col results :test #'string-equal)
 346           (push col results))))))
 347
 348 ;;; Database capabilities
 349
 350 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :odbc)))
 351   nil)
 352
 353
 354 (defmethod database-initialize-database-type ((database-type (eql :odbc)))
 355   ;; nothing to do
 356   t)
 357
 358 (when (clsql-base:database-type-library-loaded :odbc)
 359   (clsql-base:initialize-database-type :database-type :odbc))