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: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:database-type-load-foreign ((databae-type (eql :aodbc)))
  28   t)
  29
  30 (when (find-package :dbi)
  31   (clsql-base: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 field-names)
  78   #+aodbc-v2
  79   (handler-case
  80       (dbi:sql query-expression :db (database-aodbc-conn database)
  81                :types result-types
  82                :column-names field-names)
  83       (clsql-error (e)
  84         (error e))
  85     (error ()
  86       (error 'clsql-sql-error
  87              :database database
  88              :expression query-expression
  89              :errno nil
  90              :error "Query failed"))))
  91
  92 (defmethod database-execute-command (sql-expression
  93                                      (database aodbc-database))
  94   #+aodbc-v2
  95   (handler-case
  96       (dbi:sql sql-expression :db (database-aodbc-conn database))
  97       (clsql-error (e)
  98         (error e))
  99     (error ()
 100       (error 'clsql-sql-error
 101              :database database
 102              :expression sql-expression
 103              :errno nil
 104              :error "Execute command failed"))))
 105
 106 (defstruct aodbc-result-set
 107   (query nil)
 108   (types nil :type cons)
 109   (full-set nil :type boolean))
 110
 111 (defmethod database-query-result-set ((query-expression string)
 112                                       (database aodbc-database)
 113                                       &key full-set result-types)
 114   #+aodbc-v2
 115   (handler-case
 116       (multiple-value-bind (query column-names)
 117           (dbi:sql query-expression
 118                    :db (database-aodbc-conn database)
 119                    :row-count nil
 120                    :column-names t
 121                    :query t
 122                    :types result-types
 123                    )
 124         (values
 125          (make-aodbc-result-set :query query :full-set full-set
 126                                 :types result-types)
 127          (length column-names)
 128          nil ;; not able to return number of rows with aodbc
 129          ))
 130       (clsql-error (e)
 131         (error e))
 132     (error ()
 133       (error 'clsql-sql-error
 134              :database database
 135              :expression query-expression
 136              :errno nil
 137              :error "Query result set failed"))))
 138
 139 (defmethod database-dump-result-set (result-set (database aodbc-database))
 140   #+aodbc-v2
 141   (dbi:close-query (aodbc-result-set-query result-set))
 142   t)
 143
 144 (defmethod database-store-next-row (result-set
 145                                     (database aodbc-database)
 146                                     list)
 147   #+aodbc-v2
 148   (let ((row (dbi:fetch-row (aodbc-result-set-query result-set) nil 'eof)))
 149     (if (eq row 'eof)
 150         nil
 151       (progn
 152         (loop for elem in row
 153             for rest on list
 154             do
 155               (setf (car rest) elem))
 156         list))))
 157
 158 ;;; Sequence functions
 159
 160 (defun %sequence-name-to-table (sequence-name)
 161   (concatenate 'string "_CLSQL_SEQ_" (sql-escape sequence-name)))
 162
 163 (defun %table-name-to-sequence-name (table-name)
 164   (and (>= (length table-name) 11)
 165        (string-equal (subseq table-name 0 11) "_CLSQL_SEQ_")
 166        (subseq table-name 11)))
 167
 168 (defmethod database-create-sequence (sequence-name
 169                                      (database aodbc-database))
 170   (let ((table-name (%sequence-name-to-table sequence-name)))
 171     (database-execute-command
 172      (concatenate 'string "CREATE TABLE " table-name
 173                   " (last_value int NOT NULL PRIMARY KEY, increment_by int, min_value int, is_called char(1))")
 174      database)
 175     (database-execute-command
 176      (concatenate 'string "INSERT INTO " table-name
 177                   " VALUES (1,1,1,'f')")
 178      database)))
 179
 180 (defmethod database-drop-sequence (sequence-name
 181                                    (database aodbc-database))
 182   (database-execute-command
 183    (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
 184    database))
 185
 186 (defmethod database-list-sequences ((database aodbc-database)
 187                                     &key (owner nil))
 188   (declare (ignore owner))
 189   (warn "database-list-sequences not implemented for AODBC.")
 190   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 (defmethod database-initialize-database-type ((database-type (eql :aodbc)))
 305   t)
 306
 307 (when (clsql-base:database-type-library-loaded :aodbc)
 308   (clsql-base:initialize-database-type :database-type :aodbc))