+29 May 2004 Kevin Rosenberg <kevin@rosenberg.net>
+ * sql/package.lisp: Add API for prepared statments.
+ * sql/fdml.lisp: Change implicity flatp processing
+ for string map-query for greater CommonSQL conformance.
+ Add high-high API for prepared statements. Not complete.
+ * tests/test-basic.lisp: Add test for map-query and
+ single argument.
+ * sql/transactions.lisp: Change name/semantics of
+ autocommit to set-autocommit.
+ * sql/generic-postgresql.lisp: Add support for
+ prepared statements.
+ * tests/test-internal.lisp: New file
+
27 May 2004 Kevin Rosenberg <kevin@rosenberg.net>
* Version 2.11.3
* sql/ooddl.lisp: Commit patch from Edi Weitz fixing return
(:file "utils")
(:file "test-init")
(:file "benchmarks")
- (:file "test-time")
+ (:file "test-internal")
(:file "test-basic")
+ (:file "test-time")
(:file "test-connection")
(:file "test-fddl")
(:file "test-fdml")
:returning ,c-return)))
(defun ,lisp-cli-fn (,@ll &key database nulls-ok)
(let ((result (funcall %lisp-cli-fn ,@ll)))
- #+ignore
(case result
- (#.+oci-success+
- +oci-success+)
- (#.+oci-error+
- (handle-oci-error :database database :nulls-ok nulls-ok))
- (#.+oci-no-data+
- (error 'sql-database-error :message "OCI No Data Found"))
- (#.+oci-success-with-info+
- (error 'sql-database-error :message "internal error: unexpected +oci-success-with-info"))
- (#.+oci-no-data+
- (error 'sql-database-error :message "OCI No Data"))
- (#.+oci-invalid-handle+
- (error 'sql-database-error :message "OCI Invalid Handle"))
- (#.+oci-need-data+
- (error 'sql-database-error :message "OCI Need Data"))
- (#.+oci-still-executing+
- (error 'sql-temporary-error :message "OCI Still Executing"))
- (#.+oci-continue+
- (error 'sql-database-error :message "OCI Continue"))
- (1804
- (error 'sql-database-error :message "Check CLI_HOME and NLS settings."))
+ (#.SQL_SUCCESS
+ SQL_SUCCESS)
+ (#.SQL_SUCCESS_WITH_INFO
+ (format *standard-output* "sucess with info")
+ SQL_SUCCESS)
+ (#.SQL_ERROR
+ (error 'sql-database-error
+ :error-id result
+ :message
+ (format nil "DB2 error" result)))
(t
(error 'sql-database-error
:message
- (format nil "OCI unknown error, code=~A" result)))))))))
+ (format nil "DB2 unknown error, code=~A" result)))))))))
(defmacro def-raw-cli-routine
(funcall %lisp-cli-fn ,@ll)))))
-(def-cli-routine ("SQLAllocHandle" sql-allocate-handle)
+(def-cli-routine ("SQLAllocHandle" sql-alloc-handle)
:int
(fHandleType cli-smallint)
(hInput cli-handle)
(phOuput (* cli-handle)))
+(def-cli-routine ("SQLConnect" sql-connect)
+ :int
+ (hDb cli-handle)
+ (server :cstring)
+ (server-len cli-smallint)
+ (user :cstring)
+ (user-len cli-smallint)
+ (password :cstring)
+ (passwd-len cli-smallint))
+
;;; CLI Functions needed
;;; SQLBindParameter
(defconstant SQL_HANDLE_STMT 3)
(defconstant SQL_NTS -3)
+(defconstant SQL_ERROR -1)
+(defconstant SQL_SUCCESS 0)
+(defconstant SQL_SUCCESS_WITH_INFO 1)
+
(defmethod database-initialize-database-type ((database-type (eql :db2)))
t)
+(defclass db2-database (database)
+ ((henv :initform nil :allocation :class :initarg :henv :accessor henv)
+ (hdbc :initform nil :initarg :hdbc :accessor hdbc)))
+
+
+(defmethod database-name-from-spec (connection-spec
+ (database-type (eql :db2)))
+ (check-connection-spec connection-spec database-type (dsn user password))
+ (destructuring-bind (dsn user password) connection-spec
+ (declare (ignore password))
+ (concatenate 'string dsn "/" user)))
+
+(defmethod database-connect (connection-spec (database-type (eql :db2)))
+ (check-connection-spec connection-spec database-type (dsn user password))
+ (destructuring-bind (server user password) connection-spec
+ (handler-case
+ (let ((db (make-instance 'db2-database
+ :name (database-name-from-spec connection-spec :db2)
+ :database-type :db2)))
+ (db2-connect db server user password)
+ db)
+ (error () ;; Init or Connect failed
+ (error 'sql-connection-error
+ :database-type database-type
+ :connection-spec connection-spec
+ :message "Connection failed")))))
+
+
+;; API Functions
+
+(uffi:def-type handle-type cli-handle)
+(uffi:def-type handle-ptr-type (* cli-handle))
+
+(defmacro deref-vp (foreign-object)
+ `(the handle-type (uffi:deref-pointer (the handle-ptr-type ,foreign-object) cli-handle)))
+
+(defun db2-connect (db server user password)
+ (let ((henv (uffi:allocate-foreign-object cli-handle))
+ (hdbc (uffi:allocate-foreign-object cli-handle)))
+ (sql-alloc-handle SQL_HANDLE_ENV SQL_NULL_HANDLE henv)
+ (setf (slot-value db 'henv) henv)
+ (setf (slot-value db 'hdbc) hdbc)
+
+ (sql-alloc-handle SQL_HANDLE_DBC (deref-vp henv) hdbc)
+ (uffi:with-cstrings ((native-server server)
+ (native-user user)
+ (native-password password))
+ (sql-connect (deref-vp hdbc)
+ native-server SQL_NTS
+ native-user SQL_NTS
+ native-password SQL_NTS)))
+ db)
(let ((tuple (car (database-query "SHOW VARIABLES LIKE 'HAVE_INNODB'" database :auto nil))))
(and tuple (string-equal "YES" (second tuple)))))
+(defmethod db-type-has-prepared-stmt? ((db-type (eql :mysql)))
+ #+mysql-client-v4.1 t
+ #-mysql-client-v4.1 nil)
+
(when (clsql-sys:database-type-library-loaded :mysql)
(clsql-sys:initialize-database-type :database-type :mysql))
()
(SQLAllocEnv phenv)
(deref-pointer phenv 'sql-handle)))))
- (%set-attr-odbc-version henv $SQL_OV_ODBC2)
+ (%set-attr-odbc-version henv $SQL_OV_ODBC3)
henv))
(defconstant $ODBC-LONG-TYPE :int)
(defconstant $ODBC-ULONG-TYPE :unsigned-int)
-(defconstant $ODBCVER #x0210)
+;; (defconstant $ODBCVER #x0210)
;; generally useful constants
(defconstant $SQL_SPEC_MAJOR 2) ;; Major version of specification
(defconstant $SQL_POSITION 0) ;; 1.0 FALSE
(defconstant $SQL_REFRESH 1) ;; 1.0 TRUE
-; #if (ODBCVER >= #x0200))
(defconstant $SQL_UPDATE 2)
(defconstant $SQL_DELETE 3)
(defconstant $SQL_ADD 4)
:message (tidy-error-message (PQerrorMessage conn-ptr))))
(unwind-protect
(case (PQresultStatus result)
+ ;; User gave a command rather than a query
+ (#.pgsql-exec-status-type#command-ok
+ nil)
(#.pgsql-exec-status-type#empty-query
nil)
(#.pgsql-exec-status-type#tuples-ok
t)
(:documentation "T [default] if database can supports transactions."))
+(defgeneric db-type-has-prepared-stmt? (db-type)
+ (:method ((db-type t))
+ nil)
+ (:documentation "T if database backend supports prepared statements."))
+
+
;;; Large objects support (Marc Battyani)
(defgeneric database-create-large-object (database)
(defgeneric database-delete-large-object (object-id database)
(:documentation "Deletes the large object in the database"))
+;; Prepared statements
+
+(defgeneric database-prepare (stmt types database result-types field-names)
+ (:method (stmt types (database t))
+ (declare (ignore stmt types))
+ (signal-no-database-error database))
+ (:method (stmt types (database database))
+ (declare (ignore stmt types))
+ (error 'sql-database-error
+ :message
+ (format nil "DATABASE-PREPARE not implemented for ~S" database)))
+ (:documentation "Prepare a statement for later execution."))
+
+(defgeneric database-bind-parameter (prepared-stmt position value)
+ (:method ((pstmt t) position value)
+ (declare (ignore position value))
+ (error 'sql-database-error
+ :message
+ (format nil "database-bind-paremeter not implemented for ~S" pstmt)))
+ (:documentation "Bind a parameter for a prepared statement."))
+
+(defgeneric database-run-prepared (prepared-stmt)
+ (:method ((pstmt t))
+ (error 'sql-database-error
+ :message (format nil "database-run-prepared not specialized for ~S" pstmt)))
+ (:documentation "Execute a prepared statement."))
+
+(defgeneric database-free-prepared (prepared-stmt)
+ (:method ((pstmt t))
+ ;; nothing to do by default
+ nil)
+ (:documentation "Free the resources of a prepared statement."))
;; Checks for closed database
(database-query-result-set query-expression database :full-set nil
:result-types result-types)
(let ((flatp (and (= columns 1)
- (typecase query-expression
- (string t)
- (sql-query
- (slot-value query-expression 'flatp))))))
+ (typep query-expression 'sql-query)
+ (slot-value query-expression 'flatp))))
(when result-set
(unwind-protect
(do ((row (make-list columns)))
(database-query-result-set query-expression database :full-set nil
:result-types result-types)
(let ((flatp (and (= columns 1)
- (typecase query-expression
- (string t)
- (sql-query
- (slot-value query-expression 'flatp))))))
+ (typep query-expression 'sql-query)
+ (slot-value query-expression 'flatp))))
(when result-set
(unwind-protect
(let ((result (list nil)))
(database-query-result-set query-expression database :full-set t
:result-types result-types)
(let ((flatp (and (= columns 1)
- (typecase query-expression
- (string t)
- (sql-query
- (slot-value query-expression 'flatp))))))
+ (typep query-expression 'sql-query)
+ (slot-value query-expression 'flatp))))
(when result-set
(unwind-protect
(if rows
(database-delete-large-object object-id database))
+;;; Prepared statements
+
+(defun prepare-sql (sql-stmt types &key (database *default-database*) (result-types :auto) field-names)
+ "Prepares a SQL statement for execution. TYPES contains a
+list of UFFI primitive types corresponding to the input parameters. Returns a
+prepared-statement object."
+ (unless (db-type-has-prepared-stmt? (database-type database))
+ (error 'sql-user-error
+ :message
+ (format nil
+ "Database backend type ~:@(~A~) does not support prepared statements."
+ (database-type database))))
+
+ (database-prepare sql-stmt types database result-types field-names))
+
+(defun bind-parameter (prepared-stmt position value)
+ "Sets the value of a parameter is in prepared statement."
+ (database-bind-parameter prepared-stmt position value)
+ value)
+
+(defun run-prepared-sql (prepared-stmt)
+ "Execute the prepared sql statment. All input parameters must be bound."
+ (database-run-prepared prepared-stmt))
+
+(defun free-prepared-sql (prepared-stmt)
+ "Delete the objects associated with a prepared statement."
+ (database-free-prepared prepared-stmt))
(loop for row in rows
collect (fourth row))))
-
-
(defmethod database-attribute-type ((attribute string) (table string) (database generic-odbc-database)
&key (owner nil))
(declare (ignore owner))
(sql-escape (string-downcase table)))
database :auto nil))
-
-;; Capabilities
+;;; Prepared statements
+
+(defvar *next-prepared-id-num* 0)
+(defun next-prepared-id ()
+ (let ((num (incf *next-prepared-id-num*)))
+ (format nil "CLSQL_PS_~D" num)))
+
+(defclass postgresql-stmt ()
+ ((database :initarg :database :reader database)
+ (id :initarg :id :reader id)
+ (bindings :initarg :bindings :reader bindings)
+ (field-names :initarg :field-names :accessor stmt-field-names)
+ (result-types :initarg :result-types :reader result-types)))
+
+(defun clsql-type->postgresql-type (type)
+ (case type
+ (:string "VARCHAR")
+ ((:int :integer) "INT4")
+ (:short "INT2")
+ ((:number :numeric :float) "NUMERIC")
+ (:bigint "INT8")))
+
+(defun prepared-sql-to-postgresql-sql (sql)
+ ;; FIXME: Convert #\? to "$n". Don't convert within strings
+ (declare (simple-string sql))
+ (with-output-to-string (out)
+ (do ((len (length sql))
+ (param 0)
+ (in-str nil)
+ (pos 0 (1+ pos)))
+ ((= len pos))
+ (declare (fixnum len param pos))
+ (let ((c (schar sql pos)))
+ (declare (character c))
+ (cond
+ ((or (char= c #\") (char= c #\'))
+ (setq in-str (not in-str))
+ (write-char c out))
+ ((and (char= c #\?) (not in-str))
+ (write-char #\$ out)
+ (write-string (write-to-string (incf param)) out))
+ (t
+ (write-char c out)))))))
+
+(defmethod database-prepare (sql-stmt types (database generic-postgresql-database) result-types field-names)
+ (let ((id (next-prepared-id)))
+ (database-execute-command
+ (format nil "PREPARE ~A (~{~A~^,~}) AS ~A"
+ id
+ (mapcar #'clsql-type->postgresql-type types)
+ (prepared-sql-to-postgresql-sql sql-stmt))
+ database)
+ (make-instance 'postgresql-stmt
+ :id id
+ :database database
+ :result-types result-types
+ :field-names field-names
+ :bindings (make-list (length types)))))
+
+(defmethod database-bind-parameter ((stmt postgresql-stmt) position value)
+ (setf (nth (1- position) (bindings stmt)) value))
+
+(defun binding-to-param (binding)
+ (typecase binding
+ (string
+ (concatenate 'string "'" (sql-escape-quotes binding) "'"))
+ (t
+ binding)))
+
+(defmethod database-run-prepared ((stmt postgresql-stmt))
+ (with-slots (database id bindings field-names result-types) stmt
+ (let ((query (format nil "EXECUTE ~A (~{~A~^,~})"
+ id (mapcar #'binding-to-param bindings))))
+ (cond
+ ((and field-names (not (consp field-names)))
+ (multiple-value-bind (res names)
+ (database-query query database result-types field-names)
+ (setf field-names names)
+ (values res names)))
+ (field-names
+ (values (nth-value 0 (database-query query database result-types nil))
+ field-names))
+ (t
+ (database-query query database result-types field-names))))))
+
+;;; Capabilities
(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql)))
t)
(defmethod db-type-default-case ((db-type (eql :postgresql)))
:lower)
+(defmethod db-type-has-prepared-stmt? ((db-type (eql :postgresql)))
+ t)
+
+(defmethod db-type-has-prepared-stmt? ((db-type (eql :postgresql-socket)))
+ t)
+
#:db-type-has-views?
#:db-type-has-bigint?
#:db-type-has-union?
+ #:db-type-has-prepared-stmt?
#:db-type-has-subqueries?
#:db-type-has-boolean-where?
#:db-type-transaction-capable?
#:read-large-object
#:delete-large-object
+ ;; Prepared statments
+ #:database-prepare
+ #:database-run-prepared
+ #:database-bind-parameter
+ #:database-free-prepared
+
;; accessors for database class
#:name
#:connection-spec
#:loop
;; CLSQL Extensions
#:for-each-row
+ #:prepare-sql
+ #:bind-parameter
+ #:run-prepared-sql
+ #:free-prepared-sql
;; Transaction handling (transaction.lisp)
#:with-transaction
#:database-commit-transaction
#:transaction-level
#:transaction
- #:autocommit
+ #:set-autocommit
;; OODDL (ooddl.lisp)
#:standard-db-object
transaction."
(and database (transaction database) (= (transaction-level database) 1)))
-(defun autocommit (&key (database *default-database*) (set :unspecified))
- "Returns whether autocommit is currently active."
- (unless (eq set :unspecified)
- (setf (database-autocommit database) set))
- (database-autocommit database))
+(defun set-autocommit (value &key (database *default-database*))
+ "Sets autocommit on or off. Returns old value of of autocommit flag."
+ (let ((old-value (database-autocommit database)))
+ (setf (database-autocommit database) value)
+ (database-autocommit database)
+ old-value))
+
results)))
((t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t)))
+
(deftest :basic/map/2
(let ((results '())
(rows (map-query 'list #'identity "select * from TYPE_TABLE"
results)))
((t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t)))
+ ;; confirm that a query on a single element returns a list of one element
+ (deftest :basic/map/4
+ (let ((rows (map-query 'list #'identity "select t_int from TYPE_TABLE"
+ :result-types nil)))
+ (values
+ (consp (first rows))
+ (length (first rows))))
+ t 1)
+
(deftest :basic/do/1
(let ((results '()))
(do-query ((int float str) "select * from TYPE_TABLE" :result-types nil)
(defvar *report-stream* *standard-output* "Stream to send text report.")
(defvar *sexp-report-stream* nil "Stream to send sexp report.")
-(defvar *rt-connection*)
+(defvar *rt-internal*)
(defvar *rt-basic*)
+(defvar *rt-connection*)
(defvar *rt-fddl*)
(defvar *rt-fdml*)
(defvar *rt-ooddl*)
(defun compute-tests-for-backend (db-type db-underlying-type)
(let ((test-forms '())
(skip-tests '()))
- (dolist (test-form (append *rt-connection* *rt-basic* *rt-fddl* *rt-fdml*
+ (dolist (test-form (append *rt-internal* *rt-connection* *rt-basic* *rt-fddl* *rt-fdml*
*rt-ooddl* *rt-oodml* *rt-syntax*))
(let ((test (second test-form)))
(cond
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: test-internal.lisp
+;;;; Purpose: Tests for internal clsql functions
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: May 2004
+;;;;
+;;;; $Id: test-basic.lisp 9450 2004-05-23 10:51:02Z kevin $
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2004 by Kevin M. Rosenberg
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:clsql-tests)
+
+(setq *rt-internal*
+ '(
+ (deftest :int/convert/1
+ (clsql-sys::prepared-sql-to-postgresql-sql "SELECT FOO FROM BAR")
+ "SELECT FOO FROM BAR")
+
+ (deftest :int/convert/2
+ (clsql-sys::prepared-sql-to-postgresql-sql "SELECT FOO FROM BAR WHERE ID=?")
+ "SELECT FOO FROM BAR WHERE ID=$1")
+
+ (deftest :int/convert/3
+ (clsql-sys::prepared-sql-to-postgresql-sql "SELECT FOO FROM \"BAR\" WHERE ID=? AND CODE=?")
+ "SELECT FOO FROM \"BAR\" WHERE ID=$1 AND CODE=$2")
+
+ (deftest :int/convert/4
+ (clsql-sys::prepared-sql-to-postgresql-sql "SELECT FOO FROM BAR WHERE ID=\"Match?\" AND CODE=?")
+ "SELECT FOO FROM BAR WHERE ID=\"Match?\" AND CODE=$1")
+
+ (deftest :int/convert/5
+ (clsql-sys::prepared-sql-to-postgresql-sql "SELECT 'FOO' FROM BAR WHERE ID='Match?''?' AND CODE=?")
+ "SELECT 'FOO' FROM BAR WHERE ID='Match?''?' AND CODE=$1")
+
+ ))
+
projects / clsql.git / commitdiff