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