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   (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
 189           (database-query "SHOW TABLES LIKE '%clsql_seq%'"
 190                           database nil)))
 191
 192 (defmethod database-list-tables ((database aodbc-database)
 193                                  &key (owner nil))
 194   (declare (ignore owner))
 195   #+aodbc-v2
 196   (multiple-value-bind (rows col-names)
 197       (dbi:list-all-database-tables :db (database-aodbc-conn database))
 198     (declare (ignore col-names))
 199       ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 200       ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 201       (loop for row in rows
 202           when (and (not (string-equal "information_schema" (nth 1 row)))
 203                     (string-equal "TABLE" (nth 3 row)))
 204           collect (nth 2 row))))
 205
 206 (defmethod database-list-views ((database aodbc-database)
 207                                  &key (owner nil))
 208   (declare (ignore owner))
 209   #+aodbc-v2
 210   (multiple-value-bind (rows col-names)
 211       (dbi:list-all-database-tables :db (database-aodbc-conn database))
 212     (declare (ignore col-names))
 213     ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
 214     ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
 215     (loop for row in rows
 216         when (and (not (string-equal "information_schema" (nth 1 row)))
 217                   (string-equal "VIEW" (nth 3 row)))
 218         collect (nth 2 row))))
 219
 220 (defmethod database-list-attributes ((table string) (database aodbc-database)
 221                                      &key (owner nil))
 222   (declare (ignore owner))
 223   #+aodbc-v2
 224   (multiple-value-bind (rows col-names)
 225       (dbi:list-all-table-columns table :db (database-aodbc-conn database))
 226     (let ((pos (position "COLUMN_NAME" col-names :test #'string-equal)))
 227       (when pos
 228         (loop for row in rows
 229             collect (nth pos row))))))
 230
 231 (defmethod database-attribute-type ((attribute string) (table string) (database aodbc-database)
 232                                      &key (owner nil))
 233   (declare (ignore owner))
 234   #+aodbc-v2
 235   (multiple-value-bind (rows col-names)
 236       (dbi:list-all-table-columns table :db (database-aodbc-conn database))
 237     (let ((pos (position "TYPE_NAME" col-names :test #'string-equal)))
 238       (when pos
 239         (loop for row in rows
 240             collect (nth pos row))))))
 241
 242 (defmethod database-list-indexes ((database aodbc-database)
 243                                  &key (owner nil))
 244   (warn "database-list-indexes not implemented for AODBC.")
 245   nil)
 246
 247 (defmethod database-set-sequence-position (sequence-name
 248                                            (position integer)
 249                                            (database aodbc-database))
 250   (database-execute-command
 251    (format nil "UPDATE ~A SET last_value=~A,is_called='t'"
 252            (%sequence-name-to-table sequence-name)
 253            position)
 254    database)
 255   position)
 256
 257 (defmethod database-sequence-next (sequence-name (database aodbc-database))
 258   (without-interrupts
 259    (let* ((table-name (%sequence-name-to-table sequence-name))
 260           (tuple
 261            (car (database-query
 262                  (concatenate 'string "SELECT last_value,is_called FROM "
 263                               table-name)
 264                  database
 265                  :auto))))
 266      (cond
 267        ((char-equal (schar (second tuple) 0) #\f)
 268         (database-execute-command
 269          (format nil "UPDATE ~A SET is_called='t'" table-name)
 270          database)
 271         (car tuple))
 272        (t
 273         (let ((new-pos (1+ (car tuple))))
 274          (database-execute-command
 275           (format nil "UPDATE ~A SET last_value=~D" table-name new-pos)
 276           database)
 277          new-pos))))))
 278
 279 (defmethod database-sequence-last (sequence-name (database aodbc-database))
 280   (without-interrupts
 281    (caar (database-query
 282           (concatenate 'string "SELECT last_value FROM "
 283                        (%sequence-name-to-table sequence-name))
 284           database
 285           :auto))))
 286
 287 (defmethod database-create (connection-spec (type (eql :aodbc)))
 288   (warn "Not implemented."))
 289
 290 (defmethod database-destroy (connection-spec (type (eql :aodbc)))
 291   (warn "Not implemented."))
 292
 293 (defmethod database-probe (connection-spec (type (eql :aodbc)))
 294   (warn "Not implemented."))
 295
 296 ;;; Backend capabilities
 297
 298 (defmethod database-underlying-type ((database aodbc-database))
 299   (database-aodbc-db-type database))
 300
 301 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :aodbc)))
 302   nil)
 303
 304 #+ignore
 305 (when (clsql-base-sys:database-type-library-loaded :aodbc)
 306   (clsql-base-sys:initialize-database-type :database-type :aodbc))