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