db-aodbc/aodbc-sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          aodbc-sql.cl
   6 ;;;; Purpose:       Low-level interface for CLSQL AODBC backend
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; $Id$
  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 (in-package #:clsql-aodbc)
  20
  21 ;; interface foreign library loading routines
  22 (defmethod clsql-base-sys:database-type-library-loaded ((database-type (eql :aodbc)))
  23   "T if foreign library was able to be loaded successfully. "
  24   (when (find-package :dbi) ;; finds Allegro's DBI (AODBC) package
  25     t))
  26
  27 (defmethod clsql-base-sys:database-type-load-foreign ((databae-type (eql :aodbc)))
  28   t)
  29
  30 (when (find-package :dbi)
  31   (clsql-base-sys:database-type-load-foreign :aodbc))
  32
  33 (defmethod database-initialize-database-type ((database-type (eql :aodbc)))
  34   t)
  35
  36
  37 ;; AODBC interface
  38
  39 (defclass aodbc-database (database)
  40   ((aodbc-conn :accessor database-aodbc-conn :initarg :aodbc-conn)
  41    (aodbc-db-type :accessor database-aodbc-db-type :initform :unknown)))
  42
  43 (defmethod database-name-from-spec (connection-spec
  44                                     (database-type (eql :aodbc)))
  45   (check-connection-spec connection-spec database-type (dsn user password))
  46   (destructuring-bind (dsn user password) connection-spec
  47     (declare (ignore password))
  48     (concatenate 'string dsn "/" user)))
  49
  50 (defmethod database-connect (connection-spec (database-type (eql :aodbc)))
  51   (check-connection-spec connection-spec database-type (dsn user password))
  52   #+aodbc-v2
  53   (destructuring-bind (dsn user password) connection-spec
  54     (handler-case
  55         (make-instance 'aodbc-database
  56           :name (database-name-from-spec connection-spec :aodbc)
  57           :database-type :aodbc
  58           :aodbc-conn
  59           (dbi:connect :user user
  60                        :password password
  61                        :data-source-name dsn))
  62       (clsql-error (e)
  63         (error e))
  64       (error ()         ;; Init or Connect failed
  65         (error 'clsql-connect-error
  66                :database-type database-type
  67                :connection-spec connection-spec
  68                :errno nil
  69                :error "Connection failed")))))
  70
  71 (defmethod database-disconnect ((database aodbc-database))
  72   #+aodbc-v2
  73   (dbi:disconnect (database-aodbc-conn database))
  74   (setf (database-aodbc-conn database) nil)
  75   t)
  76
  77 (defmethod database-query (query-expression (database aodbc-database) result-types)
  78   #+aodbc-v2
  79   (handler-case
  80       (dbi:sql query-expression :db (database-aodbc-conn database)
  81                :types result-types)
  82       (clsql-error (e)
  83         (error e))
  84     (error ()
  85       (error 'clsql-sql-error
  86              :database database
  87              :expression query-expression
  88              :errno nil
  89              :error "Query failed"))))
  90
  91 (defmethod database-execute-command (sql-expression
  92                                      (database aodbc-database))
  93   #+aodbc-v2
  94   (handler-case
  95       (dbi:sql sql-expression :db (database-aodbc-conn database))
  96       (clsql-error (e)
  97         (error e))
  98     (error ()
  99       (error 'clsql-sql-error
 100              :database database
 101              :expression sql-expression
 102              :errno nil
 103              :error "Execute command failed"))))
 104
 105 (defstruct aodbc-result-set
 106   (query nil)
 107   (types nil :type cons)
 108   (full-set nil :type boolean))
 109
 110 (defmethod database-query-result-set ((query-expression string)
 111                                       (database aodbc-database)
 112                                       &key full-set result-types)
 113   #+aodbc-v2
 114   (handler-case
 115       (multiple-value-bind (query column-names)
 116           (dbi:sql query-expression
 117                    :db (database-aodbc-conn database)
 118                    :row-count nil
 119                    :column-names t
 120                    :query t
 121                    :types result-types
 122                    )
 123         (values
 124          (make-aodbc-result-set :query query :full-set full-set
 125                                 :types result-types)
 126          (length column-names)
 127          nil ;; not able to return number of rows with aodbc
 128          ))
 129       (clsql-error (e)
 130         (error e))
 131     (error ()
 132       (error 'clsql-sql-error
 133              :database database
 134              :expression query-expression
 135              :errno nil
 136              :error "Query result set failed"))))
 137
 138 (defmethod database-dump-result-set (result-set (database aodbc-database))
 139   #+aodbc-v2
 140   (dbi:close-query (aodbc-result-set-query result-set))
 141   t)
 142
 143 (defmethod database-store-next-row (result-set
 144                                     (database aodbc-database)
 145                                     list)
 146   #+aodbc-v2
 147   (let ((row (dbi:fetch-row (aodbc-result-set-query result-set) nil 'eof)))
 148     (if (eq row 'eof)
 149         nil
 150       (progn
 151         (loop for elem in row
 152             for rest on list
 153             do
 154               (setf (car rest) elem))
 155         list))))
 156
 157 ;;; Sequence functions
 158
 159 (defun %sequence-name-to-table (sequence-name)
 160   (concatenate 'string "_CLSQL_SEQ_" (sql-escape sequence-name)))
 161
 162 (defun %table-name-to-sequence-name (table-name)
 163   (and (>= (length table-name) 11)
 164        (string= (subseq table-name 0 11) "_CLSQL_SEQ_")
 165        (subseq table-name 11)))
 166
 167 (defmethod database-create-sequence (sequence-name
 168                                      (database aodbc-database))
 169   (let ((table-name (%sequence-name-to-table sequence-name)))
 170     (database-execute-command
 171      (concatenate 'string "CREATE TABLE " table-name
 172                   " (last_value int NOT NULL PRIMARY KEY, increment_by int, min_value int, is_called char(1))")
 173      database)
 174     (database-execute-command
 175      (concatenate 'string "INSERT INTO " table-name
 176                   " VALUES (1,1,1,'f')")
 177      database)))
 178
 179 (defmethod database-drop-sequence (sequence-name
 180                                    (database aodbc-database))
 181   (database-execute-command
 182    (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
 183    database))
 184
 185 (defmethod database-list-sequences ((database aodbc-database)
 186                                     &key (owner nil))
 187   (declare (ignore owner))
 188   (warn "database-list-sequences not implemented for AODBC.")
 189   nil)
 190
 191 (defmethod database-list-tables ((database aodbc-database)
 192                                  &key (owner nil))
 193   (declare (ignore owner))
 194   #+aodbc-v2
 195   (multiple-value-bind (rows col-names)
 196       (dbi:list-all-database-tables :db (database-aodbc-conn database))
 197     (declare (ignore col-names))
 198       ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 199       ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 200       (loop for row in rows
 201           when (and (not (string-equal "information_schema" (nth 1 row)))
 202                     (string-equal "TABLE" (nth 3 row)))
 203           collect (nth 2 row))))
 204
 205 (defmethod database-list-views ((database aodbc-database)
 206                                  &key (owner nil))
 207   (declare (ignore owner))
 208   #+aodbc-v2
 209   (multiple-value-bind (rows col-names)
 210       (dbi:list-all-database-tables :db (database-aodbc-conn database))
 211     (declare (ignore col-names))
 212     ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 213     ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 214     (loop for row in rows
 215         when (and (not (string-equal "information_schema" (nth 1 row)))
 216                   (string-equal "VIEW" (nth 3 row)))
 217         collect (nth 2 row))))
 218
 219 (defmethod database-list-attributes ((table string) (database aodbc-database)
 220                                      &key (owner nil))
 221   (declare (ignore owner))
 222   #+aodbc-v2
 223   (multiple-value-bind (rows col-names)
 224       (dbi:list-all-table-columns table :db (database-aodbc-conn database))
 225     (let ((pos (position "COLUMN_NAME" col-names :test #'string-equal)))
 226       (when pos
 227         (loop for row in rows
 228             collect (nth pos row))))))
 229
 230 (defmethod database-attribute-type ((attribute string) (table string) (database aodbc-database)
 231                                      &key (owner nil))
 232   (declare (ignore owner))
 233   #+aodbc-v2
 234   (multiple-value-bind (rows col-names)
 235       (dbi:list-all-table-columns table :db (database-aodbc-conn database))
 236     (let ((pos (position "TYPE_NAME" col-names :test #'string-equal)))
 237       (when pos
 238         (loop for row in rows
 239             collect (nth pos row))))))
 240
 241 (defmethod database-list-indexes ((database aodbc-database)
 242                                  &key (owner nil))
 243   (warn "database-list-indexes not implemented for AODBC.")
 244   nil)
 245
 246 (defmethod database-set-sequence-position (sequence-name
 247                                            (position integer)
 248                                            (database aodbc-database))
 249   (database-execute-command
 250    (format nil "UPDATE ~A SET last_value=~A,is_called='t'"
 251            (%sequence-name-to-table sequence-name)
 252            position)
 253    database)
 254   position)
 255
 256 (defmethod database-sequence-next (sequence-name (database aodbc-database))
 257   (without-interrupts
 258    (let* ((table-name (%sequence-name-to-table sequence-name))
 259           (tuple
 260            (car (database-query
 261                  (concatenate 'string "SELECT last_value,is_called FROM "
 262                               table-name)
 263                  database
 264                  :auto))))
 265      (cond
 266        ((char-equal (schar (second tuple) 0) #\f)
 267         (database-execute-command
 268          (format nil "UPDATE ~A SET is_called='t'" table-name)
 269          database)
 270         (car tuple))
 271        (t
 272         (let ((new-pos (1+ (car tuple))))
 273          (database-execute-command
 274           (format nil "UPDATE ~A SET last_value=~D" table-name new-pos)
 275           database)
 276          new-pos))))))
 277
 278 (defmethod database-sequence-last (sequence-name (database aodbc-database))
 279   (without-interrupts
 280    (caar (database-query
 281           (concatenate 'string "SELECT last_value FROM "
 282                        (%sequence-name-to-table sequence-name))
 283           database
 284           :auto))))
 285
 286 (defmethod database-create (connection-spec (type (eql :aodbc)))
 287   (warn "Not implemented."))
 288
 289 (defmethod database-destroy (connection-spec (type (eql :aodbc)))
 290   (warn "Not implemented."))
 291
 292 (defmethod database-probe (connection-spec (type (eql :aodbc)))
 293   (warn "Not implemented."))
 294
 295 ;;; Backend capabilities
 296
 297 (defmethod database-underlying-type ((database aodbc-database))
 298   (database-aodbc-db-type database))
 299
 300 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :aodbc)))
 301   nil)
 302
 303 #+ignore
 304 (when (clsql-base-sys:database-type-library-loaded :aodbc)
 305   (clsql-base-sys:initialize-database-type :database-type :aodbc))