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-db-type :accessor database-odbc-db-type)))
  30
  31 (defmethod database-name-from-spec (connection-spec
  32                                     (database-type (eql :odbc)))
  33   (check-connection-spec connection-spec database-type (dsn user password))
  34   (destructuring-bind (dsn user password) connection-spec
  35     (declare (ignore password))
  36     (concatenate 'string dsn "/" user)))
  37
  38 (defmethod database-connect (connection-spec (database-type (eql :odbc)))
  39   (check-connection-spec connection-spec database-type (dsn user password))
  40   (destructuring-bind (dsn user password) connection-spec
  41     (handler-case
  42         (let ((db (make-instance 'odbc-database
  43                                  :name (database-name-from-spec connection-spec :odbc)
  44                                  :database-type :odbc
  45                                  :dbi-package (find-package '#:odbc-dbi)
  46                                  :odbc-conn
  47                                  (odbc-dbi:connect :user user
  48                                                    :password password
  49                                                    :data-source-name dsn))))
  50           (store-type-of-connected-database db)
  51           db)
  52       (error ()         ;; Init or Connect failed
  53         (error 'sql-connection-error
  54                :database-type database-type
  55                :connection-spec connection-spec
  56                :message "Connection failed")))))
  57
  58 (defmethod database-underlying-type ((database odbc-database))
  59   (database-odbc-db-type database))
  60
  61 (defun store-type-of-connected-database (db)
  62   (let* ((odbc-conn (clsql-sys::odbc-conn db))
  63          (server-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_SERVER_NAME))
  64          (dbms-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_DBMS_NAME))
  65          (type
  66           ;; need SERVER-NAME and DBMS-NAME because many drivers mix this up
  67           (cond
  68            ((or (search "postgresql" server-name :test #'char-equal)
  69                 (search "postgresql" dbms-name :test #'char-equal))
  70             :postgresql)
  71            ((or (search "mysql" server-name :test #'char-equal)
  72                 (search "mysql" dbms-name :test #'char-equal))
  73             :mysql)
  74            ((or (search "oracle" server-name :test #'char-equal)
  75                 (search "oracle" dbms-name :test #'char-equal))
  76             :oracle))))
  77     (setf (database-odbc-db-type db) type)))
  78
  79
  80
  81
  82 ;;; Sequence functions
  83
  84 (defun %sequence-name-to-table (sequence-name)
  85   (concatenate 'string "_CLSQL_SEQ_" (sql-escape sequence-name)))
  86
  87 (defun %table-name-to-sequence-name (table-name)
  88   (and (>= (length table-name) 11)
  89        (string-equal (subseq table-name 0 11) "_CLSQL_SEQ_")
  90        (subseq table-name 11)))
  91
  92 (defmethod database-create-sequence (sequence-name
  93                                      (database odbc-database))
  94   (let ((table-name (%sequence-name-to-table sequence-name)))
  95     (database-execute-command
  96      (concatenate 'string "CREATE TABLE " table-name
  97                   " (last_value int NOT NULL PRIMARY KEY, increment_by int, min_value int, is_called char(1))")
  98      database)
  99     (database-execute-command
 100      (concatenate 'string "INSERT INTO " table-name
 101                   " VALUES (1,1,1,'f')")
 102      database)))
 103
 104 (defmethod database-drop-sequence (sequence-name
 105                                    (database odbc-database))
 106   (database-execute-command
 107    (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
 108    database))
 109
 110 (defmethod database-list-sequences ((database odbc-database)
 111                                     &key (owner nil))
 112   (declare (ignore owner))
 113   ;; FIXME: Underlying database backend stuff should come from that backend
 114
 115   (case (database-odbc-db-type database)
 116     (:mysql
 117      (mapcan #'(lambda (s)
 118                  (let ((sn (%table-name-to-sequence-name (car s))))
 119                    (and sn (list sn))))
 120              (database-query "SHOW TABLES" database nil nil)))
 121     ((:postgresql :postgresql-socket)
 122      (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
 123             (database-query "SELECT RELNAME FROM pg_class WHERE RELNAME LIKE '%clsql_seq%'"
 124                             database nil nil)))))
 125
 126
 127 (defmethod database-set-sequence-position (sequence-name
 128                                            (position integer)
 129                                            (database odbc-database))
 130   (database-execute-command
 131    (format nil "UPDATE ~A SET last_value=~A,is_called='t'"
 132            (%sequence-name-to-table sequence-name)
 133            position)
 134    database)
 135   position)
 136
 137 (defmethod database-sequence-next (sequence-name (database odbc-database))
 138   (without-interrupts
 139    (let* ((table-name (%sequence-name-to-table sequence-name))
 140           (tuple
 141            (car (database-query
 142                  (concatenate 'string "SELECT last_value,is_called FROM "
 143                               table-name)
 144                  database :auto nil))))
 145      (cond
 146        ((char-equal (schar (second tuple) 0) #\f)
 147         (database-execute-command
 148          (format nil "UPDATE ~A SET is_called='t'" table-name)
 149          database)
 150         (car tuple))
 151        (t
 152         (let ((new-pos (1+ (car tuple))))
 153          (database-execute-command
 154           (format nil "UPDATE ~A SET last_value=~D" table-name new-pos)
 155           database)
 156          new-pos))))))
 157
 158 (defmethod database-sequence-last (sequence-name (database odbc-database))
 159   (without-interrupts
 160    (caar (database-query
 161           (concatenate 'string "SELECT last_value FROM "
 162                        (%sequence-name-to-table sequence-name))
 163           database :auto nil))))
 164
 165 (defmethod database-create (connection-spec (type (eql :odbc)))
 166   (declare (ignore connection-spec))
 167   (warn "Not implemented."))
 168
 169 (defmethod database-destroy (connection-spec (type (eql :odbc)))
 170   (declare (ignore connection-spec))
 171   (warn "Not implemented."))
 172
 173 (defmethod database-probe (connection-spec (type (eql :odbc)))
 174   (when (find (car connection-spec) (database-list connection-spec type)
 175               :test #'string-equal)
 176     t))
 177
 178 (defmethod database-list (connection-spec (type (eql :odbc)))
 179   (declare (ignore connection-spec))
 180   (odbc-dbi:list-all-data-sources))
 181
 182 (defmethod database-list-indexes ((database odbc-database)
 183                                   &key (owner nil))
 184   (let ((result '()))
 185     (dolist (table (database-list-tables database :owner owner) result)
 186       (setq result
 187         (append (database-list-table-indexes table database :owner owner)
 188                 result)))))
 189
 190 (defmethod database-list-table-indexes (table (database odbc-database)
 191                                         &key (owner nil))
 192   (declare (ignore owner))
 193   (multiple-value-bind (rows col-names)
 194       (odbc-dbi:list-table-indexes
 195        table
 196        :db (clsql-sys::odbc-conn database))
 197     (declare (ignore col-names))
 198     ;; INDEX_NAME is hard-coded in sixth position by ODBC driver
 199     ;; FIXME: ??? is hard-coded in the fourth position
 200     (do ((results nil)
 201          (loop-rows rows (cdr loop-rows)))
 202         ((null loop-rows) (nreverse results))
 203       (let* ((row (car loop-rows))
 204              (col (nth 5 row)))
 205         (unless (find col results :test #'string-equal)
 206           (push col results))))))
 207
 208 ;;; Database capabilities
 209
 210 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :odbc)))
 211   nil)
 212
 213
 214 (defmethod database-initialize-database-type ((database-type (eql :odbc)))
 215   ;; nothing to do
 216   t)
 217
 218 (when (clsql-sys:database-type-library-loaded :odbc)
 219   (clsql-sys:initialize-database-type :database-type :odbc))