;; CLISP Oracle interface;; Copyright (C) 2002 Alma Mater Software, Inc., Tarrytown, NY, USA;; This program is free software; you can redistribute it and/or modify; it under the terms of the GNU General Public License version 2 as; published by the Free Software Foundation; see file GNU-GPL.;; This program is distributed in the hope that it will be useful,; but WITHOUT ANY WARRANTY; without even the implied warranty of; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the; GNU General Public License for more details.;; You should have received a copy of the GNU General Public License; along with this program; if not, write to the Free Software Foundation,; Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.;; $Id: oracle.lisp,v 1.6 2002/09/29 12:20:07 hin Exp $(defpackage "ORACLE"  (:documentation   "CLISP Oracle interface from Alma Mater Software, Inc.  Inquiries to: John Hinsdale <hin@alma.com>")  (:use "LISP" "FFI")  (:export "CONNECT" "DISCONNECT" "RUN-SQL"           "DO-ROWS" "FETCH" "FETCH-ALL" "PEEK" "COLUMNS" "EOF"           "INSERT-ROW" "UPDATE-ROW" "ROW-COUNT"           "WITH-TRANSACTION" "COMMIT" "ROLLBACK" "AUTO-COMMIT"	   "SQLCOL-NAME" "SQLCOL-TYPE" "SQLCOL-SIZE" "SQLCOL-SCALE" "SQLCOL-PRECISION" "SQLCOL-NULL_OK" ))(in-package "ORACLE"); Use "C" as foreign language(default-foreign-language :stdc); Inline everything for speed(proclaim '(inlinearef-null array-to-hash auto-commit auto-commit-nocheck catcheck-connection check-pairs check-success check-unique-elementscolumn-names columns comma-list-of-keys commit commit-nocheck connectconnection-key convert-type c-truth curconn disconnect do-rows-coldo-rows-index-of do-rows-var eof fetch flatten from-sqlvalgethash-required hash-combine hash-to-sqlparam-array if-nullinsert-row is-select-query join lisp-truth nl out out-nl pairs-to-hashpeek rollback rollback-nocheck row-count row-to-result rowval run-sqlto-sqlval to-string update-row valid-symbol));; GLOBALS; Cached connections(defvar *oracle-connection-cache* nil)  ; Table of established connections.  Maps keys constructed by                                        ; CONNECTION-KEY to a "db" struct(defvar *oracle-connection*       nil)  ; The current connection, a "db" struct, or NIL if none(defvar *oracle-in-transaction*   nil)  ; Nesting guard for WITH-TRANSACTION macro;; Lisp data types; Cached per database connection(defstruct db  connection     ; "C" library handle for Oracle operations  fetch-called   ; Flag: has fetch been called yet  pending-row    ; Look-ahead row (for PEEK)  colinfo        ; Cache the column info for speed  hkey           ; Key in global hash (useful for removal)); Shorthand for current library handle(defun curconn ()  (if (null *oracle-connection*)      nil    (db-connection *oracle-connection*)));  "C" DATA TYPES (oiface.h); Column info element(def-c-struct sqlcol (name      c-string)                     (type      c-string)                     (size      int)                     (scale     int)                     (precision int)                     (null_ok   int)); Row data element(def-c-struct sqlval (data      c-string)                     (is_null   int)); Bind parameter (name, value) pair(def-c-struct sqlparam (name    c-string)                       (value   sqlval));---------------------------------------------------------------------------------------; EXPORTED LISP FUNCTIONS;----------------------------------------------; CONNECT(defun connect (user password server &optional schema (auto-commit t) (prefetch-buffer-bytes 0))"(ORACLE::CONNECT user password server &optional schema auto-commit prefetch-buffer-bytes)Connect to an Oracle database.  All subsequent operations will affectthis database.  A single program can access several differentdatabases by repeated calls to CONNECT.  Connections are cached: ifyou call CONNECT again with the same arguments, the actual Oracleconnection will be re-used.  CONNECT may not be called inside theWITH-TRANSACTION macro.Required arguments:    user         Oracle user ID    password     Password for Oracle user, or NIL for no password (!)    server       Oracle server ID (SID)Optional arguments:    schema       Oracle default schema (default: NIL).  If null, same as user.                 This allows you to log on with one user's id/password but see                 the database as if you were some other user.    auto-commit  Commit after every operation (default: T).  Set this to NIL if                 you intend to do transactions, and call call COMMIT explicitly.    prefetch-    Number of bytes to cache from SELECT fetches (default: 1,000,000)    buffer-      If you are very short of memory, or have a slow connection to Oracle,    bytes        reduce this to 10000 or so.Returns: T if a cached connection was re-used (NIL if a new connection         was created and cached)."  (when *oracle-in-transaction* (error "CONNECT not allowed inside WITH-TRANSACTION"))  ; Default current schema  (if (null schema) (setq schema user))  ; Set up global connection cache  (if (null *oracle-connection-cache*)      (setf *oracle-connection-cache* (make-hash-table :test #'equal)))   ; Construct key for connection cache   (let* ((hkey (connection-key user schema server))         (conn (gethash hkey *oracle-connection-cache*))         (result t))    (when (null conn)          ; Connect to database          (let ((handle (oracle_connect user schema password server prefetch-buffer-bytes (c-truth auto-commit))))            (when (not (lisp-truth (oracle_success handle)))                   ; Retry connection                   ; ... TODO: implement retry logic here                   ; Failed all attempts; give up                  (error (oracle_last_error handle)))            ; OK: cache the connection            (setf conn (make-db :connection handle :hkey hkey))            (setf (gethash hkey *oracle-connection-cache*) conn)            (setf result nil)))    ; Set current connection    (setf *oracle-connection* conn)    result));----------------------------------------------; DISCONNECT(defun disconnect ()"(ORACLE:DISCONNECT)Disconnect from the database.  No more calls can be made until CONNECTis called again.  The connection is closed and removed from theconnection cache.  Does nothing if there was no connection.DISCONNECT may not be called inside the WITH-TRANSACTION macro.Arguments: none.Returns: NIL"  (when *oracle-in-transaction* (error "DISCONNECT not allowed inside WITH-TRANSACTION"))  (when (curconn)        (oracle_disconnect (curconn))        (check-success)        ; Remove connection from the hash table        (remhash (db-hkey *oracle-connection*) *oracle-connection-cache*)        (setf *oracle-connection* nil)));----------------------------------------------; RUN-SQL(defun run-sql (sql &optional params (is-select t is-select-given))"(ORACLE::RUN-SQL sql &optional params is-select)Run a SQL statement.  Must be connected to a database.Required argument:    sql        Text of SQL statement, as a string.  Statement may               contain named parameters, e.g. \":myparam\" which               whose values will be substituted from the parameters               passed in in the next argument, \"params\"Optional arguments:    params     A mapping of the names of the bind-parameters in               the query to their values.  The set of named parameters               in the query must match they keys of the hash EXACTLY.               The mapping may be passed as either (1) a hash table               whose keys are the named parameters or (2) a list of               pairs, ((name value) (name value) ...).    is-select  (Boolean) Whether the statement is a SELECT query.               You usually do not need to set this as it is detected               by default based on the SQL text.  However, there are situations,               such as when a SELECT query begins with comment, that you need               to specify it explicitly.Returns: the number of rows affected for non-SELECT statements, zerofor SELECT statements."  (check-connection "run a SQL statement")  ; Default statement type: query vs. command  (when (not is-select-given)        (setf is-select (is-select-query sql)))  ; If pairs given, convert them to hash  (setf params (check-pairs params))  (oracle_exec_sql (curconn)                   sql                   (hash-to-sqlparam-array params)                   (c-truth (not is-select)))  (setf (db-fetch-called *oracle-connection*) nil)  (setf (db-pending-row *oracle-connection*) nil)  (setf (db-colinfo *oracle-connection*) nil)  (check-success)  ; Get the row count for the result  (let ((result (row-count)))    (check-success)    result));----------------------------------------------; DO-ROWS(defmacro do-rows (vars &body body)"(ORACLE:DO-ROWS (vars &body body)Macro that extends Lisp's DO loop construct, binding database columnvalues to the symbols given in the first argument, which must be anon-empty list of symbols matching columns of an active SELECT query.It is allowed to call CONNECT in the body of the loop, but only toswitch the conneciton to a different database other than the one thatwas used to do the SELECT.  This is useful for reading from onedatabase while writing to another.When specifying variables to which to bind column values, instead of asingle symbol, a pair (bound-var \"column-name\") can be specified whichwill cause values from the given column name to be bound to the givenvariable.  This is for unusual cases where a Lisp symbol cannot becreated with the same for the column (e.g., a column names "T") andwhen it is inconvenient of impossible to alias the column with\"SELECT ... AS\""  ; COMPILE TIME CHECKS  ; Validate both variable list and column aliases are unique (at  ; compile time)  (check-unique-elements (map 'list #'do-rows-var vars))  ; Conceivably the caller MIGHT want to bind two different loop  ; variables to the same SELECTed column, but more likely that is a bug  ; on his part, so don't allow it.  (check-unique-elements (map 'list #'do-rows-col vars))  ; Declare variables and bind to fetch from appropriate array index.  ; Generate a map of the bound vars to gensyms which contain the index of that  ; var into the fetched array.  (let ((fetch-result (gensym))        (saved-oracle-connection (gensym))        (index-vars (make-hash-table)))    (dolist (v vars)            (setf (gethash (to-string (do-rows-var v)) index-vars) (gensym)))    (list 'let          ; Declare saved Oracle connection and calculated array indices OUTSIDE fetch loop          (append `((,saved-oracle-connection *oracle-connection*))                        (map 'list                             #'(lambda (v) (list (gethash (to-string (do-rows-var v)) index-vars)                                                 (list 'do-rows-index-of (list 'quote v))))                             vars))          ; Emit the DO loop itself          (append (list                    'do*                   (append (list `(,fetch-result (fetch 'array) (fetch 'array)))                             (map 'list                                   #'(lambda (k)                                      (let ((iter (list 'aref-null fetch-result (gethash (to-string (do-rows-var k)) index-vars))))                                        (list (do-rows-var k) iter iter)))                                  vars))                   (list `(null ,fetch-result) '(row-count)))                  (if (atom body) (list body) body)                  (list `(setf *oracle-connection* ,saved-oracle-connection))))));----------------------------------------------; FETCH(defun fetch (&optional (result-type 'ARRAY))"(ORACLE:FETCH (&optional (result-type 'ARRAY))))Fetch a row of data.  Returns a row of values corresponding to thecolumns of the SELECT statment.  The row data is returned in one ofthree different forms, depending on the supplied result type:    ARRAY: Values will be returned in an array with the same number of           columns as in the SELECT statment, in the same order.           This is the default.    PAIRS: A list of pairs (column, value) will be returned.  The           number and order of pairs is the same as the columns in the           SELECT statement.    HASH:  A hash table whose keys are the column names and whose values           are the column values in the row.  The SELECT columns MUST           BE UNIQUE and be valid Lisp symbols to use this option. If           you are SELECT-ing an expression, you need to use a column           alias: \"SELECT <expr> AS some_alias ...\"Oracle data types are converted to Lisp datatypes as follows:    - Numbers are converted to Lisp numeric types (fixnum/bignum/float)    - NULL values are converetd to Lisp's NIL    - Strings (char, varchar, varchar2) are left as Lisp strings    - Dates are converted to strings of the form \"YYYY-MM-DD HH:MM:SS\"      where HH is 24-hour form.Returns NIL if no rows are left (the EOF predicate can be beforea fetch to test this condition).Arguments: none"  (check-connection "fetch a row of data")  (let (result)    ; Three cases: (1) have lookahead - use it (2) at EOF (3) Do a real fetch    (cond     ; Use pending look-ahead row and reset, else do a "real" fetch     ((db-pending-row *oracle-connection*)      (setf result (row-to-result (db-pending-row *oracle-connection*) result-type))      (setf (db-pending-row *oracle-connection*) nil))     ; Check if already at EOF from previous fetches     ((and (db-fetch-called *oracle-connection*)           (let ((oracle-eof (lisp-truth (oracle_eof (curconn)))))             (check-success)             oracle-eof))      ; Do nothing