From: Kevin M. Rosenberg Date: Fri, 31 Aug 2007 18:04:31 +0000 (+0000) Subject: r11859: Canonicalize whitespace X-Git-Tag: v3.8.6 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=refs%2Ftags%2Fv3.8.6 r11859: Canonicalize whitespace --- diff --git a/db-aodbc/aodbc-package.lisp b/db-aodbc/aodbc-package.lisp index 171f547..d00e579 100644 --- a/db-aodbc/aodbc-package.lisp +++ b/db-aodbc/aodbc-package.lisp @@ -18,8 +18,8 @@ (in-package #:cl-user) -#+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) (require :aodbc-v2)) #-allegro (warn "This system requires Allegro's AODBC library to operate") diff --git a/db-aodbc/aodbc-sql.lisp b/db-aodbc/aodbc-sql.lisp index 8cd3076..e83b3fe 100644 --- a/db-aodbc/aodbc-sql.lisp +++ b/db-aodbc/aodbc-sql.lisp @@ -28,7 +28,7 @@ t) (when (find-package :dbi) - (clsql-sys:database-type-load-foreign :aodbc)) + (clsql-sys:database-type-load-foreign :aodbc)) ;; AODBC interface @@ -37,7 +37,7 @@ ((aodbc-db-type :accessor database-aodbc-db-type :initform :unknown))) (defmethod database-name-from-spec (connection-spec - (database-type (eql :aodbc))) + (database-type (eql :aodbc))) (check-connection-spec connection-spec database-type (dsn user password)) (destructuring-bind (dsn user password) connection-spec (declare (ignore password)) @@ -48,37 +48,37 @@ #+aodbc-v2 (destructuring-bind (dsn user password) connection-spec (handler-case - (make-instance 'aodbc-database - :name (database-name-from-spec connection-spec :aodbc) - :database-type :aodbc - :dbi-package (find-package '#:dbi) - :odbc-conn - (dbi:connect :user user - :password password - :data-source-name dsn)) + (make-instance 'aodbc-database + :name (database-name-from-spec connection-spec :aodbc) + :database-type :aodbc + :dbi-package (find-package '#:dbi) + :odbc-conn + (dbi:connect :user user + :password password + :data-source-name dsn)) (sql-error (e) - (error e)) - (error () ;; Init or Connect failed - (error 'sql-connection-error - :database-type database-type - :connection-spec connection-spec - :message "Connection failed"))))) + (error e)) + (error () ;; Init or Connect failed + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :message "Connection failed"))))) -(defmethod database-query (query-expression (database aodbc-database) - result-types field-names) +(defmethod database-query (query-expression (database aodbc-database) + result-types field-names) #+aodbc-v2 (handler-case (dbi:sql query-expression - :db (clsql-sys::odbc-conn database) - :types result-types - :column-names field-names) + :db (clsql-sys::odbc-conn database) + :types result-types + :column-names field-names) #+ignore (error () (error 'sql-database-data-error - :database database - :expression query-expression - :message "Query failed")))) + :database database + :expression query-expression + :message "Query failed")))) (defmethod database-create (connection-spec (type (eql :aodbc))) (warn "Not implemented.")) diff --git a/db-db2/db2-api.lisp b/db-db2/db2-api.lisp index 880f360..8d4ef01 100644 --- a/db-db2/db2-api.lisp +++ b/db-db2/db2-api.lisp @@ -47,36 +47,36 @@ (defmacro def-cli-routine ((c-cli-symbol lisp-cli-fn) c-return &rest c-parms) (let ((ll (mapcar (lambda (x) (declare (ignore x)) (gensym)) c-parms))) `(let ((%lisp-cli-fn (uffi:def-function - (,c-cli-symbol ,(intern (concatenate 'string "%" (symbol-name lisp-cli-fn)))) - ,c-parms - :returning ,c-return))) + (,c-cli-symbol ,(intern (concatenate 'string "%" (symbol-name lisp-cli-fn)))) + ,c-parms + :returning ,c-return))) (defun ,lisp-cli-fn (,@ll &key database nulls-ok) - (let ((result (funcall %lisp-cli-fn ,@ll))) - (case result - (#.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 "DB2 unknown error, code=~A" result))))))))) - + (let ((result (funcall %lisp-cli-fn ,@ll))) + (case result + (#.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 "DB2 unknown error, code=~A" result))))))))) + (defmacro def-raw-cli-routine ((c-cli-symbol lisp-cli-fn) c-return &rest c-parms) (let ((ll (mapcar (lambda (x) (declare (ignore x)) (gensym)) c-parms))) `(let ((%lisp-cli-fn (uffi:def-function (,c-cli-symbol ,(intern (concatenate 'string "%" (symbol-name lisp-cli-fn)))) - ,c-parms - :returning ,c-return))) + ,c-parms + :returning ,c-return))) (defun ,lisp-cli-fn (,@ll &key database nulls-ok) - (funcall %lisp-cli-fn ,@ll))))) + (funcall %lisp-cli-fn ,@ll))))) (def-cli-routine ("SQLAllocHandle" sql-alloc-handle) diff --git a/db-db2/db2-loader.lisp b/db-db2/db2-loader.lisp index 8faf9e3..36701f0 100644 --- a/db-db2/db2-loader.lisp +++ b/db-db2/db2-loader.lisp @@ -19,10 +19,10 @@ (defparameter *db2-lib-path* (let ((db2-home (getenv "DB2_HOME"))) (when db2-home - (make-pathname :directory - (append - (pathname-directory - (parse-namestring (concatenate 'string db2-home "/"))) + (make-pathname :directory + (append + (pathname-directory + (parse-namestring (concatenate 'string db2-home "/"))) (list "lib")))))) (defparameter *db2-library-filenames* @@ -45,7 +45,7 @@ set to the right path before compiling or loading the system.") (defmethod clsql-sys:database-type-load-foreign ((database-type (eql :db2))) (clsql-uffi:find-and-load-foreign-library *db2-library-filenames* :module "clsql-db2" - :supporting-libraries + :supporting-libraries *db2-supporting-libraries*) (setq *db2-library-loaded* t)) diff --git a/db-db2/db2-package.lisp b/db-db2/db2-package.lisp index 9ca0984..df08104 100644 --- a/db-db2/db2-package.lisp +++ b/db-db2/db2-package.lisp @@ -19,7 +19,7 @@ (defpackage #:clsql-db2 (:use #:common-lisp #:clsql-sys #:clsql-uffi) (:export #:db2-database - #:*db2-server-version* - #:*db2-so-load-path* - #:*db2-so-libraries*) + #:*db2-server-version* + #:*db2-so-load-path* + #:*db2-so-libraries*) (:documentation "This is the CLSQL interface to Db2.")) diff --git a/db-db2/db2-sql.lisp b/db-db2/db2-sql.lisp index 6224756..2244f77 100644 --- a/db-db2/db2-sql.lisp +++ b/db-db2/db2-sql.lisp @@ -24,7 +24,7 @@ (defmethod database-name-from-spec (connection-spec - (database-type (eql :db2))) + (database-type (eql :db2))) (check-connection-spec connection-spec database-type (dsn user password)) (destructuring-bind (dsn user password) connection-spec (declare (ignore password)) @@ -34,16 +34,16 @@ (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"))))) + (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 @@ -56,17 +56,17 @@ (defun db2-connect (db server user password) (let ((henv (uffi:allocate-foreign-object 'cli-handle)) - (hdbc (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)) + (native-user user) + (native-password password)) (sql-connect (deref-vp hdbc) - native-server SQL_NTS - native-user SQL_NTS - native-password SQL_NTS))) + native-server SQL_NTS + native-user SQL_NTS + native-password SQL_NTS))) db) diff --git a/db-db2/foreign-resources.lisp b/db-db2/foreign-resources.lisp index 1a8d866..ea17376 100644 --- a/db-db2/foreign-resources.lisp +++ b/db-db2/foreign-resources.lisp @@ -17,36 +17,36 @@ (defstruct (foreign-resource) (type (error "Missing TYPE.") - :read-only t) + :read-only t) (sizeof (error "Missing SIZEOF.") - :read-only t) + :read-only t) (buffer (error "Missing BUFFER.") - :read-only t) + :read-only t) (in-use nil :type boolean)) (defun %get-resource (type sizeof) (let ((resources (gethash type *foreign-resource-hash*))) (car (member-if - #'(lambda (res) - (and (= (foreign-resource-sizeof res) sizeof) - (not (foreign-resource-in-use res)))) - resources)))) + #'(lambda (res) + (and (= (foreign-resource-sizeof res) sizeof) + (not (foreign-resource-in-use res)))) + resources)))) (defun %insert-foreign-resource (type res) (let ((resource (gethash type *foreign-resource-hash*))) (setf (gethash type *foreign-resource-hash*) - (cons res resource)))) + (cons res resource)))) (defmacro acquire-foreign-resource (type &optional size) `(let ((res (%get-resource ,type ,size))) (unless res (setf res (make-foreign-resource - :type ,type :sizeof ,size - :buffer (uffi:allocate-foreign-object ,type ,size))) + :type ,type :sizeof ,size + :buffer (uffi:allocate-foreign-object ,type ,size))) (%insert-foreign-resource ',type res)) (claim-foreign-resource res))) - + (defun free-foreign-resource (ares) (setf (foreign-resource-in-use ares) nil) ares) diff --git a/db-mysql/clsql_mysql.c b/db-mysql/clsql_mysql.c index d1bb084..327f14e 100644 --- a/db-mysql/clsql_mysql.c +++ b/db-mysql/clsql_mysql.c @@ -19,15 +19,15 @@ #include BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll, DWORD fdwReason, - LPVOID lpvReserved) + LPVOID lpvReserved) { return 1; } - + #define DLLEXPORT __declspec(dllexport) #else -#define DLLEXPORT +#define DLLEXPORT #endif @@ -37,19 +37,19 @@ BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll, DWORD fdwReason, DLLEXPORT void clsql_mysql_data_seek (MYSQL_RES* res, unsigned int offset_high32, - unsigned int offset_low32) + unsigned int offset_low32) { my_ulonglong offset; offset = offset_high32; offset = offset << 32; offset += offset_low32; - + mysql_data_seek (res, offset); } /* The following functions are used to return 64-bit integers to Lisp. - They return the 32-bit low part and store in upper 32-bits in a + They return the 32-bit low part and store in upper 32-bits in a located sent via a pointer */ static const unsigned int bitmask_32bits = 0xFFFFFFFF; @@ -127,8 +127,8 @@ allocate_bind (unsigned int n) DLLEXPORT void -bind_param (MYSQL_BIND bind[], unsigned int n, unsigned long length, unsigned short is_null, - void* buffer, unsigned short buffer_type, unsigned long buffer_length) +bind_param (MYSQL_BIND bind[], unsigned int n, unsigned long length, unsigned short is_null, + void* buffer, unsigned short buffer_type, unsigned long buffer_length) { *bind[n].length = length; *bind[n].is_null = is_null; diff --git a/db-mysql/mysql-api.lisp b/db-mysql/mysql-api.lisp index 39af26f..59cbe8c 100644 --- a/db-mysql/mysql-api.lisp +++ b/db-mysql/mysql-api.lisp @@ -626,10 +626,10 @@ (defun mysql-num-rows (res) (uffi:with-foreign-object (p-high32 :unsigned-int) (let ((low32 (clsql-mysql-num-rows res p-high32)) - (high32 (uffi:deref-pointer p-high32 :unsigned-int))) + (high32 (uffi:deref-pointer p-high32 :unsigned-int))) (if (zerop high32) - low32 - (make-64-bit-integer high32 low32))))) + low32 + (make-64-bit-integer high32 low32))))) (uffi:def-function "clsql_mysql_affected_rows" ((mysql (* mysql-mysql)) @@ -640,10 +640,10 @@ (defun mysql-affected-rows (mysql) (uffi:with-foreign-object (p-high32 :unsigned-int) (let ((low32 (clsql-mysql-affected-rows mysql p-high32)) - (high32 (uffi:deref-pointer p-high32 :unsigned-int))) + (high32 (uffi:deref-pointer p-high32 :unsigned-int))) (if (zerop high32) - low32 - (make-64-bit-integer high32 low32))))) + low32 + (make-64-bit-integer high32 low32))))) (uffi:def-function "clsql_mysql_insert_id" ((res (* mysql-mysql)) @@ -654,9 +654,9 @@ (defun mysql-insert-id (mysql) (uffi:with-foreign-object (p-high32 :unsigned-int) (let ((low32 (clsql-mysql-insert-id mysql p-high32)) - (high32 (uffi:deref-pointer p-high32 :unsigned-int))) + (high32 (uffi:deref-pointer p-high32 :unsigned-int))) (if (zerop high32) - low32 + low32 (make-64-bit-integer high32 low32))))) diff --git a/db-mysql/mysql-client-info.lisp b/db-mysql/mysql-client-info.lisp index 4124e0b..0721194 100644 --- a/db-mysql/mysql-client-info.lisp +++ b/db-mysql/mysql-client-info.lisp @@ -32,15 +32,15 @@ (when (and (stringp *mysql-client-info*) - (plusp (length *mysql-client-info*))) + (plusp (length *mysql-client-info*))) (cond ((eql (schar *mysql-client-info* 0) #\3) (pushnew :mysql-client-v3 cl:*features*)) ((eql (schar *mysql-client-info* 0) #\4) (pushnew :mysql-client-v4 cl:*features*) (when (and (>= (length *mysql-client-info*) 3) - (string-equal "4.1" *mysql-client-info* :end2 3)) - (pushnew :mysql-client-v4.1 cl:*features*))) + (string-equal "4.1" *mysql-client-info* :end2 3)) + (pushnew :mysql-client-v4.1 cl:*features*))) ((eql (schar *mysql-client-info* 0) #\5) (pushnew :mysql-client-v5 cl:*features*)) (t diff --git a/db-mysql/mysql-objects.lisp b/db-mysql/mysql-objects.lisp index 64c844e..76ce5e5 100644 --- a/db-mysql/mysql-objects.lisp +++ b/db-mysql/mysql-objects.lisp @@ -16,45 +16,45 @@ (in-package #:clsql-mysql) (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database - (db-type (eql :mysql))) + (db-type (eql :mysql))) (declare (ignore args database)) "DATETIME") (defmethod database-get-type-specifier ((type (eql 'smallint)) args database - (db-type (eql :mysql))) + (db-type (eql :mysql))) (declare (ignore args database)) "SMALLINT") (defmethod database-get-type-specifier ((type (eql 'mediumint)) args database - (db-type (eql :mysql))) + (db-type (eql :mysql))) (declare (ignore args database)) "MEDIUMINT") (defmethod database-get-type-specifier ((type (eql 'tinyint)) args database - (db-type (eql :mysql))) + (db-type (eql :mysql))) (declare (ignore args database)) "TINYINT") (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database - (db-type (eql :mysql))) + (db-type (eql :mysql))) (declare (ignore database)) (if val 1 0)) (defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database - (db-type (eql :mysql))) + (db-type (eql :mysql))) (declare (ignore database)) (if val 1 0)) (defmethod read-sql-value (val (type (eql 'boolean)) database - (db-type (eql :mysql))) - (declare (ignore database)) + (db-type (eql :mysql))) + (declare (ignore database)) (etypecase val (string (if (string= "0" val) nil t)) (integer (if (zerop val) nil t)))) (defmethod read-sql-value (val (type (eql 'generalized-boolean)) database - (db-type (eql :mysql))) - (declare (ignore database)) + (db-type (eql :mysql))) + (declare (ignore database)) (etypecase val (string (if (string= "0" val) nil t)) (integer (if (zerop val) nil t)))) diff --git a/db-mysql/mysql-package.lisp b/db-mysql/mysql-package.lisp index 368dfe7..58b04ce 100644 --- a/db-mysql/mysql-package.lisp +++ b/db-mysql/mysql-package.lisp @@ -20,9 +20,9 @@ (defpackage #:mysql (:use #:common-lisp #:clsql-uffi) - (:export + (:export #:database-library-loaded - + #:mysql-socket #:mysql-book #:mysql-byte @@ -125,7 +125,7 @@ #:mysql-info #:mysql-info-string #:mysql-data-seek - + #:mysql-time #:mysql-bind #:mysql-stmt-param-count @@ -143,7 +143,7 @@ #:mysql-stmt-close #:mysql-stmt-errno #:mysql-stmt-error - + #:make-64-bit-integer ) (:documentation "This is the low-level interface MySQL.")) diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index a0e21c8..00430a3 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -23,15 +23,15 @@ ;; if we have :sb-unicode, UFFI will treat :cstring as a UTF-8 string (defun expression-length (query-expression) (length #+sb-unicode (sb-ext:string-to-octets query-expression - :external-format :utf8) - #-sb-unicode query-expression)) + :external-format :utf8) + #-sb-unicode query-expression)) ;;; Field conversion functions (defun result-field-names (num-fields res-ptr) (declare (fixnum num-fields)) (let ((names '()) - (field-vec (mysql-fetch-fields res-ptr))) + (field-vec (mysql-fetch-fields res-ptr))) (dotimes (i num-fields) (declare (fixnum i)) (let* ((field (uffi:deref-array field-vec '(:array mysql-field) i)) @@ -47,44 +47,44 @@ (dotimes (i num-fields) (declare (fixnum i)) (let* ((field (uffi:deref-array field-vec '(:array mysql-field) i)) - (flags (uffi:get-slot-value field 'mysql-field 'mysql::flags)) - (unsigned (plusp (logand flags 32))) - (type (uffi:get-slot-value field 'mysql-field 'type))) - (push - (case type - ((#.mysql-field-types#tiny - #.mysql-field-types#short - #.mysql-field-types#int24) - (if unsigned - :uint32 - :int32)) - (#.mysql-field-types#long - (if unsigned - :uint - :int)) - (#.mysql-field-types#longlong - (if unsigned - :uint64 - :int64)) - ((#.mysql-field-types#double - #.mysql-field-types#float - #.mysql-field-types#decimal) - :double) - (otherwise - t)) - new-types))) + (flags (uffi:get-slot-value field 'mysql-field 'mysql::flags)) + (unsigned (plusp (logand flags 32))) + (type (uffi:get-slot-value field 'mysql-field 'type))) + (push + (case type + ((#.mysql-field-types#tiny + #.mysql-field-types#short + #.mysql-field-types#int24) + (if unsigned + :uint32 + :int32)) + (#.mysql-field-types#long + (if unsigned + :uint + :int)) + (#.mysql-field-types#longlong + (if unsigned + :uint64 + :int64)) + ((#.mysql-field-types#double + #.mysql-field-types#float + #.mysql-field-types#decimal) + :double) + (otherwise + t)) + new-types))) (nreverse new-types))) (defun canonicalize-types (types num-fields res-ptr) (when types (let ((auto-list (make-type-list-for-auto num-fields res-ptr))) (cond - ((listp types) - (canonicalize-type-list types auto-list)) - ((eq types :auto) - auto-list) - (t - nil))))) + ((listp types) + (canonicalize-type-list types auto-list)) + ((eq types :auto) + auto-list) + (t + nil))))) (defmethod database-initialize-database-type ((database-type (eql :mysql))) t) @@ -95,76 +95,76 @@ (defclass mysql-database (database) ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr - :type mysql-mysql-ptr-def) + :type mysql-mysql-ptr-def) (server-info :accessor database-server-info :initarg :server-info - :type string))) + :type string))) (defmethod database-type ((database mysql-database)) :mysql) (defmethod database-name-from-spec (connection-spec (database-type (eql :mysql))) (check-connection-spec connection-spec database-type - (host db user password &optional port)) + (host db user password &optional port)) (destructuring-bind (host db user password &optional port) connection-spec (declare (ignore password)) (concatenate 'string - (etypecase host - (null "localhost") - (pathname (namestring host)) - (string host)) - (if port - (concatenate 'string - ":" - (etypecase port - (integer (write-to-string port)) - (string port))) - "") - "/" db "/" user))) + (etypecase host + (null "localhost") + (pathname (namestring host)) + (string host)) + (if port + (concatenate 'string + ":" + (etypecase port + (integer (write-to-string port)) + (string port))) + "") + "/" db "/" user))) (defmethod database-connect (connection-spec (database-type (eql :mysql))) (check-connection-spec connection-spec database-type - (host db user password &optional port)) + (host db user password &optional port)) (destructuring-bind (host db user password &optional port) connection-spec (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql))) - (socket nil)) + (socket nil)) (if (uffi:null-pointer-p mysql-ptr) - (error 'sql-connection-error - :database-type database-type - :connection-spec connection-spec - :error-id (mysql-errno mysql-ptr) - :message (mysql-error-string mysql-ptr)) - (uffi:with-cstrings ((host-native host) - (user-native user) - (password-native password) - (db-native db) - (socket-native socket)) - (let ((error-occurred nil)) - (unwind-protect - (if (uffi:null-pointer-p - (mysql-real-connect - mysql-ptr host-native user-native password-native - db-native - (etypecase port - (null 0) - (integer port) - (string (parse-integer port))) - socket-native 0)) - (progn - (setq error-occurred t) - (error 'sql-connection-error - :database-type database-type - :connection-spec connection-spec - :error-id (mysql-errno mysql-ptr) - :message (mysql-error-string mysql-ptr))) - (make-instance 'mysql-database - :name (database-name-from-spec connection-spec - database-type) - :database-type :mysql - :connection-spec connection-spec - :server-info (uffi:convert-from-cstring - (mysql:mysql-get-server-info mysql-ptr)) - :mysql-ptr mysql-ptr)) - (when error-occurred (mysql-close mysql-ptr))))))))) + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)) + (uffi:with-cstrings ((host-native host) + (user-native user) + (password-native password) + (db-native db) + (socket-native socket)) + (let ((error-occurred nil)) + (unwind-protect + (if (uffi:null-pointer-p + (mysql-real-connect + mysql-ptr host-native user-native password-native + db-native + (etypecase port + (null 0) + (integer port) + (string (parse-integer port))) + socket-native 0)) + (progn + (setq error-occurred t) + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr))) + (make-instance 'mysql-database + :name (database-name-from-spec connection-spec + database-type) + :database-type :mysql + :connection-spec connection-spec + :server-info (uffi:convert-from-cstring + (mysql:mysql-get-server-info mysql-ptr)) + :mysql-ptr mysql-ptr)) + (when error-occurred (mysql-close mysql-ptr))))))))) (defmethod database-disconnect ((database mysql-database)) @@ -174,20 +174,20 @@ (defmethod database-query (query-expression (database mysql-database) - result-types field-names) + result-types field-names) (declare (optimize (speed 3) (safety 0) (debug 0) (space 0))) (let ((mysql-ptr (database-mysql-ptr database))) (uffi:with-cstring (query-native query-expression) (if (zerop (mysql-real-query mysql-ptr query-native (expression-length query-expression))) - (let ((res-ptr (mysql-use-result mysql-ptr))) - (if res-ptr - (unwind-protect - (let ((num-fields (mysql-num-fields res-ptr))) - (declare (fixnum num-fields)) - (setq result-types (canonicalize-types - result-types num-fields - res-ptr)) + (let ((res-ptr (mysql-use-result mysql-ptr))) + (if res-ptr + (unwind-protect + (let ((num-fields (mysql-num-fields res-ptr))) + (declare (fixnum num-fields)) + (setq result-types (canonicalize-types + result-types num-fields + res-ptr)) (values (loop for row = (mysql-fetch-row res-ptr) for lengths = (mysql-fetch-lengths res-ptr) @@ -208,17 +208,17 @@ i))))) (when field-names (result-field-names num-fields res-ptr)))) - (mysql-free-result res-ptr)) - (error 'sql-database-data-error - :database database - :expression query-expression - :error-id (mysql-errno mysql-ptr) - :message (mysql-error-string mysql-ptr)))) - (error 'sql-database-data-error - :database database - :expression query-expression - :error-id (mysql-errno mysql-ptr) - :message (mysql-error-string mysql-ptr)))))) + (mysql-free-result res-ptr)) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))))) (defmethod database-execute-command (sql-expression (database mysql-database)) (uffi:with-cstring (sql-native sql-expression) @@ -226,12 +226,12 @@ (declare (type mysql-mysql-ptr-def mysql-ptr)) (if (zerop (mysql-real-query mysql-ptr sql-native (expression-length sql-expression))) - t - (error 'sql-database-data-error - :database database - :expression sql-expression - :error-id (mysql-errno mysql-ptr) - :message (mysql-error-string mysql-ptr)))))) + t + (error 'sql-database-data-error + :database database + :expression sql-expression + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))))) (defstruct mysql-result-set @@ -242,43 +242,43 @@ (defmethod database-query-result-set ((query-expression string) - (database mysql-database) - &key full-set result-types) + (database mysql-database) + &key full-set result-types) (uffi:with-cstring (query-native query-expression) (let ((mysql-ptr (database-mysql-ptr database))) (declare (type mysql-mysql-ptr-def mysql-ptr)) (if (zerop (mysql-real-query mysql-ptr query-native (expression-length query-expression))) - (let ((res-ptr (if full-set - (mysql-store-result mysql-ptr) - (mysql-use-result mysql-ptr)))) - (declare (type mysql-mysql-res-ptr-def res-ptr)) - (if (not (uffi:null-pointer-p res-ptr)) - (let* ((num-fields (mysql-num-fields res-ptr)) - (result-set (make-mysql-result-set - :res-ptr res-ptr - :num-fields num-fields - :full-set full-set - :types - (canonicalize-types - result-types num-fields - res-ptr)))) - (if full-set - (values result-set - num-fields - (mysql-num-rows res-ptr)) - (values result-set - num-fields))) - (error 'sql-database-data-error - :database database - :expression query-expression - :error-id (mysql-errno mysql-ptr) - :message (mysql-error-string mysql-ptr)))) - (error 'sql-database-data-error - :database database - :expression query-expression - :error-id (mysql-errno mysql-ptr) - :message (mysql-error-string mysql-ptr)))))) + (let ((res-ptr (if full-set + (mysql-store-result mysql-ptr) + (mysql-use-result mysql-ptr)))) + (declare (type mysql-mysql-res-ptr-def res-ptr)) + (if (not (uffi:null-pointer-p res-ptr)) + (let* ((num-fields (mysql-num-fields res-ptr)) + (result-set (make-mysql-result-set + :res-ptr res-ptr + :num-fields num-fields + :full-set full-set + :types + (canonicalize-types + result-types num-fields + res-ptr)))) + (if full-set + (values result-set + num-fields + (mysql-num-rows res-ptr)) + (values result-set + num-fields))) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))))) (defmethod database-dump-result-set (result-set (database mysql-database)) (mysql-free-result (mysql-result-set-res-ptr result-set)) @@ -287,20 +287,20 @@ (defmethod database-store-next-row (result-set (database mysql-database) list) (let* ((res-ptr (mysql-result-set-res-ptr result-set)) - (row (mysql-fetch-row res-ptr)) + (row (mysql-fetch-row res-ptr)) (lengths (mysql-fetch-lengths res-ptr)) - (types (mysql-result-set-types result-set))) + (types (mysql-result-set-types result-set))) (declare (type mysql-mysql-res-ptr-def res-ptr) - (type mysql-row-def row)) + (type mysql-row-def row)) (unless (uffi:null-pointer-p row) (loop for i from 0 below (mysql-result-set-num-fields result-set) - for rest on list - do - (setf (car rest) - (convert-raw-field - (uffi:deref-array row '(:array (* :unsigned-char)) i) - types - i + for rest on list + do + (setf (car rest) + (convert-raw-field + (uffi:deref-array row '(:array (* :unsigned-char)) i) + types + i (uffi:deref-array lengths '(:array :unsigned-long) i)))) list))) @@ -318,9 +318,9 @@ collect name)) (t (remove-if #'(lambda (s) - (and (>= (length s) 11) - (string-equal (subseq s 0 11) "_CLSQL_SEQ_"))) - (mapcar #'car (database-query "SHOW TABLES" database nil nil)))))) + (and (>= (length s) 11) + (string-equal (subseq s 0 11) "_CLSQL_SEQ_"))) + (mapcar #'car (database-query "SHOW TABLES" database nil nil)))))) (defmethod database-list-views ((database mysql-database) &key (owner nil)) @@ -338,49 +338,49 @@ (let ((result '())) (dolist (table (database-list-tables database :owner owner) result) (setq result - (append (database-list-table-indexes table database :owner owner) - result))))) + (append (database-list-table-indexes table database :owner owner) + result))))) (defmethod database-list-table-indexes (table (database mysql-database) - &key (owner nil)) + &key (owner nil)) (declare (ignore owner)) (do ((results nil) (rows (database-query - (format nil "SHOW INDEX FROM ~A" (string-upcase table)) - database nil nil) - (cdr rows))) + (format nil "SHOW INDEX FROM ~A" (string-upcase table)) + database nil nil) + (cdr rows))) ((null rows) (nreverse results)) (let ((col (nth 2 (car rows)))) (unless (find col results :test #'string-equal) - (push col results))))) + (push col results))))) (defmethod database-list-attributes ((table string) (database mysql-database) &key (owner nil)) (declare (ignore owner)) (mapcar #'car - (database-query - (format nil "SHOW COLUMNS FROM ~A" table) - database nil nil))) + (database-query + (format nil "SHOW COLUMNS FROM ~A" table) + database nil nil))) (defmethod database-attribute-type (attribute (table string) - (database mysql-database) + (database mysql-database) &key (owner nil)) (declare (ignore owner)) (let ((row (car (database-query - (format nil - "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute) - database nil nil)))) + (format nil + "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute) + database nil nil)))) (let* ((raw-type (second row)) - (null (third row)) - (start-length (position #\( raw-type)) - (type (if start-length - (subseq raw-type 0 start-length) - raw-type)) - (length (when start-length - (parse-integer (subseq raw-type (1+ start-length)) - :junk-allowed t)))) + (null (third row)) + (start-length (position #\( raw-type)) + (type (if start-length + (subseq raw-type 0 start-length) + raw-type)) + (length (when start-length + (parse-integer (subseq raw-type (1+ start-length)) + :junk-allowed t)))) (when type - (values (ensure-keyword type) length nil (if (string-equal null "YES") 1 0)))))) + (values (ensure-keyword type) length nil (if (string-equal null "YES") 1 0)))))) ;;; Sequence functions @@ -393,19 +393,19 @@ (subseq table-name 11))) (defmethod database-create-sequence (sequence-name - (database mysql-database)) + (database mysql-database)) (let ((table-name (%sequence-name-to-table sequence-name))) (database-execute-command (concatenate 'string "CREATE TABLE " table-name - " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)") + " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)") database) (database-execute-command (concatenate 'string "INSERT INTO " table-name - " VALUES (-1)") + " VALUES (-1)") database))) (defmethod database-drop-sequence (sequence-name - (database mysql-database)) + (database mysql-database)) (database-execute-command (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name)) database)) @@ -416,7 +416,7 @@ (mapcan #'(lambda (s) (let ((sn (%table-name-to-sequence-name (car s)))) (and sn (list sn)))) - (database-query "SHOW TABLES" database nil nil))) + (database-query "SHOW TABLES" database nil nil))) (defmethod database-set-sequence-position (sequence-name (position integer) @@ -431,47 +431,47 @@ (without-interrupts (database-execute-command (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name) - " SET id=LAST_INSERT_ID(id+1)") + " SET id=LAST_INSERT_ID(id+1)") database) (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))) (defmethod database-sequence-last (sequence-name (database mysql-database)) (without-interrupts (caar (database-query - (concatenate 'string "SELECT id from " - (%sequence-name-to-table sequence-name)) - database :auto nil)))) + (concatenate 'string "SELECT id from " + (%sequence-name-to-table sequence-name)) + database :auto nil)))) (defmethod database-create (connection-spec (type (eql :mysql))) (destructuring-bind (host name user password &optional port) connection-spec (multiple-value-bind (output status) - (clsql-sys:command-output "mysqladmin create -u~A -p~A -h~A~@[ -P~A~] ~A" - user password - (if host host "localhost") - port name - name) + (clsql-sys:command-output "mysqladmin create -u~A -p~A -h~A~@[ -P~A~] ~A" + user password + (if host host "localhost") + port name + name) (if (or (not (eql 0 status)) - (and (search "failed" output) (search "error" output))) - (error 'sql-database-error - :message - (format nil "mysql database creation failed with connection-spec ~A." - connection-spec)) - t)))) + (and (search "failed" output) (search "error" output))) + (error 'sql-database-error + :message + (format nil "mysql database creation failed with connection-spec ~A." + connection-spec)) + t)))) (defmethod database-destroy (connection-spec (type (eql :mysql))) (destructuring-bind (host name user password &optional port) connection-spec (multiple-value-bind (output status) - (clsql-sys:command-output "mysqladmin drop -f -u~A -p~A -h~A~@[ -P~A~] ~A" - user password - (if host host "localhost") - port name) + (clsql-sys:command-output "mysqladmin drop -f -u~A -p~A -h~A~@[ -P~A~] ~A" + user password + (if host host "localhost") + port name) (if (or (not (eql 0 status)) - (and (search "failed" output) (search "error" output))) - (error 'sql-database-error - :message - (format nil "mysql database deletion failed with connection-spec ~A." - connection-spec)) - t)))) + (and (search "failed" output) (search "error" output))) + (error 'sql-database-error + :message + (format nil "mysql database deletion failed with connection-spec ~A." + connection-spec)) + t)))) (defmethod database-probe (connection-spec (type (eql :mysql))) (when (find (second connection-spec) (database-list connection-spec type) @@ -483,12 +483,12 @@ (declare (ignore name)) (let ((database (database-connect (list host "mysql" user password port) type))) (unwind-protect - (progn - (setf (slot-value database 'clsql-sys::state) :open) - (mapcar #'car (database-query "show databases" database :auto nil))) - (progn - (database-disconnect database) - (setf (slot-value database 'clsql-sys::state) :closed)))))) + (progn + (setf (slot-value database 'clsql-sys::state) :open) + (mapcar #'car (database-query "show databases" database :auto nil))) + (progn + (database-disconnect database) + (setf (slot-value database 'clsql-sys::state) :closed)))))) ;;; Prepared statements @@ -517,147 +517,147 @@ ((or (eq type :blob) (and (consp type) (in (car type) :blob))) mysql-field-types#var-string) (t (error 'sql-user-error - :message - (format nil "Unknown clsql type ~A." type))))) + :message + (format nil "Unknown clsql type ~A." type))))) #+mysql-client-v4.1 (defmethod database-prepare (sql-stmt types (database mysql-database) result-types field-names) (let* ((mysql-ptr (database-mysql-ptr database)) - (stmt (mysql-stmt-init mysql-ptr))) + (stmt (mysql-stmt-init mysql-ptr))) (when (uffi:null-pointer-p stmt) (error 'sql-database-error - :error-id (mysql-errno mysql-ptr) - :message (mysql-error-string mysql-ptr))) + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr))) (uffi:with-cstring (native-query sql-stmt) (unless (zerop (mysql-stmt-prepare stmt native-query (expression-length sql-stmt))) - (mysql-stmt-close stmt) - (error 'sql-database-error - :error-id (mysql-errno mysql-ptr) - :message (mysql-error-string mysql-ptr)))) + (mysql-stmt-close stmt) + (error 'sql-database-error + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))) (unless (= (mysql-stmt-param-count stmt) (length types)) (mysql-stmt-close stmt) (error 'sql-database-error - :message - (format nil "Mysql param count (~D) does not match number of types (~D)" - (mysql-stmt-param-count stmt) (length types)))) + :message + (format nil "Mysql param count (~D) does not match number of types (~D)" + (mysql-stmt-param-count stmt) (length types)))) (let ((rs (mysql-stmt-result-metadata stmt))) (when (uffi:null-pointer-p rs) - (warn "mysql_stmt_result_metadata returned NULL") - #+nil - (mysql-stmt-close stmt) - #+nil - (error 'sql-database-error - :message "mysql_stmt_result_metadata returned NULL")) + (warn "mysql_stmt_result_metadata returned NULL") + #+nil + (mysql-stmt-close stmt) + #+nil + (error 'sql-database-error + :message "mysql_stmt_result_metadata returned NULL")) (let ((input-bind (uffi:allocate-foreign-object 'mysql-bind (length types))) - (mysql-types (mapcar 'clsql-type->mysql-type types)) - field-vec num-fields is-null-ptr output-bind length-ptr) - - (print 'a) - (dotimes (i (length types)) - (let* ((binding (uffi:deref-array input-bind '(:array mysql-bind) i))) - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-type) - (nth i mysql-types)) - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-length) 0))) - - (print 'b) - (unless (uffi:null-pointer-p rs) - (setq field-vec (mysql-fetch-fields rs) - num-fields (mysql-num-fields rs) - is-null-ptr (uffi:allocate-foreign-object :byte num-fields) - output-bind (uffi:allocate-foreign-object 'mysql-bind num-fields) - length-ptr (uffi:allocate-foreign-object :unsigned-long num-fields)) - (dotimes (i num-fields) - (declare (fixnum i)) - (let* ((field (uffi:deref-array field-vec '(:array mysql-field) i)) - (type (uffi:get-slot-value field 'mysql-field 'type)) - (binding (uffi:deref-array output-bind '(:array mysql-bind) i))) - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-type) type) - - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-length) 0) - #+need-to-allocate-foreign-object-for-this - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::is-null) - (+ i (uffi:pointer-address is-null-ptr))) - #+need-to-allocate-foreign-object-for-this - (setf (uffi:get-slot-value binding 'mysql-bind 'length) - (+ (* i 8) (uffi:pointer-address length-ptr))) - - (case type - ((#.mysql-field-types#var-string #.mysql-field-types#string - #.mysql-field-types#tiny-blob #.mysql-field-types#blob - #.mysql-field-types#medium-blob #.mysql-field-types#long-blob) - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-length) 1024) - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) - (uffi:allocate-foreign-object :unsigned-char 1024))) - (#.mysql-field-types#tiny - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) - (uffi:allocate-foreign-object :byte))) - (#.mysql-field-types#short - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) - (uffi:allocate-foreign-object :short))) - (#.mysql-field-types#long - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) - ;; segfaults if supply :int on amd64 - (uffi:allocate-foreign-object :long))) - #+64bit - (#.mysql-field-types#longlong - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) - (uffi:allocate-foreign-object :long))) - (#.mysql-field-types#float - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) - (uffi:allocate-foreign-object :float))) - (#.mysql-field-types#double - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) - (uffi:allocate-foreign-object :double))) - ((#.mysql-field-types#time #.mysql-field-types#date - #.mysql-field-types#datetime #.mysql-field-types#timestamp) - (uffi:allocate-foreign-object 'mysql-time)) - (t - (error "mysql type ~D not supported." type))))) - - (unless (zerop (mysql-stmt-bind-result stmt output-bind)) - (mysql-stmt-close stmt) - (error 'sql-database-error - :error-id (mysql-stmt-errno stmt) - :message (uffi:convert-from-cstring - (mysql-stmt-error stmt))))) - - (make-instance 'mysql-stmt - :database database - :stmt stmt - :num-fields num-fields - :input-bind input-bind - :output-bind output-bind - :result-set rs - :result-types result-types - :length-ptr length-ptr - :is-null-ptr is-null-ptr - :types mysql-types - :field-names field-names))))) + (mysql-types (mapcar 'clsql-type->mysql-type types)) + field-vec num-fields is-null-ptr output-bind length-ptr) + + (print 'a) + (dotimes (i (length types)) + (let* ((binding (uffi:deref-array input-bind '(:array mysql-bind) i))) + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-type) + (nth i mysql-types)) + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-length) 0))) + + (print 'b) + (unless (uffi:null-pointer-p rs) + (setq field-vec (mysql-fetch-fields rs) + num-fields (mysql-num-fields rs) + is-null-ptr (uffi:allocate-foreign-object :byte num-fields) + output-bind (uffi:allocate-foreign-object 'mysql-bind num-fields) + length-ptr (uffi:allocate-foreign-object :unsigned-long num-fields)) + (dotimes (i num-fields) + (declare (fixnum i)) + (let* ((field (uffi:deref-array field-vec '(:array mysql-field) i)) + (type (uffi:get-slot-value field 'mysql-field 'type)) + (binding (uffi:deref-array output-bind '(:array mysql-bind) i))) + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-type) type) + + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-length) 0) + #+need-to-allocate-foreign-object-for-this + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::is-null) + (+ i (uffi:pointer-address is-null-ptr))) + #+need-to-allocate-foreign-object-for-this + (setf (uffi:get-slot-value binding 'mysql-bind 'length) + (+ (* i 8) (uffi:pointer-address length-ptr))) + + (case type + ((#.mysql-field-types#var-string #.mysql-field-types#string + #.mysql-field-types#tiny-blob #.mysql-field-types#blob + #.mysql-field-types#medium-blob #.mysql-field-types#long-blob) + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-length) 1024) + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + (uffi:allocate-foreign-object :unsigned-char 1024))) + (#.mysql-field-types#tiny + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + (uffi:allocate-foreign-object :byte))) + (#.mysql-field-types#short + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + (uffi:allocate-foreign-object :short))) + (#.mysql-field-types#long + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + ;; segfaults if supply :int on amd64 + (uffi:allocate-foreign-object :long))) + #+64bit + (#.mysql-field-types#longlong + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + (uffi:allocate-foreign-object :long))) + (#.mysql-field-types#float + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + (uffi:allocate-foreign-object :float))) + (#.mysql-field-types#double + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + (uffi:allocate-foreign-object :double))) + ((#.mysql-field-types#time #.mysql-field-types#date + #.mysql-field-types#datetime #.mysql-field-types#timestamp) + (uffi:allocate-foreign-object 'mysql-time)) + (t + (error "mysql type ~D not supported." type))))) + + (unless (zerop (mysql-stmt-bind-result stmt output-bind)) + (mysql-stmt-close stmt) + (error 'sql-database-error + :error-id (mysql-stmt-errno stmt) + :message (uffi:convert-from-cstring + (mysql-stmt-error stmt))))) + + (make-instance 'mysql-stmt + :database database + :stmt stmt + :num-fields num-fields + :input-bind input-bind + :output-bind output-bind + :result-set rs + :result-types result-types + :length-ptr length-ptr + :is-null-ptr is-null-ptr + :types mysql-types + :field-names field-names))))) #+mysql-client-v4.1 (defmethod database-bind-parameter ((stmt mysql-stmt) position value) ;; FIXME: will need to allocate bind structure. This should probably be ;; done in C since the API is not mature and may change (let ((binding (uffi:deref-array (input-bind stmt) '(:array mysql-bind) (1- position))) - (type (nth (1- position) (types stmt)))) + (type (nth (1- position) (types stmt)))) (setf (uffi:get-slot-value binding 'mysql-bind 'length) 0) (cond ((null value) (when (is-null-ptr stmt) - (setf (uffi:deref-array (is-null-ptr stmt) '(:array :byte) (1- position)) 1))) + (setf (uffi:deref-array (is-null-ptr stmt) '(:array :byte) (1- position)) 1))) (t (when (is-null-ptr stmt) - (setf (uffi:deref-array (is-null-ptr stmt) '(:array :byte) (1- position)) 0)) + (setf (uffi:deref-array (is-null-ptr stmt) '(:array :byte) (1- position)) 0)) (case type - (#.mysql-field-types#long - (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) value)) - (t - (warn "Unknown input bind type ~D." type)) - ))))) + (#.mysql-field-types#long + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) value)) + (t + (warn "Unknown input bind type ~D." type)) + ))))) #+mysql-client-v4.1 (defmethod database-run-prepared ((stmt mysql-stmt)) @@ -665,21 +665,21 @@ (when (input-bind stmt) (unless (zerop (mysql-stmt-bind-param (stmt stmt) (input-bind stmt))) (error 'sql-database-error - :error-id (mysql-stmt-errno (stmt stmt)) - :message (uffi:convert-from-cstring - (mysql-stmt-error (stmt stmt)))))) + :error-id (mysql-stmt-errno (stmt stmt)) + :message (uffi:convert-from-cstring + (mysql-stmt-error (stmt stmt)))))) (print 'a2) (unless (zerop (mysql-stmt-execute (stmt stmt))) (error 'sql-database-error - :error-id (mysql-stmt-errno (stmt stmt)) - :message (uffi:convert-from-cstring - (mysql-stmt-error (stmt stmt))))) + :error-id (mysql-stmt-errno (stmt stmt)) + :message (uffi:convert-from-cstring + (mysql-stmt-error (stmt stmt))))) (print 'a3) (unless (zerop (mysql-stmt-store-result (stmt stmt))) (error 'sql-database-error - :error-id (mysql-stmt-errno (stmt stmt)) - :message (uffi:convert-from-cstring - (mysql-stmt-error (stmt stmt))))) + :error-id (mysql-stmt-errno (stmt stmt)) + :message (uffi:convert-from-cstring + (mysql-stmt-error (stmt stmt))))) (database-fetch-prepared-rows stmt)) #+mysql-client-v4.1 @@ -690,46 +690,46 @@ ((not (zerop rc)) (nreverse rows)) (push (loop for i from 0 below num-fields - collect - (let ((is-null - (not (zerop (uffi:ensure-char-integer - (uffi:deref-array (is-null-ptr stmt) '(:array :byte) i)))))) - (unless is-null - (let* ((bind (uffi:deref-array (output-bind stmt) '(:array mysql-bind) i)) - (type (uffi:get-slot-value bind 'mysql-bind 'mysql::buffer-type)) - (buffer (uffi:get-slot-value bind 'mysql-bind 'mysql::buffer))) - (case type - ((#.mysql-field-types#var-string #.mysql-field-types#string - #.mysql-field-types#tiny-blob #.mysql-field-types#blob - #.mysql-field-types#medium-blob #.mysql-field-types#long-blob) - (uffi:convert-from-foreign-string buffer)) - (#.mysql-field-types#tiny - (uffi:ensure-char-integer - (uffi:deref-pointer buffer :byte))) - (#.mysql-field-types#short - (uffi:deref-pointer buffer :short)) - (#.mysql-field-types#long - (uffi:deref-pointer buffer :int)) - #+64bit - (#.mysql-field-types#longlong - (uffi:deref-pointer buffer :long)) - (#.mysql-field-types#float - (uffi:deref-pointer buffer :float)) - (#.mysql-field-types#double - (uffi:deref-pointer buffer :double)) - ((#.mysql-field-types#time #.mysql-field-types#date - #.mysql-field-types#datetime #.mysql-field-types#timestamp) - (let ((year (uffi:get-slot-value buffer 'mysql-time 'mysql::year)) - (month (uffi:get-slot-value buffer 'mysql-time 'mysql::month)) - (day (uffi:get-slot-value buffer 'mysql-time 'mysql::day)) - (hour (uffi:get-slot-value buffer 'mysql-time 'mysql::hour)) - (minute (uffi:get-slot-value buffer 'mysql-time 'mysql::minute)) - (second (uffi:get-slot-value buffer 'mysql-time 'mysql::second))) - (db-timestring - (make-time :year year :month month :day day :hour hour - :minute minute :second second)))) - (t - (list type))))))) + collect + (let ((is-null + (not (zerop (uffi:ensure-char-integer + (uffi:deref-array (is-null-ptr stmt) '(:array :byte) i)))))) + (unless is-null + (let* ((bind (uffi:deref-array (output-bind stmt) '(:array mysql-bind) i)) + (type (uffi:get-slot-value bind 'mysql-bind 'mysql::buffer-type)) + (buffer (uffi:get-slot-value bind 'mysql-bind 'mysql::buffer))) + (case type + ((#.mysql-field-types#var-string #.mysql-field-types#string + #.mysql-field-types#tiny-blob #.mysql-field-types#blob + #.mysql-field-types#medium-blob #.mysql-field-types#long-blob) + (uffi:convert-from-foreign-string buffer)) + (#.mysql-field-types#tiny + (uffi:ensure-char-integer + (uffi:deref-pointer buffer :byte))) + (#.mysql-field-types#short + (uffi:deref-pointer buffer :short)) + (#.mysql-field-types#long + (uffi:deref-pointer buffer :int)) + #+64bit + (#.mysql-field-types#longlong + (uffi:deref-pointer buffer :long)) + (#.mysql-field-types#float + (uffi:deref-pointer buffer :float)) + (#.mysql-field-types#double + (uffi:deref-pointer buffer :double)) + ((#.mysql-field-types#time #.mysql-field-types#date + #.mysql-field-types#datetime #.mysql-field-types#timestamp) + (let ((year (uffi:get-slot-value buffer 'mysql-time 'mysql::year)) + (month (uffi:get-slot-value buffer 'mysql-time 'mysql::month)) + (day (uffi:get-slot-value buffer 'mysql-time 'mysql::day)) + (hour (uffi:get-slot-value buffer 'mysql-time 'mysql::hour)) + (minute (uffi:get-slot-value buffer 'mysql-time 'mysql::minute)) + (second (uffi:get-slot-value buffer 'mysql-time 'mysql::second))) + (db-timestring + (make-time :year year :month month :day day :hour hour + :minute minute :second second)))) + (t + (list type))))))) rows))) diff --git a/db-mysql/testing/mysql-struct-size.lisp b/db-mysql/testing/mysql-struct-size.lisp index 60dfd92..3aac6f9 100644 --- a/db-mysql/testing/mysql-struct-size.lisp +++ b/db-mysql/testing/mysql-struct-size.lisp @@ -1,10 +1,10 @@ (in-package :mysql) -#+lispworks +#+lispworks (progn (setq c (fli:allocate-foreign-object :type 'mysql-mysql)) (format t "~&Size MYSQL structure: ~d" (fli:pointer-element-size c))) -#+allegro +#+allegro (progn (setq c (ff:allocate-fobject 'mysql-mysql :foreign)) (format t "~&Size MYSQL structure: ~A" c)) diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index 4719d73..50ef443 100644 --- a/db-odbc/odbc-api.lisp +++ b/db-odbc/odbc-api.lisp @@ -45,14 +45,14 @@ as possible second argument) to the desired representation of date/time/timestam `(let ((,size (length ,string))) (when (and ,max-length (> ,size ,max-length)) (error 'clsql:sql-database-data-error - :message - (format nil "string \"~a\" of length ~d is longer than max-length: ~d" - ,string ,size ,max-length))) + :message + (format nil "string \"~a\" of length ~d is longer than max-length: ~d" + ,string ,size ,max-length))) (with-cast-pointer (char-ptr ,ptr :byte) - (dotimes (i ,size) - (setf (deref-array char-ptr '(:array :byte) i) - (char-code (char ,string i)))) - (setf (deref-array char-ptr '(:array :byte) ,size) 0))))) + (dotimes (i ,size) + (setf (deref-array char-ptr '(:array :byte) i) + (char-code (char ,string i)))) + (setf (deref-array char-ptr '(:array :byte) ,size) 0))))) (defun %cstring-into-vector (ptr vector offset size-in-bytes) (dotimes (i size-in-bytes) @@ -64,36 +64,36 @@ as possible second argument) to the desired representation of date/time/timestam (defun handle-error (henv hdbc hstmt) (let ((sql-state (allocate-foreign-string 256)) - (error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH))) + (error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH))) (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE) - (msg-length :short)) + (msg-length :short)) (SQLError henv hdbc hstmt sql-state - error-code error-message - #.$SQL_MAX_MESSAGE_LENGTH msg-length) + error-code error-message + #.$SQL_MAX_MESSAGE_LENGTH msg-length) (let ((err (convert-from-foreign-string error-message)) - (state (convert-from-foreign-string sql-state))) - (free-foreign-object error-message) - (free-foreign-object sql-state) - (values - err - state - (deref-pointer msg-length :short) - (deref-pointer error-code #.$ODBC-LONG-TYPE)))))) + (state (convert-from-foreign-string sql-state))) + (free-foreign-object error-message) + (free-foreign-object sql-state) + (values + err + state + (deref-pointer msg-length :short) + (deref-pointer error-code #.$ODBC-LONG-TYPE)))))) (defun sql-state (henv hdbc hstmt) (let ((sql-state (allocate-foreign-string 256)) - (error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH))) + (error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH))) (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE) - (msg-length :short)) + (msg-length :short)) (SQLError henv hdbc hstmt sql-state error-code - error-message #.$SQL_MAX_MESSAGE_LENGTH msg-length) + error-message #.$SQL_MAX_MESSAGE_LENGTH msg-length) (let ((state (convert-from-foreign-string sql-state))) - (free-foreign-object error-message) - (free-foreign-object sql-state) - state - ;; test this: return a keyword for efficiency - ;;(%cstring-to-keyword state) - )))) + (free-foreign-object error-message) + (free-foreign-object sql-state) + state + ;; test this: return a keyword for efficiency + ;;(%cstring-to-keyword state) + )))) (defmacro with-error-handling ((&key henv hdbc hstmt (print-info t)) odbc-call &body body) @@ -116,53 +116,53 @@ as possible second argument) to the desired representation of date/time/timestam (#.$SQL_SUCCESS_WITH_INFO (when ,print-info (multiple-value-bind (error-message sql-state) - (handle-error (or ,henv +null-handle-ptr+) - (or ,hdbc +null-handle-ptr+) - (or ,hstmt +null-handle-ptr+)) - (when *info-output* - (format *info-output* "[ODBC info ~A] ~A state: ~A" - ,result-code error-message - sql-state)))) + (handle-error (or ,henv +null-handle-ptr+) + (or ,hdbc +null-handle-ptr+) + (or ,hstmt +null-handle-ptr+)) + (when *info-output* + (format *info-output* "[ODBC info ~A] ~A state: ~A" + ,result-code error-message + sql-state)))) (progn ,result-code ,@body)) (#.$SQL_INVALID_HANDLE (error - 'clsql-sys:sql-database-error - :message "ODBC: Invalid handle")) + 'clsql-sys:sql-database-error + :message "ODBC: Invalid handle")) (#.$SQL_STILL_EXECUTING (error - 'clsql-sys:sql-temporary-error - :message "ODBC: Still executing")) + 'clsql-sys:sql-temporary-error + :message "ODBC: Still executing")) (#.$SQL_ERROR (multiple-value-bind (error-message sql-state) - (handle-error (or ,henv +null-handle-ptr+) - (or ,hdbc +null-handle-ptr+) - (or ,hstmt +null-handle-ptr+)) + (handle-error (or ,henv +null-handle-ptr+) + (or ,hdbc +null-handle-ptr+) + (or ,hstmt +null-handle-ptr+)) (error - 'clsql-sys:sql-database-error - :message error-message - :secondary-error-id sql-state))) - (#.$SQL_NO_DATA_FOUND - (progn ,result-code ,@body)) - ;; work-around for Allegro 7.0beta AMD64 which returns negative numbers - (otherwise - (multiple-value-bind (error-message sql-state) - (handle-error (or ,henv +null-handle-ptr+) - (or ,hdbc +null-handle-ptr+) - (or ,hstmt +null-handle-ptr+)) + 'clsql-sys:sql-database-error + :message error-message + :secondary-error-id sql-state))) + (#.$SQL_NO_DATA_FOUND + (progn ,result-code ,@body)) + ;; work-around for Allegro 7.0beta AMD64 which returns negative numbers + (otherwise + (multiple-value-bind (error-message sql-state) + (handle-error (or ,henv +null-handle-ptr+) + (or ,hdbc +null-handle-ptr+) + (or ,hstmt +null-handle-ptr+)) (error - 'clsql-sys:sql-database-error - :message error-message - :secondary-error-id sql-state)) - #+ignore + 'clsql-sys:sql-database-error + :message error-message + :secondary-error-id sql-state)) + #+ignore (progn ,result-code ,@body)))))) (defun %new-environment-handle () (let ((henv - (with-foreign-object (phenv 'sql-handle) - (with-error-handling - () - (SQLAllocHandle $SQL_HANDLE_ENV +null-handle-ptr+ phenv) - (deref-pointer phenv 'sql-handle))))) + (with-foreign-object (phenv 'sql-handle) + (with-error-handling + () + (SQLAllocHandle $SQL_HANDLE_ENV +null-handle-ptr+ phenv) + (deref-pointer phenv 'sql-handle))))) (%set-attr-odbc-version henv $SQL_OV_ODBC3) henv)) @@ -201,12 +201,12 @@ as possible second argument) to the desired representation of date/time/timestam (defun %sql-connect (hdbc server uid pwd) (with-cstrings ((server-ptr server) - (uid-ptr uid) - (pwd-ptr pwd)) + (uid-ptr uid) + (pwd-ptr pwd)) (with-error-handling - (:hdbc hdbc) + (:hdbc hdbc) (SQLConnect hdbc server-ptr $SQL_NTS uid-ptr - $SQL_NTS pwd-ptr $SQL_NTS)))) + $SQL_NTS pwd-ptr $SQL_NTS)))) (defun %sql-driver-connect (hdbc connection-string completion window-handle) (with-cstring (connection-ptr connection-string) @@ -273,14 +273,14 @@ as possible second argument) to the desired representation of date/time/timestam (defun %new-statement-handle (hdbc) (let ((statement-handle - (with-foreign-object (phstmt 'sql-handle) - (with-error-handling - (:hdbc hdbc) - (SQLAllocHandle $SQL_HANDLE_STMT hdbc phstmt) - (deref-pointer phstmt 'sql-handle))))) + (with-foreign-object (phstmt 'sql-handle) + (with-error-handling + (:hdbc hdbc) + (SQLAllocHandle $SQL_HANDLE_STMT hdbc phstmt) + (deref-pointer phstmt 'sql-handle))))) (if (uffi:null-pointer-p statement-handle) - (error 'clsql:sql-database-error :message "Received null statement handle.") - statement-handle))) + (error 'clsql:sql-database-error :message "Received null statement handle.") + statement-handle))) (defun %sql-get-info (hdbc info-type) (ecase info-type @@ -320,12 +320,12 @@ as possible second argument) to the desired representation of date/time/timestam #.$SQL_USER_NAME) (let ((info-ptr (allocate-foreign-string 1024))) (with-foreign-object (info-length-ptr :short) - (with-error-handling - (:hdbc hdbc) - (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr) - (let ((info (convert-from-foreign-string info-ptr))) - (free-foreign-object info-ptr) - info))))) + (with-error-handling + (:hdbc hdbc) + (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr) + (let ((info (convert-from-foreign-string info-ptr))) + (free-foreign-object info-ptr) + info))))) ;; those returning a word ((#.$SQL_ACTIVE_CONNECTIONS #.$SQL_ACTIVE_STATEMENTS @@ -355,14 +355,14 @@ as possible second argument) to the desired representation of date/time/timestam #.$SQL_QUOTED_IDENTIFIER_CASE #.$SQL_TXN_CAPABLE) (with-foreign-objects ((info-ptr :short) - (info-length-ptr :short)) + (info-length-ptr :short)) (with-error-handling - (:hdbc hdbc) + (:hdbc hdbc) (SQLGetInfo hdbc - info-type - info-ptr - 255 - info-length-ptr) + info-type + info-ptr + 255 + info-length-ptr) (deref-pointer info-ptr :short))) ) ;; those returning a long bitmask @@ -412,14 +412,14 @@ as possible second argument) to the desired representation of date/time/timestam #.$SQL_TXN_ISOLATION_OPTION #.$SQL_UNION) (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE) - (info-length-ptr :short)) + (info-length-ptr :short)) (with-error-handling (:hdbc hdbc) (SQLGetInfo hdbc - info-type - info-ptr - 255 - info-length-ptr) + info-type + info-ptr + 255 + info-length-ptr) (deref-pointer info-ptr #.$ODBC-LONG-TYPE))) ) ;; those returning a long integer @@ -435,7 +435,7 @@ as possible second argument) to the desired representation of date/time/timestam #.$SQL_ACTIVE_ENVIRONMENTS ) (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE) - (info-length-ptr :short)) + (info-length-ptr :short)) (with-error-handling (:hdbc hdbc) (SQLGetInfo hdbc info-type info-ptr 255 info-length-ptr) @@ -473,38 +473,38 @@ as possible second argument) to the desired representation of date/time/timestam (defun %describe-column (hstmt column-nr) (let ((column-name-ptr (allocate-foreign-string 256))) (with-foreign-objects ((column-name-length-ptr :short) - (column-sql-type-ptr :short) - (column-precision-ptr #.$ODBC-ULONG-TYPE) - (column-scale-ptr :short) - (column-nullable-p-ptr :short)) + (column-sql-type-ptr :short) + (column-precision-ptr #.$ODBC-ULONG-TYPE) + (column-scale-ptr :short) + (column-nullable-p-ptr :short)) (with-error-handling (:hstmt hstmt) - (SQLDescribeCol hstmt column-nr column-name-ptr 256 - column-name-length-ptr - column-sql-type-ptr - column-precision-ptr - column-scale-ptr - column-nullable-p-ptr) - (let ((column-name (convert-from-foreign-string column-name-ptr))) - (free-foreign-object column-name-ptr) - (values - column-name - (deref-pointer column-sql-type-ptr :short) - (deref-pointer column-precision-ptr #.$ODBC-ULONG-TYPE) - (deref-pointer column-scale-ptr :short) - (deref-pointer column-nullable-p-ptr :short))))))) + (SQLDescribeCol hstmt column-nr column-name-ptr 256 + column-name-length-ptr + column-sql-type-ptr + column-precision-ptr + column-scale-ptr + column-nullable-p-ptr) + (let ((column-name (convert-from-foreign-string column-name-ptr))) + (free-foreign-object column-name-ptr) + (values + column-name + (deref-pointer column-sql-type-ptr :short) + (deref-pointer column-precision-ptr #.$ODBC-ULONG-TYPE) + (deref-pointer column-scale-ptr :short) + (deref-pointer column-nullable-p-ptr :short))))))) ;; parameter counting is 1-based (defun %describe-parameter (hstmt parameter-nr) (with-foreign-objects ((column-sql-type-ptr :short) - (column-precision-ptr #.$ODBC-ULONG-TYPE) - (column-scale-ptr :short) - (column-nullable-p-ptr :short)) + (column-precision-ptr #.$ODBC-ULONG-TYPE) + (column-scale-ptr :short) + (column-nullable-p-ptr :short)) (with-error-handling (:hstmt hstmt) (SQLDescribeParam hstmt parameter-nr - column-sql-type-ptr + column-sql-type-ptr column-precision-ptr - column-scale-ptr + column-scale-ptr column-nullable-p-ptr) (values (deref-pointer column-sql-type-ptr :short) @@ -515,34 +515,34 @@ as possible second argument) to the desired representation of date/time/timestam (defun %column-attributes (hstmt column-nr descriptor-type) (let ((descriptor-info-ptr (allocate-foreign-string 256))) (with-foreign-objects ((descriptor-length-ptr :short) - (numeric-descriptor-ptr #.$ODBC-LONG-TYPE)) + (numeric-descriptor-ptr #.$ODBC-LONG-TYPE)) (with-error-handling - (:hstmt hstmt) - (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr - 256 descriptor-length-ptr - numeric-descriptor-ptr) - (let ((desc (convert-from-foreign-string descriptor-info-ptr))) - (free-foreign-object descriptor-info-ptr) - (values - desc - (deref-pointer numeric-descriptor-ptr #.$ODBC-LONG-TYPE))))))) + (:hstmt hstmt) + (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr + 256 descriptor-length-ptr + numeric-descriptor-ptr) + (let ((desc (convert-from-foreign-string descriptor-info-ptr))) + (free-foreign-object descriptor-info-ptr) + (values + desc + (deref-pointer numeric-descriptor-ptr #.$ODBC-LONG-TYPE))))))) (defun %prepare-describe-columns (hstmt table-qualifier table-owner table-name column-name) (with-cstrings ((table-qualifier-ptr table-qualifier) - (table-owner-ptr table-owner) - (table-name-ptr table-name) - (column-name-ptr column-name)) + (table-owner-ptr table-owner) + (table-name-ptr table-name) + (column-name-ptr column-name)) (with-error-handling - (:hstmt hstmt) + (:hstmt hstmt) (SQLColumns hstmt - table-qualifier-ptr (length table-qualifier) - table-owner-ptr (length table-owner) - table-name-ptr (length table-name) - column-name-ptr (length column-name))))) + table-qualifier-ptr (length table-qualifier) + table-owner-ptr (length table-owner) + table-name-ptr (length table-name) + column-name-ptr (length column-name))))) (defun %describe-columns (hdbc table-qualifier table-owner - table-name column-name) + table-name column-name) (with-statement-handle (hstmt hdbc) (%prepare-describe-columns hstmt table-qualifier table-owner table-name column-name) @@ -550,34 +550,34 @@ as possible second argument) to the desired representation of date/time/timestam (defun %sql-data-sources (henv &key (direction :first)) (let ((name-ptr (allocate-foreign-string (1+ $SQL_MAX_DSN_LENGTH))) - (description-ptr (allocate-foreign-string 1024))) + (description-ptr (allocate-foreign-string 1024))) (with-foreign-objects ((name-length-ptr :short) - (description-length-ptr :short)) + (description-length-ptr :short)) (let ((res (with-error-handling - (:henv henv) - (SQLDataSources henv - (ecase direction - (:first $SQL_FETCH_FIRST) - (:next $SQL_FETCH_NEXT)) - name-ptr - (1+ $SQL_MAX_DSN_LENGTH) - name-length-ptr - description-ptr - 1024 - description-length-ptr)))) - (cond - ((= res $SQL_NO_DATA_FOUND) - (let ((name (convert-from-foreign-string name-ptr)) - (desc (convert-from-foreign-string description-ptr))) - (free-foreign-object name-ptr) - (free-foreign-object description-ptr) - (values - name - desc))) - (t - (free-foreign-object name-ptr) - (free-foreign-object description-ptr) - nil)))))) + (:henv henv) + (SQLDataSources henv + (ecase direction + (:first $SQL_FETCH_FIRST) + (:next $SQL_FETCH_NEXT)) + name-ptr + (1+ $SQL_MAX_DSN_LENGTH) + name-length-ptr + description-ptr + 1024 + description-length-ptr)))) + (cond + ((= res $SQL_NO_DATA_FOUND) + (let ((name (convert-from-foreign-string name-ptr)) + (desc (convert-from-foreign-string description-ptr))) + (free-foreign-object name-ptr) + (free-foreign-object description-ptr) + (values + name + desc))) + (t + (free-foreign-object name-ptr) + (free-foreign-object description-ptr) + nil)))))) @@ -642,77 +642,77 @@ as possible second argument) to the desired representation of date/time/timestam (ecase format (:unsigned-byte-vector (let ((vector (make-array len :element-type '(unsigned-byte 8)))) - (dotimes (i len) - (setf (aref vector i) - (deref-array casted '(:array :byte) i))) - vector)) + (dotimes (i len) + (setf (aref vector i) + (deref-array casted '(:array :byte) i))) + vector)) (:bit-vector (let ((vector (make-array (ash len 3) :element-type 'bit))) - (dotimes (i len) - (let ((byte (deref-array casted '(:array :byte) i))) - (dotimes (j 8) - (setf (bit vector (+ (ash i 3) j)) - (logand (ash byte (- j 7)) 1))))) - vector))))) + (dotimes (i len) + (let ((byte (deref-array casted '(:array :byte) i))) + (dotimes (j 8) + (setf (bit vector (+ (ash i 3) j)) + (logand (ash byte (- j 7)) 1))))) + vector))))) (defun read-data (data-ptr c-type sql-type out-len-ptr result-type) (declare (type long-ptr-type out-len-ptr)) (let* ((out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE)) - (value - (cond ((= out-len $SQL_NULL_DATA) - *null*) - (t - (case sql-type - ;; SQL extended datatypes + (value + (cond ((= out-len $SQL_NULL_DATA) + *null*) + (t + (case sql-type + ;; SQL extended datatypes (#.$SQL_TINYINT (get-cast-byte data-ptr)) - (#.$SQL_C_STINYINT (get-cast-byte data-ptr)) ;; ? - (#.$SQL_C_SSHORT (get-cast-short data-ptr)) ;; ? - (#.$SQL_SMALLINT (get-cast-short data-ptr)) ;; ?? - (#.$SQL_INTEGER (get-cast-int data-ptr)) - (#.$SQL_BIGINT (read-from-string - (get-cast-foreign-string data-ptr))) - (#.$SQL_DECIMAL - (let ((*read-base* 10)) - (read-from-string (get-cast-foreign-string data-ptr)))) + (#.$SQL_C_STINYINT (get-cast-byte data-ptr)) ;; ? + (#.$SQL_C_SSHORT (get-cast-short data-ptr)) ;; ? + (#.$SQL_SMALLINT (get-cast-short data-ptr)) ;; ?? + (#.$SQL_INTEGER (get-cast-int data-ptr)) + (#.$SQL_BIGINT (read-from-string + (get-cast-foreign-string data-ptr))) + (#.$SQL_DECIMAL + (let ((*read-base* 10)) + (read-from-string (get-cast-foreign-string data-ptr)))) (#.$SQL_BIT (get-cast-byte data-ptr)) - (t - (case c-type - ((#.$SQL_C_DATE #.$SQL_C_TYPE_DATE) - (funcall *time-conversion-function* (date-to-universal-time data-ptr))) - ((#.$SQL_C_TIME #.$SQL_C_TYPE_TIME) - (multiple-value-bind (universal-time frac) (time-to-universal-time data-ptr) - (funcall *time-conversion-function* universal-time frac))) - ((#.$SQL_C_TIMESTAMP #.$SQL_C_TYPE_TIMESTAMP) - (multiple-value-bind (universal-time frac) (timestamp-to-universal-time data-ptr) - (funcall *time-conversion-function* universal-time frac))) - (#.$SQL_INTEGER - (get-cast-int data-ptr)) - (#.$SQL_C_FLOAT - (get-cast-single-float data-ptr)) - (#.$SQL_C_DOUBLE - (get-cast-double-float data-ptr)) - (#.$SQL_C_SLONG - (get-cast-long data-ptr)) - #+lispworks - (#.$SQL_C_BIT ; encountered only in Access - (get-cast-byte data-ptr)) - (#.$SQL_C_BINARY - (get-cast-binary data-ptr out-len *binary-format*)) - ((#.$SQL_C_SSHORT #.$SQL_C_STINYINT) ; LMH short ints - (get-cast-short data-ptr)) ; LMH - #+ignore - (#.$SQL_C_CHAR - (code-char (get-cast-short data-ptr))) - (t - (get-cast-foreign-string data-ptr))))))))) + (t + (case c-type + ((#.$SQL_C_DATE #.$SQL_C_TYPE_DATE) + (funcall *time-conversion-function* (date-to-universal-time data-ptr))) + ((#.$SQL_C_TIME #.$SQL_C_TYPE_TIME) + (multiple-value-bind (universal-time frac) (time-to-universal-time data-ptr) + (funcall *time-conversion-function* universal-time frac))) + ((#.$SQL_C_TIMESTAMP #.$SQL_C_TYPE_TIMESTAMP) + (multiple-value-bind (universal-time frac) (timestamp-to-universal-time data-ptr) + (funcall *time-conversion-function* universal-time frac))) + (#.$SQL_INTEGER + (get-cast-int data-ptr)) + (#.$SQL_C_FLOAT + (get-cast-single-float data-ptr)) + (#.$SQL_C_DOUBLE + (get-cast-double-float data-ptr)) + (#.$SQL_C_SLONG + (get-cast-long data-ptr)) + #+lispworks + (#.$SQL_C_BIT ; encountered only in Access + (get-cast-byte data-ptr)) + (#.$SQL_C_BINARY + (get-cast-binary data-ptr out-len *binary-format*)) + ((#.$SQL_C_SSHORT #.$SQL_C_STINYINT) ; LMH short ints + (get-cast-short data-ptr)) ; LMH + #+ignore + (#.$SQL_C_CHAR + (code-char (get-cast-short data-ptr))) + (t + (get-cast-foreign-string data-ptr))))))))) ;; FIXME: this could be better optimized for types which use READ-FROM-STRING above (if (and (or (eq result-type t) (eq result-type :string)) - value - (not (stringp value))) - (write-to-string value) + value + (not (stringp value))) + (write-to-string value) value))) ;; which value is appropriate? @@ -736,7 +736,7 @@ as possible second argument) to the desired representation of date/time/timestam ((#.$SQL_C_DATE #.$SQL_C_TYPE_DATE) (allocate-foreign-object 'sql-c-date)) ((#.$SQL_C_TIME #.$SQL_C_TYPE_TIME) (allocate-foreign-object 'sql-c-time)) ((#.$SQL_C_TIMESTAMP #.$SQL_C_TYPE_TIMESTAMP) (allocate-foreign-object 'sql-c-timestamp)) - (#.$SQL_C_FLOAT (uffi:allocate-foreign-object :float)) + (#.$SQL_C_FLOAT (uffi:allocate-foreign-object :float)) (#.$SQL_C_DOUBLE (uffi:allocate-foreign-object :double)) (#.$SQL_C_BIT (uffi:allocate-foreign-object :byte)) (#.$SQL_C_STINYINT (uffi:allocate-foreign-object :byte)) @@ -787,7 +787,7 @@ as possible second argument) to the desired representation of date/time/timestam (cond (flatp (when (> column-count 1) (error 'clsql:sql-database-error - :message "If more than one column is to be fetched, flatp has to be nil.")) + :message "If more than one column is to be fetched, flatp has to be nil.")) (loop until (= (%sql-fetch hstmt) $SQL_NO_DATA_FOUND) collect (read-data (aref data-ptrs 0) @@ -846,10 +846,10 @@ as possible second argument) to the desired representation of date/time/timestam (defun %sql-extended-fetch (hstmt fetch-type row) (with-foreign-objects ((row-count-ptr #.$ODBC-ULONG-TYPE) - (row-status-ptr :short)) + (row-status-ptr :short)) (with-error-handling (:hstmt hstmt) (SQLExtendedFetch hstmt fetch-type row row-count-ptr - row-status-ptr) + row-status-ptr) (values (deref-pointer row-count-ptr #.$ODBC-ULONG-TYPE) (deref-pointer row-status-ptr :short))))) @@ -991,7 +991,7 @@ as possible second argument) to the desired representation of date/time/timestam (defun %set-attr-odbc-version (henv version) (with-error-handling (:henv henv) (SQLSetEnvAttr henv $SQL_ATTR_ODBC_VERSION - (make-pointer version :void) 0))) + (make-pointer version :void) 0))) (defun %list-tables (hstmt) (with-error-handling (:hstmt hstmt) @@ -1010,32 +1010,32 @@ as possible second argument) to the desired representation of date/time/timestam (defun %list-data-sources (henv) (let ((dsn (allocate-foreign-string (1+ $SQL_MAX_DSN_LENGTH))) - (desc (allocate-foreign-string 256)) - (results nil)) + (desc (allocate-foreign-string 256)) + (results nil)) (unwind-protect - (with-foreign-objects ((dsn-len :short) - (desc-len :short)) - (let ((res (with-error-handling (:henv henv) - (SQLDataSources henv $SQL_FETCH_FIRST dsn - (1+ $SQL_MAX_DSN_LENGTH) - dsn-len desc 256 desc-len)))) - (when (or (eql res $SQL_SUCCESS) - (eql res $SQL_SUCCESS_WITH_INFO)) - (push (convert-from-foreign-string dsn) results)) - - (do ((res (with-error-handling (:henv henv) - (SQLDataSources henv $SQL_FETCH_NEXT dsn - (1+ $SQL_MAX_DSN_LENGTH) - dsn-len desc 256 desc-len)) - (with-error-handling (:henv henv) - (SQLDataSources henv $SQL_FETCH_NEXT dsn - (1+ $SQL_MAX_DSN_LENGTH) - dsn-len desc 256 desc-len)))) - ((not (or (eql res $SQL_SUCCESS) - (eql res $SQL_SUCCESS_WITH_INFO)))) - (push (convert-from-foreign-string dsn) results)))) + (with-foreign-objects ((dsn-len :short) + (desc-len :short)) + (let ((res (with-error-handling (:henv henv) + (SQLDataSources henv $SQL_FETCH_FIRST dsn + (1+ $SQL_MAX_DSN_LENGTH) + dsn-len desc 256 desc-len)))) + (when (or (eql res $SQL_SUCCESS) + (eql res $SQL_SUCCESS_WITH_INFO)) + (push (convert-from-foreign-string dsn) results)) + + (do ((res (with-error-handling (:henv henv) + (SQLDataSources henv $SQL_FETCH_NEXT dsn + (1+ $SQL_MAX_DSN_LENGTH) + dsn-len desc 256 desc-len)) + (with-error-handling (:henv henv) + (SQLDataSources henv $SQL_FETCH_NEXT dsn + (1+ $SQL_MAX_DSN_LENGTH) + dsn-len desc 256 desc-len)))) + ((not (or (eql res $SQL_SUCCESS) + (eql res $SQL_SUCCESS_WITH_INFO)))) + (push (convert-from-foreign-string dsn) results)))) (progn - (free-foreign-object dsn) - (free-foreign-object desc))) + (free-foreign-object dsn) + (free-foreign-object desc))) (nreverse results))) diff --git a/db-odbc/odbc-constants.lisp b/db-odbc/odbc-constants.lisp index 6d8a183..4dfef88 100644 --- a/db-odbc/odbc-constants.lisp +++ b/db-odbc/odbc-constants.lisp @@ -22,7 +22,7 @@ (defconstant $ODBC-LONG-TYPE :int) (defconstant $ODBC-ULONG-TYPE :unsigned-int) -;; (defconstant $ODBCVER #x0210) +;; (defconstant $ODBCVER #x0210) ;; for new SQLAllocHandle functiion @@ -32,12 +32,12 @@ (defconstant $SQL_HANDLE_DESC 4) ;; generally useful constants -(defconstant $SQL_SPEC_MAJOR 2) ;; Major version of specification -(defconstant $SQL_SPEC_MINOR 10) ;; Minor version of specification -(defvar $SQL_SPEC_STRING "02.10") ;; String constant for version -(defconstant $SQL_SQLSTATE_SIZE 5) ;; size of SQLSTATE -(defconstant $SQL_MAX_MESSAGE_LENGTH 512) ;; message buffer size -(defconstant $SQL_MAX_DSN_LENGTH 32) ;; maximum data source name size +(defconstant $SQL_SPEC_MAJOR 2) ;; Major version of specification +(defconstant $SQL_SPEC_MINOR 10) ;; Minor version of specification +(defvar $SQL_SPEC_STRING "02.10") ;; String constant for version +(defconstant $SQL_SQLSTATE_SIZE 5) ;; size of SQLSTATE +(defconstant $SQL_MAX_MESSAGE_LENGTH 512) ;; message buffer size +(defconstant $SQL_MAX_DSN_LENGTH 32) ;; maximum data source name size ;; RETCODEs (defconstant $SQL_INVALID_HANDLE -2) @@ -61,13 +61,13 @@ (defconstant $SQL_TYPE_NULL 0) (defconstant $SQL_TYPE_MAX $SQL_VARCHAR) -;; C datatype to SQL datatype mapping SQL types +;; C datatype to SQL datatype mapping SQL types -(defconstant $SQL_C_CHAR $SQL_CHAR) ;; CHAR, VARCHAR, DECIMAL, NUMERIC -(defconstant $SQL_C_LONG $SQL_INTEGER) ;; INTEGER -(defconstant $SQL_C_SHORT $SQL_SMALLINT) ;; SMALLINT -(defconstant $SQL_C_FLOAT $SQL_REAL) ;; REAL -(defconstant $SQL_C_DOUBLE $SQL_DOUBLE) ;; FLOAT, DOUBLE +(defconstant $SQL_C_CHAR $SQL_CHAR) ;; CHAR, VARCHAR, DECIMAL, NUMERIC +(defconstant $SQL_C_LONG $SQL_INTEGER) ;; INTEGER +(defconstant $SQL_C_SHORT $SQL_SMALLINT) ;; SMALLINT +(defconstant $SQL_C_FLOAT $SQL_REAL) ;; REAL +(defconstant $SQL_C_DOUBLE $SQL_DOUBLE) ;; FLOAT, DOUBLE (defconstant $SQL_C_DEFAULT 99) ;; NULL status constants. These are used in SQLColumns, SQLColAttributes, @@ -105,13 +105,13 @@ (defconstant $SQL_COLUMN_UNSIGNED 8) (defconstant $SQL_COLUMN_MONEY 9) (defconstant $SQL_COLUMN_UPDATABLE 10) -(defconstant $SQL_COLUMN_AUTO_INCREMENT 11) -(defconstant $SQL_COLUMN_CASE_SENSITIVE 12) +(defconstant $SQL_COLUMN_AUTO_INCREMENT 11) +(defconstant $SQL_COLUMN_CASE_SENSITIVE 12) (defconstant $SQL_COLUMN_SEARCHABLE 13) (defconstant $SQL_COLUMN_TYPE_NAME 14) (defconstant $SQL_COLUMN_TABLE_NAME 15) (defconstant $SQL_COLUMN_OWNER_NAME 16) -(defconstant $SQL_COLUMN_QUALIFIER_NAME 17) +(defconstant $SQL_COLUMN_QUALIFIER_NAME 17) (defconstant $SQL_COLUMN_LABEL 18) (defconstant $SQL_COLATT_OPT_MAX $SQL_COLUMN_LABEL) @@ -125,7 +125,7 @@ (defconstant $SQL_ATTR_READWRITE_UNKNOWN 2) ;; SQLColAttributes subdefines for SQL_COLUMN_SEARCHABLE -;; These are also used by SQLGetInfo +;; These are also used by SQLGetInfo (defconstant $SQL_UNSEARCHABLE 0) (defconstant $SQL_LIKE_ONLY 1) (defconstant $SQL_ALL_EXCEPT_LIKE 2) @@ -202,9 +202,9 @@ (defconstant $SQL_API_SQLSETSCROLLOPTIONS 69) (defconstant $SQL_API_SQLTABLEPRIVILEGES 70) -;/* SDK 2.0 Additions */ +;/* SDK 2.0 Additions */ (defconstant $SQL_API_SQLDRIVERS 71) -(defconstant $SQL_API_SQLBINDPARAMETER 72) +(defconstant $SQL_API_SQLBINDPARAMETER 72) (defconstant $SQL_EXT_API_LAST $SQL_API_SQLBINDPARAMETER) (defconstant $SQL_API_ALL_FUNCTIONS 0) @@ -298,202 +298,202 @@ (defconstant $SQL_NON_NULLABLE_COLUMNS 75) ;;; ODBC SDK 2.0 Additions -(defconstant $SQL_DRIVER_HLIB 76) -(defconstant $SQL_DRIVER_ODBC_VER 77) -(defconstant $SQL_LOCK_TYPES 78) -(defconstant $SQL_POS_OPERATIONS 79) -(defconstant $SQL_POSITIONED_STATEMENTS 80) -(defconstant $SQL_GETDATA_EXTENSIONS 81) -(defconstant $SQL_BOOKMARK_PERSISTENCE 82) -(defconstant $SQL_STATIC_SENSITIVITY 83) -(defconstant $SQL_FILE_USAGE 84) -(defconstant $SQL_NULL_COLLATION 85) -(defconstant $SQL_ALTER_TABLE 86) -(defconstant $SQL_COLUMN_ALIAS 87) -(defconstant $SQL_GROUP_BY 88) -(defconstant $SQL_KEYWORDS 89) -(defconstant $SQL_ORDER_BY_COLUMNS_IN_SELECT 90) -(defconstant $SQL_OWNER_USAGE 91) -(defconstant $SQL_QUALIFIER_USAGE 92) -(defconstant $SQL_QUOTED_IDENTIFIER_CASE 93) -(defconstant $SQL_SPECIAL_CHARACTERS 94) -(defconstant $SQL_SUBQUERIES 95) -(defconstant $SQL_UNION 96) -(defconstant $SQL_MAX_COLUMNS_IN_GROUP_BY 97) -(defconstant $SQL_MAX_COLUMNS_IN_INDEX 98) -(defconstant $SQL_MAX_COLUMNS_IN_ORDER_BY 99) -(defconstant $SQL_MAX_COLUMNS_IN_SELECT 100) -(defconstant $SQL_MAX_COLUMNS_IN_TABLE 101) -(defconstant $SQL_MAX_INDEX_SIZE 102) -(defconstant $SQL_MAX_ROW_SIZE_INCLUDES_LONG 103) -(defconstant $SQL_MAX_ROW_SIZE 104) -(defconstant $SQL_MAX_STATEMENT_LEN 105) +(defconstant $SQL_DRIVER_HLIB 76) +(defconstant $SQL_DRIVER_ODBC_VER 77) +(defconstant $SQL_LOCK_TYPES 78) +(defconstant $SQL_POS_OPERATIONS 79) +(defconstant $SQL_POSITIONED_STATEMENTS 80) +(defconstant $SQL_GETDATA_EXTENSIONS 81) +(defconstant $SQL_BOOKMARK_PERSISTENCE 82) +(defconstant $SQL_STATIC_SENSITIVITY 83) +(defconstant $SQL_FILE_USAGE 84) +(defconstant $SQL_NULL_COLLATION 85) +(defconstant $SQL_ALTER_TABLE 86) +(defconstant $SQL_COLUMN_ALIAS 87) +(defconstant $SQL_GROUP_BY 88) +(defconstant $SQL_KEYWORDS 89) +(defconstant $SQL_ORDER_BY_COLUMNS_IN_SELECT 90) +(defconstant $SQL_OWNER_USAGE 91) +(defconstant $SQL_QUALIFIER_USAGE 92) +(defconstant $SQL_QUOTED_IDENTIFIER_CASE 93) +(defconstant $SQL_SPECIAL_CHARACTERS 94) +(defconstant $SQL_SUBQUERIES 95) +(defconstant $SQL_UNION 96) +(defconstant $SQL_MAX_COLUMNS_IN_GROUP_BY 97) +(defconstant $SQL_MAX_COLUMNS_IN_INDEX 98) +(defconstant $SQL_MAX_COLUMNS_IN_ORDER_BY 99) +(defconstant $SQL_MAX_COLUMNS_IN_SELECT 100) +(defconstant $SQL_MAX_COLUMNS_IN_TABLE 101) +(defconstant $SQL_MAX_INDEX_SIZE 102) +(defconstant $SQL_MAX_ROW_SIZE_INCLUDES_LONG 103) +(defconstant $SQL_MAX_ROW_SIZE 104) +(defconstant $SQL_MAX_STATEMENT_LEN 105) (defconstant $SQL_MAX_TABLES_IN_SELECT 106) (defconstant $SQL_MAX_USER_NAME_LEN 107) (defconstant $SQL_MAX_CHAR_LITERAL_LEN 108) (defconstant $SQL_TIMEDATE_ADD_INTERVALS 109) -(defconstant $SQL_TIMEDATE_DIFF_INTERVALS 110) +(defconstant $SQL_TIMEDATE_DIFF_INTERVALS 110) (defconstant $SQL_NEED_LONG_DATA_LEN 111) -(defconstant $SQL_MAX_BINARY_LITERAL_LEN 112) -(defconstant $SQL_LIKE_ESCAPE_CLAUSE 113) -(defconstant $SQL_QUALIFIER_LOCATION 114) +(defconstant $SQL_MAX_BINARY_LITERAL_LEN 112) +(defconstant $SQL_LIKE_ESCAPE_CLAUSE 113) +(defconstant $SQL_QUALIFIER_LOCATION 114) (defconstant $SQL_ACTIVE_ENVIRONMENTS 116) #| /*** ODBC SDK 2.01 Additions ***/) -(defconstant $SQL_OJ_CAPABILITIES 65003 ;; Temp value until ODBC 3.0 +(defconstant $SQL_OJ_CAPABILITIES 65003 ;; Temp value until ODBC 3.0 -(defconstant $SQL_INFO_LAST SQL_QUALIFIER_LOCATION +(defconstant $SQL_INFO_LAST SQL_QUALIFIER_LOCATION ) (defconstant $SQL_INFO_DRIVER_START 1000 ;; SQL_CONVERT_* return value bitmasks ) -(defconstant $SQL_CVT_CHAR #x00000001L) -(defconstant $SQL_CVT_NUMERIC #x00000002L) -(defconstant $SQL_CVT_DECIMAL #x00000004L) -(defconstant $SQL_CVT_INTEGER #x00000008L) -(defconstant $SQL_CVT_SMALLINT #x00000010L) -(defconstant $SQL_CVT_FLOAT #x00000020L) -(defconstant $SQL_CVT_REAL #x00000040L) -(defconstant $SQL_CVT_DOUBLE #x00000080L) -(defconstant $SQL_CVT_VARCHAR #x00000100L) -(defconstant $SQL_CVT_LONGVARCHAR #x00000200L) -(defconstant $SQL_CVT_BINARY #x00000400L) -(defconstant $SQL_CVT_VARBINARY #x00000800L) -(defconstant $SQL_CVT_BIT #x00001000L) -(defconstant $SQL_CVT_TINYINT #x00002000L) -(defconstant $SQL_CVT_BIGINT #x00004000L) -(defconstant $SQL_CVT_DATE #x00008000L) -(defconstant $SQL_CVT_TIME #x00010000L) -(defconstant $SQL_CVT_TIMESTAMP #x00020000L) -(defconstant $SQL_CVT_LONGVARBINARY #x00040000L) +(defconstant $SQL_CVT_CHAR #x00000001L) +(defconstant $SQL_CVT_NUMERIC #x00000002L) +(defconstant $SQL_CVT_DECIMAL #x00000004L) +(defconstant $SQL_CVT_INTEGER #x00000008L) +(defconstant $SQL_CVT_SMALLINT #x00000010L) +(defconstant $SQL_CVT_FLOAT #x00000020L) +(defconstant $SQL_CVT_REAL #x00000040L) +(defconstant $SQL_CVT_DOUBLE #x00000080L) +(defconstant $SQL_CVT_VARCHAR #x00000100L) +(defconstant $SQL_CVT_LONGVARCHAR #x00000200L) +(defconstant $SQL_CVT_BINARY #x00000400L) +(defconstant $SQL_CVT_VARBINARY #x00000800L) +(defconstant $SQL_CVT_BIT #x00001000L) +(defconstant $SQL_CVT_TINYINT #x00002000L) +(defconstant $SQL_CVT_BIGINT #x00004000L) +(defconstant $SQL_CVT_DATE #x00008000L) +(defconstant $SQL_CVT_TIME #x00010000L) +(defconstant $SQL_CVT_TIMESTAMP #x00020000L) +(defconstant $SQL_CVT_LONGVARBINARY #x00040000L) ;; SQL_CONVERT_FUNCTIONS functions) -(defconstant $SQL_FN_CVT_CONVERT #x00000001L) +(defconstant $SQL_FN_CVT_CONVERT #x00000001L) ;; SQL_STRING_FUNCTIONS functions -(defconstant $SQL_FN_STR_CONCAT #x00000001L) -(defconstant $SQL_FN_STR_INSERT #x00000002L) -(defconstant $SQL_FN_STR_LEFT #x00000004L) -(defconstant $SQL_FN_STR_LTRIM #x00000008L) -(defconstant $SQL_FN_STR_LENGTH #x00000010L) -(defconstant $SQL_FN_STR_LOCATE #x00000020L) -(defconstant $SQL_FN_STR_LCASE #x00000040L) -(defconstant $SQL_FN_STR_REPEAT #x00000080L) -(defconstant $SQL_FN_STR_REPLACE #x00000100L) -(defconstant $SQL_FN_STR_RIGHT #x00000200L) -(defconstant $SQL_FN_STR_RTRIM #x00000400L) -(defconstant $SQL_FN_STR_SUBSTRING #x00000800L) -(defconstant $SQL_FN_STR_UCASE #x00001000L) -(defconstant $SQL_FN_STR_ASCII #x00002000L) -(defconstant $SQL_FN_STR_CHAR #x00004000L -(defconstant $SQL_FN_STR_DIFFERENCE #x00008000L) -(defconstant $SQL_FN_STR_LOCATE_2 #x00010000L) -(defconstant $SQL_FN_STR_SOUNDEX #x00020000L) -(defconstant $SQL_FN_STR_SPACE #x00040000L +(defconstant $SQL_FN_STR_CONCAT #x00000001L) +(defconstant $SQL_FN_STR_INSERT #x00000002L) +(defconstant $SQL_FN_STR_LEFT #x00000004L) +(defconstant $SQL_FN_STR_LTRIM #x00000008L) +(defconstant $SQL_FN_STR_LENGTH #x00000010L) +(defconstant $SQL_FN_STR_LOCATE #x00000020L) +(defconstant $SQL_FN_STR_LCASE #x00000040L) +(defconstant $SQL_FN_STR_REPEAT #x00000080L) +(defconstant $SQL_FN_STR_REPLACE #x00000100L) +(defconstant $SQL_FN_STR_RIGHT #x00000200L) +(defconstant $SQL_FN_STR_RTRIM #x00000400L) +(defconstant $SQL_FN_STR_SUBSTRING #x00000800L) +(defconstant $SQL_FN_STR_UCASE #x00001000L) +(defconstant $SQL_FN_STR_ASCII #x00002000L) +(defconstant $SQL_FN_STR_CHAR #x00004000L +(defconstant $SQL_FN_STR_DIFFERENCE #x00008000L) +(defconstant $SQL_FN_STR_LOCATE_2 #x00010000L) +(defconstant $SQL_FN_STR_SOUNDEX #x00020000L) +(defconstant $SQL_FN_STR_SPACE #x00040000L ;; SQL_NUMERIC_FUNCTIONS functions ) -(defconstant $SQL_FN_NUM_ABS #x00000001L) -(defconstant $SQL_FN_NUM_ACOS #x00000002L) -(defconstant $SQL_FN_NUM_ASIN #x00000004L) -(defconstant $SQL_FN_NUM_ATAN #x00000008L) -(defconstant $SQL_FN_NUM_ATAN2 #x00000010L) -(defconstant $SQL_FN_NUM_CEILING #x00000020L) -(defconstant $SQL_FN_NUM_COS #x00000040L) -(defconstant $SQL_FN_NUM_COT #x00000080L) -(defconstant $SQL_FN_NUM_EXP #x00000100L) -(defconstant $SQL_FN_NUM_FLOOR #x00000200L) -(defconstant $SQL_FN_NUM_LOG #x00000400L) -(defconstant $SQL_FN_NUM_MOD #x00000800L) -(defconstant $SQL_FN_NUM_SIGN #x00001000L) -(defconstant $SQL_FN_NUM_SIN #x00002000L) -(defconstant $SQL_FN_NUM_SQRT #x00004000L) -(defconstant $SQL_FN_NUM_TAN #x00008000L) -(defconstant $SQL_FN_NUM_PI #x00010000L) -(defconstant $SQL_FN_NUM_RAND #x00020000L -(defconstant $SQL_FN_NUM_DEGREES #x00040000L) -(defconstant $SQL_FN_NUM_LOG10 #x00080000L) -(defconstant $SQL_FN_NUM_POWER #x00100000L) -(defconstant $SQL_FN_NUM_RADIANS #x00200000L) -(defconstant $SQL_FN_NUM_ROUND #x00400000L) -(defconstant $SQL_FN_NUM_TRUNCATE #x00800000L +(defconstant $SQL_FN_NUM_ABS #x00000001L) +(defconstant $SQL_FN_NUM_ACOS #x00000002L) +(defconstant $SQL_FN_NUM_ASIN #x00000004L) +(defconstant $SQL_FN_NUM_ATAN #x00000008L) +(defconstant $SQL_FN_NUM_ATAN2 #x00000010L) +(defconstant $SQL_FN_NUM_CEILING #x00000020L) +(defconstant $SQL_FN_NUM_COS #x00000040L) +(defconstant $SQL_FN_NUM_COT #x00000080L) +(defconstant $SQL_FN_NUM_EXP #x00000100L) +(defconstant $SQL_FN_NUM_FLOOR #x00000200L) +(defconstant $SQL_FN_NUM_LOG #x00000400L) +(defconstant $SQL_FN_NUM_MOD #x00000800L) +(defconstant $SQL_FN_NUM_SIGN #x00001000L) +(defconstant $SQL_FN_NUM_SIN #x00002000L) +(defconstant $SQL_FN_NUM_SQRT #x00004000L) +(defconstant $SQL_FN_NUM_TAN #x00008000L) +(defconstant $SQL_FN_NUM_PI #x00010000L) +(defconstant $SQL_FN_NUM_RAND #x00020000L +(defconstant $SQL_FN_NUM_DEGREES #x00040000L) +(defconstant $SQL_FN_NUM_LOG10 #x00080000L) +(defconstant $SQL_FN_NUM_POWER #x00100000L) +(defconstant $SQL_FN_NUM_RADIANS #x00200000L) +(defconstant $SQL_FN_NUM_ROUND #x00400000L) +(defconstant $SQL_FN_NUM_TRUNCATE #x00800000L ;; SQL_TIMEDATE_FUNCTIONS functions ) -(defconstant $SQL_FN_TD_NOW #x00000001L) -(defconstant $SQL_FN_TD_CURDATE #x00000002L) -(defconstant $SQL_FN_TD_DAYOFMONTH #x00000004L) -(defconstant $SQL_FN_TD_DAYOFWEEK #x00000008L) -(defconstant $SQL_FN_TD_DAYOFYEAR #x00000010L) -(defconstant $SQL_FN_TD_MONTH #x00000020L) -(defconstant $SQL_FN_TD_QUARTER #x00000040L) -(defconstant $SQL_FN_TD_WEEK #x00000080L) -(defconstant $SQL_FN_TD_YEAR #x00000100L) -(defconstant $SQL_FN_TD_CURTIME #x00000200L) -(defconstant $SQL_FN_TD_HOUR #x00000400L) -(defconstant $SQL_FN_TD_MINUTE #x00000800L) -(defconstant $SQL_FN_TD_SECOND #x00001000L -(defconstant $SQL_FN_TD_TIMESTAMPADD #x00002000L) -(defconstant $SQL_FN_TD_TIMESTAMPDIFF #x00004000L) -(defconstant $SQL_FN_TD_DAYNAME #x00008000L) -(defconstant $SQL_FN_TD_MONTHNAME #x00010000L +(defconstant $SQL_FN_TD_NOW #x00000001L) +(defconstant $SQL_FN_TD_CURDATE #x00000002L) +(defconstant $SQL_FN_TD_DAYOFMONTH #x00000004L) +(defconstant $SQL_FN_TD_DAYOFWEEK #x00000008L) +(defconstant $SQL_FN_TD_DAYOFYEAR #x00000010L) +(defconstant $SQL_FN_TD_MONTH #x00000020L) +(defconstant $SQL_FN_TD_QUARTER #x00000040L) +(defconstant $SQL_FN_TD_WEEK #x00000080L) +(defconstant $SQL_FN_TD_YEAR #x00000100L) +(defconstant $SQL_FN_TD_CURTIME #x00000200L) +(defconstant $SQL_FN_TD_HOUR #x00000400L) +(defconstant $SQL_FN_TD_MINUTE #x00000800L) +(defconstant $SQL_FN_TD_SECOND #x00001000L +(defconstant $SQL_FN_TD_TIMESTAMPADD #x00002000L) +(defconstant $SQL_FN_TD_TIMESTAMPDIFF #x00004000L) +(defconstant $SQL_FN_TD_DAYNAME #x00008000L) +(defconstant $SQL_FN_TD_MONTHNAME #x00010000L ;; SQL_SYSTEM_FUNCTIONS functions ) -(defconstant $SQL_FN_SYS_USERNAME #x00000001L) -(defconstant $SQL_FN_SYS_DBNAME #x00000002L) -(defconstant $SQL_FN_SYS_IFNULL #x00000004L +(defconstant $SQL_FN_SYS_USERNAME #x00000001L) +(defconstant $SQL_FN_SYS_DBNAME #x00000002L) +(defconstant $SQL_FN_SYS_IFNULL #x00000004L ;; SQL_TIMEDATE_ADD_INTERVALS and SQL_TIMEDATE_DIFF_INTERVALS functions -(defconstant $SQL_FN_TSI_FRAC_SECOND #x00000001L) -(defconstant $SQL_FN_TSI_SECOND #x00000002L) -(defconstant $SQL_FN_TSI_MINUTE #x00000004L) -(defconstant $SQL_FN_TSI_HOUR #x00000008L) -(defconstant $SQL_FN_TSI_DAY #x00000010L) -(defconstant $SQL_FN_TSI_WEEK #x00000020L) -(defconstant $SQL_FN_TSI_MONTH #x00000040L) -(defconstant $SQL_FN_TSI_QUARTER #x00000080L) -(defconstant $SQL_FN_TSI_YEAR #x00000100L +(defconstant $SQL_FN_TSI_FRAC_SECOND #x00000001L) +(defconstant $SQL_FN_TSI_SECOND #x00000002L) +(defconstant $SQL_FN_TSI_MINUTE #x00000004L) +(defconstant $SQL_FN_TSI_HOUR #x00000008L) +(defconstant $SQL_FN_TSI_DAY #x00000010L) +(defconstant $SQL_FN_TSI_WEEK #x00000020L) +(defconstant $SQL_FN_TSI_MONTH #x00000040L) +(defconstant $SQL_FN_TSI_QUARTER #x00000080L) +(defconstant $SQL_FN_TSI_YEAR #x00000100L ;; SQL_ODBC_API_CONFORMANCE values ) -(defconstant $SQL_OAC_NONE #x0000) -(defconstant $SQL_OAC_LEVEL1 #x0001) -(defconstant $SQL_OAC_LEVEL2 #x0002 +(defconstant $SQL_OAC_NONE #x0000) +(defconstant $SQL_OAC_LEVEL1 #x0001) +(defconstant $SQL_OAC_LEVEL2 #x0002 ;; SQL_ODBC_SAG_CLI_CONFORMANCE values ) -(defconstant $SQL_OSCC_NOT_COMPLIANT #x0000) -(defconstant $SQL_OSCC_COMPLIANT #x0001 +(defconstant $SQL_OSCC_NOT_COMPLIANT #x0000) +(defconstant $SQL_OSCC_COMPLIANT #x0001 ;; SQL_ODBC_SQL_CONFORMANCE values ) -(defconstant $SQL_OSC_MINIMUM #x0000) -(defconstant $SQL_OSC_CORE #x0001) -(defconstant $SQL_OSC_EXTENDED #x0002 +(defconstant $SQL_OSC_MINIMUM #x0000) +(defconstant $SQL_OSC_CORE #x0001) +(defconstant $SQL_OSC_EXTENDED #x0002 ;; SQL_CONCAT_NULL_BEHAVIOR values ) -(defconstant $SQL_CB_NULL #x0000) -(defconstant $SQL_CB_NON_NULL #x0001 +(defconstant $SQL_CB_NULL #x0000) +(defconstant $SQL_CB_NON_NULL #x0001 ;; SQL_CURSOR_COMMIT_BEHAVIOR and SQL_CURSOR_ROLLBACK_BEHAVIOR values ) -(defconstant $SQL_CB_DELETE #x0000) -(defconstant $SQL_CB_CLOSE #x0001) -(defconstant $SQL_CB_PRESERVE #x0002 +(defconstant $SQL_CB_DELETE #x0000) +(defconstant $SQL_CB_CLOSE #x0001) +(defconstant $SQL_CB_PRESERVE #x0002 ;; SQL_IDENTIFIER_CASE values ) -(defconstant $SQL_IC_UPPER #x0001) -(defconstant $SQL_IC_LOWER #x0002) -(defconstant $SQL_IC_SENSITIVE #x0003) -(defconstant $SQL_IC_MIXED #x0004 +(defconstant $SQL_IC_UPPER #x0001) +(defconstant $SQL_IC_LOWER #x0002) +(defconstant $SQL_IC_SENSITIVE #x0003) +(defconstant $SQL_IC_MIXED #x0004 ;; SQL_TXN_CAPABLE values |# @@ -535,111 +535,111 @@ #| ;; SQL_TXN_ISOLATION_OPTION masks ) -(defconstant $SQL_TXN_READ_UNCOMMITTED #x00000001L) -(defconstant $SQL_TXN_READ_COMMITTED #x00000002L) -(defconstant $SQL_TXN_REPEATABLE_READ #x00000004L) -(defconstant $SQL_TXN_SERIALIZABLE #x00000008L) -(defconstant $SQL_TXN_VERSIONING #x00000010L +(defconstant $SQL_TXN_READ_UNCOMMITTED #x00000001L) +(defconstant $SQL_TXN_READ_COMMITTED #x00000002L) +(defconstant $SQL_TXN_REPEATABLE_READ #x00000004L) +(defconstant $SQL_TXN_SERIALIZABLE #x00000008L) +(defconstant $SQL_TXN_VERSIONING #x00000010L ;; SQL_CORRELATION_NAME values ) -(defconstant $SQL_CN_NONE #x0000) -(defconstant $SQL_CN_DIFFERENT #x0001) -(defconstant $SQL_CN_ANY #x0002 +(defconstant $SQL_CN_NONE #x0000) +(defconstant $SQL_CN_DIFFERENT #x0001) +(defconstant $SQL_CN_ANY #x0002 ;; SQL_NON_NULLABLE_COLUMNS values ) -(defconstant $SQL_NNC_NULL #x0000) -(defconstant $SQL_NNC_NON_NULL #x0001 +(defconstant $SQL_NNC_NULL #x0000) +(defconstant $SQL_NNC_NON_NULL #x0001 ;; SQL_NULL_COLLATION values - ) -(defconstant $SQL_NC_HIGH #x0000) -(defconstant $SQL_NC_LOW #x0001) -(defconstant $SQL_NC_START #x0002) -(defconstant $SQL_NC_END #x0004 + ) +(defconstant $SQL_NC_HIGH #x0000) +(defconstant $SQL_NC_LOW #x0001) +(defconstant $SQL_NC_START #x0002) +(defconstant $SQL_NC_END #x0004 ;; SQL_FILE_USAGE values ) -(defconstant $SQL_FILE_NOT_SUPPORTED #x0000) -(defconstant $SQL_FILE_TABLE #x0001) -(defconstant $SQL_FILE_QUALIFIER #x0002 +(defconstant $SQL_FILE_NOT_SUPPORTED #x0000) +(defconstant $SQL_FILE_TABLE #x0001) +(defconstant $SQL_FILE_QUALIFIER #x0002 ;; SQL_GETDATA_EXTENSIONS values ) -(defconstant $SQL_GD_ANY_COLUMN #x00000001L) -(defconstant $SQL_GD_ANY_ORDER #x00000002L) -(defconstant $SQL_GD_BLOCK #x00000004L) -(defconstant $SQL_GD_BOUND #x00000008L +(defconstant $SQL_GD_ANY_COLUMN #x00000001L) +(defconstant $SQL_GD_ANY_ORDER #x00000002L) +(defconstant $SQL_GD_BLOCK #x00000004L) +(defconstant $SQL_GD_BOUND #x00000008L ;; SQL_ALTER_TABLE values ) -(defconstant $SQL_AT_ADD_COLUMN #x00000001L) -(defconstant $SQL_AT_DROP_COLUMN #x00000002L +(defconstant $SQL_AT_ADD_COLUMN #x00000001L) +(defconstant $SQL_AT_DROP_COLUMN #x00000002L ;; SQL_POSITIONED_STATEMENTS masks ) -(defconstant $SQL_PS_POSITIONED_DELETE #x00000001L) -(defconstant $SQL_PS_POSITIONED_UPDATE #x00000002L) -(defconstant $SQL_PS_SELECT_FOR_UPDATE #x00000004L +(defconstant $SQL_PS_POSITIONED_DELETE #x00000001L) +(defconstant $SQL_PS_POSITIONED_UPDATE #x00000002L) +(defconstant $SQL_PS_SELECT_FOR_UPDATE #x00000004L ;; SQL_GROUP_BY values ) -(defconstant $SQL_GB_NOT_SUPPORTED #x0000) -(defconstant $SQL_GB_GROUP_BY_EQUALS_SELECT #x0001) -(defconstant $SQL_GB_GROUP_BY_CONTAINS_SELECT #x0002) -(defconstant $SQL_GB_NO_RELATION #x0003 - +(defconstant $SQL_GB_NOT_SUPPORTED #x0000) +(defconstant $SQL_GB_GROUP_BY_EQUALS_SELECT #x0001) +(defconstant $SQL_GB_GROUP_BY_CONTAINS_SELECT #x0002) +(defconstant $SQL_GB_NO_RELATION #x0003 + ;; SQL_OWNER_USAGE masks ) -(defconstant $SQL_OU_DML_STATEMENTS #x00000001L) +(defconstant $SQL_OU_DML_STATEMENTS #x00000001L) (defconstant $SQL_OU_PROCEDURE_INVOCATION #x00000002L) -(defconstant $SQL_OU_TABLE_DEFINITION #x00000004L) -(defconstant $SQL_OU_INDEX_DEFINITION #x00000008L) +(defconstant $SQL_OU_TABLE_DEFINITION #x00000004L) +(defconstant $SQL_OU_INDEX_DEFINITION #x00000008L) (defconstant $SQL_OU_PRIVILEGE_DEFINITION #x00000010L ;; SQL_QUALIFIER_USAGE masks ) -(defconstant $SQL_QU_DML_STATEMENTS #x00000001L) +(defconstant $SQL_QU_DML_STATEMENTS #x00000001L) (defconstant $SQL_QU_PROCEDURE_INVOCATION #x00000002L) -(defconstant $SQL_QU_TABLE_DEFINITION #x00000004L) -(defconstant $SQL_QU_INDEX_DEFINITION #x00000008L) +(defconstant $SQL_QU_TABLE_DEFINITION #x00000004L) +(defconstant $SQL_QU_INDEX_DEFINITION #x00000008L) (defconstant $SQL_QU_PRIVILEGE_DEFINITION #x00000010L ;; SQL_SUBQUERIES masks ) -(defconstant $SQL_SQ_COMPARISON #x00000001L) -(defconstant $SQL_SQ_EXISTS #x00000002L) -(defconstant $SQL_SQ_IN #x00000004L) -(defconstant $SQL_SQ_QUANTIFIED #x00000008L) -(defconstant $SQL_SQ_CORRELATED_SUBQUERIES #x00000010L +(defconstant $SQL_SQ_COMPARISON #x00000001L) +(defconstant $SQL_SQ_EXISTS #x00000002L) +(defconstant $SQL_SQ_IN #x00000004L) +(defconstant $SQL_SQ_QUANTIFIED #x00000008L) +(defconstant $SQL_SQ_CORRELATED_SUBQUERIES #x00000010L ;; SQL_UNION masks ) -(defconstant $SQL_U_UNION #x00000001L) -(defconstant $SQL_U_UNION_ALL #x00000002L +(defconstant $SQL_U_UNION #x00000001L) +(defconstant $SQL_U_UNION_ALL #x00000002L ;; SQL_BOOKMARK_PERSISTENCE values ) -(defconstant $SQL_BP_CLOSE #x00000001L) -(defconstant $SQL_BP_DELETE #x00000002L) -(defconstant $SQL_BP_DROP #x00000004L) -(defconstant $SQL_BP_TRANSACTION #x00000008L) -(defconstant $SQL_BP_UPDATE #x00000010L) -(defconstant $SQL_BP_OTHER_HSTMT #x00000020L) -(defconstant $SQL_BP_SCROLL #x00000040L +(defconstant $SQL_BP_CLOSE #x00000001L) +(defconstant $SQL_BP_DELETE #x00000002L) +(defconstant $SQL_BP_DROP #x00000004L) +(defconstant $SQL_BP_TRANSACTION #x00000008L) +(defconstant $SQL_BP_UPDATE #x00000010L) +(defconstant $SQL_BP_OTHER_HSTMT #x00000020L) +(defconstant $SQL_BP_SCROLL #x00000040L ;; SQL_STATIC_SENSITIVITY values ) -(defconstant $SQL_SS_ADDITIONS #x00000001L) -(defconstant $SQL_SS_DELETIONS #x00000002L) -(defconstant $SQL_SS_UPDATES #x00000004L +(defconstant $SQL_SS_ADDITIONS #x00000001L) +(defconstant $SQL_SS_DELETIONS #x00000002L) +(defconstant $SQL_SS_UPDATES #x00000004L ;; SQL_LOCK_TYPESL masks ) -(defconstant $SQL_LCK_NO_CHANGE #x00000001L) -(defconstant $SQL_LCK_EXCLUSIVE #x00000002L) -(defconstant $SQL_LCK_UNLOCK #x00000004L +(defconstant $SQL_LCK_NO_CHANGE #x00000001L) +(defconstant $SQL_LCK_EXCLUSIVE #x00000002L) +(defconstant $SQL_LCK_UNLOCK #x00000004L ;; SQL_POS_OPERATIONS masks |# @@ -653,97 +653,97 @@ #| ;; SQL_QUALIFIER_LOCATION values ) -(defconstant $SQL_QL_START #x0001L) -(defconstant $SQL_QL_END #x0002L +(defconstant $SQL_QL_START #x0001L) +(defconstant $SQL_QL_END #x0002L ;; SQL_OJ_CAPABILITIES values -(defconstant $SQL_OJ_LEFT #x00000001L) -(defconstant $SQL_OJ_RIGHT #x00000002L) -(defconstant $SQL_OJ_FULL #x00000004L) -(defconstant $SQL_OJ_NESTED #x00000008L) -(defconstant $SQL_OJ_NOT_ORDERED #x00000010L) -(defconstant $SQL_OJ_INNER #x00000020L) -(defconstant $SQL_OJ_ALL_COMPARISON_OPS #x00000040L +(defconstant $SQL_OJ_LEFT #x00000001L) +(defconstant $SQL_OJ_RIGHT #x00000002L) +(defconstant $SQL_OJ_FULL #x00000004L) +(defconstant $SQL_OJ_NESTED #x00000008L) +(defconstant $SQL_OJ_NOT_ORDERED #x00000010L) +(defconstant $SQL_OJ_INNER #x00000020L) +(defconstant $SQL_OJ_ALL_COMPARISON_OPS #x00000040L ;; options for SQLGetStmtOption/SQLSetStmtOption) -(defconstant $SQL_QUERY_TIMEOUT 0) -(defconstant $SQL_MAX_ROWS 1) -(defconstant $SQL_NOSCAN 2) -(defconstant $SQL_MAX_LENGTH 3) -(defconstant $SQL_ASYNC_ENABLE 4) -(defconstant $SQL_BIND_TYPE 5 -(defconstant $SQL_CURSOR_TYPE 6) -(defconstant $SQL_CONCURRENCY 7) -(defconstant $SQL_KEYSET_SIZE 8) -(defconstant $SQL_ROWSET_SIZE 9) -(defconstant $SQL_SIMULATE_CURSOR 10) -(defconstant $SQL_RETRIEVE_DATA 11) -(defconstant $SQL_USE_BOOKMARKS 12) -(defconstant $SQL_GET_BOOKMARK 13 /* GetStmtOption Only) -(defconstant $SQL_ROW_NUMBER 14 /* GetStmtOption Only) -(defconstant $SQL_STMT_OPT_MAX SQL_ROW_NUMBER +(defconstant $SQL_QUERY_TIMEOUT 0) +(defconstant $SQL_MAX_ROWS 1) +(defconstant $SQL_NOSCAN 2) +(defconstant $SQL_MAX_LENGTH 3) +(defconstant $SQL_ASYNC_ENABLE 4) +(defconstant $SQL_BIND_TYPE 5 +(defconstant $SQL_CURSOR_TYPE 6) +(defconstant $SQL_CONCURRENCY 7) +(defconstant $SQL_KEYSET_SIZE 8) +(defconstant $SQL_ROWSET_SIZE 9) +(defconstant $SQL_SIMULATE_CURSOR 10) +(defconstant $SQL_RETRIEVE_DATA 11) +(defconstant $SQL_USE_BOOKMARKS 12) +(defconstant $SQL_GET_BOOKMARK 13 /* GetStmtOption Only) +(defconstant $SQL_ROW_NUMBER 14 /* GetStmtOption Only) +(defconstant $SQL_STMT_OPT_MAX SQL_ROW_NUMBER ) -(defconstant $SQL_STMT_OPT_MIN SQL_QUERY_TIMEOUT +(defconstant $SQL_STMT_OPT_MIN SQL_QUERY_TIMEOUT ;; SQL_QUERY_TIMEOUT options) -(defconstant $SQL_QUERY_TIMEOUT_DEFAULT 0UL +(defconstant $SQL_QUERY_TIMEOUT_DEFAULT 0UL ;; SQL_MAX_ROWS options) -(defconstant $SQL_MAX_ROWS_DEFAULT 0UL +(defconstant $SQL_MAX_ROWS_DEFAULT 0UL ;; SQL_NOSCAN options) -(defconstant $SQL_NOSCAN_OFF 0UL /* 1.0 FALSE) -(defconstant $SQL_NOSCAN_ON 1UL /* 1.0 TRUE) -(defconstant $SQL_NOSCAN_DEFAULT SQL_NOSCAN_OFF +(defconstant $SQL_NOSCAN_OFF 0UL /* 1.0 FALSE) +(defconstant $SQL_NOSCAN_ON 1UL /* 1.0 TRUE) +(defconstant $SQL_NOSCAN_DEFAULT SQL_NOSCAN_OFF ;; SQL_MAX_LENGTH options) -(defconstant $SQL_MAX_LENGTH_DEFAULT 0UL +(defconstant $SQL_MAX_LENGTH_DEFAULT 0UL ;; SQL_ASYNC_ENABLE options) -(defconstant $SQL_ASYNC_ENABLE_OFF 0UL) -(defconstant $SQL_ASYNC_ENABLE_ON 1UL) -(defconstant $SQL_ASYNC_ENABLE_DEFAULT SQL_ASYNC_ENABLE_OFF +(defconstant $SQL_ASYNC_ENABLE_OFF 0UL) +(defconstant $SQL_ASYNC_ENABLE_ON 1UL) +(defconstant $SQL_ASYNC_ENABLE_DEFAULT SQL_ASYNC_ENABLE_OFF ;; SQL_BIND_TYPE options) -(defconstant $SQL_BIND_BY_COLUMN 0UL) -(defconstant $SQL_BIND_TYPE_DEFAULT SQL_BIND_BY_COLUMN ;; Default value +(defconstant $SQL_BIND_BY_COLUMN 0UL) +(defconstant $SQL_BIND_TYPE_DEFAULT SQL_BIND_BY_COLUMN ;; Default value ;; SQL_CONCURRENCY options) -(defconstant $SQL_CONCUR_READ_ONLY 1) -(defconstant $SQL_CONCUR_LOCK 2) -(defconstant $SQL_CONCUR_ROWVER 3) -(defconstant $SQL_CONCUR_VALUES 4) -(defconstant $SQL_CONCUR_DEFAULT SQL_CONCUR_READ_ONLY ;; Default value +(defconstant $SQL_CONCUR_READ_ONLY 1) +(defconstant $SQL_CONCUR_LOCK 2) +(defconstant $SQL_CONCUR_ROWVER 3) +(defconstant $SQL_CONCUR_VALUES 4) +(defconstant $SQL_CONCUR_DEFAULT SQL_CONCUR_READ_ONLY ;; Default value ;; SQL_CURSOR_TYPE options) -(defconstant $SQL_CURSOR_FORWARD_ONLY 0UL) -(defconstant $SQL_CURSOR_KEYSET_DRIVEN 1UL) -(defconstant $SQL_CURSOR_DYNAMIC 2UL) -(defconstant $SQL_CURSOR_STATIC 3UL) -(defconstant $SQL_CURSOR_TYPE_DEFAULT SQL_CURSOR_FORWARD_ONLY ;; Default value +(defconstant $SQL_CURSOR_FORWARD_ONLY 0UL) +(defconstant $SQL_CURSOR_KEYSET_DRIVEN 1UL) +(defconstant $SQL_CURSOR_DYNAMIC 2UL) +(defconstant $SQL_CURSOR_STATIC 3UL) +(defconstant $SQL_CURSOR_TYPE_DEFAULT SQL_CURSOR_FORWARD_ONLY ;; Default value ;; SQL_ROWSET_SIZE options) -(defconstant $SQL_ROWSET_SIZE_DEFAULT 1UL +(defconstant $SQL_ROWSET_SIZE_DEFAULT 1UL ;; SQL_KEYSET_SIZE options) -(defconstant $SQL_KEYSET_SIZE_DEFAULT 0UL +(defconstant $SQL_KEYSET_SIZE_DEFAULT 0UL ;; SQL_SIMULATE_CURSOR options) -(defconstant $SQL_SC_NON_UNIQUE 0UL) -(defconstant $SQL_SC_TRY_UNIQUE 1UL) -(defconstant $SQL_SC_UNIQUE 2UL +(defconstant $SQL_SC_NON_UNIQUE 0UL) +(defconstant $SQL_SC_TRY_UNIQUE 1UL) +(defconstant $SQL_SC_UNIQUE 2UL ;; SQL_RETRIEVE_DATA options) -(defconstant $SQL_RD_OFF 0UL) -(defconstant $SQL_RD_ON 1UL) -(defconstant $SQL_RD_DEFAULT SQL_RD_ON +(defconstant $SQL_RD_OFF 0UL) +(defconstant $SQL_RD_ON 1UL) +(defconstant $SQL_RD_DEFAULT SQL_RD_ON ;; SQL_USE_BOOKMARKS options) -(defconstant $SQL_UB_OFF 0UL) -(defconstant $SQL_UB_ON 1UL) -(defconstant $SQL_UB_DEFAULT SQL_UB_OFF +(defconstant $SQL_UB_OFF 0UL) +(defconstant $SQL_UB_ON 1UL) +(defconstant $SQL_UB_DEFAULT SQL_UB_OFF |# @@ -756,7 +756,7 @@ (defconstant $SQL_OPT_TRACEFILE 105) (defconstant $SQL_TRANSLATE_DLL 106) (defconstant $SQL_TRANSLATE_OPTION 107) -(defconstant $SQL_TXN_ISOLATION 108) +(defconstant $SQL_TXN_ISOLATION 108) (defconstant $SQL_CURRENT_QUALIFIER 109) (defconstant $SQL_ODBC_CURSORS 110) (defconstant $SQL_QUIET_MODE 111) @@ -764,7 +764,7 @@ (defconstant $SQL_CONN_OPT_MAX $SQL_PACKET_SIZE) (defconstant $SQL_CONNECT_OPT_DRVR_START 1000) -;;#define SQL_CONN_OPT_MIN SQL_ACCESS_MODE +;;#define SQL_CONN_OPT_MIN SQL_ACCESS_MODE ;; SQL_ACCESS_MODE options (defconstant $SQL_MODE_READ_WRITE 0) ; 0UL @@ -777,14 +777,14 @@ (defconstant $SQL_AUTOCOMMIT_DEFAULT $SQL_AUTOCOMMIT_ON) ;; SQL_LOGIN_TIMEOUT options) -(defconstant $SQL_LOGIN_TIMEOUT_DEFAULT 15) ; 15UL +(defconstant $SQL_LOGIN_TIMEOUT_DEFAULT 15) ; 15UL ;; SQL_OPT_TRACE options) (defconstant $SQL_OPT_TRACE_OFF 0) ; 0UL (defconstant $SQL_OPT_TRACE_ON 1) ; 1UL (defconstant $SQL_OPT_TRACE_DEFAULT $SQL_OPT_TRACE_OFF) ; #ifndef SQL_OPT_TRACE_FILE_DEFAULT -; (defconstant $SQL_OPT_TRACE_FILE_DEFAULT "\\SQL.LOG" +; (defconstant $SQL_OPT_TRACE_FILE_DEFAULT "\\SQL.LOG" ;; #endif (defconstant $SQL_CUR_USE_IF_NEEDED 0) ; 0UL @@ -797,12 +797,12 @@ (defconstant $SQL_BEST_ROWID 1) (defconstant $SQL_ROWVER 2) ) -(defconstant $SQL_SCOPE_CURROW 0) -(defconstant $SQL_SCOPE_TRANSACTION 1) -(defconstant $SQL_SCOPE_SESSION 2 +(defconstant $SQL_SCOPE_CURROW 0) +(defconstant $SQL_SCOPE_TRANSACTION 1) +(defconstant $SQL_SCOPE_SESSION 2 ;; Defines for SQLSetPos) -(defconstant $SQL_ENTIRE_ROWSET 0 +(defconstant $SQL_ENTIRE_ROWSET 0 |# ;; Operations in SQLSetPos @@ -819,7 +819,7 @@ (defconstant $SQL_LOCK_UNLOCK 2) ;; SQLBindParameter extensions -(defconstant $SQL_DEFAULT_PARAM -5) +(defconstant $SQL_DEFAULT_PARAM -5) (defconstant $SQL_IGNORE -6) (defconstant $SQL_LEN_DATA_AT_EXEC_OFFSET -100) ;(defconstant $SQL_LEN_DATA_AT_EXEC(length) (-length+SQL_LEN_DATA_AT_EXEC_OFFSET) @@ -838,7 +838,7 @@ ; #ifndef RC_INVOKED -/* This define is too large for RC) +/* This define is too large for RC) (defconstant $SQL_ODBC_KEYWORDS \ "ABSOLUTE,ACTION,ADA,ADD,ALL,ALLOCATE,ALTER,AND,ANY,ARE,AS,"\ "ASC,ASSERTION,AT,AUTHORIZATION,AVG,"\ @@ -924,7 +924,7 @@ (defconstant $SQL_TYPE_DRIVER_END $SQL_UNICODE) -(defconstant $SQL_SIGNED_OFFSET -20) +(defconstant $SQL_SIGNED_OFFSET -20) (defconstant $SQL_UNSIGNED_OFFSET -22) ;; C datatype to SQL datatype mapping diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp index 2a60462..6723a1a 100644 --- a/db-odbc/odbc-dbi.lisp +++ b/db-odbc/odbc-dbi.lisp @@ -40,7 +40,7 @@ #:run-prepared-sql #:set-autocommit #:sql - + #:*auto-trim-strings* #:*default-database* #:*default-odbc-external-format* @@ -52,19 +52,19 @@ (defgeneric terminate (src)) (defgeneric db-open-query (src query-expression - &key arglen col-positions result-types width - &allow-other-keys)) + &key arglen col-positions result-types width + &allow-other-keys)) (defgeneric db-fetch-query-results (src &optional count)) (defgeneric %db-execute (src sql-expression &key &allow-other-keys)) (defgeneric db-execute-command (src sql-string)) (defgeneric %initialize-query (src arglen col-positions - &key result-types width)) + &key result-types width)) (defgeneric %read-query-data (src ignore-columns)) (defgeneric db-map-query (src type function query-exp &key result-types)) (defgeneric db-prepare-statement (src sql &key parameter-table - parameter-columns)) + parameter-columns)) (defgeneric get-odbc-info (src info-type)) @@ -95,24 +95,24 @@ (computed-result-types :initform nil :initarg :computed-result-types :accessor computed-result-types) (column-count :initform nil :accessor column-count) (column-names :initform (make-array 0 :element-type 'string :adjustable t :fill-pointer t) - :accessor column-names) + :accessor column-names) (column-c-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) - :accessor column-c-types) + :accessor column-c-types) (column-sql-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) - :accessor column-sql-types) + :accessor column-sql-types) (column-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t) - :accessor data-ptrs) + :accessor data-ptrs) (column-out-len-ptrs :initform (make-array 0 :adjustable t :fill-pointer t) - :accessor column-out-len-ptrs) + :accessor column-out-len-ptrs) (column-precisions :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) - :accessor column-precisions) + :accessor column-precisions) (column-scales :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) - :accessor column-scales) + :accessor column-scales) (column-nullables-p :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) - :accessor column-nullables-p) + :accessor column-nullables-p) ;;(parameter-count :initform 0 :accessor parameter-count) (parameter-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t) - :accessor parameter-ptrs) + :accessor parameter-ptrs) ;; a query string or a query expression object (sql-expression :initform nil :initarg :sql-expression :accessor sql-expression) ;; database object the query is to be run against @@ -130,8 +130,8 @@ the query against." )) (setf (henv db) (%new-environment-handle))) (setf (hdbc db) (%new-db-connection-handle (henv db))) (if connection-string - (%sql-driver-connect (hdbc db) - connection-string + (%sql-driver-connect (hdbc db) + connection-string (ecase completion (:no-prompt odbc::$SQL_DRIVER_NOPROMPT) (:complete odbc::$SQL_DRIVER_COMPLETE) @@ -142,42 +142,42 @@ the query against." )) #+ignore (setf (db-hstmt db) (%new-statement-handle (hdbc db))) (when (/= (get-odbc-info db odbc::$SQL_TXN_CAPABLE) odbc::$SQL_TC_NONE) (if autocommit - (enable-autocommit (hdbc db)) - (disable-autocommit (hdbc db)))) + (enable-autocommit (hdbc db)) + (disable-autocommit (hdbc db)))) db)) (defun disconnect (database) (with-slots (hdbc queries) database (dolist (query queries) (if (query-active-p query) - (with-slots (hstmt) query - (when hstmt - (%free-statement hstmt :drop) - (setf hstmt nil))))) + (with-slots (hstmt) query + (when hstmt + (%free-statement hstmt :drop) + (setf hstmt nil))))) (when (db-hstmt database) (%free-statement (db-hstmt database) :drop)) (%disconnect hdbc))) -(defun sql (expr &key db result-types row-count (column-names t) query - hstmt width) +(defun sql (expr &key db result-types row-count (column-names t) query + hstmt width) (declare (ignore hstmt)) (cond (query (let ((q (db-open-query db expr :result-types result-types :width width))) (if column-names - (values q (column-names q)) - q))) + (values q (column-names q)) + q))) (t (multiple-value-bind (data col-names) - (db-query db expr :result-types result-types :width width) + (db-query db expr :result-types result-types :width width) (cond - (row-count - (if (consp data) (length data) data)) - (column-names - (values data col-names)) - (t - data)))))) + (row-count + (if (consp data) (length data) data)) + (column-names + (values data col-names)) + (t + data)))))) (defun fetch-row (query &optional (eof-errorp t) eof-value) (multiple-value-bind (row query count) (db-fetch-query-results query 1) @@ -185,12 +185,12 @@ the query against." )) ((zerop count) (close-query query) (when eof-errorp - (error 'clsql:sql-database-data-error - :message "ODBC: Ran out of data in fetch-row")) + (error 'clsql:sql-database-data-error + :message "ODBC: Ran out of data in fetch-row")) eof-value) (t (car row))))) - + (defun close-query (query) (db-close-query query)) @@ -199,29 +199,29 @@ the query against." )) (declare (ignore hstmt)) (let ((query (get-free-query db))) (unwind-protect - (progn - (with-slots (hstmt) query - (unless hstmt (setf hstmt (%new-statement-handle (hdbc db)))) - (%list-tables hstmt) - (%initialize-query query nil nil) - (values - (db-fetch-query-results query) - (coerce (column-names query) 'list)))) + (progn + (with-slots (hstmt) query + (unless hstmt (setf hstmt (%new-statement-handle (hdbc db)))) + (%list-tables hstmt) + (%initialize-query query nil nil) + (values + (db-fetch-query-results query) + (coerce (column-names query) 'list)))) (db-close-query query)))) (defun list-table-indexes (table &key db unique hstmt) (declare (ignore hstmt)) (let ((query (get-free-query db))) (unwind-protect - (progn - (with-slots (hstmt) query - (unless hstmt - (setf hstmt (%new-statement-handle (hdbc db)))) - (%table-statistics table hstmt :unique unique) - (%initialize-query query nil nil) - (values - (db-fetch-query-results query) - (coerce (column-names query) 'list)))) + (progn + (with-slots (hstmt) query + (unless hstmt + (setf hstmt (%new-statement-handle (hdbc db)))) + (%table-statistics table hstmt :unique unique) + (%initialize-query query nil nil) + (values + (db-fetch-query-results query) + (coerce (column-names query) 'list)))) (db-close-query query)))) (defun list-all-table-columns (table &key db hstmt) @@ -257,13 +257,13 @@ the query against." )) (:henv (henv ,*default-database*) :hdbc (hdbc ,*default-database*)) ,@body)) -(defmethod initialize-instance :after ((query odbc-query) +(defmethod initialize-instance :after ((query odbc-query) &key sql henv hdbc &allow-other-keys) (when sql (let ((hstmt (%new-statement-handle hdbc))) (%sql-exec-direct sql hstmt henv hdbc) - (with-slots (column-count - column-names column-c-types column-sql-types column-data-ptrs + (with-slots (column-count + column-names column-c-types column-sql-types column-data-ptrs column-out-len-ptrs column-precisions column-scales column-nullables-p active-p) query (setf (hstmt query) hstmt) @@ -287,52 +287,52 @@ the query against." )) when out-len-ptr do (uffi:free-foreign-object out-len-ptr)))) (defmethod db-open-query ((database odbc-db) query-expression - &key arglen col-positions result-types width - &allow-other-keys) + &key arglen col-positions result-types width + &allow-other-keys) (db-open-query (get-free-query database) query-expression :arglen arglen :col-positions col-positions - :result-types result-types - :width (if width width (db-width database)))) + :result-types result-types + :width (if width width (db-width database)))) (defmethod db-open-query ((query odbc-query) query-expression - &key arglen col-positions result-types width - &allow-other-keys) + &key arglen col-positions result-types width + &allow-other-keys) (%db-execute query query-expression) (%initialize-query query arglen col-positions :result-types result-types - :width width)) + :width width)) (defmethod db-fetch-query-results ((database odbc-db) &optional count) (db-fetch-query-results (db-query-object database) count)) (defmethod db-fetch-query-results ((query odbc-query) &optional count) (when (query-active-p query) - (with-slots (column-count column-data-ptrs column-c-types column-sql-types - column-out-len-ptrs column-precisions hstmt computed-result-types) - query + (with-slots (column-count column-data-ptrs column-c-types column-sql-types + column-out-len-ptrs column-precisions hstmt computed-result-types) + query (let* ((rows-fetched 0) - (rows - (loop for i from 0 - until (or (and count (= i count)) - (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND)) - collect - (loop for result-type across computed-result-types - for data-ptr across column-data-ptrs - for c-type across column-c-types - for sql-type across column-sql-types - for out-len-ptr across column-out-len-ptrs - for precision across column-precisions - for j from 0 ; column count is zero based in lisp - collect - (progn - (incf rows-fetched) - (cond ((< 0 precision (query-width query)) - (read-data data-ptr c-type sql-type out-len-ptr result-type)) - ((zerop (get-cast-long out-len-ptr)) - nil) - (t - (read-data-in-chunks hstmt j data-ptr c-type sql-type - out-len-ptr result-type)))))))) - (values rows query rows-fetched))))) + (rows + (loop for i from 0 + until (or (and count (= i count)) + (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND)) + collect + (loop for result-type across computed-result-types + for data-ptr across column-data-ptrs + for c-type across column-c-types + for sql-type across column-sql-types + for out-len-ptr across column-out-len-ptrs + for precision across column-precisions + for j from 0 ; column count is zero based in lisp + collect + (progn + (incf rows-fetched) + (cond ((< 0 precision (query-width query)) + (read-data data-ptr c-type sql-type out-len-ptr result-type)) + ((zerop (get-cast-long out-len-ptr)) + nil) + (t + (read-data-in-chunks hstmt j data-ptr c-type sql-type + out-len-ptr result-type)))))))) + (values rows query rows-fetched))))) (defun db-query (database query-expression &key result-types width) (let ((free-query (get-free-query database))) @@ -341,13 +341,13 @@ the query against." )) (progn (%db-execute free-query query-expression) (%initialize-query free-query nil nil :result-types result-types :width width) - (if (plusp (column-count free-query)) ;; KMR: Added check for commands that don't return columns - (values - (db-fetch-query-results free-query nil) - (map 'list #'identity (column-names free-query))) - (values - (result-rows-count (hstmt free-query)) - nil))) + (if (plusp (column-count free-query)) ;; KMR: Added check for commands that don't return columns + (values + (db-fetch-query-results free-query nil) + (map 'list #'identity (column-names free-query))) + (values + (result-rows-count (hstmt free-query)) + nil))) (db-close-query free-query) ))) @@ -357,7 +357,7 @@ the query against." )) (defmethod %db-execute ((query odbc-query) sql-expression &key &allow-other-keys) (with-slots (henv hdbc) (odbc::query-database query) (with-slots (hstmt) query - (unless hstmt (setf hstmt (%new-statement-handle hdbc))) + (unless hstmt (setf hstmt (%new-statement-handle hdbc))) (setf (sql-expression query) sql-expression) (%sql-exec-direct sql-expression hstmt henv hdbc) query))) @@ -371,18 +371,18 @@ This makes the functions db-execute-command and db-query thread safe." (let ((inactive-query (find-if (lambda (query) (not (query-active-p query))) queries))) - (when inactive-query - (with-slots (column-count column-names column-c-types - width hstmt - column-sql-types column-data-ptrs - column-out-len-ptrs column-precisions - column-scales column-nullables-p) + (when inactive-query + (with-slots (column-count column-names column-c-types + width hstmt + column-sql-types column-data-ptrs + column-out-len-ptrs column-precisions + column-scales column-nullables-p) inactive-query ;;(print column-data-ptrs tb::*local-output*) ;;(%dispose-column-ptrs inactive-query) (setf column-count 0 - width +max-precision+ - ;; KMR hstmt (%new-statement-handle hdbc) + width +max-precision+ + ;; KMR hstmt (%new-statement-handle hdbc) (fill-pointer column-names) 0 (fill-pointer column-c-types) 0 (fill-pointer column-sql-types) 0 @@ -406,22 +406,22 @@ This makes the functions db-execute-command and db-query thread safe." (defmethod db-execute-command ((query odbc-query) sql-string) (with-slots (hstmt database) query (with-slots (henv hdbc) database - (unless hstmt (setf hstmt (%new-statement-handle hdbc))) - (unwind-protect + (unless hstmt (setf hstmt (%new-statement-handle hdbc))) + (unwind-protect (%sql-exec-direct sql-string hstmt henv hdbc) (db-close-query query))))) (defmethod %initialize-query ((database odbc-db) arglen col-positions &key result-types width) (%initialize-query (db-query-object database) arglen col-positions - :result-types result-types - :width (if width width (db-width database)))) + :result-types result-types + :width (if width width (db-width database)))) (defmethod %initialize-query ((query odbc-query) arglen col-positions &key result-types width) (with-slots (hstmt computed-result-types column-count column-names column-c-types column-sql-types column-data-ptrs column-out-len-ptrs column-precisions - column-scales column-nullables-p) - query + column-scales column-nullables-p) + query (setf column-count (if arglen (min arglen (result-columns-count hstmt)) (result-columns-count hstmt))) @@ -436,7 +436,7 @@ This makes the functions db-execute-command and db-query thread safe." (if long-p ;; if long-p we fetch in chunks with %sql-get-data but must ensure that out_len_ptr is non zero (setf (uffi:deref-pointer out-len-ptr #.odbc::$ODBC-LONG-TYPE) #.odbc::$SQL_NO_TOTAL) (%bind-column hstmt col-nr c-type data-ptr (1+ size) out-len-ptr)) - (vector-push-extend name column-names) + (vector-push-extend name column-names) (vector-push-extend sql-type column-sql-types) (vector-push-extend (sql-to-c-type sql-type) column-c-types) (vector-push-extend precision column-precisions) @@ -450,26 +450,26 @@ This makes the functions db-execute-command and db-query thread safe." (dotimes (col-nr column-count) ;; get column information (initialize-column col-nr)))) - + (setf computed-result-types (make-array column-count)) (dotimes (i column-count) - (setf (aref computed-result-types i) - (cond - ((consp result-types) - (nth i result-types)) - ((eq result-types :auto) - (if (eq (aref column-sql-types i) odbc::$SQL_BIGINT) - :number - (case (aref column-c-types i) - (#.odbc::$SQL_C_SLONG :int) - (#.odbc::$SQL_C_DOUBLE :double) - (#.odbc::$SQL_C_FLOAT :float) - (#.odbc::$SQL_C_SSHORT :short) - (#.odbc::$SQL_C_STINYINT :short) - (#.odbc::$SQL_BIGINT :short) - (t t)))) - (t - t))))) + (setf (aref computed-result-types i) + (cond + ((consp result-types) + (nth i result-types)) + ((eq result-types :auto) + (if (eq (aref column-sql-types i) odbc::$SQL_BIGINT) + :number + (case (aref column-c-types i) + (#.odbc::$SQL_C_SLONG :int) + (#.odbc::$SQL_C_DOUBLE :double) + (#.odbc::$SQL_C_FLOAT :float) + (#.odbc::$SQL_C_SSHORT :short) + (#.odbc::$SQL_C_STINYINT :short) + (#.odbc::$SQL_BIGINT :short) + (t t)))) + (t + t))))) query) (defun db-close-query (query &key drop-p) @@ -481,10 +481,10 @@ This makes the functions db-execute-command and db-query thread safe." (dotimes (col-nr count) (let ((data-ptr (aref column-data-ptrs col-nr)) (out-len-ptr (aref column-out-len-ptrs col-nr))) - (declare (ignorable data-ptr out-len-ptr)) - ;; free-statment :unbind frees these - #+ignore (when data-ptr (uffi:free-foreign-object data-ptr)) - #+ignore (when out-len-ptr (uffi:free-foreign-object out-len-ptr))))) + (declare (ignorable data-ptr out-len-ptr)) + ;; free-statment :unbind frees these + #+ignore (when data-ptr (uffi:free-foreign-object data-ptr)) + #+ignore (when out-len-ptr (uffi:free-foreign-object out-len-ptr))))) (cond ((null hstmt) nil) (drop-p @@ -501,21 +501,21 @@ This makes the functions db-execute-command and db-query thread safe." (%read-query-data (db-query-object database) ignore-columns)) (defmethod %read-query-data ((query odbc-query) ignore-columns) - (with-slots (hstmt column-count column-c-types column-sql-types - column-data-ptrs column-out-len-ptrs column-precisions - computed-result-types) + (with-slots (hstmt column-count column-c-types column-sql-types + column-data-ptrs column-out-len-ptrs column-precisions + computed-result-types) query (unless (= (odbc::SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND) (values - (loop for col-nr from 0 to (- column-count + (loop for col-nr from 0 to (- column-count (if (eq ignore-columns :last) 2 1)) - for result-type across computed-result-types - collect + for result-type across computed-result-types + collect (let ((precision (aref column-precisions col-nr)) (sql-type (aref column-sql-types col-nr))) (cond ((or (< 0 precision (query-width query)) (and (zerop precision) (not (find sql-type '($SQL_C_CHAR))))) - (read-data (aref column-data-ptrs col-nr) + (read-data (aref column-data-ptrs col-nr) (aref column-c-types col-nr) sql-type (aref column-out-len-ptrs col-nr) @@ -524,7 +524,7 @@ This makes the functions db-execute-command and db-query thread safe." *null*) (t (read-data-in-chunks hstmt col-nr - (aref column-data-ptrs col-nr) + (aref column-data-ptrs col-nr) (aref column-c-types col-nr) (aref column-sql-types col-nr) (aref column-out-len-ptrs col-nr) @@ -547,8 +547,8 @@ This makes the functions db-execute-command and db-query thread safe." ;; dispose of memory and set query inactive or get rid of it (db-close-query query))) -(defun db-map-bind-query (query type function - &rest parameters) +(defun db-map-bind-query (query type function + &rest parameters) (declare (ignore type)) ; preliminary. Do a type coersion here (unwind-protect (progn @@ -583,7 +583,7 @@ This makes the functions db-execute-command and db-query thread safe." (defmethod db-prepare-statement ((database odbc-db) sql &key parameter-table parameter-columns) (with-slots (hdbc) database - (let ((query (get-free-query database))) + (let ((query (get-free-query database))) (with-slots (hstmt) query (unless hstmt (setf hstmt (%new-statement-handle hdbc)))) (db-prepare-statement query sql parameter-table parameter-columns)))) @@ -595,8 +595,8 @@ This makes the functions db-execute-command and db-query thread safe." ;; support it. (unless (string-equal sql "insert" :end1 6) (error 'clsql:sql-database-error - (format nil - "Only insert expressions are supported in literal ODBC: '~a'." sql))) + (format nil + "Only insert expressions are supported in literal ODBC: '~a'." sql))) (%db-execute query (format nil "select ~{~a~^,~} from ~a where 0 = 1" (or parameter-columns '("*")) parameter-table)) (%initialize-query query nil nil) @@ -618,14 +618,14 @@ This makes the functions db-execute-command and db-query thread safe." parameter (write-to-string parameter)) size (length parameter-string) - data-ptr + data-ptr (uffi:allocate-foreign-string (1+ size))) (vector-push-extend data-ptr parameter-data-ptrs) - (%sql-bind-parameter + (%sql-bind-parameter hstmt (1- (fill-pointer parameter-data-ptrs)) odbc::$SQL_PARAM_INPUT odbc::$SQL_C_CHAR ; (aref column-c-types parameter-count) odbc::$SQL_CHAR ; sql-type - (query-width query) ;precision ; this should be the actual precision! + (query-width query) ;precision ; this should be the actual precision! ;; scale 0 ;; should be calculated for odbc::$SQL_DECIMAL, ;;$SQL_NUMERIC and odbc::$SQL_TIMESTAMP @@ -641,7 +641,7 @@ This makes the functions db-execute-command and db-query thread safe." (defun %db-reset-query (query) (with-slots (hstmt parameter-data-ptrs) query (prog1 - (db-fetch-query-results query nil) + (db-fetch-query-results query nil) (%free-statement hstmt :reset) ;; but _not_ :unbind ! (%free-statement hstmt :close) (dotimes (param-nr (fill-pointer parameter-data-ptrs)) @@ -659,12 +659,12 @@ This makes the functions db-execute-command and db-query thread safe." ;; database inquiery functions -(defun db-describe-columns (database table-qualifier table-owner - table-name column-name) +(defun db-describe-columns (database table-qualifier table-owner + table-name column-name) (with-slots (hdbc) database (%describe-columns hdbc table-qualifier table-owner table-name column-name))) -;; should translate info-type integers to keywords in order to make this +;; should translate info-type integers to keywords in order to make this ;; more readable? (defmethod get-odbc-info ((database odbc-db) info-type) (with-slots (hdbc info) database @@ -683,7 +683,7 @@ This makes the functions db-execute-command and db-query thread safe." (let ((henv (%new-environment-handle))) (unwind-protect (loop with direction = :first - for data-source+description + for data-source+description = (multiple-value-list (%sql-data-sources henv :direction direction)) while (car data-source+description) collect data-source+description diff --git a/db-odbc/odbc-ff-interface.lisp b/db-odbc/odbc-ff-interface.lisp index 9baec6a..2ae944d 100644 --- a/db-odbc/odbc-ff-interface.lisp +++ b/db-odbc/odbc-ff-interface.lisp @@ -50,7 +50,7 @@ ((hdbc sql-handle) ; HDBC hdbc (*szDSN :cstring) ; UCHAR FAR *szDSN (cbDSN :short) ; SWORD cbDSN - (*szUID :cstring) ; UCHAR FAR *szUID + (*szUID :cstring) ; UCHAR FAR *szUID (cbUID :short) ; SWORD cbUID (*szAuthStr :cstring) ; UCHAR FAR *szAuthStr (cbAuthStr :short) ; SWORD cbAuthStr @@ -75,7 +75,7 @@ ((hdbc sql-handle)) ; HDBC hdbc :module "odbc" :returning :short) ; RETCODE_SQL_API - + ;; deprecated (def-function "SQLAllocStmt" ((hdbc sql-handle) ; HDBC hdbc @@ -300,7 +300,7 @@ :module "odbc" :returning :short) ; RETCODE_SQL_API - ; level 2 + ; level 2 (def-function "SQLExtendedFetch" ((hstmt sql-handle) ; HSTMT hstmt (fFetchType :short) ; UWORD fFetchType @@ -333,11 +333,11 @@ ;;; foreign type definitions -;;(defmacro %sql-len-data-at-exec (length) +;;(defmacro %sql-len-data-at-exec (length) ;; `(- $SQL_LEN_DATA_AT_EXEC_OFFSET ,length)) -(def-struct sql-c-time +(def-struct sql-c-time (hour :short) (minute :short) (second :short)) @@ -346,7 +346,7 @@ (year :short) (month :short) (day :short)) - + (def-struct sql-c-timestamp (year :short) (month :short) diff --git a/db-odbc/odbc-loader.lisp b/db-odbc/odbc-loader.lisp index b63a25a..5d58719 100644 --- a/db-odbc/odbc-loader.lisp +++ b/db-odbc/odbc-loader.lisp @@ -18,9 +18,9 @@ (in-package #:odbc) -(defparameter *odbc-library-filenames* +(defparameter *odbc-library-filenames* '("odbc32" "libodbc" "libiodbc")) - + (defvar *odbc-supporting-libraries* '("c") "Used only by CMU. List of library flags needed to be passed to ld to load the Odbc client library succesfully. If this differs at your site, @@ -31,7 +31,7 @@ set to the right path before compiling or loading the system.") (defmethod clsql-sys:database-type-library-loaded ((database-type (eql :odbc))) *odbc-library-loaded*) - + (defmethod clsql-sys:database-type-load-foreign ((database-type (eql :odbc))) (clsql-uffi:find-and-load-foreign-library *odbc-library-filenames* :module "odbc") diff --git a/db-odbc/odbc-package.lisp b/db-odbc/odbc-package.lisp index 011b6b4..668fd9a 100644 --- a/db-odbc/odbc-package.lisp +++ b/db-odbc/odbc-package.lisp @@ -20,7 +20,7 @@ (defpackage #:odbc (:use #:cl #:uffi) - (:export + (:export #:database-library-loaded #:*null* diff --git a/db-odbc/odbc-sql.lisp b/db-odbc/odbc-sql.lisp index e76b9d0..79fd4a5 100644 --- a/db-odbc/odbc-sql.lisp +++ b/db-odbc/odbc-sql.lisp @@ -29,7 +29,7 @@ ((odbc-db-type :accessor database-odbc-db-type))) (defmethod database-name-from-spec (connection-spec - (database-type (eql :odbc))) + (database-type (eql :odbc))) (check-connection-spec connection-spec database-type (dsn user password &key connection-string completion window-handle)) (destructuring-bind (dsn user password &key connection-string completion window-handle) connection-spec (declare (ignore password connection-string completion window-handle)) @@ -39,58 +39,58 @@ (check-connection-spec connection-spec database-type (dsn user password &key connection-string completion window-handle)) (destructuring-bind (dsn user password &key connection-string (completion :no-prompt) window-handle) connection-spec (handler-case - (let ((db (make-instance 'odbc-database - :name (database-name-from-spec connection-spec :odbc) - :database-type :odbc - :dbi-package (find-package '#:odbc-dbi) - :odbc-conn - (odbc-dbi:connect :user user - :password password - :data-source-name dsn + (let ((db (make-instance 'odbc-database + :name (database-name-from-spec connection-spec :odbc) + :database-type :odbc + :dbi-package (find-package '#:odbc-dbi) + :odbc-conn + (odbc-dbi:connect :user user + :password password + :data-source-name dsn :connection-string connection-string :completion completion :window-handle window-handle)))) - (store-type-of-connected-database db) - ;; Ensure this database type is initialized so can check capabilities of - ;; underlying database - (initialize-database-type :database-type database-type) - db) + (store-type-of-connected-database db) + ;; Ensure this database type is initialized so can check capabilities of + ;; underlying database + (initialize-database-type :database-type database-type) + db) #+ignore - (error () ;; Init or Connect failed - (error 'sql-connection-error - :database-type database-type - :connection-spec connection-spec - :message "Connection failed"))))) + (error () ;; Init or Connect failed + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :message "Connection failed"))))) (defmethod database-underlying-type ((database odbc-database)) (database-odbc-db-type database)) (defun store-type-of-connected-database (db) (let* ((odbc-conn (clsql-sys::odbc-conn db)) - (server-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_SERVER_NAME)) - (dbms-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_DBMS_NAME)) - (type - ;; need SERVER-NAME and DBMS-NAME because many drivers mix this up - (cond - ((or (search "postgresql" server-name :test #'char-equal) - (search "postgresql" dbms-name :test #'char-equal)) - (unless (find-package 'clsql-postgresql) - (ignore-errors (asdf:operate 'asdf:load-op 'clsql-postgresql-socket))) - :postgresql) + (server-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_SERVER_NAME)) + (dbms-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_DBMS_NAME)) + (type + ;; need SERVER-NAME and DBMS-NAME because many drivers mix this up + (cond + ((or (search "postgresql" server-name :test #'char-equal) + (search "postgresql" dbms-name :test #'char-equal)) + (unless (find-package 'clsql-postgresql) + (ignore-errors (asdf:operate 'asdf:load-op 'clsql-postgresql-socket))) + :postgresql) ((or (search "Microsoft SQL Server" server-name :test #'char-equal) (search "Microsoft SQL Server" dbms-name :test #'char-equal)) :mssql) - ((or (search "mysql" server-name :test #'char-equal) - (search "mysql" dbms-name :test #'char-equal)) - (unless (find-package 'clsql-mysql) - ;; ignore errors on platforms where the shared libraries are not available - (ignore-errors (asdf:operate 'asdf:load-op 'clsql-mysql))) - :mysql) - ((or (search "oracle" server-name :test #'char-equal) - (search "oracle" dbms-name :test #'char-equal)) - :oracle)))) + ((or (search "mysql" server-name :test #'char-equal) + (search "mysql" dbms-name :test #'char-equal)) + (unless (find-package 'clsql-mysql) + ;; ignore errors on platforms where the shared libraries are not available + (ignore-errors (asdf:operate 'asdf:load-op 'clsql-mysql))) + :mysql) + ((or (search "oracle" server-name :test #'char-equal) + (search "oracle" dbms-name :test #'char-equal)) + :oracle)))) (setf (database-odbc-db-type db) type))) - + (defmethod database-create (connection-spec (type (eql :odbc))) @@ -103,7 +103,7 @@ (defmethod database-probe (connection-spec (type (eql :odbc))) (when (find (car connection-spec) (database-list connection-spec type) - :test #'string-equal) + :test #'string-equal) t)) (defmethod database-list (connection-spec (type (eql :odbc))) @@ -115,26 +115,26 @@ (let ((result '())) (dolist (table (database-list-tables database :owner owner) result) (setq result - (append (database-list-table-indexes table database :owner owner) - result))))) + (append (database-list-table-indexes table database :owner owner) + result))))) (defmethod database-list-table-indexes (table (database odbc-database) - &key (owner nil)) + &key (owner nil)) (declare (ignore owner)) (multiple-value-bind (rows col-names) - (odbc-dbi:list-table-indexes + (odbc-dbi:list-table-indexes table :db (clsql-sys::odbc-conn database)) (declare (ignore col-names)) ;; INDEX_NAME is hard-coded in sixth position by ODBC driver ;; FIXME: ??? is hard-coded in the fourth position (do ((results nil) - (loop-rows rows (cdr loop-rows))) - ((null loop-rows) (nreverse results)) + (loop-rows rows (cdr loop-rows))) + ((null loop-rows) (nreverse results)) (let* ((row (car loop-rows)) - (col (nth 5 row))) - (unless (or (null col) (find col results :test #'string-equal)) - (push col results)))))) + (col (nth 5 row))) + (unless (or (null col) (find col results :test #'string-equal)) + (push col results)))))) ;;; Database capabilities diff --git a/db-oracle/foreign-resources.lisp b/db-oracle/foreign-resources.lisp index badfedc..fe6986b 100644 --- a/db-oracle/foreign-resources.lisp +++ b/db-oracle/foreign-resources.lisp @@ -17,36 +17,36 @@ (defstruct (foreign-resource) (type (error "Missing TYPE.") - :read-only t) + :read-only t) (sizeof (error "Missing SIZEOF.") - :read-only t) + :read-only t) (buffer (error "Missing BUFFER.") - :read-only t) + :read-only t) (in-use nil :type boolean)) (defun %get-resource (type sizeof) (let ((resources (gethash type *foreign-resource-hash*))) (car (member-if - #'(lambda (res) - (and (= (foreign-resource-sizeof res) sizeof) - (not (foreign-resource-in-use res)))) - resources)))) + #'(lambda (res) + (and (= (foreign-resource-sizeof res) sizeof) + (not (foreign-resource-in-use res)))) + resources)))) (defun %insert-foreign-resource (type res) (let ((resource (gethash type *foreign-resource-hash*))) (setf (gethash type *foreign-resource-hash*) - (cons res resource)))) + (cons res resource)))) (defmacro acquire-foreign-resource (type &optional size) `(let ((res (%get-resource ,type ,size))) (unless res (setf res (make-foreign-resource - :type ,type :sizeof ,size - :buffer (uffi:allocate-foreign-object ,type ,size))) + :type ,type :sizeof ,size + :buffer (uffi:allocate-foreign-object ,type ,size))) (%insert-foreign-resource ',type res)) (claim-foreign-resource res))) - + (defun free-foreign-resource (ares) (setf (foreign-resource-in-use ares) nil) ares) diff --git a/db-oracle/oracle-api.lisp b/db-oracle/oracle-api.lisp index 19b3f6e..d51050b 100644 --- a/db-oracle/oracle-api.lisp +++ b/db-oracle/oracle-api.lisp @@ -72,26 +72,26 @@ ((c-oci-symbol lisp-oci-fn) c-return &rest c-parms) (let ((ll (mapcar (lambda (x) (declare (ignore x)) (gensym)) c-parms))) `(let ((%lisp-oci-fn (uffi:def-function (,c-oci-symbol ,(intern (concatenate 'string "%" (symbol-name lisp-oci-fn)))) - ,c-parms - :returning ,c-return))) + ,c-parms + :returning ,c-return))) (defun ,lisp-oci-fn (,@ll &key database nulls-ok) (declare (ignore database nulls-ok)) - (funcall %lisp-oci-fn ,@ll))))) + (funcall %lisp-oci-fn ,@ll))))) (def-oci-routine ("OCIInitialize" oci-initialize) :int - (mode ub4) ; ub4 - (ctxp :pointer-void) ; dvoid * - (malocfp :pointer-void) ; dvoid *(*) - (ralocfp :pointer-void) ; dvoid *(*) - (mfreefp (* :pointer-void))) ; void *(*) + (mode ub4) ; ub4 + (ctxp :pointer-void) ; dvoid * + (malocfp :pointer-void) ; dvoid *(*) + (ralocfp :pointer-void) ; dvoid *(*) + (mfreefp (* :pointer-void))) ; void *(*) (def-oci-routine ("OCIEnvInit" oci-env-init) :int (envpp :pointer-void) ; OCIEnv ** - (mode ub4) ; ub4 + (mode ub4) ; ub4 (xtramem-sz size_t) ; size_t (usermempp (* :pointer-void))) ; dvoid ** @@ -109,19 +109,19 @@ (def-oci-routine ("OCIHandleAlloc" oci-handle-alloc) :int - (parenth :pointer-void) ; const dvoid * - (hndlpp (* :pointer-void)) ; dvoid ** - (type ub4) ; ub4 - (xtramem_sz size_t) ; size_t - (usrmempp (* :pointer-void))) ; dvoid ** + (parenth :pointer-void) ; const dvoid * + (hndlpp (* :pointer-void)) ; dvoid ** + (type ub4) ; ub4 + (xtramem_sz size_t) ; size_t + (usrmempp (* :pointer-void))) ; dvoid ** (def-oci-routine ("OCIServerAttach" oci-server-attach) :int (srvhp :pointer-void) ; oci-server (errhp :pointer-void) ; oci-error - (dblink :cstring) ; :in - (dblink-len sb4) ; sb4 - (mode ub4)) ; ub4 + (dblink :cstring) ; :in + (dblink-len sb4) ; sb4 + (mode ub4)) ; ub4 (def-oci-routine ("OCIHandleFree" oci-handle-free) @@ -131,20 +131,20 @@ (def-oci-routine ("OCILogon" oci-logon) :int - (envhp :pointer-void) ; env - (errhp :pointer-void) ; err - (svchpp (* :pointer-void)) ; svc - (username (* :unsigned-char)) ; username - (uname-len ub4) ; - (passwd (* :unsigned-char)) ; passwd - (password-len ub4) ; - (dsn (* :unsigned-char)) ; datasource - (dsn-len ub4)) ; + (envhp :pointer-void) ; env + (errhp :pointer-void) ; err + (svchpp (* :pointer-void)) ; svc + (username (* :unsigned-char)) ; username + (uname-len ub4) ; + (passwd (* :unsigned-char)) ; passwd + (password-len ub4) ; + (dsn (* :unsigned-char)) ; datasource + (dsn-len ub4)) ; (def-oci-routine ("OCILogoff" oci-logoff) :int - (p0 :pointer-void) ; svc - (p1 :pointer-void)) ; err + (p0 :pointer-void) ; svc + (p1 :pointer-void)) ; err (declaim (inline oci-error-get)) (uffi:def-function ("OCIErrorGet" oci-error-get) @@ -260,26 +260,26 @@ ;;; for setting up global environment. (uffi:def-function "OCIInitialize" - ((mode ub4) ; ub4 - (ctxp :pointer-void) ; dvoid * - (malocfp :pointer-void) ; dvoid *(*) - (ralocfp :pointer-void) ; dvoid *(*) + ((mode ub4) ; ub4 + (ctxp :pointer-void) ; dvoid * + (malocfp :pointer-void) ; dvoid *(*) + (ralocfp :pointer-void) ; dvoid *(*) (mfreefp (* :pointer-void))) :returning :int) (uffi:def-function "OCIEnvInit" - ((envpp :pointer-void) ; OCIEnv ** - (mode ub4) ; ub4 - (xtramem-sz size_t) ; size_t + ((envpp :pointer-void) ; OCIEnv ** + (mode ub4) ; ub4 + (xtramem-sz size_t) ; size_t (usermempp (* :pointer-void))) :returning :int) (uffi:def-function "OCIHandleAlloc" - ((parenth :pointer-void) ; const dvoid * - (hndlpp (* :pointer-void)) ; dvoid ** - (type ub4) ; ub4 - (xtramem_sz size_t) ; size_t + ((parenth :pointer-void) ; const dvoid * + (hndlpp (* :pointer-void)) ; dvoid ** + (type ub4) ; ub4 + (xtramem_sz size_t) ; size_t (usrmempp (* :pointer-void))) :returning :int) @@ -291,27 +291,27 @@ (defvar *oci-env* nil) (defvar *oci-handle-types* - '(:error ; error report handle (OCIError) - :service-context ; service context handle (OCISvcCtx) - :statement ; statement (application request) handle (OCIStmt) - :describe ; select list description handle (OCIDescribe) - :server ; server context handle (OCIServer) - :session ; user session handle (OCISession) - :transaction ; transaction context handle (OCITrans) - :complex-object ; complex object retrieval handle (OCIComplexObject) - :security)) ; security handle (OCISecurity) + '(:error ; error report handle (OCIError) + :service-context ; service context handle (OCISvcCtx) + :statement ; statement (application request) handle (OCIStmt) + :describe ; select list description handle (OCIDescribe) + :server ; server context handle (OCIServer) + :session ; user session handle (OCISession) + :transaction ; transaction context handle (OCITrans) + :complex-object ; complex object retrieval handle (OCIComplexObject) + :security)) ; security handle (OCISecurity) (defun oci-init (&key (mode +oci-default+)) (let ((x (OCIInitialize mode +null-void-pointer+ +null-void-pointer+ - +null-void-pointer+ +null-void-pointer-pointer+))) + +null-void-pointer+ +null-void-pointer-pointer+))) (if (= x 0) - (let ((env (uffi:allocate-foreign-object :pointer-void))) - (setq *oci-initialized* mode) - (let ((x (OCIEnvInit env +oci-default+ 0 +null-void-pointer+))) - (format t ";; OEI: returned ~d~%" x) - (setq *oci-env* env)))))) + (let ((env (uffi:allocate-foreign-object :pointer-void))) + (setq *oci-initialized* mode) + (let ((x (OCIEnvInit env +oci-default+ 0 +null-void-pointer+))) + (format t ";; OEI: returned ~d~%" x) + (setq *oci-env* env)))))) (defun oci-check-return (value) (when (= value +oci-invalid-handle+) @@ -324,13 +324,13 @@ (:error (let ((ptr (uffi:allocate-foreign-object :pointer-void))) (let ((x (OCIHandleAlloc - (uffi:deref-pointer *oci-env* void-pointer) - ptr - +oci-default+ - 0 - +null-void-pointer-pointer+))) - (oci-check-return x) - ptr))) + (uffi:deref-pointer *oci-env* void-pointer) + ptr + +oci-default+ + 0 + +null-void-pointer-pointer+))) + (oci-check-return x) + ptr))) (:service-context "OCISvcCtx") (:statement @@ -349,8 +349,8 @@ "OCISecurity") (t (error 'sql-database-error - :message - (format nil "'~s' is not a valid OCI handle type" type))))) + :message + (format nil "'~s' is not a valid OCI handle type" type))))) (defun oci-environment () (let ((envhp (oci-get-handle :type :env))) diff --git a/db-oracle/oracle-constants.lisp b/db-oracle/oracle-constants.lisp index 692b55b..9462bfc 100644 --- a/db-oracle/oracle-constants.lisp +++ b/db-oracle/oracle-constants.lisp @@ -16,36 +16,36 @@ (in-package #:clsql-oracle) -(defconstant +oci-default+ #x00) ; default value for parameters and attributes -(defconstant +oci-threaded+ #x01) ; application is in threaded environment -(defconstant +oci-object+ #x02) ; the application is in object environment -(defconstant +oci-non-blocking+ #x04) ; non blocking mode of operation -(defconstant +oci-env-no-mutex+ #x08) ; the environment handle will not be protected by a mutex internally +(defconstant +oci-default+ #x00) ; default value for parameters and attributes +(defconstant +oci-threaded+ #x01) ; application is in threaded environment +(defconstant +oci-object+ #x02) ; the application is in object environment +(defconstant +oci-non-blocking+ #x04) ; non blocking mode of operation +(defconstant +oci-env-no-mutex+ #x08) ; the environment handle will not be protected by a mutex internally ;; Handle types -(defconstant +oci-htype-env+ 1) ; environment handle -(defconstant +oci-htype-error+ 2) ; error handle -(defconstant +oci-htype-svcctx+ 3) ; service handle -(defconstant +oci-htype-stmt+ 4) ; statement handle -(defconstant +oci-htype-bind+ 5) ; bind handle -(defconstant +oci-htype-define+ 6) ; define handle -(defconstant +oci-htype-describe+ 7) ; describe handle -(defconstant +oci-htype-server+ 8) ; server handle -(defconstant +oci-htype-session+ 9) ; authentication handle -(defconstant +oci-htype-trans+ 10) ; transaction handle +(defconstant +oci-htype-env+ 1) ; environment handle +(defconstant +oci-htype-error+ 2) ; error handle +(defconstant +oci-htype-svcctx+ 3) ; service handle +(defconstant +oci-htype-stmt+ 4) ; statement handle +(defconstant +oci-htype-bind+ 5) ; bind handle +(defconstant +oci-htype-define+ 6) ; define handle +(defconstant +oci-htype-describe+ 7) ; describe handle +(defconstant +oci-htype-server+ 8) ; server handle +(defconstant +oci-htype-session+ 9) ; authentication handle +(defconstant +oci-htype-trans+ 10) ; transaction handle (defconstant +oci-htype-complexobject+ 11) ; complex object retrieval handle -(defconstant +oci-htype-security+ 12) ; security handle +(defconstant +oci-htype-security+ 12) ; security handle ;; Descriptor types -(defconstant +oci-dtype-lob+ 50) ; lob locator -(defconstant +oci-dtype-snap+ 51) ; snapshot -(defconstant +oci-dtype-rset+ 52) ; result set -(defconstant +oci-dtype-param+ 53) ; parameter descriptor obtained from ocigparm +(defconstant +oci-dtype-lob+ 50) ; lob locator +(defconstant +oci-dtype-snap+ 51) ; snapshot +(defconstant +oci-dtype-rset+ 52) ; result set +(defconstant +oci-dtype-param+ 53) ; parameter descriptor obtained from ocigparm (defconstant +oci-dtype-rowid+ 54) ; rowid (defconstant +oci-dtype-complexobjectcomp+ 55) ; complex object retrieval descriptor -(defconstant +oci-dtype-file+ 56) ; File Lob locator +(defconstant +oci-dtype-file+ 56) ; File Lob locator (defconstant +oci-dtype-aqenq-options+ 57) ; enqueue options (defconstant +oci-dtype-aqdeq-options+ 58) ; dequeue options (defconstant +oci-dtype-aqmsg-properties+ 59) ; message properties @@ -53,9 +53,9 @@ ;; Objectr pointer types -(defconstant +oci-otype-name+ 1) ; object name -(defconstant +oci-otype-ref+ 2) ; REF to TDO -(defconstant +oci-otype-ptr+ 3) ; PTR to TDO +(defconstant +oci-otype-name+ 1) ; object name +(defconstant +oci-otype-ref+ 2) ; REF to TDO +(defconstant +oci-otype-ptr+ 3) ; PTR to TDO ;; Attribute types @@ -109,87 +109,87 @@ ;; AQ Attribute Types ;; Enqueue Options -(defconstant +oci-attr-visibility+ 47) ; visibility +(defconstant +oci-attr-visibility+ 47) ; visibility (defconstant +oci-attr-relative-msgid+ 48) ; relative message id (defconstant +oci-attr-sequence-deviation+ 49) ; sequence deviation ; - Dequeue Options - ; consumer name ;#define OCI-ATTR-DEQ-MODE 50 -;(defconstant +OCI-ATTR-CONSUMER-NAME 50 + 51) ; dequeue mode -;#define OCI-ATTR-NAVIGATION 52 ; navigation -;#define OCI-ATTR-WAIT 53 ; wait -;#define OCI-ATTR-DEQ-MSGID 54 ; dequeue message id +;(defconstant +OCI-ATTR-CONSUMER-NAME 50 + 51) ; dequeue mode +;#define OCI-ATTR-NAVIGATION 52 ; navigation +;#define OCI-ATTR-WAIT 53 ; wait +;#define OCI-ATTR-DEQ-MSGID 54 ; dequeue message id ; - Message Properties - -(defconstant +OCI-ATTR-PRIORITY+ 55) ; priority -(defconstant +OCI-ATTR-DELAY+ 56) ; delay -(defconstant +OCI-ATTR-EXPIRATION+ 57) ; expiration -(defconstant +OCI-ATTR-CORRELATION+ 58) ; correlation id -(defconstant +OCI-ATTR-ATTEMPTS+ 59) ; # of attempts +(defconstant +OCI-ATTR-PRIORITY+ 55) ; priority +(defconstant +OCI-ATTR-DELAY+ 56) ; delay +(defconstant +OCI-ATTR-EXPIRATION+ 57) ; expiration +(defconstant +OCI-ATTR-CORRELATION+ 58) ; correlation id +(defconstant +OCI-ATTR-ATTEMPTS+ 59) ; # of attempts (defconstant +OCI-ATTR-RECIPIENT-LIST+ 60) ; recipient list (defconstant +OCI-ATTR-EXCEPTION-QUEUE+ 61) ; exception queue name -(defconstant +OCI-ATTR-ENQ-TIME+ 62) ; enqueue time (only OCIAttrGet) -(defconstant +OCI-ATTR-MSG-STATE+ 63) ; message state (only OCIAttrGet) +(defconstant +OCI-ATTR-ENQ-TIME+ 62) ; enqueue time (only OCIAttrGet) +(defconstant +OCI-ATTR-MSG-STATE+ 63) ; message state (only OCIAttrGet) ;; AQ Agent -(defconstant +OCI-ATTR-AGENT-NAME+ 64) ; agent name +(defconstant +OCI-ATTR-AGENT-NAME+ 64) ; agent name (defconstant +OCI-ATTR-AGENT-ADDRESS+ 65) ; agent address (defconstant +OCI-ATTR-AGENT-PROTOCOL+ 66) ; agent protocol ;- Server handle - -(defconstant +OCI-ATTR-NATIVE-FDES+ 67) ; native cncxn file desc +(defconstant +OCI-ATTR-NATIVE-FDES+ 67) ; native cncxn file desc ;-Parameter Attribute Types- -(defconstant +OCI-ATTR-UNK+ 101) ; unknown attribute -(defconstant +OCI-ATTR-NUM-COLS+ 102) ; number of columns +(defconstant +OCI-ATTR-UNK+ 101) ; unknown attribute +(defconstant +OCI-ATTR-NUM-COLS+ 102) ; number of columns (defconstant +OCI-ATTR-LIST-COLUMNS+ 103) ; parameter of the column list -(defconstant +OCI-ATTR-RDBA+ 104) ; DBA of the segment header -(defconstant +OCI-ATTR-CLUSTERED+ 105) ; whether the table is clustered +(defconstant +OCI-ATTR-RDBA+ 104) ; DBA of the segment header +(defconstant +OCI-ATTR-CLUSTERED+ 105) ; whether the table is clustered (defconstant +OCI-ATTR-PARTITIONED+ 106) ; whether the table is partitioned -(defconstant +OCI-ATTR-INDEX-ONLY+ 107) ; whether the table is index only +(defconstant +OCI-ATTR-INDEX-ONLY+ 107) ; whether the table is index only (defconstant +OCI-ATTR-LIST-ARGUMENTS+ 108) ; parameter of the argument list (defconstant +OCI-ATTR-LIST-SUBPROGRAMS+ 109) ; parameter of the subprogram list -(defconstant +OCI-ATTR-REF-TDO+ 110) ; REF to the type descriptor -(defconstant +OCI-ATTR-LINK+ 111) ; the database link name -(defconstant +OCI-ATTR-MIN+ 112) ; minimum value -(defconstant +OCI-ATTR-MAX+ 113) ; maximum value -(defconstant +OCI-ATTR-INCR+ 114) ; increment value -(defconstant +OCI-ATTR-CACHE+ 115) ; number of sequence numbers cached -(defconstant +OCI-ATTR-ORDER+ 116) ; whether the sequence is ordered -(defconstant +OCI-ATTR-HW-MARK+ 117) ; high-water mark +(defconstant +OCI-ATTR-REF-TDO+ 110) ; REF to the type descriptor +(defconstant +OCI-ATTR-LINK+ 111) ; the database link name +(defconstant +OCI-ATTR-MIN+ 112) ; minimum value +(defconstant +OCI-ATTR-MAX+ 113) ; maximum value +(defconstant +OCI-ATTR-INCR+ 114) ; increment value +(defconstant +OCI-ATTR-CACHE+ 115) ; number of sequence numbers cached +(defconstant +OCI-ATTR-ORDER+ 116) ; whether the sequence is ordered +(defconstant +OCI-ATTR-HW-MARK+ 117) ; high-water mark (defconstant +OCI-ATTR-TYPE-SCHEMA+ 118) ; type's schema name -(defconstant +OCI-ATTR-TIMESTAMP+ 119) ; timestamp of the object -(defconstant +OCI-ATTR-NUM-ATTRS+ 120) ; number of sttributes -(defconstant +OCI-ATTR-NUM-PARAMS+ 121) ; number of parameters -(defconstant +OCI-ATTR-OBJID+ 122) ; object id for a table or view -(defconstant +OCI-ATTR-PTYPE+ 123) ; type of info described by -(defconstant +OCI-ATTR-PARAM+ 124) ; parameter descriptor +(defconstant +OCI-ATTR-TIMESTAMP+ 119) ; timestamp of the object +(defconstant +OCI-ATTR-NUM-ATTRS+ 120) ; number of sttributes +(defconstant +OCI-ATTR-NUM-PARAMS+ 121) ; number of parameters +(defconstant +OCI-ATTR-OBJID+ 122) ; object id for a table or view +(defconstant +OCI-ATTR-PTYPE+ 123) ; type of info described by +(defconstant +OCI-ATTR-PARAM+ 124) ; parameter descriptor (defconstant +OCI-ATTR-OVERLOAD-ID+ 125) ; overload ID for funcs and procs -(defconstant +OCI-ATTR-TABLESPACE+ 126) ; table name space -(defconstant +OCI-ATTR-TDO+ 127) ; TDO of a type -(defconstant +OCI-ATTR-PARSE-ERROR-OFFSET+ 128) ; Parse Error offset +(defconstant +OCI-ATTR-TABLESPACE+ 126) ; table name space +(defconstant +OCI-ATTR-TDO+ 127) ; TDO of a type +(defconstant +OCI-ATTR-PARSE-ERROR-OFFSET+ 128) ; Parse Error offset ;-Credential Types- -(defconstant +OCI-CRED-RDBMS+ 1) ; database username/password -(defconstant +OCI-CRED-EXT+ 2) ; externally provided credentials +(defconstant +OCI-CRED-RDBMS+ 1) ; database username/password +(defconstant +OCI-CRED-EXT+ 2) ; externally provided credentials ;; Error Return Values- -(defconstant +oci-continue+ -24200) ; Continue with the body of the OCI function +(defconstant +oci-continue+ -24200) ; Continue with the body of the OCI function (defconstant +oci-still-executing+ -3123) ; OCI would block error -(defconstant +oci-invalid-handle+ -2) ; maps to SQL-INVALID-HANDLE +(defconstant +oci-invalid-handle+ -2) ; maps to SQL-INVALID-HANDLE (defconstant +oci-error+ -1) ; maps to SQL-ERROR (defconstant +oci-success+ 0) ; maps to SQL-SUCCESS of SAG CLI (defconstant +oci-success-with-info+ 1) ; maps to SQL-SUCCESS-WITH-INFO -(defconstant +oci-need-data+ 99) ; maps to SQL-NEED-DATA +(defconstant +oci-need-data+ 99) ; maps to SQL-NEED-DATA (defconstant +oci-no-data+ 100) ; maps to SQL-NO-DATA ;; Parsing Syntax Types- -(defconstant +oci-ntv-syntax+ 1) ; Use what so ever is the native lang of server -(defconstant +oci-v7-syntax+ 2) ; V7 language -(defconstant +oci-v8-syntax+ 3) ; V8 language +(defconstant +oci-ntv-syntax+ 1) ; Use what so ever is the native lang of server +(defconstant +oci-v7-syntax+ 2) ; V7 language +(defconstant +oci-v8-syntax+ 3) ; V8 language ;-Scrollable Cursor Options- @@ -202,31 +202,31 @@ ;-Bind and Define Options- -(defconstant +OCI-SB2-IND-PTR+ #x01) ; unused -(defconstant +OCI-DATA-AT-EXEC+ #x02) ; data at execute time -(defconstant +OCI-DYNAMIC-FETCH+ #x02) ; fetch dynamically -(defconstant +OCI-PIECEWISE+ #x04) ; piecewise DMLs or fetch +(defconstant +OCI-SB2-IND-PTR+ #x01) ; unused +(defconstant +OCI-DATA-AT-EXEC+ #x02) ; data at execute time +(defconstant +OCI-DYNAMIC-FETCH+ #x02) ; fetch dynamically +(defconstant +OCI-PIECEWISE+ #x04) ; piecewise DMLs or fetch ;- ;-Execution Modes- -(defconstant +OCI-BATCH-MODE+ #x01) ; batch the oci statement for execution -(defconstant +OCI-EXACT-FETCH+ #x02) ; fetch the exact rows specified +(defconstant +OCI-BATCH-MODE+ #x01) ; batch the oci statement for execution +(defconstant +OCI-EXACT-FETCH+ #x02) ; fetch the exact rows specified (defconstant +OCI-KEEP-FETCH-STATE+ #x04) ; unused (defconstant +OCI-SCROLLABLE-CURSOR+ #x08) ; cursor scrollable -(defconstant +OCI-DESCRIBE-ONLY+ #x10) ; only describe the statement +(defconstant +OCI-DESCRIBE-ONLY+ #x10) ; only describe the statement (defconstant +OCI-COMMIT-ON-SUCCESS+ #x20) ; commit, if successful execution ;- ;-Authentication Modes- -(defconstant +OCI-MIGRATE+ #x0001) ; migratable auth context -(defconstant +OCI-SYSDBA+ #x0002) ; for SYSDBA authorization -(defconstant +OCI-SYSOPER+ #x0004) ; for SYSOPER authorization -(defconstant +OCI-PRELIM-AUTH+ #x0008) ; for preliminary authorization +(defconstant +OCI-MIGRATE+ #x0001) ; migratable auth context +(defconstant +OCI-SYSDBA+ #x0002) ; for SYSDBA authorization +(defconstant +OCI-SYSOPER+ #x0004) ; for SYSOPER authorization +(defconstant +OCI-PRELIM-AUTH+ #x0008) ; for preliminary authorization ;- ;-Piece Information- -(defconstant +OCI-PARAM-IN+ #x01) ; in parameter -(defconstant +OCI-PARAM-OUT+ #x02) ; out parameter +(defconstant +OCI-PARAM-IN+ #x01) ; in parameter +(defconstant +OCI-PARAM-OUT+ #x02) ; out parameter ;- ;- Transaction Start Flags - @@ -235,12 +235,12 @@ (defconstant +OCI-TRANS-JOIN+ #x00000002) ; join an existing transaction (defconstant +OCI-TRANS-RESUME+ #x00000004) ; resume this transaction (defconstant +OCI-TRANS-STARTMASK+ #x000000ff) - - + + (defconstant +OCI-TRANS-READONLY+ #x00000100) ; starts a readonly transaction (defconstant +OCI-TRANS-READWRITE+ #x00000200) ; starts a read-write transaction (defconstant +OCI-TRANS-SERIALIZABLE+ #x00000400) - ; starts a serializable transaction + ; starts a serializable transaction (defconstant +OCI-TRANS-ISOLMASK+ #x0000ff00) (defconstant +OCI-TRANS-LOOSE+ #x00010000) ; a loosely coupled branch @@ -261,39 +261,39 @@ ;; NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE ; - Visibility flags - -(defconstant +OCI-ENQ-IMMEDIATE+ 1) ; enqueue is an independent transaction -(defconstant +OCI-ENQ-ON-COMMIT+ 2) ; enqueue is part of current transaction +(defconstant +OCI-ENQ-IMMEDIATE+ 1) ; enqueue is an independent transaction +(defconstant +OCI-ENQ-ON-COMMIT+ 2) ; enqueue is part of current transaction ; - Dequeue mode flags - -(defconstant +OCI-DEQ-BROWSE+ 1) ; read message without acquiring a lock -(defconstant +OCI-DEQ-LOCKED+ 2) ; read and obtain write lock on message -(defconstant +OCI-DEQ-REMOVE+ 3) ; read the message and delete it +(defconstant +OCI-DEQ-BROWSE+ 1) ; read message without acquiring a lock +(defconstant +OCI-DEQ-LOCKED+ 2) ; read and obtain write lock on message +(defconstant +OCI-DEQ-REMOVE+ 3) ; read the message and delete it ; - Dequeue navigation flags - (defconstant +OCI-DEQ-FIRST-MSG+ 1) ; get first message at head of queue -(defconstant +OCI-DEQ-NEXT-MSG+ 3) ; next message that is available +(defconstant +OCI-DEQ-NEXT-MSG+ 3) ; next message that is available (defconstant +OCI-DEQ-NEXT-TRANSACTION+ 2) ; get first message of next txn group ; - Message states - -(defconstant +OCI-MSG-WAITING+ 1) ; the message delay has not yet completed -(defconstant +OCI-MSG-READY+ 0) ; the message is ready to be processed -(defconstant +OCI-MSG-PROCESSED+ 2) ; the message has been processed -(defconstant +OCI-MSG-EXPIRED+ 3) ; message has moved to exception queue +(defconstant +OCI-MSG-WAITING+ 1) ; the message delay has not yet completed +(defconstant +OCI-MSG-READY+ 0) ; the message is ready to be processed +(defconstant +OCI-MSG-PROCESSED+ 2) ; the message has been processed +(defconstant +OCI-MSG-EXPIRED+ 3) ; message has moved to exception queue ; - Sequence deviation - -(defconstant +OCI-ENQ-BEFORE+ 2) ; enqueue message before another message -(defconstant +OCI-ENQ-TOP+ 3) ; enqueue message before all messages +(defconstant +OCI-ENQ-BEFORE+ 2) ; enqueue message before another message +(defconstant +OCI-ENQ-TOP+ 3) ; enqueue message before all messages ; - Visibility flags - -(defconstant +OCI-DEQ-IMMEDIATE+ 1) ; dequeue is an independent transaction -(defconstant +OCI-DEQ-ON-COMMIT+ 2) ; dequeue is part of current transaction +(defconstant +OCI-DEQ-IMMEDIATE+ 1) ; dequeue is an independent transaction +(defconstant +OCI-DEQ-ON-COMMIT+ 2) ; dequeue is part of current transaction ; - Wait - -(defconstant +OCI-DEQ-WAIT-FOREVER+ -1) ; wait forever if no message available -(defconstant +OCI-DEQ-NO-WAIT+ 0) ; do not wait if no message is available +(defconstant +OCI-DEQ-WAIT-FOREVER+ -1) ; wait forever if no message available +(defconstant +OCI-DEQ-NO-WAIT+ 0) ; do not wait if no message is available ; - Delay - -(defconstant +OCI-MSG-NO-DELAY+ 0) ; message is available immediately +(defconstant +OCI-MSG-NO-DELAY+ 0) ; message is available immediately ;; Expiration (defconstant +OCI-MSG-NO-EXPIRATION+ -1) ; message will never expire @@ -301,20 +301,20 @@ ;; Describe Handle Parameter Attributes ;; Attributes common to Columns and Stored Procs -(defconstant +oci-attr-data-size+ 1) ; maximum size of the data -(defconstant +oci-attr-data-type+ 2) ; the sql type of the column/argument -(defconstant +oci-attr-disp-size+ 3) ; the display size +(defconstant +oci-attr-data-size+ 1) ; maximum size of the data +(defconstant +oci-attr-data-type+ 2) ; the sql type of the column/argument +(defconstant +oci-attr-disp-size+ 3) ; the display size (defconstant +oci-attr-name+ 4) ; the name of the column/argument -(defconstant +oci-attr-precision+ 5) ; precision if number type -(defconstant +oci-attr-scale+ 6) ; scale if number type -(defconstant +oci-attr-is-null+ 7) ; is it null ? +(defconstant +oci-attr-precision+ 5) ; precision if number type +(defconstant +oci-attr-scale+ 6) ; scale if number type +(defconstant +oci-attr-is-null+ 7) ; is it null ? (defconstant +oci-attr-type-name+ 8) ;; name of the named data type or a package name for package private types -(defconstant +OCI-ATTR-SCHEMA-NAME+ 9) ; the schema name -(defconstant +OCI-ATTR-SUB-NAME+ 10) ; type name if package private type -(defconstant +OCI-ATTR-POSITION+ 11) ; relative position of col/arg in the list of cols/args +(defconstant +OCI-ATTR-SCHEMA-NAME+ 9) ; the schema name +(defconstant +OCI-ATTR-SUB-NAME+ 10) ; type name if package private type +(defconstant +OCI-ATTR-POSITION+ 11) ; relative position of col/arg in the list of cols/args ; complex object retrieval parameter attributes (defconstant +OCI-ATTR-COMPLEXOBJECTCOMP-TYPE+ 50) ; @@ -323,16 +323,16 @@ (defconstant +OCI-ATTR-COMPLEXOBJECT-COLL-OUTOFLINE+ 53) ; ; Only Columns -(defconstant +OCI-ATTR-DISP-NAME+ 100) ; the display name +(defconstant +OCI-ATTR-DISP-NAME+ 100) ; the display name ;; stored procs -(defconstant +OCI-ATTR-OVERLOAD+ 210) ; is this position overloaded -(defconstant +OCI-ATTR-LEVEL+ 211) ; level for structured types +(defconstant +OCI-ATTR-OVERLOAD+ 210) ; is this position overloaded +(defconstant +OCI-ATTR-LEVEL+ 211) ; level for structured types (defconstant +OCI-ATTR-HAS-DEFAULT+ 212) ; has a default value -(defconstant +OCI-ATTR-IOMODE+ 213) ; in, out inout -(defconstant +OCI-ATTR-RADIX+ 214) ; returns a radix -(defconstant +OCI-ATTR-NUM-ARGS+ 215) ; total number of arguments +(defconstant +OCI-ATTR-IOMODE+ 213) ; in, out inout +(defconstant +OCI-ATTR-RADIX+ 214) ; returns a radix +(defconstant +OCI-ATTR-NUM-ARGS+ 215) ; total number of arguments ;; named type attributes @@ -356,66 +356,66 @@ (defconstant +oci-attr-order-method+ 233) ; order method of type ; only collection element -(defconstant +OCI-ATTR-NUM-ELEMS+ 234) ; number of elements +(defconstant +OCI-ATTR-NUM-ELEMS+ 234) ; number of elements ; only type methods (defconstant +OCI-ATTR-ENCAPSULATION+ 235) ; encapsulation level -(defconstant +OCI-ATTR-IS-SELFISH+ 236) ; method selfish -(defconstant +OCI-ATTR-IS-VIRTUAL+ 237) ; virtual -(defconstant +OCI-ATTR-IS-INLINE+ 238) ; inline +(defconstant +OCI-ATTR-IS-SELFISH+ 236) ; method selfish +(defconstant +OCI-ATTR-IS-VIRTUAL+ 237) ; virtual +(defconstant +OCI-ATTR-IS-INLINE+ 238) ; inline (defconstant +OCI-ATTR-IS-CONSTANT+ 239) ; constant -(defconstant +OCI-ATTR-HAS-RESULT+ 240) ; has result +(defconstant +OCI-ATTR-HAS-RESULT+ 240) ; has result (defconstant +OCI-ATTR-IS-CONSTRUCTOR+ 241) ; constructor (defconstant +OCI-ATTR-IS-DESTRUCTOR+ 242) ; destructor (defconstant +OCI-ATTR-IS-OPERATOR+ 243) ; operator -(defconstant +OCI-ATTR-IS-MAP+ 244) ; a map method -(defconstant +OCI-ATTR-IS-ORDER+ 245) ; order method -(defconstant +OCI-ATTR-IS-RNDS+ 246) ; read no data state method -(defconstant +OCI-ATTR-IS-RNPS+ 247) ; read no process state -(defconstant +OCI-ATTR-IS-WNDS+ 248) ; write no data state method -(defconstant +OCI-ATTR-IS-WNPS+ 249) ; write no process state +(defconstant +OCI-ATTR-IS-MAP+ 244) ; a map method +(defconstant +OCI-ATTR-IS-ORDER+ 245) ; order method +(defconstant +OCI-ATTR-IS-RNDS+ 246) ; read no data state method +(defconstant +OCI-ATTR-IS-RNPS+ 247) ; read no process state +(defconstant +OCI-ATTR-IS-WNDS+ 248) ; write no data state method +(defconstant +OCI-ATTR-IS-WNPS+ 249) ; write no process state ; describing public objects (defconstant +OCI-ATTR-DESC-PUBLIC+ 250) ; public object ;- ;-OCIPasswordChange- -(defconstant +OCI-AUTH+ #x08) ; Change the password but do not login +(defconstant +OCI-AUTH+ #x08) ; Change the password but do not login ;-Other Constants- -(defconstant +OCI-MAX-FNS+ 100) ; max number of OCI Functions -(defconstant +OCI-SQLSTATE-SIZE+ 5) ; +(defconstant +OCI-MAX-FNS+ 100) ; max number of OCI Functions +(defconstant +OCI-SQLSTATE-SIZE+ 5) ; (defconstant +OCI-ERROR-MAXMSG-SIZE+ 1024) ; max size of an error message -;; (defconstant +OCI-LOBMAXSIZE+ 4MAXVAL) ; maximum lob data size -(defconstant +OCI-ROWID-LEN+ 23) ; +;; (defconstant +OCI-LOBMAXSIZE+ 4MAXVAL) ; maximum lob data size +(defconstant +OCI-ROWID-LEN+ 23) ; ;- ;- Fail Over Events - -(defconstant +OCI-FO-END+ #x00000001) ; -(defconstant +OCI-FO-ABORT+ #x00000002) ; +(defconstant +OCI-FO-END+ #x00000001) ; +(defconstant +OCI-FO-ABORT+ #x00000002) ; (defconstant +OCI-FO-REAUTH+ #x00000004) ; -(defconstant +OCI-FO-BEGIN+ #x00000008) ; +(defconstant +OCI-FO-BEGIN+ #x00000008) ; (defconstant +OCI-FO-ERROR+ #x00000010) ; ;- ;- Fail Over Types - -(defconstant +OCI-FO-NONE+ #x00000001) ; +(defconstant +OCI-FO-NONE+ #x00000001) ; (defconstant +OCI-FO-SESSION+ #x00000002) ; (defconstant +OCI-FO-SELECT+ #x00000004) ; (defconstant +OCI-FO-TXNAL+ #x00000008) ; ;- ;-Function Codes- -(defconstant +OCI-FNCODE-INITIALIZE+ 1) ; OCIInitialize +(defconstant +OCI-FNCODE-INITIALIZE+ 1) ; OCIInitialize (defconstant +OCI-FNCODE-HANDLEALLOC+ 2) ; OCIHandleAlloc -(defconstant +OCI-FNCODE-HANDLEFREE+ 3) ; OCIHandleFree +(defconstant +OCI-FNCODE-HANDLEFREE+ 3) ; OCIHandleFree (defconstant +OCI-FNCODE-DESCRIPTORALLOC+ 4) ; OCIDescriptorAlloc (defconstant +OCI-FNCODE-DESCRIPTORFREE+ 5) ; OCIDescriptorFree -(defconstant +OCI-FNCODE-ENVINIT+ 6) ; OCIEnvInit +(defconstant +OCI-FNCODE-ENVINIT+ 6) ; OCIEnvInit (defconstant +OCI-FNCODE-SERVERATTACH+ 7) ; OCIServerAttach (defconstant +OCI-FNCODE-SERVERDETACH+ 8) ; OCIServerDetach -; unused 9 +; unused 9 (defconstant +OCI-FNCODE-SESSIONBEGIN+ 10) ; OCISessionBegin (defconstant +OCI-FNCODE-SESSIONEND+ 11) ; OCISessionEnd (defconstant +OCI-FNCODE-PASSWORDCHANGE+ 12) ; OCIPasswordChange @@ -424,13 +424,13 @@ (defconstant +OCI-FNCODE-BINDDYNAMIC+ 17) ; OCIBindDynamic (defconstant +OCI-FNCODE-BINDOBJECT+ 18) ; OCIBindObject ; 19 unused -(defconstant +OCI-FNCODE-BINDARRAYOFSTRUCT+ 20) ; OCIBindArrayOfStruct +(defconstant +OCI-FNCODE-BINDARRAYOFSTRUCT+ 20) ; OCIBindArrayOfStruct (defconstant +OCI-FNCODE-STMTEXECUTE+ 21) ; OCIStmtExecute ; unused 22-24 (defconstant +OCI-FNCODE-DEFINEOBJECT+ 25) ; OCIDefineObject (defconstant +OCI-FNCODE-DEFINEDYNAMIC+ 26) ; OCIDefineDynamic (defconstant +OCI-FNCODE-DEFINEARRAYOFSTRUCT+ 27) ; OCIDefineArrayOfStruct -(defconstant +OCI-FNCODE-STMTFETCH+ 28) ; OCIStmtFetch +(defconstant +OCI-FNCODE-STMTFETCH+ 28) ; OCIStmtFetch (defconstant +OCI-FNCODE-STMTGETBIND+ 29) ; OCIStmtGetBindInfo ; 30, 31 unused (defconstant +OCI-FNCODE-DESCRIBEANY+ 32) ; OCIDescribeAny @@ -438,26 +438,26 @@ (defconstant +OCI-FNCODE-TRANSDETACH+ 34) ; OCITransDetach (defconstant +OCI-FNCODE-TRANSCOMMIT+ 35) ; OCITransCommit ; 36 unused -(defconstant +OCI-FNCODE-ERRORGET+ 37) ; OCIErrorGet +(defconstant +OCI-FNCODE-ERRORGET+ 37) ; OCIErrorGet (defconstant +OCI-FNCODE-LOBOPENFILE+ 38) ; OCILobFileOpen (defconstant +OCI-FNCODE-LOBCLOSEFILE+ 39) ; OCILobFileClose ; 40 was LOBCREATEFILE, unused ; 41 was OCILobFileDelete, unused -(defconstant +OCI-FNCODE-LOBCOPY+ 42) ; OCILobCopy -(defconstant +OCI-FNCODE-LOBAPPEND+ 43) ; OCILobAppend -(defconstant +OCI-FNCODE-LOBERASE+ 44) ; OCILobErase -(defconstant +OCI-FNCODE-LOBLENGTH+ 45) ; OCILobGetLength -(defconstant +OCI-FNCODE-LOBTRIM+ 46) ; OCILobTrim -(defconstant +OCI-FNCODE-LOBREAD+ 47) ; OCILobRead -(defconstant +OCI-FNCODE-LOBWRITE+ 48) ; OCILobWrite +(defconstant +OCI-FNCODE-LOBCOPY+ 42) ; OCILobCopy +(defconstant +OCI-FNCODE-LOBAPPEND+ 43) ; OCILobAppend +(defconstant +OCI-FNCODE-LOBERASE+ 44) ; OCILobErase +(defconstant +OCI-FNCODE-LOBLENGTH+ 45) ; OCILobGetLength +(defconstant +OCI-FNCODE-LOBTRIM+ 46) ; OCILobTrim +(defconstant +OCI-FNCODE-LOBREAD+ 47) ; OCILobRead +(defconstant +OCI-FNCODE-LOBWRITE+ 48) ; OCILobWrite ; 49 unused (defconstant +OCI-FNCODE-SVCCTXBREAK+ 50) ; OCIBreak (defconstant +OCI-FNCODE-SERVERVERSION+ 51) ; OCIServerVersion ; unused 52, 53 -(defconstant +OCI-FNCODE-ATTRGET+ 54) ; OCIAttrGet -(defconstant +OCI-FNCODE-ATTRSET+ 55) ; OCIAttrSet -(defconstant +OCI-FNCODE-PARAMSET+ 56) ; OCIParamSet -(defconstant +OCI-FNCODE-PARAMGET+ 57) ; OCIParamGet +(defconstant +OCI-FNCODE-ATTRGET+ 54) ; OCIAttrGet +(defconstant +OCI-FNCODE-ATTRSET+ 55) ; OCIAttrSet +(defconstant +OCI-FNCODE-PARAMSET+ 56) ; OCIParamSet +(defconstant +OCI-FNCODE-PARAMGET+ 57) ; OCIParamGet (defconstant +OCI-FNCODE-STMTGETPIECEINFO+ 58) ; OCIStmtGetPieceInfo (defconstant +OCI-FNCODE-LDATOSVCCTX+ 59) ; OCILdaToSvcCtx ; 60 unused @@ -466,19 +466,19 @@ (defconstant +OCI-FNCODE-TRANSPREPARE+ 63) ; OCITransPrepare (defconstant +OCI-FNCODE-TRANSROLLBACK+ 64) ; OCITransRollback (defconstant +OCI-FNCODE-DEFINEBYPOS+ 65) ; OCIDefineByPos -(defconstant +OCI-FNCODE-BINDBYPOS+ 66) ; OCIBindByPos +(defconstant +OCI-FNCODE-BINDBYPOS+ 66) ; OCIBindByPos (defconstant +OCI-FNCODE-BINDBYNAME+ 67) ; OCIBindByName -(defconstant +OCI-FNCODE-LOBASSIGN+ 68) ; OCILobAssign +(defconstant +OCI-FNCODE-LOBASSIGN+ 68) ; OCILobAssign (defconstant +OCI-FNCODE-LOBISEQUAL+ 69) ; OCILobIsEqual -(defconstant +OCI-FNCODE-LOBISINIT+ 70) ; OCILobLocatorIsInit +(defconstant +OCI-FNCODE-LOBISINIT+ 70) ; OCILobLocatorIsInit ; 71 was lob locator size in beta2 (defconstant +OCI-FNCODE-LOBENABLEBUFFERING+ 71) ; OCILobEnableBuffering (defconstant +OCI-FNCODE-LOBCHARSETID+ 72) ; OCILobCharSetID (defconstant +OCI-FNCODE-LOBCHARSETFORM+ 73) ; OCILobCharSetForm (defconstant +OCI-FNCODE-LOBFILESETNAME+ 74) ; OCILobFileSetName (defconstant +OCI-FNCODE-LOBFILEGETNAME+ 75) ; OCILobFileGetName -(defconstant +OCI-FNCODE-LOGON+ 76) ; OCILogon -(defconstant +OCI-FNCODE-LOGOFF+ 77) ; OCILogoff +(defconstant +OCI-FNCODE-LOGON+ 76) ; OCILogon +(defconstant +OCI-FNCODE-LOGOFF+ 77) ; OCILogoff (defconstant +OCI-FNCODE-LOBDISABLEBUFFERING+ 78) ; OCILobDisableBuffering (defconstant +OCI-FNCODE-LOBFLUSHBUFFER+ 79) ; OCILobFlushBuffer (defconstant +OCI-FNCODE-LOBLOADFROMFILE+ 80) ; OCILobLoadFromFile @@ -487,55 +487,55 @@ ;- ;- FILE open modes - -(defconstant +OCI-FILE-READONLY+ 1) ; readonly mode open for FILE types +(defconstant +OCI-FILE-READONLY+ 1) ; readonly mode open for FILE types ;- ;- LOB Buffering Flush Flags - -(defconstant +OCI-LOB-BUFFER-FREE+ 1) ; +(defconstant +OCI-LOB-BUFFER-FREE+ 1) ; (defconstant +OCI-LOB-BUFFER-NOFREE+ 2) ; ;- ;- OCI Statement Types - -(defconstant +oci-stmt-select+ 1) ; select statement -(defconstant +oci-stmt-update+ 2) ; update statement -(defconstant +oci-stmt-delete+ 3) ; delete statement -(defconstant +oci-stmt-insert+ 4) ; insert statement -(defconstant +oci-stmt-create+ 5) ; create statement -(defconstant +oci-stmt-drop+ 6) ; drop statement -(defconstant +oci-stmt-alter+ 7) ; alter statement -(defconstant +oci-stmt-begin+ 8) ; begin ... (pl/sql statement) -(defconstant +oci-stmt-declare+ 9) ; declare .. (pl/sql statement ) +(defconstant +oci-stmt-select+ 1) ; select statement +(defconstant +oci-stmt-update+ 2) ; update statement +(defconstant +oci-stmt-delete+ 3) ; delete statement +(defconstant +oci-stmt-insert+ 4) ; insert statement +(defconstant +oci-stmt-create+ 5) ; create statement +(defconstant +oci-stmt-drop+ 6) ; drop statement +(defconstant +oci-stmt-alter+ 7) ; alter statement +(defconstant +oci-stmt-begin+ 8) ; begin ... (pl/sql statement) +(defconstant +oci-stmt-declare+ 9) ; declare .. (pl/sql statement ) ;- ;- OCI Parameter Types - -(defconstant +OCI-PTYPE-UNK+ 0) ; unknown -(defconstant +OCI-PTYPE-TABLE+ 1) ; table -(defconstant +OCI-PTYPE-VIEW+ 2) ; view -(defconstant +OCI-PTYPE-PROC+ 3) ; procedure -(defconstant +OCI-PTYPE-FUNC+ 4) ; function -(defconstant +OCI-PTYPE-PKG+ 5) ; package -(defconstant +OCI-PTYPE-TYPE+ 6) ; user-defined type -(defconstant +OCI-PTYPE-SYN+ 7) ; synonym -(defconstant +OCI-PTYPE-SEQ+ 8) ; sequence -(defconstant +OCI-PTYPE-COL+ 9) ; column -(defconstant +OCI-PTYPE-ARG+ 10) ; argument -(defconstant +OCI-PTYPE-LIST+ 11) ; list -(defconstant +OCI-PTYPE-TYPE-ATTR+ 12) ; user-defined type's attribute -(defconstant +OCI-PTYPE-TYPE-COLL+ 13) ; collection type's element +(defconstant +OCI-PTYPE-UNK+ 0) ; unknown +(defconstant +OCI-PTYPE-TABLE+ 1) ; table +(defconstant +OCI-PTYPE-VIEW+ 2) ; view +(defconstant +OCI-PTYPE-PROC+ 3) ; procedure +(defconstant +OCI-PTYPE-FUNC+ 4) ; function +(defconstant +OCI-PTYPE-PKG+ 5) ; package +(defconstant +OCI-PTYPE-TYPE+ 6) ; user-defined type +(defconstant +OCI-PTYPE-SYN+ 7) ; synonym +(defconstant +OCI-PTYPE-SEQ+ 8) ; sequence +(defconstant +OCI-PTYPE-COL+ 9) ; column +(defconstant +OCI-PTYPE-ARG+ 10) ; argument +(defconstant +OCI-PTYPE-LIST+ 11) ; list +(defconstant +OCI-PTYPE-TYPE-ATTR+ 12) ; user-defined type's attribute +(defconstant +OCI-PTYPE-TYPE-COLL+ 13) ; collection type's element (defconstant +OCI-PTYPE-TYPE-METHOD+ 14) ; user-defined type's method -(defconstant +OCI-PTYPE-TYPE-ARG+ 15) ; user-defined type method's argument +(defconstant +OCI-PTYPE-TYPE-ARG+ 15) ; user-defined type method's argument (defconstant +OCI-PTYPE-TYPE-RESULT+ 16) ; user-defined type method's result ;- ;- OCI List Types - -(defconstant +OCI-LTYPE-UNK+ 0) ; unknown -(defconstant +OCI-LTYPE-COLUMN+ 1) ; column list -(defconstant +OCI-LTYPE-ARG-PROC+ 2) ; procedure argument list -(defconstant +OCI-LTYPE-ARG-FUNC+ 3) ; function argument list -(defconstant +OCI-LTYPE-SUBPRG+ 4) ; subprogram list -(defconstant +OCI-LTYPE-TYPE-ATTR+ 5) ; type attribute -(defconstant +OCI-LTYPE-TYPE-METHOD+ 6) ; type method +(defconstant +OCI-LTYPE-UNK+ 0) ; unknown +(defconstant +OCI-LTYPE-COLUMN+ 1) ; column list +(defconstant +OCI-LTYPE-ARG-PROC+ 2) ; procedure argument list +(defconstant +OCI-LTYPE-ARG-FUNC+ 3) ; function argument list +(defconstant +OCI-LTYPE-SUBPRG+ 4) ; subprogram list +(defconstant +OCI-LTYPE-TYPE-ATTR+ 5) ; type attribute +(defconstant +OCI-LTYPE-TYPE-METHOD+ 6) ; type method (defconstant +OCI-LTYPE-TYPE-ARG-PROC+ 7) ; type method w/o result argument list (defconstant +OCI-LTYPE-TYPE-ARG-FUNC+ 8) ; type method w/result argument list diff --git a/db-oracle/oracle-objects.lisp b/db-oracle/oracle-objects.lisp index ea9c15b..5c7d7fb 100644 --- a/db-oracle/oracle-objects.lisp +++ b/db-oracle/oracle-objects.lisp @@ -19,65 +19,65 @@ (declare (ignore type args database)) (format nil "VARCHAR2(~D)" *default-string-length*)) -(defmethod database-get-type-specifier ((type (eql 'integer)) args - database (db-type (eql :oracle))) +(defmethod database-get-type-specifier ((type (eql 'integer)) args + database (db-type (eql :oracle))) (declare (ignore database)) (if args (format nil "NUMBER(~A,~A)" - (or (first args) 38) (or (second args) 0)) + (or (first args) 38) (or (second args) 0)) "INTEGER")) (defmethod database-get-type-specifier ((type (eql 'bigint)) args - database (db-type (eql :oracle))) - (declare (ignore args database)) + database (db-type (eql :oracle))) + (declare (ignore args database)) "CHAR(20)") (defmethod database-get-type-specifier ((type (eql 'universal-time)) args - database (db-type (eql :oracle))) - (declare (ignore args database)) + database (db-type (eql :oracle))) + (declare (ignore args database)) "CHAR(20)") (defmethod database-get-type-specifier ((type (eql 'string)) args - database (db-type (eql :oracle))) - (declare (ignore database)) + database (db-type (eql :oracle))) + (declare (ignore database)) (if args (format nil "CHAR(~A)" (car args)) (format nil "VARCHAR2(~D)" *default-string-length*))) (defmethod database-get-type-specifier ((type (eql 'varchar)) args - database (db-type (eql :oracle))) - (declare (ignore database)) + database (db-type (eql :oracle))) + (declare (ignore database)) (if args (format nil "VARCHAR2(~A)" (car args)) (format nil "VARCHAR2(~D)" *default-string-length*))) (defmethod database-get-type-specifier ((type (eql 'float)) args - database (db-type (eql :oracle))) - (declare (ignore database)) + database (db-type (eql :oracle))) + (declare (ignore database)) (if args (format nil "NUMBER(~A,~A)" (or (first args) 38) (or (second args) 38)) "DOUBLE PRECISION")) (defmethod database-get-type-specifier ((type (eql 'long-float)) args - database (db-type (eql :oracle))) - (declare (ignore database)) + database (db-type (eql :oracle))) + (declare (ignore database)) (if args (format nil "NUMBER(~A,~A)" - (or (first args) 38) (or (second args) 38)) + (or (first args) 38) (or (second args) 38)) "DOUBLE PRECISION")) (defmethod database-get-type-specifier ((type (eql 'boolean)) args - database (db-type (eql :oracle))) + database (db-type (eql :oracle))) (declare (ignore args database)) "CHAR(1)") (defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args - database (db-type (eql :oracle))) + database (db-type (eql :oracle))) (declare (ignore args database)) "CHAR(1)") (defmethod read-sql-value (val type - database (db-type (eql :oracle))) + database (db-type (eql :oracle))) ;;(format t "value is \"~A\" of type ~A~%" val (type-of val)) (declare (ignore type database)) (etypecase val @@ -87,44 +87,44 @@ nil))) (defmethod read-sql-value (val (type (eql 'integer)) - database (db-type (eql :oracle))) + database (db-type (eql :oracle))) (declare (ignore database)) val) (defmethod read-sql-value (val (type (eql 'float)) - database (db-type (eql :oracle))) + database (db-type (eql :oracle))) (declare (ignore database)) val) (defmethod read-sql-value (val (type (eql 'boolean)) - database (db-type (eql :oracle))) + database (db-type (eql :oracle))) (declare (ignore database)) (when (char-equal #\t (schar val 0)) t)) (defmethod read-sql-value (val (type (eql 'generalized-boolean)) - database (db-type (eql :oracle))) + database (db-type (eql :oracle))) (declare (ignore database)) (when (char-equal #\t (schar val 0)) t)) (defmethod read-sql-value (val (type (eql 'bigint)) - database (db-type (eql :oracle))) + database (db-type (eql :oracle))) (declare (ignore database)) (parse-integer val)) (defmethod read-sql-value (val (type (eql 'universal-time)) - database (db-type (eql :oracle))) + database (db-type (eql :oracle))) (declare (ignore database)) (parse-integer val)) (defmethod database-get-type-specifier ((type (eql 'wall-time)) args - database (db-type (eql :oracle))) + database (db-type (eql :oracle))) (declare (ignore args database)) "DATE") (defmethod database-get-type-specifier ((type (eql 'duration)) args - database (db-type (eql :oracle))) + database (db-type (eql :oracle))) (declare (ignore args database)) "NUMBER(38)") diff --git a/db-oracle/oracle-package.lisp b/db-oracle/oracle-package.lisp index 07f0a55..462c858 100644 --- a/db-oracle/oracle-package.lisp +++ b/db-oracle/oracle-package.lisp @@ -19,7 +19,7 @@ (defpackage #:clsql-oracle (:use #:common-lisp #:clsql-sys #:clsql-uffi) (:export #:oracle-database - #:*oracle-server-version* - #:*oracle-so-load-path* - #:*oracle-so-libraries*) + #:*oracle-server-version* + #:*oracle-so-load-path* + #:*oracle-so-libraries*) (:documentation "This is the CLSQL interface to Oracle.")) diff --git a/db-oracle/oracle-sql.lisp b/db-oracle/oracle-sql.lisp index 3f5cb49..87d1137 100644 --- a/db-oracle/oracle-sql.lisp +++ b/db-oracle/oracle-sql.lisp @@ -143,8 +143,8 @@ the length of that format.") (error 'sql-database-error :message "Check ORACLE_HOME and NLS settings.")) (t (error 'sql-database-error - :message - (format nil "OCI unknown error, code=~A" result))))) + :message + (format nil "OCI unknown error, code=~A" result))))) ;;; Handle the messy case of return code=+oci-error+, querying the ;;; system for subcodes and reporting them as appropriate. ERRHP and @@ -156,34 +156,34 @@ the length of that format.") (with-slots (errhp) database (let ((errcode (uffi:allocate-foreign-object 'sb4)) (errbuf (uffi:allocate-foreign-string #.+errbuf-len+))) - ;; ensure errbuf empty string - (setf (uffi:deref-array errbuf '(:array :unsigned-char) 0) - (uffi:ensure-char-storable (code-char 0))) - (setf (uffi:deref-pointer errcode 'sb4) 0) - - (uffi:with-cstring (sqlstate nil) - (oci-error-get (deref-vp errhp) 1 - sqlstate - errcode - (uffi:char-array-to-pointer errbuf) - +errbuf-len+ +oci-htype-error+)) - (let ((subcode (uffi:deref-pointer errcode 'sb4)) - (errstr (uffi:convert-from-foreign-string errbuf))) + ;; ensure errbuf empty string + (setf (uffi:deref-array errbuf '(:array :unsigned-char) 0) + (uffi:ensure-char-storable (code-char 0))) + (setf (uffi:deref-pointer errcode 'sb4) 0) + + (uffi:with-cstring (sqlstate nil) + (oci-error-get (deref-vp errhp) 1 + sqlstate + errcode + (uffi:char-array-to-pointer errbuf) + +errbuf-len+ +oci-htype-error+)) + (let ((subcode (uffi:deref-pointer errcode 'sb4)) + (errstr (uffi:convert-from-foreign-string errbuf))) (uffi:free-foreign-object errcode) (uffi:free-foreign-object errbuf) - (unless (and nulls-ok (= subcode +null-value-returned+)) - (error 'sql-database-error - :database database - :error-id subcode - :message errstr)))))) + (unless (and nulls-ok (= subcode +null-value-returned+)) + (error 'sql-database-error + :database database + :error-id subcode + :message errstr)))))) (nulls-ok (error 'sql-database-error - :database database - :message "can't handle NULLS-OK without ERRHP")) + :database database + :message "can't handle NULLS-OK without ERRHP")) (t (error 'sql-database-error - :database database - :message "OCI Error (and no ERRHP available to find subcode)")))) + :database database + :message "OCI Error (and no ERRHP available to find subcode)")))) ;;; Require an OCI success code. ;;; @@ -199,7 +199,7 @@ the length of that format.") (declare (type fixnum code)) (unless (= code +oci-success+) (error 'sql-database-error - :message (format nil "unexpected OCI failure, code=~S" code)))) + :message (format nil "unexpected OCI failure, code=~S" code)))) ;;; Enabling this can be handy for low-level debugging. @@ -222,9 +222,9 @@ the length of that format.") (declare (type (mod #.+n-buf-rows+) string-index)) (declare (type (and unsigned-byte fixnum) size)) (let ((str (uffi:convert-from-foreign-string - (uffi:make-pointer - (+ (uffi:pointer-address arrayptr) (* string-index size)) - :unsigned-char)))) + (uffi:make-pointer + (+ (uffi:pointer-address arrayptr) (* string-index size)) + :unsigned-char)))) (if (string-equal str "NULL") nil str))) ;; the OCI library, part Z: no-longer used logic to convert from @@ -240,42 +240,42 @@ the length of that format.") #+nil (defun deref-oci-date (arrayptr index) (oci-date->universal-time (uffi:pointer-address - (uffi:deref-array arrayptr - '(:array :unsigned-char) - (* index +oci-date-bytes+))))) + (uffi:deref-array arrayptr + '(:array :unsigned-char) + (* index +oci-date-bytes+))))) #+nil (defun oci-date->universal-time (oci-date) (declare (type (alien (* :unsigned-char)) oci-date)) (flet (;; a character from OCI-DATE, interpreted as an unsigned byte - (ub (i) - (declare (type (mod #.+oci-date-bytes+) i)) - (mod (uffi:deref-array oci-date string-array i) 256))) + (ub (i) + (declare (type (mod #.+oci-date-bytes+) i)) + (mod (uffi:deref-array oci-date string-array i) 256))) (let* ((century (* (- (ub 0) 100) 100)) - (year (+ century (- (ub 1) 100))) - (month (ub 2)) - (day (ub 3)) - (hour (1- (ub 4))) - (minute (1- (ub 5))) - (second (1- (ub 6)))) + (year (+ century (- (ub 1) 100))) + (month (ub 2)) + (day (ub 3)) + (hour (1- (ub 4))) + (minute (1- (ub 5))) + (second (1- (ub 6)))) (encode-universal-time second minute hour day month year)))) (defmethod database-list-tables ((database oracle-database) &key owner) (let ((query - (cond ((null owner) + (cond ((null owner) "select table_name from user_tables") ((eq owner :all) "select table_name from all_tables") (t (format nil "select user_tables.table_name from user_tables,all_tables where user_tables.table_name=all_tables.table_name and all_tables.owner='~:@(~A~)'" - owner))))) + owner))))) (mapcar #'car (database-query query database nil nil)))) (defmethod database-list-views ((database oracle-database) &key owner) (let ((query - (cond ((null owner) + (cond ((null owner) "select view_name from user_views") ((eq owner :all) "select view_name from all_views") @@ -299,7 +299,7 @@ the length of that format.") (mapcar #'car (database-query query database nil nil)))) (defmethod database-list-table-indexes (table (database oracle-database) - &key (owner nil)) + &key (owner nil)) (let ((query (cond ((null owner) (format nil "select index_name from user_indexes where table_name='~A'" @@ -329,10 +329,10 @@ the length of that format.") (mapcar #'car (database-query query database nil nil)))) (defmethod database-attribute-type (attribute (table string) - (database oracle-database) - &key (owner nil)) + (database oracle-database) + &key (owner nil)) (let ((query - (cond ((null owner) + (cond ((null owner) (format nil "select data_type,data_length,data_scale,nullable from user_tab_columns where table_name='~A' and column_name='~A'" table attribute)) @@ -346,7 +346,7 @@ the length of that format.") table attribute owner))))) (destructuring-bind (type length scale nullable) (car (database-query query database :auto nil)) (values (ensure-keyword type) length scale - (if (char-equal #\Y (schar nullable 0)) 1 0))))) + (if (char-equal #\Y (schar nullable 0)) 1 0))))) ;; Return one row of the table referred to by QC, represented as a ;; list; or if there are no more rows, signal an error if EOF-ERRORP, @@ -380,11 +380,11 @@ the length of that format.") :type oracle-database :read-only t) (stmthp (error "missing STMTHP") ; the statement handle used to create -;; :type alien ; this table. owned by the QUERY-CURSOR +;; :type alien ; this table. owned by the QUERY-CURSOR :read-only t) ; object, deallocated on CLOSE-QUERY (cds) ; (error "missing CDS") ; column descriptors ; :type (simple-array cd 1) - ; :read-only t) + ; :read-only t) (n-from-oci 0 ; buffered rows: number of rows recv'd :type (integer 0 #.+n-buf-rows+)) ; from the database on the last read @@ -407,48 +407,48 @@ the length of that format.") (defun fetch-row (qc &optional (eof-errorp t) eof-value) (declare (optimize (speed 3))) (cond ((zerop (qc-n-from-oci qc)) - (if eof-errorp - (error 'sql-database-error :message - (format nil "no more rows available in ~S" qc)) - eof-value)) - ((>= (qc-n-to-dbi qc) - (qc-n-from-oci qc)) - (refill-qc-buffers qc) - (fetch-row qc nil eof-value)) - (t - (let ((cds (qc-cds qc)) - (reversed-result nil) - (irow (qc-n-to-dbi qc))) - (dotimes (icd (length cds)) - (let* ((cd (aref cds icd)) - (b (foreign-resource-buffer (cd-buffer cd))) - (value - (let* ((arb (foreign-resource-buffer (cd-indicators cd))) - (indicator (uffi:deref-array arb '(:array :short) irow))) - (declare (type short-array arb)) - (unless (= indicator -1) - (ecase (cd-oci-data-type cd) - (#.SQLT-STR - (deref-oci-string b irow (cd-sizeof cd))) - (#.SQLT-FLT + (if eof-errorp + (error 'sql-database-error :message + (format nil "no more rows available in ~S" qc)) + eof-value)) + ((>= (qc-n-to-dbi qc) + (qc-n-from-oci qc)) + (refill-qc-buffers qc) + (fetch-row qc nil eof-value)) + (t + (let ((cds (qc-cds qc)) + (reversed-result nil) + (irow (qc-n-to-dbi qc))) + (dotimes (icd (length cds)) + (let* ((cd (aref cds icd)) + (b (foreign-resource-buffer (cd-buffer cd))) + (value + (let* ((arb (foreign-resource-buffer (cd-indicators cd))) + (indicator (uffi:deref-array arb '(:array :short) irow))) + (declare (type short-array arb)) + (unless (= indicator -1) + (ecase (cd-oci-data-type cd) + (#.SQLT-STR + (deref-oci-string b irow (cd-sizeof cd))) + (#.SQLT-FLT (locally (declare (type double-array b)) (uffi:deref-array b '(:array :double) irow))) - (#.SQLT-INT - (ecase (cd-sizeof cd) - (4 + (#.SQLT-INT + (ecase (cd-sizeof cd) + (4 (locally (declare (type int-array b)) (uffi:deref-array b '(:array :int) irow))))) - (#.SQLT-DATE - (deref-oci-string b irow (cd-sizeof cd)))))))) - (when (and (eq :string (cd-result-type cd)) - value - (not (stringp value))) - (setq value (write-to-string value))) - (push value reversed-result))) - (incf (qc-n-to-dbi qc)) - (nreverse reversed-result))))) + (#.SQLT-DATE + (deref-oci-string b irow (cd-sizeof cd)))))))) + (when (and (eq :string (cd-result-type cd)) + value + (not (stringp value))) + (setq value (write-to-string value))) + (push value reversed-result))) + (incf (qc-n-to-dbi qc)) + (nreverse reversed-result))))) (defun refill-qc-buffers (qc) (with-slots (errhp) (qc-db qc) @@ -457,10 +457,10 @@ the length of that format.") (setf (qc-n-from-oci qc) 0)) (t (let ((oci-code (%oci-stmt-fetch - (deref-vp (qc-stmthp qc)) - (deref-vp errhp) - +n-buf-rows+ - +oci-fetch-next+ +oci-default+))) + (deref-vp (qc-stmthp qc)) + (deref-vp errhp) + +n-buf-rows+ + +oci-fetch-next+ +oci-default+))) (ecase oci-code (#.+oci-success+ (values)) (#.+oci-no-data+ (setf (qc-oci-end-seen-p qc) t) @@ -469,14 +469,14 @@ the length of that format.") :nulls-ok t)))) (uffi:with-foreign-object (rowcount 'ub4) (oci-attr-get (deref-vp (qc-stmthp qc)) - +oci-htype-stmt+ + +oci-htype-stmt+ rowcount - +unsigned-int-null-pointer+ - +oci-attr-row-count+ + +unsigned-int-null-pointer+ + +oci-attr-row-count+ (deref-vp errhp)) (setf (qc-n-from-oci qc) (- (uffi:deref-pointer rowcount 'ub4) - (qc-total-n-from-oci qc))) + (qc-total-n-from-oci qc))) (when (< (qc-n-from-oci qc) +n-buf-rows+) (setf (qc-oci-end-seen-p qc) t)) (setf (qc-total-n-from-oci qc) @@ -550,10 +550,10 @@ the length of that format.") (defun make-query-cursor (db stmthp result-types field-names) (let ((qc (%make-query-cursor :db db - :stmthp stmthp - :cds (make-query-cursor-cds db stmthp - result-types - field-names)))) + :stmthp stmthp + :cds (make-query-cursor-cds db stmthp + result-types + field-names)))) (refill-qc-buffers qc) qc)) @@ -633,122 +633,122 @@ the length of that format.") (defun make-query-cursor-cds (database stmthp result-types field-names) (declare (optimize (safety 3) #+nil (speed 3)) - (type oracle-database database) - (type pointer-pointer-void stmthp)) + (type oracle-database database) + (type pointer-pointer-void stmthp)) (with-slots (errhp) database (uffi:with-foreign-objects ((dtype-foreign :unsigned-short) - (parmdp :pointer-void) - (precision :short) - (scale :byte) - (colname '(* :unsigned-char)) - (colnamelen 'ub4) - (colsize 'ub2) - (defnp ':pointer-void)) + (parmdp :pointer-void) + (precision :short) + (scale :byte) + (colname '(* :unsigned-char)) + (colnamelen 'ub4) + (colsize 'ub2) + (defnp ':pointer-void)) (let ((buffer nil) - (sizeof nil)) - (do ((icolumn 0 (1+ icolumn)) - (cds-as-reversed-list nil)) - ((not (eql (oci-param-get (deref-vp stmthp) - +oci-htype-stmt+ - (deref-vp errhp) - parmdp - (1+ icolumn) :database database) - +oci-success+)) - (coerce (reverse cds-as-reversed-list) 'simple-vector)) - ;; Decode type of ICOLUMNth column into a type we're prepared to - ;; handle in Lisp. - (oci-attr-get (deref-vp parmdp) - +oci-dtype-param+ - dtype-foreign - +unsigned-int-null-pointer+ - +oci-attr-data-type+ - (deref-vp errhp)) - (let ((dtype (uffi:deref-pointer dtype-foreign :unsigned-short))) - (declare (fixnum dtype)) - (case dtype - (#.SQLT-DATE - (setf buffer (acquire-foreign-resource :unsigned-char - (* 32 +n-buf-rows+))) - (setf sizeof 32 dtype #.SQLT-STR)) - (#.SQLT-NUMBER - (oci-attr-get (deref-vp parmdp) - +oci-dtype-param+ - precision - +unsigned-int-null-pointer+ - +oci-attr-precision+ - (deref-vp errhp)) - (oci-attr-get (deref-vp parmdp) - +oci-dtype-param+ - scale - +unsigned-int-null-pointer+ - +oci-attr-scale+ - (deref-vp errhp)) - (let ((*scale (uffi:deref-pointer scale :byte)) - (*precision (uffi:deref-pointer precision :short))) - - ;;(format t "scale=~d, precision=~d~%" *scale *precision) - (cond - ((or (and (minusp *scale) (zerop *precision)) - (and (zerop *scale) (plusp *precision))) - (setf buffer (acquire-foreign-resource :int +n-buf-rows+) - sizeof 4 ;; sizeof(int) - dtype #.SQLT-INT)) - (t - (setf buffer (acquire-foreign-resource :double +n-buf-rows+) - sizeof 8 ;; sizeof(double) - dtype #.SQLT-FLT))))) - ;; Default to SQL-STR - (t - (setf (uffi:deref-pointer colsize :unsigned-short) 0) - (setf dtype #.SQLT-STR) - (oci-attr-get (deref-vp parmdp) - +oci-dtype-param+ - colsize - +unsigned-int-null-pointer+ - +oci-attr-data-size+ - (deref-vp errhp)) - (let ((colsize-including-null (1+ (uffi:deref-pointer colsize :unsigned-short)))) - (setf buffer (acquire-foreign-resource - :unsigned-char (* +n-buf-rows+ colsize-including-null))) - (setf sizeof colsize-including-null)))) - (let ((retcodes (acquire-foreign-resource :unsigned-short +n-buf-rows+)) - (indicators (acquire-foreign-resource :short +n-buf-rows+)) - (colname-string "")) - (when field-names - (oci-attr-get (deref-vp parmdp) - +oci-dtype-param+ - colname - colnamelen - +oci-attr-name+ - (deref-vp errhp)) - (setq colname-string (uffi:convert-from-foreign-string - (uffi:deref-pointer colname '(* :unsigned-char)) - :length (uffi:deref-pointer colnamelen 'ub4)))) - (push (make-cd :name colname-string - :sizeof sizeof - :buffer buffer - :oci-data-type dtype - :retcodes retcodes - :indicators indicators - :result-type (cond - ((consp result-types) - (nth icolumn result-types)) - ((null result-types) - :string) - (t - result-types))) - cds-as-reversed-list) - (oci-define-by-pos (deref-vp stmthp) - defnp - (deref-vp errhp) - (1+ icolumn) ; OCI 1-based indexing again - (foreign-resource-buffer buffer) - sizeof - dtype - (foreign-resource-buffer indicators) - +unsigned-short-null-pointer+ - (foreign-resource-buffer retcodes) - +oci-default+)))))))) + (sizeof nil)) + (do ((icolumn 0 (1+ icolumn)) + (cds-as-reversed-list nil)) + ((not (eql (oci-param-get (deref-vp stmthp) + +oci-htype-stmt+ + (deref-vp errhp) + parmdp + (1+ icolumn) :database database) + +oci-success+)) + (coerce (reverse cds-as-reversed-list) 'simple-vector)) + ;; Decode type of ICOLUMNth column into a type we're prepared to + ;; handle in Lisp. + (oci-attr-get (deref-vp parmdp) + +oci-dtype-param+ + dtype-foreign + +unsigned-int-null-pointer+ + +oci-attr-data-type+ + (deref-vp errhp)) + (let ((dtype (uffi:deref-pointer dtype-foreign :unsigned-short))) + (declare (fixnum dtype)) + (case dtype + (#.SQLT-DATE + (setf buffer (acquire-foreign-resource :unsigned-char + (* 32 +n-buf-rows+))) + (setf sizeof 32 dtype #.SQLT-STR)) + (#.SQLT-NUMBER + (oci-attr-get (deref-vp parmdp) + +oci-dtype-param+ + precision + +unsigned-int-null-pointer+ + +oci-attr-precision+ + (deref-vp errhp)) + (oci-attr-get (deref-vp parmdp) + +oci-dtype-param+ + scale + +unsigned-int-null-pointer+ + +oci-attr-scale+ + (deref-vp errhp)) + (let ((*scale (uffi:deref-pointer scale :byte)) + (*precision (uffi:deref-pointer precision :short))) + + ;;(format t "scale=~d, precision=~d~%" *scale *precision) + (cond + ((or (and (minusp *scale) (zerop *precision)) + (and (zerop *scale) (plusp *precision))) + (setf buffer (acquire-foreign-resource :int +n-buf-rows+) + sizeof 4 ;; sizeof(int) + dtype #.SQLT-INT)) + (t + (setf buffer (acquire-foreign-resource :double +n-buf-rows+) + sizeof 8 ;; sizeof(double) + dtype #.SQLT-FLT))))) + ;; Default to SQL-STR + (t + (setf (uffi:deref-pointer colsize :unsigned-short) 0) + (setf dtype #.SQLT-STR) + (oci-attr-get (deref-vp parmdp) + +oci-dtype-param+ + colsize + +unsigned-int-null-pointer+ + +oci-attr-data-size+ + (deref-vp errhp)) + (let ((colsize-including-null (1+ (uffi:deref-pointer colsize :unsigned-short)))) + (setf buffer (acquire-foreign-resource + :unsigned-char (* +n-buf-rows+ colsize-including-null))) + (setf sizeof colsize-including-null)))) + (let ((retcodes (acquire-foreign-resource :unsigned-short +n-buf-rows+)) + (indicators (acquire-foreign-resource :short +n-buf-rows+)) + (colname-string "")) + (when field-names + (oci-attr-get (deref-vp parmdp) + +oci-dtype-param+ + colname + colnamelen + +oci-attr-name+ + (deref-vp errhp)) + (setq colname-string (uffi:convert-from-foreign-string + (uffi:deref-pointer colname '(* :unsigned-char)) + :length (uffi:deref-pointer colnamelen 'ub4)))) + (push (make-cd :name colname-string + :sizeof sizeof + :buffer buffer + :oci-data-type dtype + :retcodes retcodes + :indicators indicators + :result-type (cond + ((consp result-types) + (nth icolumn result-types)) + ((null result-types) + :string) + (t + result-types))) + cds-as-reversed-list) + (oci-define-by-pos (deref-vp stmthp) + defnp + (deref-vp errhp) + (1+ icolumn) ; OCI 1-based indexing again + (foreign-resource-buffer buffer) + sizeof + dtype + (foreign-resource-buffer indicators) + +unsigned-short-null-pointer+ + (foreign-resource-buffer retcodes) + +oci-default+)))))))) ;; Release the resources associated with a QUERY-CURSOR. @@ -795,33 +795,33 @@ the length of that format.") #-oci7 (oci-env-create envhp +oci-default+ +null-void-pointer+ - +null-void-pointer+ +null-void-pointer+ - +null-void-pointer+ 0 +null-void-pointer-pointer+) + +null-void-pointer+ +null-void-pointer+ + +null-void-pointer+ 0 +null-void-pointer-pointer+) #+oci7 (progn - (oci-initialize +oci-object+ +null-void-pointer+ +null-void-pointer+ - +null-void-pointer+ +null-void-pointer-pointer+) + (oci-initialize +oci-object+ +null-void-pointer+ +null-void-pointer+ + +null-void-pointer+ +null-void-pointer-pointer+) (ignore-errors (oci-handle-alloc +null-void-pointer+ envhp - +oci-htype-env+ 0 - +null-void-pointer-pointer+)) ;no testing return + +oci-htype-env+ 0 + +null-void-pointer-pointer+)) ;no testing return (oci-env-init envhp +oci-default+ 0 +null-void-pointer-pointer+)) (oci-handle-alloc (deref-vp envhp) errhp - +oci-htype-error+ 0 +null-void-pointer-pointer+) + +oci-htype-error+ 0 +null-void-pointer-pointer+) (oci-handle-alloc (deref-vp envhp) srvhp - +oci-htype-server+ 0 +null-void-pointer-pointer+) + +oci-htype-server+ 0 +null-void-pointer-pointer+) (let ((db (make-instance 'oracle-database - :name (database-name-from-spec connection-spec - database-type) - :connection-spec connection-spec - :envhp envhp - :errhp errhp - :database-type :oracle - :svchp svchp - :dsn data-source-name - :user user))) + :name (database-name-from-spec connection-spec + database-type) + :connection-spec connection-spec + :envhp envhp + :errhp errhp + :database-type :oracle + :svchp svchp + :dsn data-source-name + :user user))) (uffi:with-foreign-strings ((c-user user) (c-password password) (c-data-source-name data-source-name)) @@ -832,16 +832,16 @@ the length of that format.") c-password (length password) c-data-source-name (length data-source-name) :database db)) - ;; :date-format-length (1+ (length date-format))))) - (setf (slot-value db 'clsql-sys::state) :open) + ;; :date-format-length (1+ (length date-format))))) + (setf (slot-value db 'clsql-sys::state) :open) (database-execute-command - (format nil "ALTER SESSION SET NLS_DATE_FORMAT='~A'" (date-format db)) db) - (let ((server-version - (caar (database-query - "SELECT BANNER FROM V$VERSION WHERE BANNER LIKE '%Oracle%'" db nil nil)))) - (setf (slot-value db 'server-version) server-version - (slot-value db 'major-server-version) (major-client-version-from-string - server-version))) + (format nil "ALTER SESSION SET NLS_DATE_FORMAT='~A'" (date-format db)) db) + (let ((server-version + (caar (database-query + "SELECT BANNER FROM V$VERSION WHERE BANNER LIKE '%Oracle%'" db nil nil)))) + (setf (slot-value db 'server-version) server-version + (slot-value db 'major-server-version) (major-client-version-from-string + server-version))) db)))) @@ -869,7 +869,7 @@ the length of that format.") (defmethod database-disconnect ((database oracle-database)) (osucc (oci-logoff (deref-vp (svchp database)) - (deref-vp (errhp database)))) + (deref-vp (errhp database)))) (osucc (oci-handle-free (deref-vp (envhp database)) +oci-htype-env+)) ;; Note: It's neither required nor allowed to explicitly deallocate the ;; ERRHP handle here, since it's owned by the ENVHP deallocated above, @@ -892,19 +892,19 @@ the length of that format.") (let ((cursor (sql-stmt-exec query-expression database result-types field-names))) ;; (declare (type (or query-cursor null) cursor)) (if (null cursor) ; No table was returned. - (values) + (values) (do ((reversed-result nil)) - (nil) - (let* ((eof-value :eof) - (row (fetch-row cursor nil eof-value))) - (when (eq row eof-value) - (close-query cursor) - (if field-names - (return (values (nreverse reversed-result) - (loop for cd across (qc-cds cursor) - collect (cd-name cd)))) - (return (nreverse reversed-result)))) - (push row reversed-result)))))) + (nil) + (let* ((eof-value :eof) + (row (fetch-row cursor nil eof-value))) + (when (eq row eof-value) + (close-query cursor) + (if field-names + (return (values (nreverse reversed-result) + (loop for cd across (qc-cds cursor) + collect (cd-name cd)))) + (return (nreverse reversed-result)))) + (push row reversed-result)))))) (defmethod database-create-sequence (sequence-name (database oracle-database)) @@ -919,26 +919,26 @@ the length of that format.") (defmethod database-sequence-next (sequence-name (database oracle-database)) (caar (database-query - (concatenate 'string "SELECT " - (sql-escape sequence-name) - ".NEXTVAL FROM dual") - database :auto nil))) + (concatenate 'string "SELECT " + (sql-escape sequence-name) + ".NEXTVAL FROM dual") + database :auto nil))) (defmethod database-sequence-last (sequence-name (database oracle-database)) (caar (database-query - (concatenate 'string "SELECT " - (sql-escape sequence-name) - ".CURRVAL FROM dual") - database :auto nil))) + (concatenate 'string "SELECT " + (sql-escape sequence-name) + ".CURRVAL FROM dual") + database :auto nil))) (defmethod database-set-sequence-position (name position (database oracle-database)) (without-interrupts (let* ((next (database-sequence-next name database)) - (incr (- position next))) + (incr (- position next))) (unless (zerop incr) (database-execute-command - (format nil "ALTER SEQUENCE ~A INCREMENT BY ~D" name incr) - database)) + (format nil "ALTER SEQUENCE ~A INCREMENT BY ~D" name incr) + database)) (database-sequence-next name database) (database-execute-command (format nil "ALTER SEQUENCE ~A INCREMENT BY 1" name) @@ -946,7 +946,7 @@ the length of that format.") (defmethod database-list-sequences ((database oracle-database) &key owner) (let ((query - (cond ((null owner) + (cond ((null owner) "select sequence_name from user_sequences") ((eq owner :all) "select sequence_name from all_sequences") @@ -964,7 +964,7 @@ the length of that format.") (defstruct (cd (:constructor make-cd) - (:print-function print-cd)) + (:print-function print-cd)) "a column descriptor: metadata about the data in a table" ;; name of this column @@ -973,33 +973,33 @@ the length of that format.") (sizeof (error "missing SIZE") :type fixnum :read-only t) ;; an array of +N-BUF-ROWS+ elements in C representation (buffer (error "Missing BUFFER") - :type foreign-resource - :read-only t) + :type foreign-resource + :read-only t) ;; an array of +N-BUF-ROWS+ OCI return codes in C representation. ;; (There must be one return code for every element of every ;; row in order to be able to represent nullness.) (retcodes (error "Missing RETCODES") - :type foreign-resource - :read-only t) + :type foreign-resource + :read-only t) (indicators (error "Missing INDICATORS") - :type foreign-resource - :read-only t) + :type foreign-resource + :read-only t) ;; the OCI code for the data type of a single element (oci-data-type (error "missing OCI-DATA-TYPE") - :type fixnum - :read-only t) + :type fixnum + :read-only t) (result-type (error "missing RESULT-TYPE") - :read-only t)) + :read-only t)) (defun print-cd (cd stream depth) (declare (ignore depth)) (print-unreadable-object (cd stream :type t) (format stream - ":NAME ~S :OCI-DATA-TYPE ~S :OCI-DATA-SIZE ~S" - (cd-name cd) - (cd-oci-data-type cd) - (cd-sizeof cd)))) + ":NAME ~S :OCI-DATA-TYPE ~S :OCI-DATA-SIZE ~S" + (cd-name cd) + (cd-oci-data-type cd) + (cd-sizeof cd)))) (defun print-query-cursor (qc stream depth) (declare (ignore depth)) @@ -1008,12 +1008,12 @@ the length of that format.") (defmethod database-query-result-set ((query-expression string) - (database oracle-database) - &key full-set result-types) + (database oracle-database) + &key full-set result-types) (let ((cursor (sql-stmt-exec query-expression database result-types nil))) (if full-set - (values cursor (length (qc-cds cursor)) nil) - (values cursor (length (qc-cds cursor)))))) + (values cursor (length (qc-cds cursor)) nil) + (values cursor (length (qc-cds cursor)))))) (defmethod database-dump-result-set (result-set (database oracle-database)) @@ -1021,10 +1021,10 @@ the length of that format.") (defmethod database-store-next-row (result-set (database oracle-database) list) (let* ((eof-value :eof) - (row (fetch-row result-set nil eof-value))) + (row (fetch-row result-set nil eof-value))) (unless (eq eof-value row) (loop for i from 0 below (length row) - do (setf (nth i list) (nth i row))) + do (setf (nth i list) (nth i row))) list))) (defmethod database-start-transaction ((database oracle-database)) @@ -1033,17 +1033,17 @@ the length of that format.") #+ignore (with-slots (svchp errhp) database (oci-trans-start (deref-vp svchp) - (deref-vp errhp) - 60 - +oci-trans-new+)) + (deref-vp errhp) + 60 + +oci-trans-new+)) t) (defun oracle-commit (database) (with-slots (svchp errhp) database (osucc (oci-trans-commit (deref-vp svchp) - (deref-vp errhp) - 0)))) + (deref-vp errhp) + 0)))) (defmethod database-commit-transaction ((database oracle-database)) (call-next-method) @@ -1053,8 +1053,8 @@ the length of that format.") (defmethod database-abort-transaction ((database oracle-database)) (call-next-method) (osucc (oci-trans-rollback (deref-vp (svchp database)) - (deref-vp (errhp database)) - 0)) + (deref-vp (errhp database)) + 0)) t) ;; Specifications diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp index 3ca868a..31756ef 100644 --- a/db-postgresql-socket/postgresql-socket-api.lisp +++ b/db-postgresql-socket/postgresql-socket-api.lisp @@ -28,7 +28,7 @@ (:float8 701))) (defmethod clsql-sys:database-type-library-loaded ((database-type - (eql :postgresql-socket))) + (eql :postgresql-socket))) "T if foreign library was able to be loaded successfully. Always true for socket interface" t) @@ -42,18 +42,18 @@ socket interface" (defmacro define-message-constants (description &rest clauses) (assert (evenp (length clauses))) (loop with seen-characters = nil - for (name char) on clauses by #'cddr - for char-code = (char-code char) - for doc-string = (format nil "~A (~:C): ~A" description char name) - if (member char seen-characters) - do (error "Duplicate message type ~@C for group ~A" char description) - else - collect - `(defconstant ,name ,char-code ,doc-string) - into result-clauses - and do (push char seen-characters) + for (name char) on clauses by #'cddr + for char-code = (char-code char) + for doc-string = (format nil "~A (~:C): ~A" description char name) + if (member char seen-characters) + do (error "Duplicate message type ~@C for group ~A" char description) + else + collect + `(defconstant ,name ,char-code ,doc-string) + into result-clauses + and do (push char seen-characters) finally - (return `(progn ,@result-clauses)))) + (return `(progn ,@result-clauses)))) (eval-when (:compile-toplevel :load-toplevel :execute) (define-message-constants "Backend Message Constants" @@ -78,7 +78,7 @@ socket interface" (defun send-socket-value-int32 (socket value) (declare (type stream socket) - (type (unsigned-byte 32) value)) + (type (unsigned-byte 32) value)) (write-byte (ldb (byte 8 24) value) socket) (write-byte (ldb (byte 8 16) value) socket) (write-byte (ldb (byte 8 8) value) socket) @@ -87,26 +87,26 @@ socket interface" (defun send-socket-value-int16 (socket value) (declare (type stream socket) - (type (unsigned-byte 16) value)) + (type (unsigned-byte 16) value)) (write-byte (ldb (byte 8 8) value) socket) (write-byte (ldb (byte 8 0) value) socket) nil) (defun send-socket-value-int8 (socket value) (declare (type stream socket) - (type (unsigned-byte 8) value)) + (type (unsigned-byte 8) value)) (write-byte (ldb (byte 8 0) value) socket) nil) (defun send-socket-value-char-code (socket value) (declare (type stream socket) - (type character value)) + (type character value)) (write-byte (ldb (byte 8 0) (char-code value)) socket) nil) (defun send-socket-value-string (socket value) (declare (type stream socket) - (type string value)) + (type string value)) #-sb-unicode (loop for char across value for code = (char-code char) @@ -118,12 +118,12 @@ socket interface" (defun send-socket-value-limstring (socket value limit) (declare (type stream socket) - (type string value) - (type fixnum limit)) + (type string value) + (type fixnum limit)) (let ((length (length value))) (dotimes (i (min length limit)) (let ((code (char-code (char value i)))) - (write-byte code socket))) + (write-byte code socket))) (dotimes (i (- limit length)) (write-byte 0 socket))) nil) @@ -172,12 +172,12 @@ socket interface" (defmacro define-message-sender (name (&rest args) &rest clauses) (let ((socket-var (gensym)) - (body nil)) + (body nil)) (dolist (clause clauses) (let* ((type (first clause)) - (fn (intern (concatenate 'string (symbol-name '#:send-socket-value-) - (symbol-name type))))) - (push `(,fn ,socket-var ,@(rest clause)) body))) + (fn (intern (concatenate 'string (symbol-name '#:send-socket-value-) + (symbol-name type))))) + (push `(,fn ,socket-var ,@(rest clause)) body))) `(defun ,name (,socket-var ,@args) ,@(nreverse body)))) @@ -215,7 +215,7 @@ socket interface" (defun read-socket-sequence (stream length &optional (allow-wide t)) (declare (stream stream) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0))) #-sb-unicode (let ((result (make-string length))) (dotimes (i length result) @@ -238,8 +238,8 @@ socket interface" (unless *crypt-library-loaded* (uffi:load-foreign-library (uffi:find-foreign-library "libcrypt" - '(#+(or 64bit x86-64) "/usr/lib64/" - "/usr/lib/" "/usr/local/lib/" "/lib/")) + '(#+(or 64bit x86-64) "/usr/lib64/" + "/usr/lib/" "/usr/local/lib/" "/lib/")) :supporting-libraries '("c")) (setq *crypt-library-loaded* t))) @@ -266,9 +266,9 @@ socket interface" (:report (lambda (c stream) (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>" - (type-of c) - (postgresql-condition-connection c) - (postgresql-condition-message c))))) + (type-of c) + (postgresql-condition-connection c) + (postgresql-condition-message c))))) (define-condition postgresql-error (error postgresql-condition) ()) @@ -287,8 +287,8 @@ socket interface" (:report (lambda (c stream) (format stream "~@" - (postgresql-condition-connection c) - (postgresql-condition-message c))))) + (postgresql-condition-connection c) + (postgresql-condition-message c))))) ;;; Structures @@ -325,7 +325,7 @@ socket interface" (ext:connect-to-unix-socket (namestring (make-pathname :name ".s.PGSQL" :type (princ-to-string port) - :defaults host)))) + :defaults host)))) (string (ext:connect-to-inet-socket host port)))) @@ -335,7 +335,7 @@ socket interface" (pathname ;; Directory to unix-domain socket (let ((sock (make-instance 'sb-bsd-sockets:local-socket - :type :stream))) + :type :stream))) (sb-bsd-sockets:socket-connect sock (namestring @@ -344,13 +344,13 @@ socket interface" sock)) (string (let ((sock (make-instance 'sb-bsd-sockets:inet-socket - :type :stream - :protocol :tcp))) + :type :stream + :protocol :tcp))) (sb-bsd-sockets:socket-connect - sock - (sb-bsd-sockets:host-ent-address - (sb-bsd-sockets:get-host-by-name host)) - port) + sock + (sb-bsd-sockets:host-ent-address + (sb-bsd-sockets:get-host-by-name host)) + port) sock)))) #+(or cmu scl) @@ -374,32 +374,32 @@ socket interface" (etypecase host (pathname (let ((path (namestring - (make-pathname :name ".s.PGSQL" :type (princ-to-string port) - :defaults host)))) + (make-pathname :name ".s.PGSQL" :type (princ-to-string port) + :defaults host)))) (socket:make-socket :type :stream :address-family :file - :connect :active - :remote-filename path :local-filename path))) + :connect :active + :remote-filename path :local-filename path))) (string (socket:with-pending-connect - (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed")) - (socket:make-socket :type :stream :address-family :internet - :remote-port port :remote-host host - :connect :active :nodelay t)))))) + (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed")) + (socket:make-socket :type :stream :address-family :internet + :remote-port port :remote-host host + :connect :active :nodelay t)))))) #+openmcl (defun open-postgresql-socket-stream (host port) (etypecase host (pathname (let ((path (namestring - (make-pathname :name ".s.PGSQL" :type (princ-to-string port) - :defaults host)))) + (make-pathname :name ".s.PGSQL" :type (princ-to-string port) + :defaults host)))) (ccl:make-socket :type :stream :address-family :file - :connect :active - :remote-filename path :local-filename path))) + :connect :active + :remote-filename path :local-filename path))) (string (ccl:make-socket :type :stream :address-family :internet - :remote-port port :remote-host host - :connect :active :nodelay t)))) + :remote-port port :remote-host host + :connect :active :nodelay t)))) #+lispworks (defun open-postgresql-socket-stream (host port) @@ -408,7 +408,7 @@ socket interface" (error "File sockets not supported on Lispworks.")) (string (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8) - :read-timeout *postgresql-server-socket-timeout*)) + :read-timeout *postgresql-server-socket-timeout*)) )) @@ -427,10 +427,10 @@ socket interface" ;;; Interface Functions (defun open-postgresql-connection (&key (host (cmucl-compat:required-argument)) - (port +postgresql-server-default-port+) - (database (cmucl-compat:required-argument)) - (user (cmucl-compat:required-argument)) - options tty password) + (port +postgresql-server-default-port+) + (database (cmucl-compat:required-argument)) + (user (cmucl-compat:required-argument)) + options tty password) "Open a connection to a PostgreSQL server with the given parameters. Note that host, database and user arguments must be supplied. @@ -454,14 +454,14 @@ order to facilitate automatic reconnection in case of communication troubles." (reopen-postgresql-connection (make-postgresql-connection :host host :port port - :options (or options "") :tty (or tty "") - :database database :user user - :password (or password "")))) + :options (or options "") :tty (or tty "") + :database database :user user + :password (or password "")))) (defun encrypt-md5 (plaintext salt) (string-downcase (format nil "~{~2,'0X~}" - (coerce (md5sum-sequence (concatenate 'string plaintext salt)) 'list)))) + (coerce (md5sum-sequence (concatenate 'string plaintext salt)) 'list)))) (defun reopen-postgresql-connection (connection) "Reopen the given PostgreSQL connection. Closes any existing @@ -469,90 +469,90 @@ connection, if it is still open." (when (postgresql-connection-open-p connection) (close-postgresql-connection connection)) (let ((socket (open-postgresql-socket-stream - (postgresql-connection-host connection) - (postgresql-connection-port connection)))) + (postgresql-connection-host connection) + (postgresql-connection-port connection)))) (unwind-protect - (progn - (setf (postgresql-connection-socket connection) socket) - (send-startup-message socket - (postgresql-connection-database connection) - (postgresql-connection-user connection) - (postgresql-connection-options connection) - (postgresql-connection-tty connection)) - (force-output socket) - (loop - (case (read-socket-value-int8 socket) - (#.+authentication-message+ - (case (read-socket-value-int32 socket) - (0 (return)) - ((1 2) - (error 'postgresql-login-error - :connection connection - :message - "Postmaster expects unsupported Kerberos authentication.")) - (3 - (send-unencrypted-password-message - socket - (postgresql-connection-password connection)) + (progn + (setf (postgresql-connection-socket connection) socket) + (send-startup-message socket + (postgresql-connection-database connection) + (postgresql-connection-user connection) + (postgresql-connection-options connection) + (postgresql-connection-tty connection)) + (force-output socket) + (loop + (case (read-socket-value-int8 socket) + (#.+authentication-message+ + (case (read-socket-value-int32 socket) + (0 (return)) + ((1 2) + (error 'postgresql-login-error + :connection connection + :message + "Postmaster expects unsupported Kerberos authentication.")) + (3 + (send-unencrypted-password-message + socket + (postgresql-connection-password connection)) (force-output socket)) - (4 - (let ((salt (read-socket-sequence socket 2 nil))) - (send-encrypted-password-message - socket - (crypt-password - (postgresql-connection-password connection) salt))) + (4 + (let ((salt (read-socket-sequence socket 2 nil))) + (send-encrypted-password-message + socket + (crypt-password + (postgresql-connection-password connection) salt))) (force-output socket)) - (5 - (let ((salt (read-socket-sequence socket 4 nil))) - (let* ((pwd2 (encrypt-md5 (postgresql-connection-password connection) - (postgresql-connection-user connection))) - (pwd (encrypt-md5 pwd2 salt))) - (send-encrypted-password-message - socket - (concatenate 'string "md5" pwd)))) + (5 + (let ((salt (read-socket-sequence socket 4 nil))) + (let* ((pwd2 (encrypt-md5 (postgresql-connection-password connection) + (postgresql-connection-user connection))) + (pwd (encrypt-md5 pwd2 salt))) + (send-encrypted-password-message + socket + (concatenate 'string "md5" pwd)))) (force-output socket)) - (t - (error 'postgresql-login-error - :connection connection - :message - "Postmaster expects unknown authentication method.")))) - (#.+error-response-message+ - (let ((message (read-socket-value-string socket))) - (error 'postgresql-login-error - :connection connection :message message))) - (t - (error 'postgresql-login-error - :connection connection - :message - "Received garbled message from Postmaster")))) - ;; Start backend communication - (force-output socket) - (loop - (case (read-socket-value-int8 socket) - (#.+backend-key-message+ - (setf (postgresql-connection-pid connection) - (read-socket-value-int32 socket) - (postgresql-connection-key connection) - (read-socket-value-int32 socket))) - (#.+ready-for-query-message+ - (setq socket nil) - (return connection)) - (#.+error-response-message+ - (let ((message (read-socket-value-string socket))) - (error 'postgresql-login-error - :connection connection - :message message))) - (#.+notice-response-message+ - (let ((message (read-socket-value-string socket))) - (warn 'postgresql-warning :connection connection - :message message))) - (t - (error 'postgresql-login-error - :connection connection - :message - "Received garbled message from Postmaster"))))) + (t + (error 'postgresql-login-error + :connection connection + :message + "Postmaster expects unknown authentication method.")))) + (#.+error-response-message+ + (let ((message (read-socket-value-string socket))) + (error 'postgresql-login-error + :connection connection :message message))) + (t + (error 'postgresql-login-error + :connection connection + :message + "Received garbled message from Postmaster")))) + ;; Start backend communication + (force-output socket) + (loop + (case (read-socket-value-int8 socket) + (#.+backend-key-message+ + (setf (postgresql-connection-pid connection) + (read-socket-value-int32 socket) + (postgresql-connection-key connection) + (read-socket-value-int32 socket))) + (#.+ready-for-query-message+ + (setq socket nil) + (return connection)) + (#.+error-response-message+ + (let ((message (read-socket-value-string socket))) + (error 'postgresql-login-error + :connection connection + :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value-string socket))) + (warn 'postgresql-warning :connection connection + :message message))) + (t + (error 'postgresql-login-error + :connection connection + :message + "Received garbled message from Postmaster"))))) (when socket - (close socket))))) + (close socket))))) (defun close-postgresql-connection (connection &optional abort) (unless abort @@ -572,24 +572,24 @@ connection, if it is still open." (assert (postgresql-connection-open-p connection)) ;; Process any asnychronous messages (loop with socket = (postgresql-connection-socket connection) - while (listen socket) - do - (case (read-socket-value-int8 socket) - (#.+ready-for-query-message+) - (#.+notice-response-message+ - (let ((message (read-socket-value-string socket))) - (warn 'postgresql-warning :connection connection - :message message))) - (#.+notification-response-message+ - (let ((pid (read-socket-value-int32 socket)) - (message (read-socket-value-string socket))) - (when (= pid (postgresql-connection-pid connection)) - (signal 'postgresql-notification :connection connection - :message message)))) - (t - (close-postgresql-connection connection) - (error 'postgresql-fatal-error :connection connection - :message "Received garbled message from backend"))))) + while (listen socket) + do + (case (read-socket-value-int8 socket) + (#.+ready-for-query-message+) + (#.+notice-response-message+ + (let ((message (read-socket-value-string socket))) + (warn 'postgresql-warning :connection connection + :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value-int32 socket)) + (message (read-socket-value-string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))) (defun start-query-execution (connection query) (ensure-open-postgresql-connection connection) @@ -600,65 +600,65 @@ connection, if it is still open." (defun wait-for-query-results (connection) (assert (postgresql-connection-open-p connection)) (let ((socket (postgresql-connection-socket connection)) - (cursor-name nil) - (error nil)) + (cursor-name nil) + (error nil)) (loop - (case (read-socket-value-int8 socket) - (#.+completed-response-message+ - (return (values :completed (read-socket-value-string socket)))) - (#.+cursor-response-message+ - (setq cursor-name (read-socket-value-string socket))) - (#.+row-description-message+ - (let* ((count (read-socket-value-int16 socket)) - (fields - (loop repeat count - collect - (list - (read-socket-value-string socket) - (read-socket-value-int32 socket) - (read-socket-value-int16 socket) - (read-socket-value-int32 socket))))) - (return - (values :cursor - (make-postgresql-cursor :connection connection - :name cursor-name - :fields fields))))) - (#.+copy-in-response-message+ - (return :copy-in)) - (#.+copy-out-response-message+ - (return :copy-out)) - (#.+ready-for-query-message+ - (when error - (error error)) - (return nil)) - (#.+error-response-message+ - (let ((message (read-socket-value-string socket))) - (setq error - (make-condition 'postgresql-error - :connection connection :message message)))) - (#.+notice-response-message+ - (let ((message (read-socket-value-string socket))) - (unless (eq :ignore clsql-sys:*backend-warning-behavior*) - (warn 'postgresql-warning - :connection connection :message message)))) - (#.+notification-response-message+ - (let ((pid (read-socket-value-int32 socket)) - (message (read-socket-value-string socket))) - (when (= pid (postgresql-connection-pid connection)) - (signal 'postgresql-notification :connection connection - :message message)))) - (t - (close-postgresql-connection connection) - (error 'postgresql-fatal-error :connection connection - :message "Received garbled message from backend")))))) + (case (read-socket-value-int8 socket) + (#.+completed-response-message+ + (return (values :completed (read-socket-value-string socket)))) + (#.+cursor-response-message+ + (setq cursor-name (read-socket-value-string socket))) + (#.+row-description-message+ + (let* ((count (read-socket-value-int16 socket)) + (fields + (loop repeat count + collect + (list + (read-socket-value-string socket) + (read-socket-value-int32 socket) + (read-socket-value-int16 socket) + (read-socket-value-int32 socket))))) + (return + (values :cursor + (make-postgresql-cursor :connection connection + :name cursor-name + :fields fields))))) + (#.+copy-in-response-message+ + (return :copy-in)) + (#.+copy-out-response-message+ + (return :copy-out)) + (#.+ready-for-query-message+ + (when error + (error error)) + (return nil)) + (#.+error-response-message+ + (let ((message (read-socket-value-string socket))) + (setq error + (make-condition 'postgresql-error + :connection connection :message message)))) + (#.+notice-response-message+ + (let ((message (read-socket-value-string socket))) + (unless (eq :ignore clsql-sys:*backend-warning-behavior*) + (warn 'postgresql-warning + :connection connection :message message)))) + (#.+notification-response-message+ + (let ((pid (read-socket-value-int32 socket)) + (message (read-socket-value-string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend")))))) (defun read-null-bit-vector (socket count) (let ((result (make-array count :element-type 'bit))) (dotimes (offset (ceiling count 8)) (loop with byte = (read-byte socket) - for index from (* offset 8) below (min count (* (1+ offset) 8)) - for weight downfrom 7 - do (setf (aref result index) (ldb (byte 1 weight) byte)))) + for index from (* offset 8) below (min count (* (1+ offset) 8)) + for weight downfrom 7 + do (setf (aref result index) (ldb (byte 1 weight) byte)))) result)) @@ -684,46 +684,46 @@ connection, if it is still open." (if (zerop length) nil (let ((val 0) - (first-char (read-byte socket)) - (minusp nil)) + (first-char (read-byte socket)) + (minusp nil)) (declare (fixnum first-char)) (decf length) ;; read first char (cond ((= first-char +char-code-minus+) - (setq minusp t)) + (setq minusp t)) ((= first-char +char-code-plus+) - ) ;; nothing to do + ) ;; nothing to do (t - (setq val (- first-char +char-code-zero+)))) + (setq val (- first-char +char-code-zero+)))) (dotimes (i length) - (declare (fixnum i)) - (setq val (+ - (* 10 val) - (- (read-byte socket) +char-code-zero+)))) + (declare (fixnum i)) + (setq val (+ + (* 10 val) + (- (read-byte socket) +char-code-zero+)))) (if minusp - (- val) - val)))) + (- val) + val)))) (defmacro ascii-digit (int) (let ((offset (gensym))) `(let ((,offset (- ,int +char-code-zero+))) (declare (fixnum ,int ,offset)) (if (and (>= ,offset 0) - (< ,offset 10)) - ,offset - nil)))) + (< ,offset 10)) + ,offset + nil)))) (defun read-double-from-socket (socket length) (declare (fixnum length)) (let ((before-decimal 0) - (after-decimal 0) - (decimal-count 0) - (exponent 0) - (decimalp nil) - (minusp nil) - (result nil) - (char (read-byte socket))) + (after-decimal 0) + (decimal-count 0) + (exponent 0) + (decimalp nil) + (minusp nil) + (result nil) + (char (read-byte socket))) (declare (fixnum char exponent decimal-count)) (decf length) ;; already read first character (cond @@ -736,37 +736,37 @@ connection, if it is still open." (t (setq before-decimal (ascii-digit char)) (unless before-decimal - (error "Unexpected value")))) + (error "Unexpected value")))) (block loop (dotimes (i length) - (setq char (read-byte socket)) - ;; (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp) - (let ((weight (ascii-digit char))) - (cond - ((and weight (not decimalp)) ;; before decimal point - (setq before-decimal (+ weight (* 10 before-decimal)))) - ((and weight decimalp) ;; after decimal point - (setq after-decimal (+ weight (* 10 after-decimal))) - (incf decimal-count)) - ((and (= char +char-code-period+)) - (setq decimalp t)) - ((or (= char +char-code-lower-e+) ;; E is for exponent - (= char +char-code-upper-e+)) - (setq exponent (read-integer-from-socket socket (- length i 1))) - (setq exponent (or exponent 0)) - (return-from loop)) - (t - (break "Unexpected value")) - ) - ))) + (setq char (read-byte socket)) + ;; (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp) + (let ((weight (ascii-digit char))) + (cond + ((and weight (not decimalp)) ;; before decimal point + (setq before-decimal (+ weight (* 10 before-decimal)))) + ((and weight decimalp) ;; after decimal point + (setq after-decimal (+ weight (* 10 after-decimal))) + (incf decimal-count)) + ((and (= char +char-code-period+)) + (setq decimalp t)) + ((or (= char +char-code-lower-e+) ;; E is for exponent + (= char +char-code-upper-e+)) + (setq exponent (read-integer-from-socket socket (- length i 1))) + (setq exponent (or exponent 0)) + (return-from loop)) + (t + (break "Unexpected value")) + ) + ))) (setq result (* (+ (coerce before-decimal 'double-float) - (* after-decimal - (expt 10 (- decimal-count)))) - (expt 10 exponent))) + (* after-decimal + (expt 10 (- decimal-count)))) + (expt 10 exponent))) (if minusp - (- result) - result))) + (- result) + result))) #+ignore @@ -778,141 +778,141 @@ connection, if it is still open." (defun read-cursor-row (cursor types) (let* ((connection (postgresql-cursor-connection cursor)) - (socket (postgresql-connection-socket connection)) - (fields (postgresql-cursor-fields cursor))) + (socket (postgresql-connection-socket connection)) + (fields (postgresql-cursor-fields cursor))) (assert (postgresql-connection-open-p connection)) (loop - (let ((code (read-socket-value-int8 socket))) - (case code - (#.+ascii-row-message+ - (return - (loop with count = (length fields) - with null-vector = (read-null-bit-vector socket count) - repeat count - for null-bit across null-vector - for i from 0 - for null-p = (zerop null-bit) - if null-p - collect nil - else - collect - (read-field socket (nth i types))))) - (#.+binary-row-message+ - (error "NYI")) - (#.+completed-response-message+ - (return (values nil (read-socket-value-string socket)))) - (#.+error-response-message+ - (let ((message (read-socket-value-string socket))) - (error 'postgresql-error - :connection connection :message message))) - (#.+notice-response-message+ - (let ((message (read-socket-value-string socket))) - (warn 'postgresql-warning - :connection connection :message message))) - (#.+notification-response-message+ - (let ((pid (read-socket-value-int32 socket)) - (message (read-socket-value-string socket))) - (when (= pid (postgresql-connection-pid connection)) - (signal 'postgresql-notification :connection connection - :message message)))) - (t - (close-postgresql-connection connection) - (error 'postgresql-fatal-error :connection connection - :message "Received garbled message from backend"))))))) + (let ((code (read-socket-value-int8 socket))) + (case code + (#.+ascii-row-message+ + (return + (loop with count = (length fields) + with null-vector = (read-null-bit-vector socket count) + repeat count + for null-bit across null-vector + for i from 0 + for null-p = (zerop null-bit) + if null-p + collect nil + else + collect + (read-field socket (nth i types))))) + (#.+binary-row-message+ + (error "NYI")) + (#.+completed-response-message+ + (return (values nil (read-socket-value-string socket)))) + (#.+error-response-message+ + (let ((message (read-socket-value-string socket))) + (error 'postgresql-error + :connection connection :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value-string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value-int32 socket)) + (message (read-socket-value-string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))))) (defun map-into-indexed (result-seq func seq) (dotimes (i (length seq)) (declare (fixnum i)) (setf (elt result-seq i) - (funcall func (elt seq i) i))) + (funcall func (elt seq i) i))) result-seq) (defun copy-cursor-row (cursor sequence types) (let* ((connection (postgresql-cursor-connection cursor)) - (socket (postgresql-connection-socket connection)) - (fields (postgresql-cursor-fields cursor))) + (socket (postgresql-connection-socket connection)) + (fields (postgresql-cursor-fields cursor))) (assert (= (length fields) (length sequence))) (loop - (let ((code (read-socket-value-int8 socket))) - (case code - (#.+ascii-row-message+ - (return - #+ignore - (let* ((count (length sequence)) - (null-vector (read-null-bit-vector socket count))) - (dotimes (i count) - (declare (fixnum i)) - (if (zerop (elt null-vector i)) - (setf (elt sequence i) nil) - (let ((value (read-field socket (nth i types)))) - (setf (elt sequence i) value))))) - (map-into-indexed - sequence - #'(lambda (null-bit i) - (if (zerop null-bit) - nil - (read-field socket (nth i types)))) - (read-null-bit-vector socket (length sequence))))) - (#.+binary-row-message+ - (error "NYI")) - (#.+completed-response-message+ - (return (values nil (read-socket-value-string socket)))) - (#.+error-response-message+ - (let ((message (read-socket-value-string socket))) - (error 'postgresql-error - :connection connection :message message))) - (#.+notice-response-message+ - (let ((message (read-socket-value-string socket))) - (warn 'postgresql-warning - :connection connection :message message))) - (#.+notification-response-message+ - (let ((pid (read-socket-value-int32 socket)) - (message (read-socket-value-string socket))) - (when (= pid (postgresql-connection-pid connection)) - (signal 'postgresql-notification :connection connection - :message message)))) - (t - (close-postgresql-connection connection) - (error 'postgresql-fatal-error :connection connection - :message "Received garbled message from backend"))))))) + (let ((code (read-socket-value-int8 socket))) + (case code + (#.+ascii-row-message+ + (return + #+ignore + (let* ((count (length sequence)) + (null-vector (read-null-bit-vector socket count))) + (dotimes (i count) + (declare (fixnum i)) + (if (zerop (elt null-vector i)) + (setf (elt sequence i) nil) + (let ((value (read-field socket (nth i types)))) + (setf (elt sequence i) value))))) + (map-into-indexed + sequence + #'(lambda (null-bit i) + (if (zerop null-bit) + nil + (read-field socket (nth i types)))) + (read-null-bit-vector socket (length sequence))))) + (#.+binary-row-message+ + (error "NYI")) + (#.+completed-response-message+ + (return (values nil (read-socket-value-string socket)))) + (#.+error-response-message+ + (let ((message (read-socket-value-string socket))) + (error 'postgresql-error + :connection connection :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value-string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value-int32 socket)) + (message (read-socket-value-string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))))) (defun skip-cursor-row (cursor) (let* ((connection (postgresql-cursor-connection cursor)) - (socket (postgresql-connection-socket connection)) - (fields (postgresql-cursor-fields cursor))) + (socket (postgresql-connection-socket connection)) + (fields (postgresql-cursor-fields cursor))) (loop - (let ((code (read-socket-value-int8 socket))) - (case code - (#.+ascii-row-message+ - (loop for null-bit across - (read-null-bit-vector socket (length fields)) - do - (unless (zerop null-bit) - (let* ((length (read-socket-value-int32 socket))) - (loop repeat (- length 4) do (read-byte socket))))) - (return t)) - (#.+binary-row-message+ - (error "NYI")) - (#.+completed-response-message+ - (return (values nil (read-socket-value-string socket)))) - (#.+error-response-message+ - (let ((message (read-socket-value-string socket))) - (error 'postgresql-error - :connection connection :message message))) - (#.+notice-response-message+ - (let ((message (read-socket-value-string socket))) - (warn 'postgresql-warning - :connection connection :message message))) - (#.+notification-response-message+ - (let ((pid (read-socket-value-int32 socket)) - (message (read-socket-value-string socket))) - (when (= pid (postgresql-connection-pid connection)) - (signal 'postgresql-notification :connection connection - :message message)))) - (t - (close-postgresql-connection connection) - (error 'postgresql-fatal-error :connection connection - :message "Received garbled message from backend"))))))) + (let ((code (read-socket-value-int8 socket))) + (case code + (#.+ascii-row-message+ + (loop for null-bit across + (read-null-bit-vector socket (length fields)) + do + (unless (zerop null-bit) + (let* ((length (read-socket-value-int32 socket))) + (loop repeat (- length 4) do (read-byte socket))))) + (return t)) + (#.+binary-row-message+ + (error "NYI")) + (#.+completed-response-message+ + (return (values nil (read-socket-value-string socket)))) + (#.+error-response-message+ + (let ((message (read-socket-value-string socket))) + (error 'postgresql-error + :connection connection :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value-string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value-int32 socket)) + (message (read-socket-value-string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))))) (defun run-query (connection query &optional (result-types nil)) (start-query-execution connection query) @@ -920,10 +920,10 @@ connection, if it is still open." (wait-for-query-results connection) (assert (eq status :cursor)) (loop for row = (read-cursor-row cursor result-types) - while row - collect row - finally - (wait-for-query-results connection)))) + while row + collect row + finally + (wait-for-query-results connection)))) #+scl (declaim (ext:maybe-inline read-byte write-byte)) diff --git a/db-postgresql-socket/postgresql-socket-package.lisp b/db-postgresql-socket/postgresql-socket-package.lisp index 99de2aa..aa15fa7 100644 --- a/db-postgresql-socket/postgresql-socket-package.lisp +++ b/db-postgresql-socket/postgresql-socket-package.lisp @@ -23,39 +23,39 @@ (defpackage #:postgresql-socket (:use #:cl md5) (:export #:pgsql-ftype - #:pgsql-ftype#bytea - #:pgsql-ftype#int2 - #:pgsql-ftype#int4 - #:pgsql-ftype#int8 - #:pgsql-ftype#float4 - #:pgsql-ftype#float8 + #:pgsql-ftype#bytea + #:pgsql-ftype#int2 + #:pgsql-ftype#int4 + #:pgsql-ftype#int8 + #:pgsql-ftype#float4 + #:pgsql-ftype#float8 - #:+crypt-library+ - #:postgresql-condition - #:postgresql-condition-connection - #:postgresql-condition-message - #:postgresql-error - #:postgresql-fatal-error - #:postgresql-login-error - #:postgresql-warning - #:postgresql-notification - #:postgresql-connection - #:postgresql-connection-p - #:postgresql-cursor - #:postgresql-cursor-p - #:postgresql-cursor-connection - #:postgresql-cursor-name - #:postgresql-cursor-fields - #:+postgresql-server-default-port+ - #:open-postgresql-connection - #:reopen-postgresql-connection - #:close-postgresql-connection - #:postgresql-connection-open-p - #:ensure-open-postgresql-connection - #:start-query-execution - #:wait-for-query-results - #:read-cursor-row - #:copy-cursor-row - #:skip-cursor-row - )) + #:+crypt-library+ + #:postgresql-condition + #:postgresql-condition-connection + #:postgresql-condition-message + #:postgresql-error + #:postgresql-fatal-error + #:postgresql-login-error + #:postgresql-warning + #:postgresql-notification + #:postgresql-connection + #:postgresql-connection-p + #:postgresql-cursor + #:postgresql-cursor-p + #:postgresql-cursor-connection + #:postgresql-cursor-name + #:postgresql-cursor-fields + #:+postgresql-server-default-port+ + #:open-postgresql-connection + #:reopen-postgresql-connection + #:close-postgresql-connection + #:postgresql-connection-open-p + #:ensure-open-postgresql-connection + #:start-query-execution + #:wait-for-query-results + #:read-cursor-row + #:copy-cursor-row + #:skip-cursor-row + )) diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index 7a56931..aaa5fcb 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -4,7 +4,7 @@ ;;;; ;;;; Name: postgresql-socket-sql.sql ;;;; Purpose: High-level PostgreSQL interface using socket -;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai +;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai ;;;; Created: Feb 2002 ;;;; ;;;; $Id$ @@ -36,8 +36,8 @@ (defun make-type-list-for-auto (cursor) (let* ((fields (postgresql-cursor-fields cursor)) - (num-fields (length fields)) - (new-types '())) + (num-fields (length fields)) + (new-types '())) (dotimes (i num-fields) (declare (fixnum i)) (push (canonical-field-type fields i) new-types)) @@ -48,13 +48,13 @@ (let ((oid (cadr (nth index fields)))) (case oid ((#.pgsql-ftype#bytea - #.pgsql-ftype#int2 - #.pgsql-ftype#int4) + #.pgsql-ftype#int2 + #.pgsql-ftype#int4) :int32) (#.pgsql-ftype#int8 :int64) ((#.pgsql-ftype#float4 - #.pgsql-ftype#float8) + #.pgsql-ftype#float8) :double) (otherwise t)))) @@ -63,43 +63,43 @@ (if (null types) nil (let ((auto-list (make-type-list-for-auto cursor))) - (cond - ((listp types) - (canonicalize-type-list types auto-list)) - ((eq types :auto) - auto-list) - (t - nil))))) + (cond + ((listp types) + (canonicalize-type-list types auto-list)) + ((eq types :auto) + auto-list) + (t + nil))))) (defun canonicalize-type-list (types auto-list) "Ensure a field type list meets expectations. Duplicated from clsql-uffi package so that this interface doesn't depend on UFFI." (let ((length-types (length types)) - (new-types '())) + (new-types '())) (loop for i from 0 below (length auto-list) - do - (if (>= i length-types) - (push t new-types) ;; types is shorted than num-fields - (push - (case (nth i types) - (:int - (case (nth i auto-list) - (:int32 - :int32) - (:int64 - :int64) - (t - t))) - (:double - (case (nth i auto-list) - (:double - :double) - (t - t))) - (t - t)) - new-types))) + do + (if (>= i length-types) + (push t new-types) ;; types is shorted than num-fields + (push + (case (nth i types) + (:int + (case (nth i auto-list) + (:int32 + :int32) + (:int64 + :int64) + (t + t))) + (:double + (case (nth i auto-list) + (:double + :double) + (t + t))) + (t + t)) + new-types))) (nreverse new-types))) @@ -107,104 +107,104 @@ doesn't depend on UFFI." (ecase *backend-warning-behavior* (:warn (warn 'sql-database-warning :database database - :message (postgresql-condition-message condition))) + :message (postgresql-condition-message condition))) (:error (error 'sql-database-error :database database - :message (format nil "Warning upgraded to error: ~A" - (postgresql-condition-message condition)))) + :message (format nil "Warning upgraded to error: ~A" + (postgresql-condition-message condition)))) ((:ignore nil) ;; do nothing ))) (defun convert-to-clsql-error (database expression condition) (error 'sql-database-data-error - :database database - :expression expression - :error-id (type-of condition) - :message (postgresql-condition-message condition))) + :database database + :expression expression + :error-id (type-of condition) + :message (postgresql-condition-message condition))) (defmacro with-postgresql-handlers ((database &optional expression) &body body) (let ((database-var (gensym)) - (expression-var (gensym))) + (expression-var (gensym))) `(let ((,database-var ,database) - (,expression-var ,expression)) + (,expression-var ,expression)) (handler-bind ((postgresql-warning - (lambda (c) - (convert-to-clsql-warning ,database-var c))) - (postgresql-error - (lambda (c) - (convert-to-clsql-error - ,database-var ,expression-var c)))) - ,@body)))) + (lambda (c) + (convert-to-clsql-warning ,database-var c))) + (postgresql-error + (lambda (c) + (convert-to-clsql-error + ,database-var ,expression-var c)))) + ,@body)))) (defmethod database-initialize-database-type ((database-type - (eql :postgresql-socket))) + (eql :postgresql-socket))) t) (defclass postgresql-socket-database (generic-postgresql-database) ((connection :accessor database-connection :initarg :connection - :type postgresql-connection))) + :type postgresql-connection))) (defmethod database-type ((database postgresql-socket-database)) :postgresql-socket) (defmethod database-name-from-spec (connection-spec - (database-type (eql :postgresql-socket))) + (database-type (eql :postgresql-socket))) (check-connection-spec connection-spec database-type - (host db user password &optional port options tty)) + (host db user password &optional port options tty)) (destructuring-bind (host db user password &optional port options tty) connection-spec (declare (ignore password options tty)) - (concatenate 'string + (concatenate 'string (etypecase host - (null - "localhost") - (pathname (namestring host)) - (string host)) - (when port - (concatenate 'string - ":" - (etypecase port - (integer (write-to-string port)) - (string port)))) + (null + "localhost") + (pathname (namestring host)) + (string host)) + (when port + (concatenate 'string + ":" + (etypecase port + (integer (write-to-string port)) + (string port)))) "/" db "/" user))) -(defmethod database-connect (connection-spec - (database-type (eql :postgresql-socket))) +(defmethod database-connect (connection-spec + (database-type (eql :postgresql-socket))) (check-connection-spec connection-spec database-type - (host db user password &optional port options tty)) + (host db user password &optional port options tty)) (destructuring-bind (host db user password &optional - (port +postgresql-server-default-port+) - (options "") (tty "")) + (port +postgresql-server-default-port+) + (options "") (tty "")) connection-spec (handler-case - (handler-bind ((postgresql-warning - (lambda (c) - (warn 'sql-warning - :format-control "~A" - :format-arguments - (list (princ-to-string c)))))) - (open-postgresql-connection :host host :port port - :options options :tty tty - :database db :user user - :password password)) + (handler-bind ((postgresql-warning + (lambda (c) + (warn 'sql-warning + :format-control "~A" + :format-arguments + (list (princ-to-string c)))))) + (open-postgresql-connection :host host :port port + :options options :tty tty + :database db :user user + :password password)) (postgresql-error (c) - ;; Connect failed - (error 'sql-connection-error - :database-type database-type - :connection-spec connection-spec - :error-id (type-of c) - :message (postgresql-condition-message c))) + ;; Connect failed + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (type-of c) + :message (postgresql-condition-message c))) (:no-error (connection) - ;; Success, make instance - (make-instance 'postgresql-socket-database - :name (database-name-from-spec connection-spec - database-type) - :database-type :postgresql-socket - :connection-spec connection-spec - :connection connection))))) + ;; Success, make instance + (make-instance 'postgresql-socket-database + :name (database-name-from-spec connection-spec + database-type) + :database-type :postgresql-socket + :connection-spec connection-spec + :connection connection))))) (defmethod database-disconnect ((database postgresql-socket-database)) (close-postgresql-connection (database-connection database)) @@ -215,15 +215,15 @@ doesn't depend on UFFI." (with-postgresql-handlers (database expression) (start-query-execution connection expression) (multiple-value-bind (status cursor) - (wait-for-query-results connection) - (unless (eq status :cursor) - (close-postgresql-connection connection) - (error 'sql-database-data-error - :database database - :expression expression - :error-id "missing-result" - :message "Didn't receive result cursor for query.")) - (setq result-types (canonicalize-types result-types cursor)) + (wait-for-query-results connection) + (unless (eq status :cursor) + (close-postgresql-connection connection) + (error 'sql-database-data-error + :database database + :expression expression + :error-id "missing-result" + :message "Didn't receive result cursor for query.")) + (setq result-types (canonicalize-types result-types cursor)) (values (loop for row = (read-cursor-row cursor result-types) while row @@ -237,7 +237,7 @@ doesn't depend on UFFI." :error-id "multiple-results" :message "Received multiple results for query."))) (when field-names - (mapcar #'car (postgresql-cursor-fields cursor)))))))) + (mapcar #'car (postgresql-cursor-fields cursor)))))))) (defmethod database-execute-command (expression (database postgresql-socket-database)) @@ -245,33 +245,33 @@ doesn't depend on UFFI." (with-postgresql-handlers (database expression) (start-query-execution connection expression) (multiple-value-bind (status result) - (wait-for-query-results connection) - (when (eq status :cursor) - (loop - (multiple-value-bind (row stuff) - (skip-cursor-row result) - (unless row - (setq status :completed result stuff) - (return))))) - (cond - ((null status) - t) - ((eq status :completed) - (unless (null (wait-for-query-results connection)) - (close-postgresql-connection connection) - (error 'sql-database-data-error - :database database - :expression expression - :error-id "multiple-results" - :message "Received multiple results for command.")) - result) - (t - (close-postgresql-connection connection) - (error 'sql-database-data-error - :database database - :expression expression - :errno "missing-result" - :message "Didn't receive completion for command."))))))) + (wait-for-query-results connection) + (when (eq status :cursor) + (loop + (multiple-value-bind (row stuff) + (skip-cursor-row result) + (unless row + (setq status :completed result stuff) + (return))))) + (cond + ((null status) + t) + ((eq status :completed) + (unless (null (wait-for-query-results connection)) + (close-postgresql-connection connection) + (error 'sql-database-data-error + :database database + :expression expression + :error-id "multiple-results" + :message "Received multiple results for command.")) + result) + (t + (close-postgresql-connection connection) + (error 'sql-database-data-error + :database database + :expression expression + :errno "missing-result" + :message "Didn't receive completion for command."))))))) (defstruct postgresql-socket-result-set (done nil) @@ -279,65 +279,65 @@ doesn't depend on UFFI." (types nil)) (defmethod database-query-result-set ((expression string) - (database postgresql-socket-database) - &key full-set result-types) + (database postgresql-socket-database) + &key full-set result-types) (declare (ignore full-set)) (let ((connection (database-connection database))) (with-postgresql-handlers (database expression) (start-query-execution connection expression) (multiple-value-bind (status cursor) - (wait-for-query-results connection) - (unless (eq status :cursor) - (close-postgresql-connection connection) - (error 'sql-database-data-error - :database database - :expression expression - :error-id "missing-result" - :message "Didn't receive result cursor for query.")) - (values (make-postgresql-socket-result-set - :done nil - :cursor cursor - :types (canonicalize-types result-types cursor)) - (length (postgresql-cursor-fields cursor))))))) + (wait-for-query-results connection) + (unless (eq status :cursor) + (close-postgresql-connection connection) + (error 'sql-database-data-error + :database database + :expression expression + :error-id "missing-result" + :message "Didn't receive result cursor for query.")) + (values (make-postgresql-socket-result-set + :done nil + :cursor cursor + :types (canonicalize-types result-types cursor)) + (length (postgresql-cursor-fields cursor))))))) (defmethod database-dump-result-set (result-set - (database postgresql-socket-database)) + (database postgresql-socket-database)) (if (postgresql-socket-result-set-done result-set) t (with-postgresql-handlers (database) - (loop while (skip-cursor-row - (postgresql-socket-result-set-cursor result-set)) - finally (setf (postgresql-socket-result-set-done result-set) t))))) + (loop while (skip-cursor-row + (postgresql-socket-result-set-cursor result-set)) + finally (setf (postgresql-socket-result-set-done result-set) t))))) (defmethod database-store-next-row (result-set - (database postgresql-socket-database) - list) + (database postgresql-socket-database) + list) (let ((cursor (postgresql-socket-result-set-cursor result-set))) (with-postgresql-handlers (database) - (if (copy-cursor-row cursor - list - (postgresql-socket-result-set-types - result-set)) - t - (prog1 nil - (setf (postgresql-socket-result-set-done result-set) t) - (wait-for-query-results (database-connection database))))))) + (if (copy-cursor-row cursor + list + (postgresql-socket-result-set-types + result-set)) + t + (prog1 nil + (setf (postgresql-socket-result-set-done result-set) t) + (wait-for-query-results (database-connection database))))))) (defmethod database-create (connection-spec (type (eql :postgresql-socket))) (destructuring-bind (host name user password) connection-spec (let ((database (database-connect (list host "template1" user password) - type))) + type))) (unwind-protect - (execute-command (format nil "create database ~A" name)) - (database-disconnect database))))) + (execute-command (format nil "create database ~A" name)) + (database-disconnect database))))) (defmethod database-destroy (connection-spec (type (eql :postgresql-socket))) (destructuring-bind (host name user password) connection-spec (let ((database (database-connect (list host "template1" user password) - type))) + type))) (unwind-protect - (execute-command (format nil "drop database ~A" name)) - (database-disconnect database))))) + (execute-command (format nil "drop database ~A" name)) + (database-disconnect database))))) (defmethod database-probe (connection-spec (type (eql :postgresql-socket))) diff --git a/db-postgresql/postgresql-api.lisp b/db-postgresql/postgresql-api.lisp index 4789491..fb474c5 100644 --- a/db-postgresql/postgresql-api.lisp +++ b/db-postgresql/postgresql-api.lisp @@ -4,8 +4,8 @@ ;;;; ;;;; Name: postgresql.cl ;;;; Purpose: Low-level PostgreSQL interface using UFFI -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; ;;;; $Id$ @@ -35,7 +35,7 @@ (uffi:def-foreign-type pgsql-oid :unsigned-int) -(uffi:def-enum pgsql-conn-status-type +(uffi:def-enum pgsql-conn-status-type (:connection-ok :connection-bad)) @@ -61,7 +61,7 @@ (:int8 20) (:float4 700) (:float8 701))) - + ;;(declaim (inline PQsetdbLogin)) ;; causes compile error in LW 4.2.0 (uffi:def-function ("PQsetdbLogin" PQsetdbLogin) ((pghost :cstring) @@ -147,7 +147,7 @@ :returning :cstring) (declaim (inline PQntuples)) -(uffi:def-function ("PQntuples" PQntuples) +(uffi:def-function ("PQntuples" PQntuples) ((res pgsql-result)) :module "postgresql" :returning :int) diff --git a/db-postgresql/postgresql-loader.lisp b/db-postgresql/postgresql-loader.lisp index f98aec6..160ca2c 100644 --- a/db-postgresql/postgresql-loader.lisp +++ b/db-postgresql/postgresql-loader.lisp @@ -28,11 +28,11 @@ set to the right path before compiling or loading the system.") "T if foreign library was able to be loaded successfully") (defmethod clsql-sys:database-type-library-loaded ((database-type - (eql :postgresql))) + (eql :postgresql))) *postgresql-library-loaded*) - + (defmethod clsql-sys:database-type-load-foreign ((database-type - (eql :postgresql))) + (eql :postgresql))) (clsql-uffi:find-and-load-foreign-library "libpq" :module "postgresql" :supporting-libraries *postgresql-supporting-libraries*) diff --git a/db-postgresql/postgresql-package.lisp b/db-postgresql/postgresql-package.lisp index c6ba65b..aded77b 100644 --- a/db-postgresql/postgresql-package.lisp +++ b/db-postgresql/postgresql-package.lisp @@ -49,7 +49,7 @@ ;; Used by PQresultErrorField to get the sql error code #:+PG-DIAG-SQLSTATE+ - + ;; Functions #:PQsetdbLogin #:PQlogin @@ -74,7 +74,7 @@ #:PQgetisnull #:PQclear #:PQisBusy - + ;;Large Objects (Marc B) #:lo-create #:lo-open diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp index a3f9b88..2ab36e0 100644 --- a/db-postgresql/postgresql-sql.lisp +++ b/db-postgresql/postgresql-sql.lisp @@ -29,33 +29,33 @@ (dotimes (i num-fields) (declare (fixnum i)) (let* ((type (PQftype res-ptr i))) - (push - (case type - ((#.pgsql-ftype#bytea - #.pgsql-ftype#int2 - #.pgsql-ftype#int4) - :int32) - (#.pgsql-ftype#int8 - :int64) - ((#.pgsql-ftype#float4 - #.pgsql-ftype#float8) - :double) - (otherwise - t)) - new-types))) + (push + (case type + ((#.pgsql-ftype#bytea + #.pgsql-ftype#int2 + #.pgsql-ftype#int4) + :int32) + (#.pgsql-ftype#int8 + :int64) + ((#.pgsql-ftype#float4 + #.pgsql-ftype#float8) + :double) + (otherwise + t)) + new-types))) (nreverse new-types))) (defun canonicalize-types (types num-fields res-ptr) (if (null types) nil (let ((auto-list (make-type-list-for-auto num-fields res-ptr))) - (cond - ((listp types) - (canonicalize-type-list types auto-list)) - ((eq types :auto) - auto-list) - (t - nil))))) + (cond + ((listp types) + (canonicalize-type-list types auto-list)) + ((eq types :auto) + auto-list) + (t + nil))))) (defun tidy-error-message (message) (unless (stringp message) @@ -70,7 +70,7 @@ message)))) (defmethod database-initialize-database-type ((database-type - (eql :postgresql))) + (eql :postgresql))) t) (uffi:def-type pgsql-conn-def pgsql-conn) @@ -79,7 +79,7 @@ (defclass postgresql-database (generic-postgresql-database) ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr - :type pgsql-conn-def) + :type pgsql-conn-def) (lock :accessor database-lock :initform (make-process-lock "conn")))) @@ -88,45 +88,45 @@ :postgresql) (defmethod database-name-from-spec (connection-spec (database-type - (eql :postgresql))) + (eql :postgresql))) (check-connection-spec connection-spec database-type - (host db user password &optional port options tty)) + (host db user password &optional port options tty)) (destructuring-bind (host db user password &optional port options tty) connection-spec (declare (ignore password options tty)) - (concatenate 'string + (concatenate 'string (etypecase host - (null "localhost") - (pathname (namestring host)) - (string host)) - (when port - (concatenate 'string - ":" - (etypecase port - (integer (write-to-string port)) - (string port)))) + (null "localhost") + (pathname (namestring host)) + (string host)) + (when port + (concatenate 'string + ":" + (etypecase port + (integer (write-to-string port)) + (string port)))) "/" db "/" user))) (defmethod database-connect (connection-spec (database-type (eql :postgresql))) (check-connection-spec connection-spec database-type - (host db user password &optional port options tty)) + (host db user password &optional port options tty)) (destructuring-bind (host db user password &optional port options tty) connection-spec (uffi:with-cstrings ((host-native host) - (user-native user) - (password-native password) - (db-native db) - (port-native port) - (options-native options) - (tty-native tty)) + (user-native user) + (password-native password) + (db-native db) + (port-native port) + (options-native options) + (tty-native tty)) (let ((connection (PQsetdbLogin host-native port-native - options-native tty-native - db-native user-native - password-native))) - (declare (type pgsql-conn-def connection)) - (when (not (eq (PQstatus connection) - pgsql-conn-status-type#connection-ok)) + options-native tty-native + db-native user-native + password-native))) + (declare (type pgsql-conn-def connection)) + (when (not (eq (PQstatus connection) + pgsql-conn-status-type#connection-ok)) (let ((pqstatus (PQstatus connection)) (pqmessage (tidy-error-message (PQerrorMessage connection)))) (PQfinish connection) @@ -135,12 +135,12 @@ :connection-spec connection-spec :error-id pqstatus :message pqmessage))) - (make-instance 'postgresql-database - :name (database-name-from-spec connection-spec - database-type) - :database-type :postgresql - :connection-spec connection-spec - :conn-ptr connection))))) + (make-instance 'postgresql-database + :name (database-name-from-spec connection-spec + database-type) + :database-type :postgresql + :connection-spec connection-spec + :conn-ptr connection))))) (defmethod database-disconnect ((database postgresql-database)) @@ -160,36 +160,36 @@ :message (tidy-error-message (PQerrorMessage conn-ptr)))) (unwind-protect (case (PQresultStatus result) - ;; User gave a command rather than a query + ;; 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 - (let ((num-fields (PQnfields result))) - (when result-types - (setq result-types - (canonicalize-types result-types num-fields - result))) - (let ((res (loop for tuple-index from 0 below (PQntuples result) - collect - (loop for i from 0 below num-fields - collect - (if (zerop (PQgetisnull result tuple-index i)) - (convert-raw-field - (PQgetvalue result tuple-index i) - result-types i) - nil))))) - (if field-names - (values res (result-field-names num-fields result)) - res)))) + (let ((num-fields (PQnfields result))) + (when result-types + (setq result-types + (canonicalize-types result-types num-fields + result))) + (let ((res (loop for tuple-index from 0 below (PQntuples result) + collect + (loop for i from 0 below num-fields + collect + (if (zerop (PQgetisnull result tuple-index i)) + (convert-raw-field + (PQgetvalue result tuple-index i) + result-types i) + nil))))) + (if field-names + (values res (result-field-names num-fields result)) + res)))) (t (error 'sql-database-data-error :database database :expression query-expression :error-id (PQresultStatus result) :message (tidy-error-message - (PQresultErrorMessage result))))) + (PQresultErrorMessage result))))) (PQclear result)))))) (defun result-field-names (num-fields result) @@ -224,19 +224,19 @@ :expression sql-expression :error-id (PQresultErrorField result +PG-DIAG-SQLSTATE+) :message (tidy-error-message - (PQresultErrorMessage result))))) + (PQresultErrorMessage result))))) (PQclear result)))))) (defstruct postgresql-result-set - (res-ptr (uffi:make-null-pointer 'pgsql-result) - :type pgsql-result-def) - (types nil) + (res-ptr (uffi:make-null-pointer 'pgsql-result) + :type pgsql-result-def) + (types nil) (num-tuples 0 :type integer) (num-fields 0 :type integer) (tuple-index 0 :type integer)) (defmethod database-query-result-set ((query-expression string) - (database postgresql-database) + (database postgresql-database) &key full-set result-types) (let ((conn-ptr (database-conn-ptr database))) (declare (type pgsql-conn-def conn-ptr)) @@ -250,44 +250,44 @@ (case (PQresultStatus result) ((#.pgsql-exec-status-type#empty-query #.pgsql-exec-status-type#tuples-ok) - (let ((result-set (make-postgresql-result-set + (let ((result-set (make-postgresql-result-set :res-ptr result :num-fields (PQnfields result) :num-tuples (PQntuples result) - :types (canonicalize-types - result-types - (PQnfields result) - result)))) - (if full-set - (values result-set - (PQnfields result) - (PQntuples result)) - (values result-set - (PQnfields result))))) - (t - (unwind-protect + :types (canonicalize-types + result-types + (PQnfields result) + result)))) + (if full-set + (values result-set + (PQnfields result) + (PQntuples result)) + (values result-set + (PQnfields result))))) + (t + (unwind-protect (error 'sql-database-data-error :database database :expression query-expression :error-id (PQresultStatus result) :message (tidy-error-message - (PQresultErrorMessage result))) + (PQresultErrorMessage result))) (PQclear result)))))))) - + (defmethod database-dump-result-set (result-set (database postgresql-database)) - (let ((res-ptr (postgresql-result-set-res-ptr result-set))) + (let ((res-ptr (postgresql-result-set-res-ptr result-set))) (declare (type pgsql-result-def res-ptr)) (PQclear res-ptr) t)) -(defmethod database-store-next-row (result-set (database postgresql-database) +(defmethod database-store-next-row (result-set (database postgresql-database) list) (let ((result (postgresql-result-set-res-ptr result-set)) - (types (postgresql-result-set-types result-set))) + (types (postgresql-result-set-types result-set))) (declare (type pgsql-result-def result)) (if (>= (postgresql-result-set-tuple-index result-set) - (postgresql-result-set-num-tuples result-set)) - nil + (postgresql-result-set-num-tuples result-set)) + nil (loop with tuple-index = (postgresql-result-set-tuple-index result-set) for i from 0 below (postgresql-result-set-num-fields result-set) for rest on list @@ -296,7 +296,7 @@ (if (zerop (PQgetisnull result tuple-index i)) (convert-raw-field (PQgetvalue result tuple-index i) - types i) + types i) nil)) finally (incf (postgresql-result-set-tuple-index result-set)) @@ -306,71 +306,71 @@ (defmethod database-create-large-object ((database postgresql-database)) (lo-create (database-conn-ptr database) - (logior pgsql::+INV_WRITE+ pgsql::+INV_READ+))) + (logior pgsql::+INV_WRITE+ pgsql::+INV_READ+))) #+mb-original (defmethod database-write-large-object (object-id (data string) (database postgresql-database)) (let ((ptr (database-conn-ptr database)) - (length (length data)) - (result nil) - (fd nil)) + (length (length data)) + (result nil) + (fd nil)) (with-transaction (:database database) (unwind-protect - (progn - (setf fd (lo-open ptr object-id pgsql::+INV_WRITE+)) - (when (>= fd 0) - (when (= (lo-write ptr fd data length) length) - (setf result t)))) - (progn - (when (and fd (>= fd 0)) - (lo-close ptr fd)) - ))) + (progn + (setf fd (lo-open ptr object-id pgsql::+INV_WRITE+)) + (when (>= fd 0) + (when (= (lo-write ptr fd data length) length) + (setf result t)))) + (progn + (when (and fd (>= fd 0)) + (lo-close ptr fd)) + ))) result)) (defmethod database-write-large-object (object-id (data string) (database postgresql-database)) (let ((ptr (database-conn-ptr database)) - (length (length data)) - (result nil) - (fd nil)) + (length (length data)) + (result nil) + (fd nil)) (database-execute-command "begin" database) (unwind-protect - (progn - (setf fd (lo-open ptr object-id pgsql::+INV_WRITE+)) - (when (>= fd 0) - (when (= (lo-write ptr fd data length) length) - (setf result t)))) + (progn + (setf fd (lo-open ptr object-id pgsql::+INV_WRITE+)) + (when (>= fd 0) + (when (= (lo-write ptr fd data length) length) + (setf result t)))) (progn - (when (and fd (>= fd 0)) - (lo-close ptr fd)) - (database-execute-command (if result "commit" "rollback") database))) + (when (and fd (>= fd 0)) + (lo-close ptr fd)) + (database-execute-command (if result "commit" "rollback") database))) result)) ;; (MB) the begin/commit/rollback stuff will be removed when with-transaction wil be implemented ;; (KMR) Can't use with-transaction since that function is in high-level code (defmethod database-read-large-object (object-id (database postgresql-database)) (let ((ptr (database-conn-ptr database)) - (buffer nil) - (result nil) - (length 0) - (fd nil)) + (buffer nil) + (result nil) + (length 0) + (fd nil)) (unwind-protect (progn - (database-execute-command "begin" database) - (setf fd (lo-open ptr object-id pgsql::+INV_READ+)) - (when (>= fd 0) - (setf length (lo-lseek ptr fd 0 2)) - (lo-lseek ptr fd 0 0) - (when (> length 0) - (setf buffer (uffi:allocate-foreign-string - length :unsigned t)) - (when (= (lo-read ptr fd buffer length) length) - (setf result (uffi:convert-from-foreign-string - buffer :length length :null-terminated-p nil)))))) + (database-execute-command "begin" database) + (setf fd (lo-open ptr object-id pgsql::+INV_READ+)) + (when (>= fd 0) + (setf length (lo-lseek ptr fd 0 2)) + (lo-lseek ptr fd 0 0) + (when (> length 0) + (setf buffer (uffi:allocate-foreign-string + length :unsigned t)) + (when (= (lo-read ptr fd buffer length) length) + (setf result (uffi:convert-from-foreign-string + buffer :length length :null-terminated-p nil)))))) (progn - (when buffer (uffi:free-foreign-object buffer)) - (when (and fd (>= fd 0)) (lo-close ptr fd)) - (database-execute-command (if result "commit" "rollback") database))) + (when buffer (uffi:free-foreign-object buffer)) + (when (and fd (>= fd 0)) (lo-close ptr fd)) + (database-execute-command (if result "commit" "rollback") database))) result)) (defmethod database-delete-large-object (object-id (database postgresql-database)) @@ -380,36 +380,36 @@ ;;; Object listing - + (defmethod database-create (connection-spec (type (eql :postgresql))) (destructuring-bind (host name user password) connection-spec (declare (ignore user password)) (multiple-value-bind (output status) - (clsql-sys:command-output "createdb -h~A ~A" - (if host host "localhost") - name) + (clsql-sys:command-output "createdb -h~A ~A" + (if host host "localhost") + name) (if (or (not (zerop status)) - (search "database creation failed: ERROR:" output)) - (error 'sql-database-error - :message - (format nil "createdb failed for postgresql backend with connection spec ~A." - connection-spec)) - t)))) + (search "database creation failed: ERROR:" output)) + (error 'sql-database-error + :message + (format nil "createdb failed for postgresql backend with connection spec ~A." + connection-spec)) + t)))) (defmethod database-destroy (connection-spec (type (eql :postgresql))) (destructuring-bind (host name user password) connection-spec (declare (ignore user password)) (multiple-value-bind (output status) - (clsql-sys:command-output "dropdb -h~A ~A" - (if host host "localhost") - name) + (clsql-sys:command-output "dropdb -h~A ~A" + (if host host "localhost") + name) (if (or (not (zerop status)) - (search "database removal failed: ERROR:" output)) - (error 'sql-database-error - :message - (format nil "dropdb failed for postgresql backend with connection spec ~A." - connection-spec)) - t)))) + (search "database removal failed: ERROR:" output)) + (error 'sql-database-error + :message + (format nil "dropdb failed for postgresql backend with connection spec ~A." + connection-spec)) + t)))) (defmethod database-probe (connection-spec (type (eql :postgresql))) @@ -420,7 +420,7 @@ (defun %pg-database-connection (connection-spec) (check-connection-spec connection-spec :postgresql - (host db user password &optional port options tty)) + (host db user password &optional port options tty)) (macrolet ((coerce-string (var) `(unless (typep ,var 'simple-base-string) (setf ,var (coerce ,var 'simple-base-string))))) @@ -431,7 +431,7 @@ (let ((connection (PQsetdbLogin host port options tty db user password))) (declare (type pgsql::pgsql-conn-ptr connection)) (unless (eq (PQstatus connection) - pgsql-conn-status-type#connection-ok) + pgsql-conn-status-type#connection-ok) ;; Connect failed (error 'sql-connection-error :database-type :postgresql @@ -444,9 +444,9 @@ (let ((lock (database-lock database))) (with-process-lock (lock "Reconnecting") (with-slots (connection-spec conn-ptr) - database - (setf conn-ptr (%pg-database-connection connection-spec)) - database)))) + database + (setf conn-ptr (%pg-database-connection connection-spec)) + database)))) ;;; Database capabilities diff --git a/db-sqlite/sqlite-api.lisp b/db-sqlite/sqlite-api.lisp index ad25a77..de46ae8 100644 --- a/db-sqlite/sqlite-api.lisp +++ b/db-sqlite/sqlite-api.lisp @@ -24,38 +24,38 @@ (:export ;;; Conditions #:sqlite-error - #:sqlite-error-code - #:sqlite-error-message - - ;;; Core API. + #:sqlite-error-code + #:sqlite-error-message + + ;;; Core API. #:sqlite-open - #:sqlite-close - - ;;; New API. - #:sqlite-compile - #:sqlite-step - #:sqlite-finalize - - ;;; Extended API. - #:sqlite-get-table - #:sqlite-free-table - #:sqlite-version ; Defined as constant. - #:sqlite-encoding ; Defined as constant. - #:sqlite-last-insert-rowid - - ;;; Utility functions. - #:make-null-row - #:make-null-vm - #:null-row-p - #:sqlite-aref - #:sqlite-raw-aref - #:sqlite-free-row - - ;;; Types. - #:sqlite-row - #:sqlite-row-pointer - #:sqlite-row-pointer-type - #:sqlite-vm-pointer)) + #:sqlite-close + + ;;; New API. + #:sqlite-compile + #:sqlite-step + #:sqlite-finalize + + ;;; Extended API. + #:sqlite-get-table + #:sqlite-free-table + #:sqlite-version ; Defined as constant. + #:sqlite-encoding ; Defined as constant. + #:sqlite-last-insert-rowid + + ;;; Utility functions. + #:make-null-row + #:make-null-vm + #:null-row-p + #:sqlite-aref + #:sqlite-raw-aref + #:sqlite-free-row + + ;;; Types. + #:sqlite-row + #:sqlite-row-pointer + #:sqlite-row-pointer-type + #:sqlite-vm-pointer)) (in-package #:sqlite) @@ -78,16 +78,16 @@ (:report (lambda (condition stream) (let ((code (sqlite-error-code condition))) (format stream "SQLite error [~A]: ~A" - code (sqlite-error-message condition)))))) + code (sqlite-error-message condition)))))) (defun signal-sqlite-error (code &optional message) (let ((condition - (make-condition 'sqlite-error - :code code - :message (if message - message - (uffi:convert-from-cstring - (sqlite-error-string code)))))) + (make-condition 'sqlite-error + :code code + :message (if message + message + (uffi:convert-from-cstring + (sqlite-error-string code)))))) (unless (signal condition) (invoke-debugger condition)))) @@ -221,53 +221,53 @@ (defparameter sqlite-encoding (sqlite-libencoding)) (defun sqlite-open (db-name &optional (mode 0)) - (with-cstring (db-name-native db-name) + (with-cstring (db-name-native db-name) (let ((db (%open db-name-native mode +null-errmsg-pointer+))) (if (null-pointer-p db) - (signal-sqlite-error SQLITE-ERROR - (format nil "unable to open ~A" db-name)) - db)))) + (signal-sqlite-error SQLITE-ERROR + (format nil "unable to open ~A" db-name)) + db)))) (defun sqlite-compile (db sql) (with-cstring (sql-native sql) (let ((vm (allocate-foreign-object 'sqlite-vm))) (with-foreign-object (sql-tail '(* :unsigned-char)) - (let ((result (%compile db sql-native sql-tail vm +null-errmsg-pointer+))) - (if (= result SQLITE-OK) - vm - (progn - (free-foreign-object vm) - (signal-sqlite-error result)))))))) + (let ((result (%compile db sql-native sql-tail vm +null-errmsg-pointer+))) + (if (= result SQLITE-OK) + vm + (progn + (free-foreign-object vm) + (signal-sqlite-error result)))))))) (defun sqlite-step (vm) (declare (type sqlite-vm-pointer vm)) (with-foreign-object (cols-n :int) (let ((cols (allocate-foreign-object '(* (* :unsigned-char)))) - (col-names (allocate-foreign-object '(* (* :unsigned-char))))) + (col-names (allocate-foreign-object '(* (* :unsigned-char))))) (declare (type sqlite-row-pointer-type cols col-names)) (let ((result (%step (deref-pointer vm 'sqlite-vm) - cols-n cols col-names))) - (cond - ((= result SQLITE-ROW) - (let ((n (deref-pointer cols-n :int))) - (values n cols col-names))) - ((= result SQLITE-DONE) - (free-foreign-object cols) - (free-foreign-object col-names) - (values 0 +null-string-pointer-pointer+ +null-string-pointer-pointer+)) - (t - (free-foreign-object cols) - (free-foreign-object col-names) - (signal-sqlite-error result))))))) + cols-n cols col-names))) + (cond + ((= result SQLITE-ROW) + (let ((n (deref-pointer cols-n :int))) + (values n cols col-names))) + ((= result SQLITE-DONE) + (free-foreign-object cols) + (free-foreign-object col-names) + (values 0 +null-string-pointer-pointer+ +null-string-pointer-pointer+)) + (t + (free-foreign-object cols) + (free-foreign-object col-names) + (signal-sqlite-error result))))))) (defun sqlite-finalize (vm) (declare (type sqlite-vm-pointer vm)) (let ((result (%finalize (deref-pointer vm 'sqlite-vm) +null-errmsg-pointer+))) (if (= result SQLITE-OK) - (progn - (free-foreign-object vm) - t) - (signal-sqlite-error result)))) + (progn + (free-foreign-object vm) + t) + (signal-sqlite-error result)))) (defun sqlite-get-table (db sql) (declare (type sqlite-db-type db)) @@ -275,15 +275,15 @@ (let ((rows (allocate-foreign-object '(* (* :unsigned-char))))) (declare (type sqlite-row-pointer-type rows)) (with-foreign-object (rows-n :int) - (with-foreign-object (cols-n :int) - (let ((result (%get-table db sql-native rows rows-n cols-n +null-errmsg-pointer+))) - (if (= result SQLITE-OK) - (let ((cn (deref-pointer cols-n :int)) - (rn (deref-pointer rows-n :int))) - (values rows rn cn)) - (progn - (free-foreign-object rows) - (signal-sqlite-error result))))))))) + (with-foreign-object (cols-n :int) + (let ((result (%get-table db sql-native rows rows-n cols-n +null-errmsg-pointer+))) + (if (= result SQLITE-OK) + (let ((cn (deref-pointer cols-n :int)) + (rn (deref-pointer rows-n :int))) + (values rows rn cn)) + (progn + (free-foreign-object rows) + (signal-sqlite-error result))))))))) (declaim (inline sqlite-free-table)) (defun sqlite-free-table (table) diff --git a/db-sqlite/sqlite-loader.lisp b/db-sqlite/sqlite-loader.lisp index 27bea20..e7d4f72 100644 --- a/db-sqlite/sqlite-loader.lisp +++ b/db-sqlite/sqlite-loader.lisp @@ -39,4 +39,4 @@ set to the right path before compiling or loading the system.") (clsql-sys:database-type-load-foreign :sqlite) - + diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index be6ff90..e0c7464 100644 --- a/db-sqlite/sqlite-sql.lisp +++ b/db-sqlite/sqlite-sql.lisp @@ -32,7 +32,7 @@ (check-connection-spec connection-spec :sqlite (name))) (defmethod database-name-from-spec (connection-spec - (database-type (eql :sqlite))) + (database-type (eql :sqlite))) (check-sqlite-connection-spec connection-spec) (first connection-spec)) @@ -40,16 +40,16 @@ (check-sqlite-connection-spec connection-spec) (handler-case (make-instance 'sqlite-database - :name (database-name-from-spec connection-spec :sqlite) - :database-type :sqlite - :connection-spec connection-spec - :sqlite-db (sqlite:sqlite-open (first connection-spec))) + :name (database-name-from-spec connection-spec :sqlite) + :database-type :sqlite + :connection-spec connection-spec + :sqlite-db (sqlite:sqlite-open (first connection-spec))) (sqlite:sqlite-error (err) (error 'sql-connection-error - :database-type database-type - :connection-spec connection-spec - :error-id (sqlite:sqlite-error-code err) - :message (sqlite:sqlite-error-message err))))) + :database-type database-type + :connection-spec connection-spec + :error-id (sqlite:sqlite-error-code err) + :message (sqlite:sqlite-error-message err))))) (defmethod database-disconnect ((database sqlite-database)) (sqlite:sqlite-close (sqlite-db database)) @@ -59,28 +59,28 @@ (defmethod database-execute-command (sql-expression (database sqlite-database)) (handler-case (multiple-value-bind (data row-n col-n) - (sqlite:sqlite-get-table (sqlite-db database) sql-expression) - (sqlite:sqlite-free-table data) - (unless (= row-n 0) - (error 'sql-warning - :format-control - "Result set not empty: ~@(~A~) row~:P, ~@(~A~) column~:P " - :format-arguments (list row-n col-n)))) + (sqlite:sqlite-get-table (sqlite-db database) sql-expression) + (sqlite:sqlite-free-table data) + (unless (= row-n 0) + (error 'sql-warning + :format-control + "Result set not empty: ~@(~A~) row~:P, ~@(~A~) column~:P " + :format-arguments (list row-n col-n)))) (sqlite:sqlite-error (err) (error 'sql-database-data-error - :database database - :expression sql-expression - :error-id (sqlite:sqlite-error-code err) - :message (sqlite:sqlite-error-message err)))) + :database database + :expression sql-expression + :error-id (sqlite:sqlite-error-code err) + :message (sqlite:sqlite-error-message err)))) t) (defstruct sqlite-result-set (vm (sqlite:make-null-vm) :type sqlite:sqlite-vm-pointer) (first-row (sqlite:make-null-row) - :type sqlite:sqlite-row-pointer-type) + :type sqlite:sqlite-row-pointer-type) (col-names (sqlite:make-null-row) - :type sqlite:sqlite-row-pointer-type) + :type sqlite:sqlite-row-pointer-type) (result-types nil) (n-col 0 :type fixnum)) @@ -88,148 +88,148 @@ (declare (optimize (speed 3) (safety 0) (debug 0) (space 0))) (handler-case (let ((vm (sqlite:sqlite-compile (sqlite-db database) - query-expression)) - (rows '()) - (col-names '())) - (unwind-protect - ;; Read the first row to get column number and names. - (multiple-value-bind (n-col new-row sqlite-col-names) - (sqlite:sqlite-step vm) - (declare (type sqlite:sqlite-row-pointer-type new-row)) - (when (> n-col 0) - (when field-names - (setf col-names (loop for i from 0 below n-col - collect (sqlite:sqlite-aref sqlite-col-names i)))) - (let ((canonicalized-result-types - (canonicalize-result-types result-types n-col sqlite-col-names))) - (flet ((extract-row-data (row) - (declare (type sqlite:sqlite-row-pointer-type row)) - (loop for i from 0 below n-col - collect (clsql-uffi:convert-raw-field - (sqlite:sqlite-raw-aref row i) - canonicalized-result-types i)))) - (push (extract-row-data new-row) rows) - - ;; Read subsequent rows. - (do () (nil) - (multiple-value-bind (n-col new-row) - (sqlite:sqlite-step vm) - (declare (type sqlite:sqlite-row-pointer-type new-row)) - (if (> n-col 0) - (push (extract-row-data new-row) rows) - (return)))))))) - (sqlite:sqlite-finalize vm)) - (values (nreverse rows) col-names)) + query-expression)) + (rows '()) + (col-names '())) + (unwind-protect + ;; Read the first row to get column number and names. + (multiple-value-bind (n-col new-row sqlite-col-names) + (sqlite:sqlite-step vm) + (declare (type sqlite:sqlite-row-pointer-type new-row)) + (when (> n-col 0) + (when field-names + (setf col-names (loop for i from 0 below n-col + collect (sqlite:sqlite-aref sqlite-col-names i)))) + (let ((canonicalized-result-types + (canonicalize-result-types result-types n-col sqlite-col-names))) + (flet ((extract-row-data (row) + (declare (type sqlite:sqlite-row-pointer-type row)) + (loop for i from 0 below n-col + collect (clsql-uffi:convert-raw-field + (sqlite:sqlite-raw-aref row i) + canonicalized-result-types i)))) + (push (extract-row-data new-row) rows) + + ;; Read subsequent rows. + (do () (nil) + (multiple-value-bind (n-col new-row) + (sqlite:sqlite-step vm) + (declare (type sqlite:sqlite-row-pointer-type new-row)) + (if (> n-col 0) + (push (extract-row-data new-row) rows) + (return)))))))) + (sqlite:sqlite-finalize vm)) + (values (nreverse rows) col-names)) (sqlite:sqlite-error (err) (error 'sql-database-data-error - :database database - :expression query-expression - :error-id (sqlite:sqlite-error-code err) - :message (sqlite:sqlite-error-message err))))) + :database database + :expression query-expression + :error-id (sqlite:sqlite-error-code err) + :message (sqlite:sqlite-error-message err))))) (defmethod database-query-result-set ((query-expression string) - (database sqlite-database) - &key result-types full-set) + (database sqlite-database) + &key result-types full-set) (let ((vm nil)) (handler-case - (progn - (setf vm (sqlite:sqlite-compile (sqlite-db database) - query-expression)) - ;;; To obtain column number/datatypes we have to read the first row. - (multiple-value-bind (n-col cols col-names) - (sqlite:sqlite-step vm) - (declare (type sqlite:sqlite-row-pointer-type cols)) - (let ((result-set (make-sqlite-result-set - :vm vm - :first-row cols - :n-col n-col - :col-names col-names - :result-types - (canonicalize-result-types - result-types - n-col - col-names)))) - (if full-set - (values result-set n-col nil) - (values result-set n-col))))) + (progn + (setf vm (sqlite:sqlite-compile (sqlite-db database) + query-expression)) + ;;; To obtain column number/datatypes we have to read the first row. + (multiple-value-bind (n-col cols col-names) + (sqlite:sqlite-step vm) + (declare (type sqlite:sqlite-row-pointer-type cols)) + (let ((result-set (make-sqlite-result-set + :vm vm + :first-row cols + :n-col n-col + :col-names col-names + :result-types + (canonicalize-result-types + result-types + n-col + col-names)))) + (if full-set + (values result-set n-col nil) + (values result-set n-col))))) (sqlite:sqlite-error (err) - (progn - (when vm - ;; The condition was thrown by sqlite-step, vm must be - ;; deallocated. - (ignore-errors - (sqlite:sqlite-finalize vm))) - (error 'sql-database-data-error - :database database - :expression query-expression - :error-id (sqlite:sqlite-error-code err) - :message (sqlite:sqlite-error-message err))11))))) + (progn + (when vm + ;; The condition was thrown by sqlite-step, vm must be + ;; deallocated. + (ignore-errors + (sqlite:sqlite-finalize vm))) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (sqlite:sqlite-error-code err) + :message (sqlite:sqlite-error-message err))11))))) (defun canonicalize-result-types (result-types n-col col-names) (when result-types (let ((raw-types (if (eq :auto result-types) - (loop for j from n-col below (* 2 n-col) - collect (ensure-keyword (sqlite:sqlite-aref col-names j))) - result-types))) + (loop for j from n-col below (* 2 n-col) + collect (ensure-keyword (sqlite:sqlite-aref col-names j))) + result-types))) (loop for type in raw-types - collect - (case type - ((:int :integer :tinyint) - :int32) - (:long #+(or x86-64 64bit) :int64 #-(or x86-64 64bit) :int32) - (:bigint - :int64) - ((:float :double) - :double) - ((:numeric) - :number) - (otherwise - :string)))))) + collect + (case type + ((:int :integer :tinyint) + :int32) + (:long #+(or x86-64 64bit) :int64 #-(or x86-64 64bit) :int32) + (:bigint + :int64) + ((:float :double) + :double) + ((:numeric) + :number) + (otherwise + :string)))))) (defmethod database-dump-result-set (result-set (database sqlite-database)) (handler-case (sqlite:sqlite-finalize (sqlite-result-set-vm result-set)) (sqlite:sqlite-error (err) (error 'sql-database-error - :message - (format nil "Error finalizing SQLite VM: ~A" - (sqlite:sqlite-error-message err)))))) + :message + (format nil "Error finalizing SQLite VM: ~A" + (sqlite:sqlite-error-message err)))))) (defmethod database-store-next-row (result-set (database sqlite-database) list) (let ((n-col (sqlite-result-set-n-col result-set)) - (result-types (sqlite-result-set-result-types result-set))) + (result-types (sqlite-result-set-result-types result-set))) (if (= n-col 0) - ;; empty result set - nil - (let ((row (sqlite-result-set-first-row result-set))) - (if (sqlite:null-row-p row) - ;; First row already used. fetch another row from DB. - (handler-case - (multiple-value-bind (n new-row col-names) - (sqlite:sqlite-step (sqlite-result-set-vm result-set)) - (declare (ignore n col-names) - (type sqlite:sqlite-row-pointer-type new-row)) - (if (sqlite:null-row-p new-row) - (return-from database-store-next-row nil) - (setf row new-row))) - (sqlite:sqlite-error (err) - (error 'sql-database-error - :message - (format nil "Error in sqlite-step: ~A" - (sqlite:sqlite-error-message err))))) - - ;; Use the row previously read by database-query-result-set. - (setf (sqlite-result-set-first-row result-set) - (sqlite:make-null-row))) - (loop for i = 0 then (1+ i) - for rest on list - do (setf (car rest) - (clsql-uffi:convert-raw-field - (sqlite:sqlite-raw-aref row i) - result-types - i))) - (sqlite:sqlite-free-row row) - t)))) + ;; empty result set + nil + (let ((row (sqlite-result-set-first-row result-set))) + (if (sqlite:null-row-p row) + ;; First row already used. fetch another row from DB. + (handler-case + (multiple-value-bind (n new-row col-names) + (sqlite:sqlite-step (sqlite-result-set-vm result-set)) + (declare (ignore n col-names) + (type sqlite:sqlite-row-pointer-type new-row)) + (if (sqlite:null-row-p new-row) + (return-from database-store-next-row nil) + (setf row new-row))) + (sqlite:sqlite-error (err) + (error 'sql-database-error + :message + (format nil "Error in sqlite-step: ~A" + (sqlite:sqlite-error-message err))))) + + ;; Use the row previously read by database-query-result-set. + (setf (sqlite-result-set-first-row result-set) + (sqlite:make-null-row))) + (loop for i = 0 then (1+ i) + for rest on list + do (setf (car rest) + (clsql-uffi:convert-raw-field + (sqlite:sqlite-raw-aref row i) + result-types + i))) + (sqlite:sqlite-free-row row) + t)))) ;;; Object listing @@ -237,14 +237,14 @@ (declare (ignore owner)) ;; Query is copied from .table command of sqlite comamnd line utility. (mapcar #'car (database-query - "SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name" - database nil nil))) + "SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name" + database nil nil))) (defmethod database-list-tables ((database sqlite-database) &key owner) (remove-if #'(lambda (s) (and (>= (length s) 11) (string-equal (subseq s 0 11) "_CLSQL_SEQ_"))) - (database-list-tables-and-sequences database :owner owner))) + (database-list-tables-and-sequences database :owner owner))) (defmethod database-list-views ((database sqlite-database) &key (owner nil)) @@ -261,49 +261,49 @@ database nil nil))) (defmethod database-list-table-indexes (table (database sqlite-database) - &key (owner nil)) + &key (owner nil)) (declare (ignore owner)) (let ((*print-circle* nil)) - (mapcar #'car - (database-query - (format - nil - "SELECT name FROM sqlite_master WHERE type='index' AND tbl_name='~A' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' AND tbl_name='~A' ORDER BY name" - table table) - database nil nil)))) + (mapcar #'car + (database-query + (format + nil + "SELECT name FROM sqlite_master WHERE type='index' AND tbl_name='~A' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' AND tbl_name='~A' ORDER BY name" + table table) + database nil nil)))) (declaim (inline sqlite-table-info)) (defun sqlite-table-info (table database) (database-query (format nil "PRAGMA table_info('~A')" table) - database nil nil)) + database nil nil)) (defmethod database-list-attributes (table (database sqlite-database) &key (owner nil)) (declare (ignore owner)) (mapcar #'(lambda (table-info) (second table-info)) - (sqlite-table-info table database))) + (sqlite-table-info table database))) -(defmethod database-attribute-type (attribute table - (database sqlite-database) +(defmethod database-attribute-type (attribute table + (database sqlite-database) &key (owner nil)) (declare (ignore owner)) (loop for field-info in (sqlite-table-info table database) when (string= attribute (second field-info)) - return - (let* ((raw-type (third field-info)) - (start-length (position #\( raw-type)) - (type (if start-length - (subseq raw-type 0 start-length) - raw-type)) - (length (if start-length - (parse-integer (subseq raw-type (1+ start-length)) - :junk-allowed t) - nil))) - (values (when type (ensure-keyword type)) - length - nil - (if (string-equal (fourth field-info) "0") - 1 0))))) + return + (let* ((raw-type (third field-info)) + (start-length (position #\( raw-type)) + (type (if start-length + (subseq raw-type 0 start-length) + raw-type)) + (length (if start-length + (parse-integer (subseq raw-type (1+ start-length)) + :junk-allowed t) + nil))) + (values (when type (ensure-keyword type)) + length + nil + (if (string-equal (fourth field-info) "0") + 1 0))))) (defmethod database-create (connection-spec (type (eql :sqlite))) (declare (ignore connection-spec)) @@ -313,14 +313,14 @@ (defmethod database-destroy (connection-spec (type (eql :sqlite))) (destructuring-bind (name) connection-spec (if (probe-file name) - (delete-file name) - nil))) + (delete-file name) + nil))) (defmethod database-probe (connection-spec (type (eql :sqlite))) (destructuring-bind (name) connection-spec ;; TODO: Add a test that this file is a real sqlite database (or (string-equal ":memory:" name) - (and (probe-file name) t)))) + (and (probe-file name) t)))) ;;; Database capabilities diff --git a/db-sqlite3/sqlite3-api.lisp b/db-sqlite3/sqlite3-api.lisp index 856b990..196434d 100644 --- a/db-sqlite3/sqlite3-api.lisp +++ b/db-sqlite3/sqlite3-api.lisp @@ -25,35 +25,35 @@ #:sqlite3-error #:sqlite3-error-code #:sqlite3-error-message - - ;;; API functions. + + ;;; API functions. #:sqlite3-open - #:sqlite3-close - - #:sqlite3-prepare - #:sqlite3-step - #:sqlite3-finalize - - #:sqlite3-column-count - #:sqlite3-column-name - #:sqlite3-column-type - #:sqlite3-column-text - #:sqlite3-column-bytes - #:sqlite3-column-blob - - ;;; Types. - #:sqlite3-db - #:sqlite3-db-type - #:sqlite3-stmt-type - #:unsigned-char-ptr-type - #:null-stmt - - ;;; Columnt types. - #:SQLITE-INTEGER - #:SQLITE-FLOAT - #:SQLITE-TEXT - #:SQLITE-BLOB - #:SQLITE-NULL)) + #:sqlite3-close + + #:sqlite3-prepare + #:sqlite3-step + #:sqlite3-finalize + + #:sqlite3-column-count + #:sqlite3-column-name + #:sqlite3-column-type + #:sqlite3-column-text + #:sqlite3-column-bytes + #:sqlite3-column-blob + + ;;; Types. + #:sqlite3-db + #:sqlite3-db-type + #:sqlite3-stmt-type + #:unsigned-char-ptr-type + #:null-stmt + + ;;; Columnt types. + #:SQLITE-INTEGER + #:SQLITE-FLOAT + #:SQLITE-TEXT + #:SQLITE-BLOB + #:SQLITE-NULL)) (in-package #:sqlite3) @@ -91,7 +91,7 @@ (defconstant SQLITE-ROW 100 "sqlite3_step() has another row ready") (defconstant SQLITE-DONE 101 "sqlite3_step() has finished executing") -(defparameter error-codes +(defparameter error-codes (list (cons SQLITE-OK "not an error") (cons SQLITE-ERROR "SQL logic error or missing database") @@ -166,27 +166,27 @@ ((message :initarg :message :reader sqlite3-error-message :initform "") (code :initarg :code :reader sqlite3-error-code)) (:report (lambda (condition stream) - (format stream "Sqlite3 error [~A]: ~A" - (sqlite3-error-code condition) - (sqlite3-error-message condition))))) + (format stream "Sqlite3 error [~A]: ~A" + (sqlite3-error-code condition) + (sqlite3-error-message condition))))) (defgeneric signal-sqlite3-error (db)) (defmethod signal-sqlite3-error (db) (let ((condition - (make-condition 'sqlite3-error - :code (sqlite3-errcode db) - :message (convert-from-cstring (sqlite3-errmsg db))))) + (make-condition 'sqlite3-error + :code (sqlite3-errcode db) + :message (convert-from-cstring (sqlite3-errmsg db))))) (unless (signal condition) (invoke-debugger condition)))) (defmethod signal-sqlite3-error ((code number)) (let ((condition - (make-condition 'sqlite3-error - :code code - :message (let ((s (cdr (assoc code error-codes)))) - (if s - s - "unknown error"))))) + (make-condition 'sqlite3-error + :code code + :message (let ((s (cdr (assoc code error-codes)))) + (if s + s + "unknown error"))))) (unless (signal condition) (invoke-debugger condition)))) @@ -247,41 +247,41 @@ :returning :int) (declaim (inline sqlite3-column-count)) -(def-sqlite3-function +(def-sqlite3-function "sqlite3_column_count" ((stmt sqlite3-stmt)) :returning :int) (declaim (inline %column-name)) -(def-sqlite3-function +(def-sqlite3-function ("sqlite3_column_name" %column-name) ((stmt sqlite3-stmt) (n-col :int)) :returning :cstring) (declaim (inline sqlite3-column-type)) -(def-sqlite3-function +(def-sqlite3-function "sqlite3_column_type" ((stmt sqlite3-stmt) (n-col :int)) :returning :int) (declaim (inline sqlite3-column-text)) -(def-sqlite3-function +(def-sqlite3-function "sqlite3_column_text" ((stmt sqlite3-stmt) (n-col :int)) :returning (* :unsigned-char)) (declaim (inline sqlite3-column-bytes)) -(def-sqlite3-function +(def-sqlite3-function "sqlite3_column_bytes" ((stmt sqlite3-stmt) (n-col :int)) :returning :int) (declaim (inline sqlite3-column-blob)) -(def-sqlite3-function +(def-sqlite3-function "sqlite3_column_blob" ((stmt sqlite3-stmt) (n-col :int)) @@ -295,30 +295,30 @@ (declare (ignore mode) (type string db-name)) (let ((dbp (allocate-foreign-object 'sqlite3-db))) (declare (type sqlite3-db-ptr-type dbp)) - (with-cstring (db-name-native db-name) + (with-cstring (db-name-native db-name) (let ((result (%open db-name-native dbp))) - (if (/= result 0) - (progn - ;; According to docs, the db must be closed even in case - ;; of error. - (%close (deref-pointer dbp 'sqlite3-db)) - (free-foreign-object dbp) - (signal-sqlite3-error result)) - (let ((db (deref-pointer dbp 'sqlite3-db))) - (declare (type sqlite3-db-type db)) - (setf (gethash db *db-pointers*) dbp) - db)))))) + (if (/= result 0) + (progn + ;; According to docs, the db must be closed even in case + ;; of error. + (%close (deref-pointer dbp 'sqlite3-db)) + (free-foreign-object dbp) + (signal-sqlite3-error result)) + (let ((db (deref-pointer dbp 'sqlite3-db))) + (declare (type sqlite3-db-type db)) + (setf (gethash db *db-pointers*) dbp) + db)))))) (declaim (ftype (function (sqlite3-db-type) t) sqlite3-close)) (defun sqlite3-close (db) (declare (type sqlite3-db-type db)) (let ((result (%close db))) (if (/= result 0) - (signal-sqlite3-error result) - (progn - (free-foreign-object (gethash db *db-pointers*)) - (remhash db *db-pointers*) - t)))) + (signal-sqlite3-error result) + (progn + (free-foreign-object (gethash db *db-pointers*)) + (remhash db *db-pointers*) + t)))) (declaim (ftype (function (sqlite3-db-type string) sqlite3-stmt-type) sqlite3-prepare)) (defun sqlite3-prepare (db sql) @@ -327,38 +327,38 @@ (let ((stmtp (allocate-foreign-object 'sqlite3-stmt))) (declare (type sqlite3-stmt-ptr-type stmtp)) (with-foreign-object (sql-tail '(* :unsigned-char)) - (let ((result (%prepare db sql-native -1 stmtp sql-tail))) - (if (/= result SQLITE-OK) - (progn - (unless (null-pointer-p stmtp) - ;; There is an error, but a statement has been allocated: - ;; finalize it (better safe than sorry). - (%finalize (deref-pointer stmtp 'sqlite3-stmt))) - (free-foreign-object stmtp) - (signal-sqlite3-error db)) - (let ((stmt (deref-pointer stmtp 'sqlite3-stmt))) - (declare (type sqlite3-stmt-type stmt)) - (setf (gethash stmt *stmt-pointers*) stmtp) - stmt))))))) + (let ((result (%prepare db sql-native -1 stmtp sql-tail))) + (if (/= result SQLITE-OK) + (progn + (unless (null-pointer-p stmtp) + ;; There is an error, but a statement has been allocated: + ;; finalize it (better safe than sorry). + (%finalize (deref-pointer stmtp 'sqlite3-stmt))) + (free-foreign-object stmtp) + (signal-sqlite3-error db)) + (let ((stmt (deref-pointer stmtp 'sqlite3-stmt))) + (declare (type sqlite3-stmt-type stmt)) + (setf (gethash stmt *stmt-pointers*) stmtp) + stmt))))))) (declaim (ftype (function (sqlite3-stmt-type) t) sqlite3-step)) (defun sqlite3-step (stmt) (declare (type sqlite3-stmt-type stmt)) (let ((result (%step stmt))) (cond ((= result SQLITE-ROW) t) - ((= result SQLITE-DONE) nil) - (t (signal-sqlite3-error result))))) + ((= result SQLITE-DONE) nil) + (t (signal-sqlite3-error result))))) (declaim (ftype (function (sqlite3-stmt-type) t) sqlite3-finalize)) (defun sqlite3-finalize (stmt) (declare (type sqlite3-stmt-type stmt)) (let ((result (%finalize stmt))) (if (/= result SQLITE-OK) - (signal-sqlite3-error result) - (progn - (free-foreign-object (gethash stmt *stmt-pointers*)) - (remhash stmt *stmt-pointers*) - t)))) + (signal-sqlite3-error result) + (progn + (free-foreign-object (gethash stmt *stmt-pointers*)) + (remhash stmt *stmt-pointers*) + t)))) (declaim (inline sqlite3-column-name)) (defun sqlite3-column-name (stmt n) diff --git a/db-sqlite3/sqlite3-sql.lisp b/db-sqlite3/sqlite3-sql.lisp index 8b433be..90f0812 100644 --- a/db-sqlite3/sqlite3-sql.lisp +++ b/db-sqlite3/sqlite3-sql.lisp @@ -31,34 +31,34 @@ (check-connection-spec connection-spec :sqlite3 (name &optional init-foreign-func))) (defmethod database-name-from-spec (connection-spec - (database-type (eql :sqlite3))) + (database-type (eql :sqlite3))) (check-sqlite3-connection-spec connection-spec) (first connection-spec)) (defmethod database-connect (connection-spec (database-type (eql :sqlite3))) (check-sqlite3-connection-spec connection-spec) (handler-case - (let ((db (sqlite3:sqlite3-open (first connection-spec))) - (init-foreign-func (second connection-spec))) - (declare (type sqlite3:sqlite3-db-type db)) - (when init-foreign-func - (handler-case - (funcall init-foreign-func db) - (condition (c) - (progn - (sqlite3:sqlite3-close db) - (error c))))) - (make-instance 'sqlite3-database - :name (database-name-from-spec connection-spec :sqlite3) - :database-type :sqlite3 - :connection-spec connection-spec - :sqlite3-db db)) + (let ((db (sqlite3:sqlite3-open (first connection-spec))) + (init-foreign-func (second connection-spec))) + (declare (type sqlite3:sqlite3-db-type db)) + (when init-foreign-func + (handler-case + (funcall init-foreign-func db) + (condition (c) + (progn + (sqlite3:sqlite3-close db) + (error c))))) + (make-instance 'sqlite3-database + :name (database-name-from-spec connection-spec :sqlite3) + :database-type :sqlite3 + :connection-spec connection-spec + :sqlite3-db db)) (sqlite3:sqlite3-error (err) - (error 'sql-connection-error - :database-type database-type - :connection-spec connection-spec - :error-id (sqlite3:sqlite3-error-code err) - :message (sqlite3:sqlite3-error-message err))))) + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (sqlite3:sqlite3-error-code err) + :message (sqlite3:sqlite3-error-message err))))) (defmethod database-disconnect ((database sqlite3-database)) (sqlite3:sqlite3-close (sqlite3-db database)) @@ -68,22 +68,22 @@ (defmethod database-execute-command (sql-expression (database sqlite3-database)) (handler-case (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database) sql-expression))) - (declare (type sqlite3:sqlite3-stmt-type stmt)) - (when stmt - (unwind-protect - (sqlite3:sqlite3-step stmt) - (sqlite3:sqlite3-finalize stmt)))) + (declare (type sqlite3:sqlite3-stmt-type stmt)) + (when stmt + (unwind-protect + (sqlite3:sqlite3-step stmt) + (sqlite3:sqlite3-finalize stmt)))) (sqlite3:sqlite3-error (err) (error 'sql-database-data-error - :database database - :expression sql-expression - :error-id (sqlite3:sqlite3-error-code err) - :message (sqlite3:sqlite3-error-message err)))) + :database database + :expression sql-expression + :error-id (sqlite3:sqlite3-error-code err) + :message (sqlite3:sqlite3-error-message err)))) t) (defstruct sqlite3-result-set (stmt sqlite3:null-stmt - :type sqlite3:sqlite3-stmt-type) + :type sqlite3:sqlite3-stmt-type) (n-col 0 :type fixnum) (col-names '()) (result-types '())) @@ -93,137 +93,137 @@ (declare (type sqlite3:sqlite3-stmt-type stmt) (type fixnum n-col)) (if (eq :auto result-types) (loop for n from 0 below n-col - collect (let ((column-type (sqlite3:sqlite3-column-type stmt n))) - (cond - ((= column-type sqlite3:SQLITE-INTEGER) :int64) - ((= column-type sqlite3:SQLITE-FLOAT) :double) - ((= column-type sqlite3:SQLITE-TEXT) :string) - ((= column-type sqlite3:SQLITE-BLOB) :blob) - ((= column-type sqlite3:SQLITE-NULL) :string) - (t :string)))) + collect (let ((column-type (sqlite3:sqlite3-column-type stmt n))) + (cond + ((= column-type sqlite3:SQLITE-INTEGER) :int64) + ((= column-type sqlite3:SQLITE-FLOAT) :double) + ((= column-type sqlite3:SQLITE-TEXT) :string) + ((= column-type sqlite3:SQLITE-BLOB) :blob) + ((= column-type sqlite3:SQLITE-NULL) :string) + (t :string)))) (loop for type in result-types - collect (case type - ((:int :integer :tinyint) :int32) - (:long #+(or x86-64 64bit) :int64 #-(or x86-64 64bit) :int32) - (:bigint :int64) - ((:float :double) :double) - ((:numeric) :number) - (otherwise :string))))) + collect (case type + ((:int :integer :tinyint) :int32) + (:long #+(or x86-64 64bit) :int64 #-(or x86-64 64bit) :int32) + (:bigint :int64) + ((:float :double) :double) + ((:numeric) :number) + (otherwise :string))))) (defmethod database-query-result-set ((query-expression string) - (database sqlite3-database) - &key result-types full-set) + (database sqlite3-database) + &key result-types full-set) (let ((stmt sqlite3:null-stmt)) (declare (type sqlite3:sqlite3-stmt-type stmt)) (handler-case - (progn - (setf stmt (sqlite3:sqlite3-prepare (sqlite3-db database) - query-expression)) - (let* ((n-col (if (sqlite3:sqlite3-step stmt) - ;; Non empty result set. - (sqlite3:sqlite3-column-count stmt) - ;; Empty result set. - 0)) - (result-set (make-sqlite3-result-set - :stmt stmt - :n-col n-col - :col-names (loop for n from 0 below n-col - collect (sqlite3:sqlite3-column-name stmt n)) - :result-types (when (> n-col 0) - (get-result-types stmt n-col result-types))))) - (if full-set - (values result-set n-col nil) - (values result-set n-col)))) + (progn + (setf stmt (sqlite3:sqlite3-prepare (sqlite3-db database) + query-expression)) + (let* ((n-col (if (sqlite3:sqlite3-step stmt) + ;; Non empty result set. + (sqlite3:sqlite3-column-count stmt) + ;; Empty result set. + 0)) + (result-set (make-sqlite3-result-set + :stmt stmt + :n-col n-col + :col-names (loop for n from 0 below n-col + collect (sqlite3:sqlite3-column-name stmt n)) + :result-types (when (> n-col 0) + (get-result-types stmt n-col result-types))))) + (if full-set + (values result-set n-col nil) + (values result-set n-col)))) (sqlite3:sqlite3-error (err) - (progn - (unless (eq stmt sqlite3:null-stmt) - (ignore-errors - (sqlite3:sqlite3-finalize stmt))) - (error 'sql-database-data-error - :database database - :expression query-expression - :error-id (sqlite3:sqlite3-error-code err) - :message (sqlite3:sqlite3-error-message err))))))) + (progn + (unless (eq stmt sqlite3:null-stmt) + (ignore-errors + (sqlite3:sqlite3-finalize stmt))) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (sqlite3:sqlite3-error-code err) + :message (sqlite3:sqlite3-error-message err))))))) (defmethod database-dump-result-set (result-set (database sqlite3-database)) - (handler-case + (handler-case (sqlite3:sqlite3-finalize (sqlite3-result-set-stmt result-set)) (sqlite3:sqlite3-error (err) (error 'sql-database-error - :message - (format nil "Error finalizing SQLite3 statement: ~A" - (sqlite3:sqlite3-error-message err)))))) + :message + (format nil "Error finalizing SQLite3 statement: ~A" + (sqlite3:sqlite3-error-message err)))))) (defmethod database-store-next-row (result-set (database sqlite3-database) list) (let ((n-col (sqlite3-result-set-n-col result-set))) (if (= n-col 0) - ;; empty result set. - nil - ;; Non-empty set. - (let ((stmt (sqlite3-result-set-stmt result-set))) - (declare (type sqlite3:sqlite3-stmt-type stmt)) - ;; Store row in list. - (loop for i = 0 then (1+ i) - for rest on list - for types = (sqlite3-result-set-result-types result-set) then (rest types) - do (setf (car rest) - (if (eq (first types) :blob) - (clsql-uffi:convert-raw-field - (sqlite3:sqlite3-column-blob stmt i) - types 0 - (sqlite3:sqlite3-column-bytes stmt i)) - (clsql-uffi:convert-raw-field - (sqlite3:sqlite3-column-text stmt i) - types 0)))) - ;; Advance result set cursor. - (handler-case - (unless (sqlite3:sqlite3-step stmt) - (setf (sqlite3-result-set-n-col result-set) 0)) - (sqlite3:sqlite3-error (err) - (error 'sql-database-error - :message (format nil "Error in sqlite3-step: ~A" + ;; empty result set. + nil + ;; Non-empty set. + (let ((stmt (sqlite3-result-set-stmt result-set))) + (declare (type sqlite3:sqlite3-stmt-type stmt)) + ;; Store row in list. + (loop for i = 0 then (1+ i) + for rest on list + for types = (sqlite3-result-set-result-types result-set) then (rest types) + do (setf (car rest) + (if (eq (first types) :blob) + (clsql-uffi:convert-raw-field + (sqlite3:sqlite3-column-blob stmt i) + types 0 + (sqlite3:sqlite3-column-bytes stmt i)) + (clsql-uffi:convert-raw-field + (sqlite3:sqlite3-column-text stmt i) + types 0)))) + ;; Advance result set cursor. + (handler-case + (unless (sqlite3:sqlite3-step stmt) + (setf (sqlite3-result-set-n-col result-set) 0)) + (sqlite3:sqlite3-error (err) + (error 'sql-database-error + :message (format nil "Error in sqlite3-step: ~A" (sqlite3:sqlite3-error-message err))))) - t)))) + t)))) (defmethod database-query (query-expression (database sqlite3-database) result-types field-names) (declare (optimize (speed 3) (safety 0) (debug 0) (space 0))) (handler-case - (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database) - query-expression)) - (rows '()) - (col-names '())) - (declare (type sqlite3:sqlite3-stmt-type stmt)) - (unwind-protect - (when (sqlite3:sqlite3-step stmt) - (let ((n-col (sqlite3:sqlite3-column-count stmt))) - (flet ((extract-row-data () - (loop for i from 0 below n-col - for types = (get-result-types stmt n-col result-types) then (rest types) - collect (if (eq (first types) :blob) - (clsql-uffi:convert-raw-field - (sqlite3:sqlite3-column-blob stmt i) - types 0 - (sqlite3:sqlite3-column-bytes stmt i)) - (clsql-uffi:convert-raw-field - (sqlite3:sqlite3-column-text stmt i) - types 0))))) - (when field-names - (setf col-names (loop for n from 0 below n-col - collect (sqlite3:sqlite3-column-name stmt n)))) - (push (extract-row-data) rows) - (do* () (nil) - (if (sqlite3:sqlite3-step stmt) - (push (extract-row-data) rows) - (return)))))) - (sqlite3:sqlite3-finalize stmt)) - (values (nreverse rows) col-names)) + (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database) + query-expression)) + (rows '()) + (col-names '())) + (declare (type sqlite3:sqlite3-stmt-type stmt)) + (unwind-protect + (when (sqlite3:sqlite3-step stmt) + (let ((n-col (sqlite3:sqlite3-column-count stmt))) + (flet ((extract-row-data () + (loop for i from 0 below n-col + for types = (get-result-types stmt n-col result-types) then (rest types) + collect (if (eq (first types) :blob) + (clsql-uffi:convert-raw-field + (sqlite3:sqlite3-column-blob stmt i) + types 0 + (sqlite3:sqlite3-column-bytes stmt i)) + (clsql-uffi:convert-raw-field + (sqlite3:sqlite3-column-text stmt i) + types 0))))) + (when field-names + (setf col-names (loop for n from 0 below n-col + collect (sqlite3:sqlite3-column-name stmt n)))) + (push (extract-row-data) rows) + (do* () (nil) + (if (sqlite3:sqlite3-step stmt) + (push (extract-row-data) rows) + (return)))))) + (sqlite3:sqlite3-finalize stmt)) + (values (nreverse rows) col-names)) (sqlite3:sqlite3-error (err) (error 'sql-database-data-error - :database database - :expression query-expression - :error-id (sqlite3:sqlite3-error-code err) - :message (sqlite3:sqlite3-error-message err))))) + :database database + :expression query-expression + :error-id (sqlite3:sqlite3-error-code err) + :message (sqlite3:sqlite3-error-message err))))) ;;; Object listing @@ -231,14 +231,14 @@ (declare (ignore owner)) ;; Query is copied from .table command of sqlite3 command line utility. (mapcar #'car (database-query - "SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name" - database nil nil))) + "SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name" + database nil nil))) (defmethod database-list-tables ((database sqlite3-database) &key owner) (remove-if #'(lambda (s) (and (>= (length s) 11) (string-equal (subseq s 0 11) "_CLSQL_SEQ_"))) - (database-list-tables-and-sequences database :owner owner))) + (database-list-tables-and-sequences database :owner owner))) (defmethod database-list-views ((database sqlite3-database) &key (owner nil)) @@ -255,49 +255,49 @@ database nil nil))) (defmethod database-list-table-indexes (table (database sqlite3-database) - &key (owner nil)) + &key (owner nil)) (declare (ignore owner)) (let ((*print-circle* nil)) - (mapcar #'car - (database-query - (format - nil - "SELECT name FROM sqlite_master WHERE type='index' AND tbl_name='~A' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' AND tbl_name='~A' ORDER BY name" - table table) - database nil nil)))) + (mapcar #'car + (database-query + (format + nil + "SELECT name FROM sqlite_master WHERE type='index' AND tbl_name='~A' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' AND tbl_name='~A' ORDER BY name" + table table) + database nil nil)))) (declaim (inline sqlite3-table-info)) (defun sqlite3-table-info (table database) (database-query (format nil "PRAGMA table_info('~A')" table) - database nil nil)) + database nil nil)) (defmethod database-list-attributes (table (database sqlite3-database) &key (owner nil)) (declare (ignore owner)) (mapcar #'(lambda (table-info) (second table-info)) - (sqlite3-table-info table database))) + (sqlite3-table-info table database))) -(defmethod database-attribute-type (attribute table - (database sqlite3-database) +(defmethod database-attribute-type (attribute table + (database sqlite3-database) &key (owner nil)) (declare (ignore owner)) (loop for field-info in (sqlite3-table-info table database) when (string= attribute (second field-info)) - return - (let* ((raw-type (third field-info)) - (start-length (position #\( raw-type)) - (type (if start-length - (subseq raw-type 0 start-length) - raw-type)) - (length (if start-length - (parse-integer (subseq raw-type (1+ start-length)) - :junk-allowed t) - nil))) - (values (when type (ensure-keyword type)) - length - nil - (if (string-equal (fourth field-info) "0") - 1 0))))) + return + (let* ((raw-type (third field-info)) + (start-length (position #\( raw-type)) + (type (if start-length + (subseq raw-type 0 start-length) + raw-type)) + (length (if start-length + (parse-integer (subseq raw-type (1+ start-length)) + :junk-allowed t) + nil))) + (values (when type (ensure-keyword type)) + length + nil + (if (string-equal (fourth field-info) "0") + 1 0))))) (defmethod database-create (connection-spec (type (eql :sqlite3))) (declare (ignore connection-spec)) @@ -307,14 +307,14 @@ (defmethod database-destroy (connection-spec (type (eql :sqlite3))) (destructuring-bind (name) connection-spec (if (probe-file name) - (delete-file name) - nil))) + (delete-file name) + nil))) (defmethod database-probe (connection-spec (type (eql :sqlite3))) (destructuring-bind (name) connection-spec ;; TODO: Add a test that this file is a real sqlite3 database (or (string-equal ":memory:" name) - (and (probe-file name) t)))) + (and (probe-file name) t)))) ;;; Database capabilities diff --git a/examples/clsql-tutorial.lisp b/examples/clsql-tutorial.lisp index 265ae6d..1980e3d 100644 --- a/examples/clsql-tutorial.lisp +++ b/examples/clsql-tutorial.lisp @@ -2,17 +2,17 @@ (in-package #:clsql-user) -;; You must set these variables to appropriate values. -(defvar *tutorial-database-type* nil +;; You must set these variables to appropriate values. +(defvar *tutorial-database-type* nil "Possible values are :postgresql :postgresql-socket, :mysql, :oracle, :odbc, :aodbc or :sqlite") (defvar *tutorial-database-name* "clsqltut" "The name of the database we will work in.") -(defvar *tutorial-database-user* "" +(defvar *tutorial-database-user* "" "The name of the database user we will work as.") (defvar *tutorial-database-server* "" "The name of the database server if required") -(defvar *tutorial-database-password* "" +(defvar *tutorial-database-password* "" "The password if required") (clsql:def-view-class employee () @@ -40,9 +40,9 @@ :accessor employee-company :db-kind :join :db-info (:join-class company - :home-key companyid - :foreign-key companyid - :set nil)) + :home-key companyid + :foreign-key companyid + :set nil)) (managerid :type integer :initarg :managerid) @@ -50,9 +50,9 @@ :accessor employee-manager :db-kind :join :db-info (:join-class employee - :home-key managerid - :foreign-key emplid - :set nil))) + :home-key managerid + :foreign-key emplid + :set nil))) (:base-table employee)) (clsql:def-view-class company () @@ -71,35 +71,35 @@ :reader president :db-kind :join :db-info (:join-class employee - :home-key presidentid - :foreign-key emplid - :set nil)) + :home-key presidentid + :foreign-key emplid + :set nil)) (employees :reader company-employees :db-kind :join :db-info (:join-class employee - :home-key companyid - :foreign-key companyid - :set t))) + :home-key companyid + :foreign-key companyid + :set t))) (:base-table company)) ;; Connect to the database (see the CLSQL documentation for vendor ;; specific connection specs). (case *tutorial-database-type* ((:mysql :postgresql :postgresql-socket) - (clsql:connect `(,*tutorial-database-server* - ,*tutorial-database-name* - ,*tutorial-database-user* - ,*tutorial-database-password*) - :database-type *tutorial-database-type*)) + (clsql:connect `(,*tutorial-database-server* + ,*tutorial-database-name* + ,*tutorial-database-user* + ,*tutorial-database-password*) + :database-type *tutorial-database-type*)) ((:odbc :aodbc :oracle) - (clsql:connect `(,*tutorial-database-name* - ,*tutorial-database-user* - ,*tutorial-database-password*) - :database-type *tutorial-database-type*)) + (clsql:connect `(,*tutorial-database-name* + ,*tutorial-database-user* + ,*tutorial-database-password*) + :database-type *tutorial-database-type*)) (:sqlite (clsql:connect `(,*tutorial-database-name*) - :database-type *tutorial-database-type*))) + :database-type *tutorial-database-type*))) ;; Record the sql going out, helps us learn what is going ;; on behind the scenes @@ -117,38 +117,38 @@ ;; Create some instances of our view classes (defvar company1 (make-instance 'company - :companyid 1 - :name "Widgets Inc." - ;; Lenin is president of Widgets Inc. - :presidentid 1)) + :companyid 1 + :name "Widgets Inc." + ;; Lenin is president of Widgets Inc. + :presidentid 1)) (defvar employee1 (make-instance 'employee - :emplid 1 - :first-name "Vladamir" - :last-name "Lenin" - :email "lenin@soviet.org" - :companyid 1)) + :emplid 1 + :first-name "Vladamir" + :last-name "Lenin" + :email "lenin@soviet.org" + :companyid 1)) (defvar employee2 (make-instance 'employee - :emplid 2 - :first-name "Josef" - :last-name "Stalin" - :email "stalin@soviet.org" - :companyid 1 - ;; Lenin manages Stalin (for now) - :managerid 1)) + :emplid 2 + :first-name "Josef" + :last-name "Stalin" + :email "stalin@soviet.org" + :companyid 1 + ;; Lenin manages Stalin (for now) + :managerid 1)) (clsql:update-records-from-instance employee1) (clsql:update-records-from-instance employee2) (clsql:update-records-from-instance company1) -;; lets use the functional sql interface +;; lets use the functional sql interface (clsql:locally-enable-sql-reader-syntax) (format t "The email address of ~A ~A is ~A" - (first-name employee1) - (last-name employee1) - (employee-email employee1)) + (first-name employee1) + (last-name employee1) + (employee-email employee1)) (setf (employee-email employee1) "lenin-nospam@soviets.org") @@ -156,11 +156,11 @@ (clsql:update-records-from-instance employee1) (let ((new-lenin (car - (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] 1] - :flatp t)))) + (clsql:select 'employee + :where [= [slot-value 'employee 'emplid] 1] + :flatp t)))) (format t "His new email is ~A" - (employee-email new-lenin))) + (employee-email new-lenin))) ;; Some queries @@ -172,17 +172,17 @@ ;; employees named Lenin (clsql:select 'employee :where [= [slot-value 'employee 'last-name] - "Lenin"]) + "Lenin"]) (clsql:select 'company :where [= [slot-value 'company 'name] - "Widgets Inc."]) + "Widgets Inc."]) ;; Employees of Widget's Inc. (clsql:select 'employee - :where [and [= [slot-value 'employee 'companyid] - [slot-value 'company 'companyid]] - [= [slot-value 'company 'name] - "Widgets Inc."]]) + :where [and [= [slot-value 'employee 'companyid] + [slot-value 'company 'companyid]] + [= [slot-value 'company 'name] + "Widgets Inc."]]) ;; Same thing, except that we are using the employee ;; relation in the company view class to do the join for us, diff --git a/examples/sqlite3/init-func/example.lisp b/examples/sqlite3/init-func/example.lisp index 1a81645..c94c621 100644 --- a/examples/sqlite3/init-func/example.lisp +++ b/examples/sqlite3/init-func/example.lisp @@ -21,12 +21,12 @@ ;;;; Load sqlite3-utils.so library. See Makefile for library creation. (unless (uffi:load-foreign-library "/usr/lib/clsql/sqlite3-utils.so" - :module "sqlite3-utils" - :supporting-libraries '("c")) + :module "sqlite3-utils" + :supporting-libraries '("c")) (error "Unable to load foreign library")) ;;;; Define the foreign function to be used as init function. -(uffi:def-function +(uffi:def-function ("create_iso_8859_15_ci_collation" create-coll) ((db sqlite3:sqlite3-db)) :returning :int @@ -39,7 +39,7 @@ ;;;; Create a table. Field f2 uses the newly defined collating ;;;; sequence. -(clsql:execute-command +(clsql:execute-command "CREATE TABLE t1 (f1 CHAR(1), f2 CHAR(1) COLLATE ISO_8859_15_CI)") ;;;; Populate the table. @@ -61,10 +61,10 @@ ;;;; Perform some SELECTs. (format t "~&SELECT * FROM t1 ==> ~A~%"(clsql:query "SELECT * FROM t1")) -(format t "~&SELECT * FROM t1 ORDER BY f1 ==> ~A~%" - (clsql:query "SELECT * FROM t1 ORDER BY f1")) -(format t "~&SELECT * FROM t1 ORDER BY f2 ==> ~A~%" - (clsql:query "SELECT * FROM t1 ORDER BY f2")) +(format t "~&SELECT * FROM t1 ORDER BY f1 ==> ~A~%" + (clsql:query "SELECT * FROM t1 ORDER BY f1")) +(format t "~&SELECT * FROM t1 ORDER BY f2 ==> ~A~%" + (clsql:query "SELECT * FROM t1 ORDER BY f2")) ;;;; Disconnect from database. (clsql:disconnect) \ No newline at end of file diff --git a/examples/sqlite3/init-func/iso-8859-15-coll.c b/examples/sqlite3/init-func/iso-8859-15-coll.c index 0e7fea1..e69a2ee 100644 --- a/examples/sqlite3/init-func/iso-8859-15-coll.c +++ b/examples/sqlite3/init-func/iso-8859-15-coll.c @@ -2,7 +2,7 @@ * FILE IDENTIFICATION * * Name: iso-8859-15-coll.c - * Purpose: SQLite 3 initialization function for + * Purpose: SQLite 3 initialization function for * ISO-8859-15 collating sequence. * Programmer: Aurelio Bignoli * Date Started: Oct 2004 @@ -22,20 +22,20 @@ /* Conversion table. */ const unsigned char iso_8859_15_ci [] = { - /* 0 */ 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0A, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, - /* 1 */ 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x1B, 0x1C, 0x1D, 0x1E, 0x1F, - /* 2 */ 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x2D, 0x2E, 0x2F, - /* 3 */ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3A, 0x3B, 0x3C, 0x3D, 0x3E, 0x3F, - /* 4 */ 0x40, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, - /* 5 */ 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x5B, 0x5C, 0x5D, 0x5E, 0x5F, - /* 6 */ 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, - /* 7 */ 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x7B, 0x7C, 0x7D, 0x7E, 0x7F, - /* 8 */ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x73, 0x8B, 0x6F, 0x8D, 0x7A, 0x79, - /* 9 */ 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x73, 0x9B, 0x6F, 0x9D, 0x7A, 0x79, - /* A */ 0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0x73, 0xA7, 0x73, 0xA9, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF, - /* B */ 0xB0, 0xB1, 0xB2, 0xB3, 0x7A, 0xB5, 0xB6, 0xB7, 0x7A, 0xB9, 0xBA, 0xBB, 0x6F, 0xBD, 0x79, 0xBF, - /* C */ 0x61, 0x61, 0x61, 0x61, 0x61, 0x61, 0x65, 0x63, 0x65, 0x65, 0x65, 0x65, 0x69, 0x69, 0x69, 0x69, - /* D */ 0x64, 0x6E, 0x6F, 0x6F, 0x6F, 0x6F, 0x6F, 0xD7, 0x6F, 0x75, 0x75, 0x75, 0x75, 0x79, 0xDE, 0x73, + /* 0 */ 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0A, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, + /* 1 */ 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x1B, 0x1C, 0x1D, 0x1E, 0x1F, + /* 2 */ 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x2D, 0x2E, 0x2F, + /* 3 */ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3A, 0x3B, 0x3C, 0x3D, 0x3E, 0x3F, + /* 4 */ 0x40, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, + /* 5 */ 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x5B, 0x5C, 0x5D, 0x5E, 0x5F, + /* 6 */ 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, + /* 7 */ 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x7B, 0x7C, 0x7D, 0x7E, 0x7F, + /* 8 */ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x73, 0x8B, 0x6F, 0x8D, 0x7A, 0x79, + /* 9 */ 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x73, 0x9B, 0x6F, 0x9D, 0x7A, 0x79, + /* A */ 0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0x73, 0xA7, 0x73, 0xA9, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF, + /* B */ 0xB0, 0xB1, 0xB2, 0xB3, 0x7A, 0xB5, 0xB6, 0xB7, 0x7A, 0xB9, 0xBA, 0xBB, 0x6F, 0xBD, 0x79, 0xBF, + /* C */ 0x61, 0x61, 0x61, 0x61, 0x61, 0x61, 0x65, 0x63, 0x65, 0x65, 0x65, 0x65, 0x69, 0x69, 0x69, 0x69, + /* D */ 0x64, 0x6E, 0x6F, 0x6F, 0x6F, 0x6F, 0x6F, 0xD7, 0x6F, 0x75, 0x75, 0x75, 0x75, 0x79, 0xDE, 0x73, /* E */ 0x61, 0x61, 0x61, 0x61, 0x61, 0x61, 0x65, 0x63, 0x65, 0x65, 0x65, 0x65, 0x69, 0x69, 0x69, 0x69, /* F */ 0x64, 0x6E, 0x6F, 0x6F, 0x6F, 0x6F, 0x6F, 0xF7, 0x6F, 0x75, 0x75, 0x75, 0x75, 0x79, 0xFE, 0x73 }; @@ -66,8 +66,8 @@ int iso_8859_15_ci_CollatingFunc( } return r; } - -/* + +/* * Set the ISO_8859_15_CI collating sequence for a db. */ #include "sqlite3.h" @@ -75,5 +75,5 @@ int iso_8859_15_ci_CollatingFunc( int create_iso_8859_15_ci_collation (sqlite3 *db) { return sqlite3_create_collation (db, ISO_8859_15_CI_NAME, SQLITE_UTF8, 0, - iso_8859_15_ci_CollatingFunc); + iso_8859_15_ci_CollatingFunc); } diff --git a/sql/ansi-loop.lisp b/sql/ansi-loop.lisp index bc5f306..6a2cab4 100644 --- a/sql/ansi-loop.lisp +++ b/sql/ansi-loop.lisp @@ -132,7 +132,7 @@ ;;; end of the list might be suboptimal because the end of the list will ;;; probably be RPLACDed and so cdr-normal should be used instead. (defmacro loop-copylist* (l) - #+Genera `(lisp:copy-list ,l nil t) ; arglist = (list &optional area force-dotted) + #+Genera `(lisp:copy-list ,l nil t) ; arglist = (list &optional area force-dotted) ;;@@@@Explorer?? #-Genera `(copy-list ,l) ) @@ -159,15 +159,15 @@ ;; replaced with the appropriate conditional name for your ;; implementation/dialect. (declare #-ANSI (ignore env) - #+Genera (values speed space safety compilation-speed debug)) + #+Genera (values speed space safety compilation-speed debug)) #+ANSI (let ((stuff (declaration-information 'optimize env))) - (values (or (cdr (assoc 'speed stuff)) 1) - (or (cdr (assoc 'space stuff)) 1) - (or (cdr (assoc 'safety stuff)) 1) - (or (cdr (assoc 'compilation-speed stuff)) 1) - (or (cdr (assoc 'debug stuff)) 1))) + (values (or (cdr (assoc 'speed stuff)) 1) + (or (cdr (assoc 'space stuff)) 1) + (or (cdr (assoc 'safety stuff)) 1) + (or (cdr (assoc 'compilation-speed stuff)) 1) + (or (cdr (assoc 'debug stuff)) 1))) #+CLOE-Runtime (values compiler::time compiler::space - compiler::safety compiler::compilation-speed 1) + compiler::safety compiler::compilation-speed 1) #-(or ANSI CLOE-Runtime) (values 1 1 1 1 1)) @@ -206,9 +206,9 @@ ;;; for all callers to contain the conditional invisibility construction. (defun hide-variable-reference (really-hide variable form) (declare #-Genera (ignore really-hide variable)) - #+Genera (if (and really-hide variable (atom variable)) ;Punt on destructuring patterns - `(compiler:invisible-references (,variable) ,form) - form) + #+Genera (if (and really-hide variable (atom variable)) ;Punt on destructuring patterns + `(compiler:invisible-references (,variable) ,form) + form) #-Genera form) @@ -216,81 +216,81 @@ (defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var) - &body body) + &body body) ;;@@@@ TI? Exploder? #+LISPM (let ((head-place (or user-head-var head-var))) - `(let* ((,head-place nil) - (,tail-var - ,(hide-variable-reference - user-head-var user-head-var - `(progn #+Genera (scl:locf ,head-place) - #-Genera (system:variable-location ,head-place))))) - ,@body)) + `(let* ((,head-place nil) + (,tail-var + ,(hide-variable-reference + user-head-var user-head-var + `(progn #+Genera (scl:locf ,head-place) + #-Genera (system:variable-location ,head-place))))) + ,@body)) #-LISPM (let ((l (and user-head-var (list (list user-head-var nil))))) - #+CLOE `(sys::with-stack-list* (,head-var nil nil) - (let ((,tail-var ,head-var) ,@l) - ,@body)) - #-CLOE `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l) - ,@body))) + #+CLOE `(sys::with-stack-list* (,head-var nil nil) + (let ((,tail-var ,head-var) ,@l) + ,@body)) + #-CLOE `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l) + ,@body))) (defmacro loop-collect-rplacd (&environment env - (head-var tail-var &optional user-head-var) form) + (head-var tail-var &optional user-head-var) form) (declare - #+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail. + #+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail. ) (setq form (macroexpand form env)) (flet ((cdr-wrap (form n) - (declare (fixnum n)) - (do () ((<= n 4) (setq form `(,(case n - (1 'cdr) - (2 'cddr) - (3 'cdddr) - (4 'cddddr)) - ,form))) - (setq form `(cddddr ,form) n (- n 4))))) + (declare (fixnum n)) + (do () ((<= n 4) (setq form `(,(case n + (1 'cdr) + (2 'cddr) + (3 'cdddr) + (4 'cddddr)) + ,form))) + (setq form `(cddddr ,form) n (- n 4))))) (let ((tail-form form) (ncdrs nil)) ;;Determine if the form being constructed is a list of known length. (when (consp form) - (cond ((eq (car form) 'list) - (setq ncdrs (1- (length (cdr form)))) - ;;@@@@ Because the last element is going to be RPLACDed, - ;; we don't want the cdr-coded implementations to use - ;; cdr-nil at the end (which would just force copying - ;; the whole list again). - #+LISPM (setq tail-form `(list* ,@(cdr form) nil))) - ((member (car form) '(list* cons)) - (when (and (cddr form) (member (car (last form)) '(nil 'nil))) - (setq ncdrs (- (length (cdr form)) 2)))))) + (cond ((eq (car form) 'list) + (setq ncdrs (1- (length (cdr form)))) + ;;@@@@ Because the last element is going to be RPLACDed, + ;; we don't want the cdr-coded implementations to use + ;; cdr-nil at the end (which would just force copying + ;; the whole list again). + #+LISPM (setq tail-form `(list* ,@(cdr form) nil))) + ((member (car form) '(list* cons)) + (when (and (cddr form) (member (car (last form)) '(nil 'nil))) + (setq ncdrs (- (length (cdr form)) 2)))))) (let ((answer - (cond ((null ncdrs) - `(when (setf (cdr ,tail-var) ,tail-form) - (setq ,tail-var (last (cdr ,tail-var))))) - ((< ncdrs 0) (return-from loop-collect-rplacd nil)) - ((= ncdrs 0) - ;;@@@@ Here we have a choice of two idioms: - ;; (rplacd tail (setq tail tail-form)) - ;; (setq tail (setf (cdr tail) tail-form)). - ;;Genera and most others I have seen do better with the former. - `(rplacd ,tail-var (setq ,tail-var ,tail-form))) - (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form) - ncdrs)))))) - ;;If not using locatives or something similar to update the user's - ;; head variable, we've got to set it... It's harmless to repeatedly set it - ;; unconditionally, and probably faster than checking. - #-LISPM (when user-head-var - (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var))))) - answer)))) + (cond ((null ncdrs) + `(when (setf (cdr ,tail-var) ,tail-form) + (setq ,tail-var (last (cdr ,tail-var))))) + ((< ncdrs 0) (return-from loop-collect-rplacd nil)) + ((= ncdrs 0) + ;;@@@@ Here we have a choice of two idioms: + ;; (rplacd tail (setq tail tail-form)) + ;; (setq tail (setf (cdr tail) tail-form)). + ;;Genera and most others I have seen do better with the former. + `(rplacd ,tail-var (setq ,tail-var ,tail-form))) + (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form) + ncdrs)))))) + ;;If not using locatives or something similar to update the user's + ;; head variable, we've got to set it... It's harmless to repeatedly set it + ;; unconditionally, and probably faster than checking. + #-LISPM (when user-head-var + (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var))))) + answer)))) (defmacro loop-collect-answer (head-var &optional user-head-var) (or user-head-var (progn - ;;If we use locatives to get tail-updating to update the head var, - ;; then the head var itself contains the answer. Otherwise we - ;; have to cdr it. - #+LISPM head-var - #-LISPM `(cdr ,head-var)))) + ;;If we use locatives to get tail-updating to update the head var, + ;; then the head var itself contains the answer. Otherwise we + ;; have to cdr it. + #+LISPM head-var + #-LISPM `(cdr ,head-var)))) ;;;; Maximization Technology @@ -312,9 +312,9 @@ constructed. (defstruct (loop-minimax - (:constructor make-loop-minimax-internal) - (:copier nil) - (:predicate nil)) + (:constructor make-loop-minimax-internal) + (:copier nil) + (:predicate nil)) answer-variable type temp-variable @@ -324,39 +324,39 @@ constructed. (defvar *loop-minimax-type-infinities-alist* - ;;@@@@ This is the sort of value this should take on for a Lisp that has - ;; "eminently usable" infinities. n.b. there are neither constants nor - ;; printed representations for infinities defined by CL. - ;;@@@@ This grotesque read-from-string below is to help implementations - ;; which croak on the infinity character when it appears in a token, even - ;; conditionalized out. - #+Genera - '#.(read-from-string - "((fixnum most-positive-fixnum most-negative-fixnum) - (short-float +1s -1s) - (single-float +1f -1f) - (double-float +1d -1d) - (long-float +1l -1l))") - ;;This is how the alist should look for a lisp that has no infinities. In - ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive. - #+(or CLOE-Runtime Minima) - '((fixnum most-positive-fixnum most-negative-fixnum) - (short-float most-positive-short-float most-negative-short-float) - (single-float most-positive-single-float most-negative-single-float) - (double-float most-positive-double-float most-negative-double-float) - (long-float most-positive-long-float most-negative-long-float)) - ;; CMUCL has infinities so let's use them. - #+CMU - '((fixnum most-positive-fixnum most-negative-fixnum) - (short-float ext:single-float-positive-infinity ext:single-float-negative-infinity) - (single-float ext:single-float-positive-infinity ext:single-float-negative-infinity) - (double-float ext:double-float-positive-infinity ext:double-float-negative-infinity) - (long-float ext:long-float-positive-infinity ext:long-float-negative-infinity)) - ;; If we don't know, then we cannot provide "infinite" initial values for any of the - ;; types but FIXNUM: - #-(or Genera CLOE-Runtime Minima CMU) - '((fixnum most-positive-fixnum most-negative-fixnum)) - ) + ;;@@@@ This is the sort of value this should take on for a Lisp that has + ;; "eminently usable" infinities. n.b. there are neither constants nor + ;; printed representations for infinities defined by CL. + ;;@@@@ This grotesque read-from-string below is to help implementations + ;; which croak on the infinity character when it appears in a token, even + ;; conditionalized out. + #+Genera + '#.(read-from-string + "((fixnum most-positive-fixnum most-negative-fixnum) + (short-float +1s -1s) + (single-float +1f -1f) + (double-float +1d -1d) + (long-float +1l -1l))") + ;;This is how the alist should look for a lisp that has no infinities. In + ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive. + #+(or CLOE-Runtime Minima) + '((fixnum most-positive-fixnum most-negative-fixnum) + (short-float most-positive-short-float most-negative-short-float) + (single-float most-positive-single-float most-negative-single-float) + (double-float most-positive-double-float most-negative-double-float) + (long-float most-positive-long-float most-negative-long-float)) + ;; CMUCL has infinities so let's use them. + #+CMU + '((fixnum most-positive-fixnum most-negative-fixnum) + (short-float ext:single-float-positive-infinity ext:single-float-negative-infinity) + (single-float ext:single-float-positive-infinity ext:single-float-negative-infinity) + (double-float ext:double-float-positive-infinity ext:double-float-negative-infinity) + (long-float ext:long-float-positive-infinity ext:long-float-negative-infinity)) + ;; If we don't know, then we cannot provide "infinite" initial values for any of the + ;; types but FIXNUM: + #-(or Genera CLOE-Runtime Minima CMU) + '((fixnum most-positive-fixnum most-negative-fixnum)) + ) (defun make-loop-minimax (answer-variable type) @@ -373,45 +373,45 @@ constructed. (defun loop-note-minimax-operation (operation minimax) (pushnew (the symbol operation) (loop-minimax-operations minimax)) (when (and (cdr (loop-minimax-operations minimax)) - (not (loop-minimax-flag-variable minimax))) + (not (loop-minimax-flag-variable minimax))) (setf (loop-minimax-flag-variable minimax) (loop-gentemp 'loop-maxmin-flag-))) operation) (defmacro with-minimax-value (lm &body body) (let ((init (loop-typed-init (loop-minimax-type lm))) - (which (car (loop-minimax-operations lm))) - (infinity-data (loop-minimax-infinity-data lm)) - (answer-var (loop-minimax-answer-variable lm)) - (temp-var (loop-minimax-temp-variable lm)) - (flag-var (loop-minimax-flag-variable lm)) - (type (loop-minimax-type lm))) + (which (car (loop-minimax-operations lm))) + (infinity-data (loop-minimax-infinity-data lm)) + (answer-var (loop-minimax-answer-variable lm)) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (type (loop-minimax-type lm))) (if flag-var - `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) - (declare (type ,type ,answer-var ,temp-var)) - ,@body) - `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data))) - (,temp-var ,init)) - (declare (type ,type ,answer-var ,temp-var)) - ,@body)))) + `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) + (declare (type ,type ,answer-var ,temp-var)) + ,@body) + `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data))) + (,temp-var ,init)) + (declare (type ,type ,answer-var ,temp-var)) + ,@body)))) (defmacro loop-accumulate-minimax-value (lm operation form) (let* ((answer-var (loop-minimax-answer-variable lm)) - (temp-var (loop-minimax-temp-variable lm)) - (flag-var (loop-minimax-flag-variable lm)) - (test - (hide-variable-reference - t (loop-minimax-answer-variable lm) - `(,(ecase operation - (min '<) - (max '>)) - ,temp-var ,answer-var)))) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (test + (hide-variable-reference + t (loop-minimax-answer-variable lm) + `(,(ecase operation + (min '<) + (max '>)) + ,temp-var ,answer-var)))) `(progn (setq ,temp-var ,form) (when ,(if flag-var `(or (not ,flag-var) ,test) test) - (setq ,@(and flag-var `(,flag-var t)) - ,answer-var ,temp-var))))) + (setq ,@(and flag-var `(,flag-var t)) + ,answer-var ,temp-var))))) @@ -458,17 +458,17 @@ code to be loaded. (defstruct (loop-universe - (:print-function print-loop-universe) - (:copier nil) - (:predicate nil)) - keywords ;hash table, value = (fn-name . extra-data). - iteration-keywords ;hash table, value = (fn-name . extra-data). - for-keywords ;hash table, value = (fn-name . extra-data). - path-keywords ;hash table, value = (fn-name . extra-data). - type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier. - type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec. - ansi ;NIL, T, or :EXTENDED. - implicit-for-required ;see loop-hack-iteration + (:print-function print-loop-universe) + (:copier nil) + (:predicate nil)) + keywords ;hash table, value = (fn-name . extra-data). + iteration-keywords ;hash table, value = (fn-name . extra-data). + for-keywords ;hash table, value = (fn-name . extra-data). + path-keywords ;hash table, value = (fn-name . extra-data). + type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier. + type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec. + ansi ;NIL, T, or :EXTENDED. + implicit-for-required ;see loop-hack-iteration ) @@ -522,7 +522,7 @@ code to be loaded. (defvar *loop-destructuring-hooks* - nil + nil "If not NIL, this must be a list of two things: a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.") @@ -530,83 +530,83 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-make-psetq (frobs) (and frobs (loop-make-desetq - (list (car frobs) - (if (null (cddr frobs)) (cadr frobs) - `(prog1 ,(cadr frobs) - ,(loop-make-psetq (cddr frobs)))))))) + (list (car frobs) + (if (null (cddr frobs)) (cadr frobs) + `(prog1 ,(cadr frobs) + ,(loop-make-psetq (cddr frobs)))))))) (defun loop-make-desetq (var-val-pairs) (if (null var-val-pairs) nil (cons (if *loop-destructuring-hooks* - (cadr *loop-destructuring-hooks*) - 'loop-really-desetq) - var-val-pairs))) + (cadr *loop-destructuring-hooks*) + 'loop-really-desetq) + var-val-pairs))) (defvar *loop-desetq-temporary* - (make-symbol "LOOP-DESETQ-TEMP")) + (make-symbol "LOOP-DESETQ-TEMP")) (defmacro loop-really-desetq (&environment env &rest var-val-pairs) (labels ((find-non-null (var) - ;; see if there's any non-null thing here - ;; recurse if the list element is itself a list - (do ((tail var)) ((not (consp tail)) tail) - (when (find-non-null (pop tail)) (return t)))) - (loop-desetq-internal (var val &optional temp) - ;; returns a list of actions to be performed - (typecase var - (null - (when (consp val) - ;; don't lose possible side-effects - (if (eq (car val) 'prog1) - ;; these can come from psetq or desetq below. - ;; throw away the value, keep the side-effects. - ;;Special case is for handling an expanded POP. - (mapcan #'(lambda (x) - (and (consp x) - (or (not (eq (car x) 'car)) - (not (symbolp (cadr x))) - (not (symbolp (setq x (macroexpand x env))))) - (cons x nil))) - (cdr val)) - `(,val)))) - (cons - (let* ((car (car var)) - (cdr (cdr var)) - (car-non-null (find-non-null car)) - (cdr-non-null (find-non-null cdr))) - (when (or car-non-null cdr-non-null) - (if cdr-non-null - (let* ((temp-p temp) - (temp (or temp *loop-desetq-temporary*)) - (body #+LOOP-Prefer-POP `(,@(loop-desetq-internal - car - `(prog1 (car ,temp) - (setq ,temp (cdr ,temp)))) - ,@(loop-desetq-internal cdr temp temp)) - #-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp)) - (setq ,temp (cdr ,temp)) - ,@(loop-desetq-internal cdr temp temp)))) - (if temp-p - `(,@(unless (eq temp val) - `((setq ,temp ,val))) - ,@body) - `((let ((,temp ,val)) - ,@body)))) - ;; no cdring to do - (loop-desetq-internal car `(car ,val) temp))))) - (otherwise - (unless (eq var val) - `((setq ,var ,val))))))) + ;; see if there's any non-null thing here + ;; recurse if the list element is itself a list + (do ((tail var)) ((not (consp tail)) tail) + (when (find-non-null (pop tail)) (return t)))) + (loop-desetq-internal (var val &optional temp) + ;; returns a list of actions to be performed + (typecase var + (null + (when (consp val) + ;; don't lose possible side-effects + (if (eq (car val) 'prog1) + ;; these can come from psetq or desetq below. + ;; throw away the value, keep the side-effects. + ;;Special case is for handling an expanded POP. + (mapcan #'(lambda (x) + (and (consp x) + (or (not (eq (car x) 'car)) + (not (symbolp (cadr x))) + (not (symbolp (setq x (macroexpand x env))))) + (cons x nil))) + (cdr val)) + `(,val)))) + (cons + (let* ((car (car var)) + (cdr (cdr var)) + (car-non-null (find-non-null car)) + (cdr-non-null (find-non-null cdr))) + (when (or car-non-null cdr-non-null) + (if cdr-non-null + (let* ((temp-p temp) + (temp (or temp *loop-desetq-temporary*)) + (body #+LOOP-Prefer-POP `(,@(loop-desetq-internal + car + `(prog1 (car ,temp) + (setq ,temp (cdr ,temp)))) + ,@(loop-desetq-internal cdr temp temp)) + #-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp)) + (setq ,temp (cdr ,temp)) + ,@(loop-desetq-internal cdr temp temp)))) + (if temp-p + `(,@(unless (eq temp val) + `((setq ,temp ,val))) + ,@body) + `((let ((,temp ,val)) + ,@body)))) + ;; no cdring to do + (loop-desetq-internal car `(car ,val) temp))))) + (otherwise + (unless (eq var val) + `((setq ,var ,val))))))) (do ((actions)) - ((null var-val-pairs) - (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) + ((null var-val-pairs) + (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) (setq actions (revappend - (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs)) - actions))))) + (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs)) + actions))))) ;;;; LOOP-local variables @@ -718,7 +718,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;List of all the value-accumulation descriptor structures in the loop. ;;; See loop-get-collection-info. -(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) +(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) ;;;; Code Analysis Stuff @@ -728,22 +728,22 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. #+Genera (declare (values new-form constantp constant-value)) (let ((new-form form) (constantp nil) (constant-value nil)) #+Genera (setq new-form (compiler:optimize-form form *loop-macro-environment* - :repeat t - :do-macro-expansion t - :do-named-constants t - :do-inline-forms t - :do-optimizers t - :do-constant-folding t - :do-function-args t) - constantp (constantp new-form *loop-macro-environment*) - constant-value (and constantp (lt:evaluate-constant new-form *loop-macro-environment*))) + :repeat t + :do-macro-expansion t + :do-named-constants t + :do-inline-forms t + :do-optimizers t + :do-constant-folding t + :do-function-args t) + constantp (constantp new-form *loop-macro-environment*) + constant-value (and constantp (lt:evaluate-constant new-form *loop-macro-environment*))) #-Genera (when (setq constantp (constantp new-form)) - (setq constant-value (eval new-form))) + (setq constant-value (eval new-form))) (when (and constantp expected-type) (unless (typep constant-value expected-type) - (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." - form constant-value expected-type) - (setq constantp nil constant-value nil))) + (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." + form constant-value expected-type) + (setq constantp nil constant-value nil))) (values new-form constantp constant-value))) @@ -755,11 +755,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; LOOP Iteration Optimization (defvar *loop-duplicate-code* - nil) + nil) (defvar *loop-iteration-flag-variable* - (make-symbol "LOOP-NOT-FIRST-TIME")) + (make-symbol "LOOP-NOT-FIRST-TIME")) (defun loop-code-duplication-threshold (env) @@ -768,37 +768,37 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defmacro loop-body (&environment env - prologue - before-loop - main-body - after-loop - epilogue - &aux rbefore rafter flagvar) + prologue + before-loop + main-body + after-loop + epilogue + &aux rbefore rafter flagvar) (unless (= (length before-loop) (length after-loop)) (error "LOOP-BODY called with non-synched before- and after-loop lists.")) ;;All our work is done from these copies, working backwards from the end: (setq rbefore (reverse before-loop) rafter (reverse after-loop)) (labels ((psimp (l) - (let ((ans nil)) - (dolist (x l) - (when x - (push x ans) - (when (and (consp x) (member (car x) '(go return return-from))) - (return nil)))) - (nreverse ans))) - (pify (l) (if (null (cdr l)) (car l) `(progn ,@l))) - (makebody () - (let ((form `(tagbody - ;; ANSI CL 6.1.7.2 says that initially clauses are - ;; evaluated in the loop prologue, which precedes - ;; all loop code except for the initial settings - ;; provided by with, for, or as. - ,@(psimp (append (nreverse rbefore) prologue)) - next-loop - ,@(psimp (append main-body (nreconc rafter `((go next-loop))))) - end-loop - ,@(psimp epilogue)))) - (if flagvar `(let ((,flagvar nil)) ,form) form)))) + (let ((ans nil)) + (dolist (x l) + (when x + (push x ans) + (when (and (consp x) (member (car x) '(go return return-from))) + (return nil)))) + (nreverse ans))) + (pify (l) (if (null (cdr l)) (car l) `(progn ,@l))) + (makebody () + (let ((form `(tagbody + ;; ANSI CL 6.1.7.2 says that initially clauses are + ;; evaluated in the loop prologue, which precedes + ;; all loop code except for the initial settings + ;; provided by with, for, or as. + ,@(psimp (append (nreverse rbefore) prologue)) + next-loop + ,@(psimp (append main-body (nreconc rafter `((go next-loop))))) + end-loop + ,@(psimp epilogue)))) + (if flagvar `(let ((,flagvar nil)) ,form) form)))) (when (or *loop-duplicate-code* (not rbefore)) (return-from loop-body (makebody))) ;; This outer loop iterates once for each not-first-time flag test generated @@ -808,8 +808,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;; Go backwards from the ends of before-loop and after-loop merging all the equivalent ;; forms into the body. (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) - (push (pop rbefore) main-body) - (pop rafter)) + (push (pop rbefore) main-body) + (pop rafter)) (unless rbefore (return (makebody))) ;; The first forms in rbefore & rafter (which are the chronologically ;; last forms in the list) differ, therefore they cannot be moved @@ -823,66 +823,66 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;; What chronologically precedes the non-duplicatable form will ;; be handled the next time around the outer loop. (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) (count 0) (inc nil)) - ((null bb) (return-from loop-body (makebody))) ;Did it. - (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) - ((or (not (setq inc (estimate-code-size (car bb) env))) - (> (incf count inc) threshold)) - ;; Ok, we have found a non-duplicatable piece of code. Everything - ;; chronologically after it must be in the central body. - ;; Everything chronologically at and after lastdiff goes into the - ;; central body under a flag test. - (let ((then nil) (else nil)) - (do () (nil) - (push (pop rbefore) else) - (push (pop rafter) then) - (when (eq rbefore (cdr lastdiff)) (return))) - (unless flagvar - (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else)) - (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) - main-body)) - ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb) - ;; is the same in rbefore and rafter so just copy it into the body - (do () (nil) - (pop rafter) - (push (pop rbefore) main-body) - (when (eq rbefore (cdr bb)) (return))) - (return))))))) + ((null bb) (return-from loop-body (makebody))) ;Did it. + (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) + ((or (not (setq inc (estimate-code-size (car bb) env))) + (> (incf count inc) threshold)) + ;; Ok, we have found a non-duplicatable piece of code. Everything + ;; chronologically after it must be in the central body. + ;; Everything chronologically at and after lastdiff goes into the + ;; central body under a flag test. + (let ((then nil) (else nil)) + (do () (nil) + (push (pop rbefore) else) + (push (pop rafter) then) + (when (eq rbefore (cdr lastdiff)) (return))) + (unless flagvar + (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else)) + (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) + main-body)) + ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb) + ;; is the same in rbefore and rafter so just copy it into the body + (do () (nil) + (pop rafter) + (push (pop rbefore) main-body) + (when (eq rbefore (cdr bb)) (return))) + (return))))))) (defun duplicatable-code-p (expr env) (if (null expr) 0 (let ((ans (estimate-code-size expr env))) - (declare (fixnum ans)) - ;;@@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of - ;; optimize quantities back to help quantify how much code we are willing to - ;; duplicate. - ans))) + (declare (fixnum ans)) + ;;@@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of + ;; optimize quantities back to help quantify how much code we are willing to + ;; duplicate. + ans))) (defvar *special-code-sizes* - '((return 0) (progn 0) - (null 1) (not 1) (eq 1) (car 1) (cdr 1) - (when 1) (unless 1) (if 1) - (caar 2) (cadr 2) (cdar 2) (cddr 2) - (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3) - (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4) - (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4) - (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4) - (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4))) + '((return 0) (progn 0) + (null 1) (not 1) (eq 1) (car 1) (cdr 1) + (when 1) (unless 1) (if 1) + (caar 2) (cadr 2) (cdar 2) (cddr 2) + (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3) + (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4) + (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4) + (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4) + (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4))) (defvar *estimate-code-size-punt* - '(block - do do* dolist - flet - labels lambda let let* locally - macrolet multiple-value-bind - prog prog* - symbol-macrolet - tagbody - unwind-protect - with-open-file)) + '(block + do do* dolist + flet + labels lambda let let* locally + macrolet multiple-value-bind + prog prog* + symbol-macrolet + tagbody + unwind-protect + with-open-file)) (defun destructuring-size (x) @@ -897,52 +897,52 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun estimate-code-size-1 (x env) (flet ((list-size (l) - (let ((n 0)) - (declare (fixnum n)) - (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) + (let ((n 0)) + (declare (fixnum n)) + (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) ;;@@@@ ???? (declare (function list-size (list) fixnum)) (cond ((constantp x #+Genera env) 1) - ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) - (if expanded-p (estimate-code-size-1 new-form env) 1))) - ((atom x) 1) ;??? self-evaluating??? - ((symbolp (car x)) - (let ((fn (car x)) (tem nil) (n 0)) - (declare (symbol fn) (fixnum n)) - (macrolet ((f (overhead &optional (args nil args-p)) - `(the fixnum (+ (the fixnum ,overhead) - (the fixnum (list-size ,(if args-p args '(cdr x)))))))) - (cond ((setq tem (get fn 'estimate-code-size)) - (typecase tem - (fixnum (f tem)) - (t (funcall tem x env)))) - ((setq tem (assoc fn *special-code-sizes*)) (f (second tem))) - #+Genera - ((eq fn 'compiler:invisible-references) (list-size (cddr x))) - ((eq fn 'cond) - (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n))) - ((eq fn 'desetq) - (do ((l (cdr x) (cdr l))) ((null l) n) - (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env))))) - ((member fn '(setq psetq)) - (do ((l (cdr x) (cdr l))) ((null l) n) - (setq n (+ n (estimate-code-size-1 (cadr l) env) 1)))) - ((eq fn 'go) 1) - ((eq fn 'function) - ;;This skirts the issue of implementationally-defined lambda macros - ;; by recognizing CL function names and nothing else. + ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) + (if expanded-p (estimate-code-size-1 new-form env) 1))) + ((atom x) 1) ;??? self-evaluating??? + ((symbolp (car x)) + (let ((fn (car x)) (tem nil) (n 0)) + (declare (symbol fn) (fixnum n)) + (macrolet ((f (overhead &optional (args nil args-p)) + `(the fixnum (+ (the fixnum ,overhead) + (the fixnum (list-size ,(if args-p args '(cdr x)))))))) + (cond ((setq tem (get fn 'estimate-code-size)) + (typecase tem + (fixnum (f tem)) + (t (funcall tem x env)))) + ((setq tem (assoc fn *special-code-sizes*)) (f (second tem))) + #+Genera + ((eq fn 'compiler:invisible-references) (list-size (cddr x))) + ((eq fn 'cond) + (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n))) + ((eq fn 'desetq) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env))))) + ((member fn '(setq psetq)) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n (estimate-code-size-1 (cadr l) env) 1)))) + ((eq fn 'go) 1) + ((eq fn 'function) + ;;This skirts the issue of implementationally-defined lambda macros + ;; by recognizing CL function names and nothing else. #-cmu 1 #+cmu (if (ext:valid-function-name-p (cadr x)) 1 (throw 'duplicatable-code-p nil))) - ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x))) - ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env))) - ((or (special-operator-p fn) (member fn *estimate-code-size-punt*)) - (throw 'estimate-code-size nil)) - (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) - (if expanded-p - (estimate-code-size-1 new-form env) - (f 3)))))))) - (t (throw 'estimate-code-size nil))))) + ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x))) + ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env))) + ((or (special-operator-p fn) (member fn *estimate-code-size-punt*)) + (throw 'estimate-code-size nil)) + (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) + (if expanded-p + (estimate-code-size-1 new-form env) + (f 3)))))))) + (t (throw 'estimate-code-size nil))))) ;;;; Loop Errors @@ -955,10 +955,10 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-error (format-string &rest format-args) #+(or Genera CLOE) (declare (dbg:error-reporter)) - #+Genera (setq format-args (copy-list format-args)) ;Don't ask. + #+Genera (setq format-args (copy-list format-args)) ;Don't ask. #+cmu (kernel:simple-program-error "~?~%Current LOOP context:~{ ~S~}." - format-string format-args (loop-context)) + format-string format-args (loop-context)) #-cmu (error "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context))) @@ -969,17 +969,17 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-check-data-type (specified-type required-type - &optional (default-type required-type)) + &optional (default-type required-type)) (if (null specified-type) default-type (multiple-value-bind (a b) (subtypep specified-type required-type) - (cond ((not b) - (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." - specified-type required-type)) - ((not a) - (loop-error "Specified data type ~S is not a subtype of ~S." - specified-type required-type))) - specified-type))) + (cond ((not b) + (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." + specified-type required-type)) + ((not a) + (loop-error "Specified data type ~S is not a subtype of ~S." + specified-type required-type))) + specified-type))) ;;;INTERFACE: Traditional, ANSI, Lucid. @@ -998,89 +998,89 @@ collected result will be returned as the value of the LOOP." ((null tree) (car (push (loop-gentemp) *ignores*))) ((atom tree) tree) (t (cons (subst-gensyms-for-nil (car tree)) - (subst-gensyms-for-nil (cdr tree)))))) + (subst-gensyms-for-nil (cdr tree)))))) (defun loop-build-destructuring-bindings (crocks forms) (if crocks (let ((*ignores* ())) - (declare (special *ignores*)) - `((destructuring-bind ,(subst-gensyms-for-nil (car crocks)) - ,(cadr crocks) - (declare (ignore ,@*ignores*)) - ,@(loop-build-destructuring-bindings (cddr crocks) forms)))) + (declare (special *ignores*)) + `((destructuring-bind ,(subst-gensyms-for-nil (car crocks)) + ,(cadr crocks) + (declare (ignore ,@*ignores*)) + ,@(loop-build-destructuring-bindings (cddr crocks) forms)))) forms)) (defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) (let ((*loop-original-source-code* *loop-source-code*) - (*loop-source-context* nil) - (*loop-iteration-variables* nil) - (*loop-variables* nil) - (*loop-nodeclare* nil) - (*loop-named-variables* nil) - (*loop-declarations* nil) - (*loop-desetq-crocks* nil) - (*loop-bind-stack* nil) - (*loop-prologue* nil) - (*loop-wrappers* nil) - (*loop-before-loop* nil) - (*loop-body* nil) - (*loop-emitted-body* nil) - (*loop-after-body* nil) - (*loop-epilogue* nil) - (*loop-after-epilogue* nil) - (*loop-final-value-culprit* nil) - (*loop-inside-conditional* nil) - (*loop-when-it-variable* nil) - (*loop-never-stepped-variable* nil) - (*loop-names* nil) - (*loop-collection-cruft* nil)) + (*loop-source-context* nil) + (*loop-iteration-variables* nil) + (*loop-variables* nil) + (*loop-nodeclare* nil) + (*loop-named-variables* nil) + (*loop-declarations* nil) + (*loop-desetq-crocks* nil) + (*loop-bind-stack* nil) + (*loop-prologue* nil) + (*loop-wrappers* nil) + (*loop-before-loop* nil) + (*loop-body* nil) + (*loop-emitted-body* nil) + (*loop-after-body* nil) + (*loop-epilogue* nil) + (*loop-after-epilogue* nil) + (*loop-final-value-culprit* nil) + (*loop-inside-conditional* nil) + (*loop-when-it-variable* nil) + (*loop-never-stepped-variable* nil) + (*loop-names* nil) + (*loop-collection-cruft* nil)) (loop-iteration-driver) (loop-bind-block) (let ((answer `(loop-body - ,(nreverse *loop-prologue*) - ,(nreverse *loop-before-loop*) - ,(nreverse *loop-body*) - ,(nreverse *loop-after-body*) - ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*))))) + ,(nreverse *loop-prologue*) + ,(nreverse *loop-before-loop*) + ,(nreverse *loop-body*) + ,(nreverse *loop-after-body*) + ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*))))) (dolist (entry *loop-bind-stack*) - (let ((vars (first entry)) - (dcls (second entry)) - (crocks (third entry)) - (wrappers (fourth entry))) - (dolist (w wrappers) - (setq answer (append w (list answer)))) - (when (or vars dcls crocks) - (let ((forms (list answer))) - ;;(when crocks (push crocks forms)) - (when dcls (push `(declare ,@dcls) forms)) - (setq answer `(,(cond ((not vars) 'locally) - (*loop-destructuring-hooks* (first *loop-destructuring-hooks*)) - (t 'let)) - ,vars - ,@(loop-build-destructuring-bindings crocks forms))))))) + (let ((vars (first entry)) + (dcls (second entry)) + (crocks (third entry)) + (wrappers (fourth entry))) + (dolist (w wrappers) + (setq answer (append w (list answer)))) + (when (or vars dcls crocks) + (let ((forms (list answer))) + ;;(when crocks (push crocks forms)) + (when dcls (push `(declare ,@dcls) forms)) + (setq answer `(,(cond ((not vars) 'locally) + (*loop-destructuring-hooks* (first *loop-destructuring-hooks*)) + (t 'let)) + ,vars + ,@(loop-build-destructuring-bindings crocks forms))))))) (if *loop-names* - (do () ((null (car *loop-names*)) answer) - (setq answer `(block ,(pop *loop-names*) ,answer))) - `(block nil ,answer))))) + (do () ((null (car *loop-names*)) answer) + (setq answer `(block ,(pop *loop-names*) ,answer))) + `(block nil ,answer))))) (defun loop-iteration-driver () (do () ((null *loop-source-code*)) (let ((keyword (car *loop-source-code*)) (tem nil)) (cond ((not (symbolp keyword)) - (loop-error "~S found where LOOP keyword expected." keyword)) - (t (setq *loop-source-context* *loop-source-code*) - (loop-pop-source) - (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*))) - ;;It's a "miscellaneous" toplevel LOOP keyword (do, collect, named, etc.) - (apply (symbol-function (first tem)) (rest tem))) - ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*))) - (loop-hack-iteration tem)) - ((loop-tmember keyword '(and else)) - ;; Alternative is to ignore it, ie let it go around to the next keyword... - (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." - keyword (car *loop-source-code*) (cadr *loop-source-code*))) - (t (loop-error "~S is an unknown keyword in LOOP macro." keyword)))))))) + (loop-error "~S found where LOOP keyword expected." keyword)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*))) + ;;It's a "miscellaneous" toplevel LOOP keyword (do, collect, named, etc.) + (apply (symbol-function (first tem)) (rest tem))) + ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*))) + (loop-hack-iteration tem)) + ((loop-tmember keyword '(and else)) + ;; Alternative is to ignore it, ie let it go around to the next keyword... + (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." + keyword (car *loop-source-code*) (cadr *loop-source-code*))) + (t (loop-error "~S is an unknown keyword in LOOP macro." keyword)))))))) @@ -1117,7 +1117,7 @@ collected result will be returned as the value of the LOOP." (defun loop-pseudo-body (form) (cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*)) - (t (push form *loop-before-loop*) (push form *loop-after-body*)))) + (t (push form *loop-before-loop*) (push form *loop-after-body*)))) (defun loop-emit-body (form) (setq *loop-emitted-body* t) @@ -1128,8 +1128,8 @@ collected result will be returned as the value of the LOOP." (push (loop-construct-return form) *loop-after-epilogue*)) (when *loop-final-value-culprit* (loop-warn "LOOP clause is providing a value for the iteration,~@ - however one was already established by a ~S clause." - *loop-final-value-culprit*)) + however one was already established by a ~S clause." + *loop-final-value-culprit*)) (setq *loop-final-value-culprit* (car *loop-source-context*))) @@ -1154,60 +1154,60 @@ collected result will be returned as the value of the LOOP." (defun loop-typed-init (data-type) (when (and data-type (subtypep data-type 'number)) (if (or (subtypep data-type 'float) (subtypep data-type '(complex float))) - (coerce 0 data-type) - 0))) + (coerce 0 data-type) + 0))) (defun loop-optional-type (&optional variable) ;;No variable specified implies that no destructuring is permissible. - (and *loop-source-code* ;Don't get confused by NILs... + (and *loop-source-code* ;Don't get confused by NILs... (let ((z (car *loop-source-code*))) - (cond ((loop-tequal z 'of-type) - ;;This is the syntactically unambigous form in that the form of the - ;; type specifier does not matter. Also, it is assumed that the - ;; type specifier is unambiguously, and without need of translation, - ;; a common lisp type specifier or pattern (matching the variable) thereof. - (loop-pop-source) - (loop-pop-source)) - - ((symbolp z) - ;;This is the (sort of) "old" syntax, even though we didn't used to support all of - ;; these type symbols. - (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) - (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*))))) - (when type-spec - (loop-pop-source) - type-spec))) - (t - ;;This is our sort-of old syntax. But this is only valid for when we are destructuring, - ;; so we will be compulsive (should we really be?) and require that we in fact be - ;; doing variable destructuring here. We must translate the old keyword pattern typespec - ;; into a fully-specified pattern of real type specifiers here. - (if (consp variable) - (unless (consp z) - (loop-error - "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected." - z)) - (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z)) - (loop-pop-source) - (labels ((translate (k v) - (cond ((null k) nil) - ((atom k) - (replicate - (or (gethash k (loop-universe-type-symbols *loop-universe*)) - (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*)) - (loop-error - "Destructuring type pattern ~S contains unrecognized type keyword ~S." - z k)) - v)) - ((atom v) - (loop-error - "Destructuring type pattern ~S doesn't match variable pattern ~S." - z variable)) - (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v)))))) - (replicate (typ v) - (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v)))))) - (translate z variable))))))) + (cond ((loop-tequal z 'of-type) + ;;This is the syntactically unambigous form in that the form of the + ;; type specifier does not matter. Also, it is assumed that the + ;; type specifier is unambiguously, and without need of translation, + ;; a common lisp type specifier or pattern (matching the variable) thereof. + (loop-pop-source) + (loop-pop-source)) + + ((symbolp z) + ;;This is the (sort of) "old" syntax, even though we didn't used to support all of + ;; these type symbols. + (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) + (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*))))) + (when type-spec + (loop-pop-source) + type-spec))) + (t + ;;This is our sort-of old syntax. But this is only valid for when we are destructuring, + ;; so we will be compulsive (should we really be?) and require that we in fact be + ;; doing variable destructuring here. We must translate the old keyword pattern typespec + ;; into a fully-specified pattern of real type specifiers here. + (if (consp variable) + (unless (consp z) + (loop-error + "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected." + z)) + (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z)) + (loop-pop-source) + (labels ((translate (k v) + (cond ((null k) nil) + ((atom k) + (replicate + (or (gethash k (loop-universe-type-symbols *loop-universe*)) + (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*)) + (loop-error + "Destructuring type pattern ~S contains unrecognized type keyword ~S." + z k)) + v)) + ((atom v) + (loop-error + "Destructuring type pattern ~S doesn't match variable pattern ~S." + z variable)) + (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v)))))) + (replicate (typ v) + (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v)))))) + (translate z variable))))))) @@ -1217,57 +1217,57 @@ collected result will be returned as the value of the LOOP." (defun loop-bind-block () (when (or *loop-variables* *loop-declarations* *loop-wrappers*) (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*) - *loop-bind-stack*) + *loop-bind-stack*) (setq *loop-variables* nil - *loop-declarations* nil - *loop-desetq-crocks* nil - *loop-wrappers* nil))) + *loop-declarations* nil + *loop-desetq-crocks* nil + *loop-wrappers* nil))) (defun loop-variable-p (name) (do ((entry *loop-bind-stack* (cdr entry))) (nil) (cond ((null entry) - (return nil)) - ((assoc name (caar entry) :test #'eq) - (return t))))) + (return nil)) + ((assoc name (caar entry) :test #'eq) + (return t))))) (defun loop-make-variable (name initialization dtype &optional iteration-variable-p) (cond ((null name) - (cond ((not (null initialization)) - (push (list (setq name (loop-gentemp 'loop-ignore-)) - initialization) - *loop-variables*) - (push `(ignore ,name) *loop-declarations*)))) - ((atom name) - (cond (iteration-variable-p - (if (member name *loop-iteration-variables*) - (loop-error "Duplicated LOOP iteration variable ~S." name) - (push name *loop-iteration-variables*))) - ((assoc name *loop-variables*) - (loop-error "Duplicated variable ~S in LOOP parallel binding." name))) - (unless (symbolp name) - (loop-error "Bad variable ~S somewhere in LOOP." name)) - (loop-declare-variable name dtype) - ;; We use ASSOC on this list to check for duplications (above), - ;; so don't optimize out this list: - (push (list name (or initialization (loop-typed-init dtype))) - *loop-variables*)) - (initialization - (cond (*loop-destructuring-hooks* - (loop-declare-variable name dtype) - (push (list name initialization) *loop-variables*)) - (t (let ((newvar (loop-gentemp 'loop-destructure-))) - (loop-declare-variable name dtype) - (push (list newvar initialization) *loop-variables*) - ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. - (setq *loop-desetq-crocks* - (list* name newvar *loop-desetq-crocks*)) - #+ignore - (loop-make-variable name nil dtype iteration-variable-p))))) - (t (let ((tcar nil) (tcdr nil)) - (if (atom dtype) (setq tcar (setq tcdr dtype)) - (setq tcar (car dtype) tcdr (cdr dtype))) - (loop-make-variable (car name) nil tcar iteration-variable-p) - (loop-make-variable (cdr name) nil tcdr iteration-variable-p)))) + (cond ((not (null initialization)) + (push (list (setq name (loop-gentemp 'loop-ignore-)) + initialization) + *loop-variables*) + (push `(ignore ,name) *loop-declarations*)))) + ((atom name) + (cond (iteration-variable-p + (if (member name *loop-iteration-variables*) + (loop-error "Duplicated LOOP iteration variable ~S." name) + (push name *loop-iteration-variables*))) + ((assoc name *loop-variables*) + (loop-error "Duplicated variable ~S in LOOP parallel binding." name))) + (unless (symbolp name) + (loop-error "Bad variable ~S somewhere in LOOP." name)) + (loop-declare-variable name dtype) + ;; We use ASSOC on this list to check for duplications (above), + ;; so don't optimize out this list: + (push (list name (or initialization (loop-typed-init dtype))) + *loop-variables*)) + (initialization + (cond (*loop-destructuring-hooks* + (loop-declare-variable name dtype) + (push (list name initialization) *loop-variables*)) + (t (let ((newvar (loop-gentemp 'loop-destructure-))) + (loop-declare-variable name dtype) + (push (list newvar initialization) *loop-variables*) + ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. + (setq *loop-desetq-crocks* + (list* name newvar *loop-desetq-crocks*)) + #+ignore + (loop-make-variable name nil dtype iteration-variable-p))))) + (t (let ((tcar nil) (tcdr nil)) + (if (atom dtype) (setq tcar (setq tcdr dtype)) + (setq tcar (car dtype) tcdr (cdr dtype))) + (loop-make-variable (car name) nil tcar iteration-variable-p) + (loop-make-variable (cdr name) nil tcdr iteration-variable-p)))) name) @@ -1279,20 +1279,20 @@ collected result will be returned as the value of the LOOP." (defun loop-declare-variable (name dtype) (cond ((or (null name) (null dtype) (eq dtype t)) nil) - ((symbolp name) - (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*)) - (let ((dtype (let ((init (loop-typed-init dtype))) - (if (typep init dtype) + ((symbolp name) + (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*)) + (let ((dtype (let ((init (loop-typed-init dtype))) + (if (typep init dtype) dtype `(or (member ,init) ,dtype))))) - (push `(type ,dtype ,name) *loop-declarations*)))) - ((consp name) - (cond ((consp dtype) - (loop-declare-variable (car name) (car dtype)) - (loop-declare-variable (cdr name) (cdr dtype))) - (t (loop-declare-variable (car name) dtype) - (loop-declare-variable (cdr name) dtype)))) - (t (error "Invalid LOOP variable passed in: ~S." name)))) + (push `(type ,dtype ,name) *loop-declarations*)))) + ((consp name) + (cond ((consp dtype) + (loop-declare-variable (car name) (car dtype)) + (loop-declare-variable (cdr name) (cdr dtype))) + (t (loop-declare-variable (car name) dtype) + (loop-declare-variable (cdr name) dtype)))) + (t (error "Invalid LOOP variable passed in: ~S." name)))) (defun loop-maybe-bind-form (form data-type) @@ -1304,47 +1304,47 @@ collected result will be returned as the value of the LOOP." (defun loop-do-if (for negatep) (let ((form (loop-get-form)) - (it-p nil) - (first-clause-p t) then else) + (it-p nil) + (first-clause-p t) then else) (let ((*loop-inside-conditional* t)) (flet ((get-clause (for) - (do ((body nil)) (nil) - (let ((key (car *loop-source-code*)) (*loop-body* nil) data) - (cond ((not (symbolp key)) - (loop-error - "~S found where keyword expected getting LOOP clause after ~S." - key for)) - (t (setq *loop-source-context* *loop-source-code*) - (loop-pop-source) - (when (and (loop-tequal (car *loop-source-code*) 'it) - first-clause-p) - (setq *loop-source-code* - (cons (or it-p (setq it-p (loop-when-it-variable))) - (cdr *loop-source-code*)))) - (cond ((or (not (setq data (loop-lookup-keyword - key (loop-universe-keywords *loop-universe*)))) - (progn (apply (symbol-function (car data)) (cdr data)) - (null *loop-body*))) - (loop-error - "~S does not introduce a LOOP clause that can follow ~S." - key for)) - (t (setq body (nreconc *loop-body* body))))))) - (setq first-clause-p nil) - (if (loop-tequal (car *loop-source-code*) :and) - (loop-pop-source) - (return (if (cdr body) `(progn ,@(nreverse body)) (car body))))))) - (setq then (get-clause for)) - (setq else (when (loop-tequal (car *loop-source-code*) :else) - (loop-pop-source) - (list (get-clause :else))))) + (do ((body nil)) (nil) + (let ((key (car *loop-source-code*)) (*loop-body* nil) data) + (cond ((not (symbolp key)) + (loop-error + "~S found where keyword expected getting LOOP clause after ~S." + key for)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (when (and (loop-tequal (car *loop-source-code*) 'it) + first-clause-p) + (setq *loop-source-code* + (cons (or it-p (setq it-p (loop-when-it-variable))) + (cdr *loop-source-code*)))) + (cond ((or (not (setq data (loop-lookup-keyword + key (loop-universe-keywords *loop-universe*)))) + (progn (apply (symbol-function (car data)) (cdr data)) + (null *loop-body*))) + (loop-error + "~S does not introduce a LOOP clause that can follow ~S." + key for)) + (t (setq body (nreconc *loop-body* body))))))) + (setq first-clause-p nil) + (if (loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (return (if (cdr body) `(progn ,@(nreverse body)) (car body))))))) + (setq then (get-clause for)) + (setq else (when (loop-tequal (car *loop-source-code*) :else) + (loop-pop-source) + (list (get-clause :else))))) (when (loop-tequal (car *loop-source-code*) :end) - (loop-pop-source)) + (loop-pop-source)) (when it-p - (setq form `(setq ,it-p ,form)))) + (setq form `(setq ,it-p ,form)))) (loop-pseudo-body `(if ,(if negatep `(not ,form) form) - ,then - ,@else)))) + ,then + ,@else)))) (defun loop-do-initially () @@ -1366,7 +1366,7 @@ collected result will be returned as the value of the LOOP." (loop-error "The NAMED ~S clause occurs too late." name)) (when *loop-names* (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S." - (car *loop-names*) name)) + (car *loop-names*) name)) (setq *loop-names* (list name nil)))) (defun loop-do-return () @@ -1377,22 +1377,22 @@ collected result will be returned as the value of the LOOP." (defstruct (loop-collector - (:copier nil) - (:predicate nil)) + (:copier nil) + (:predicate nil)) name class (history nil) (tempvars nil) dtype - (data nil)) ;collector-specific data + (data nil)) ;collector-specific data (defun loop-get-collection-info (collector class default-type) (let ((form (loop-get-form)) - (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) - (name (when (loop-tequal (car *loop-source-code*) 'into) - (loop-pop-source) - (loop-pop-source)))) + (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) + (name (when (loop-tequal (car *loop-source-code*) 'into) + (loop-pop-source) + (loop-pop-source)))) (when (not (symbolp name)) (loop-error "Value accumulation recipient name, ~S, is not a symbol." name)) (unless name @@ -1400,47 +1400,47 @@ collected result will be returned as the value of the LOOP." (unless dtype (setq dtype (or (loop-optional-type) default-type))) (let ((cruft (find (the symbol name) *loop-collection-cruft* - :key #'loop-collector-name))) + :key #'loop-collector-name))) (cond ((not cruft) - (when (and name (loop-variable-p name)) - (loop-error "Variable ~S cannot be used in INTO clause" name)) - (push (setq cruft (make-loop-collector - :name name :class class - :history (list collector) :dtype dtype)) - *loop-collection-cruft*)) - (t (unless (eq (loop-collector-class cruft) class) - (loop-error - "Incompatible kinds of LOOP value accumulation specified for collecting~@ - ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S." - name (car (loop-collector-history cruft)) collector)) - (unless (equal dtype (loop-collector-dtype cruft)) - (loop-warn - "Unequal datatypes specified in different LOOP value accumulations~@ - into ~S: ~S and ~S." - name dtype (loop-collector-dtype cruft)) - (when (eq (loop-collector-dtype cruft) t) - (setf (loop-collector-dtype cruft) dtype))) - (push collector (loop-collector-history cruft)))) + (when (and name (loop-variable-p name)) + (loop-error "Variable ~S cannot be used in INTO clause" name)) + (push (setq cruft (make-loop-collector + :name name :class class + :history (list collector) :dtype dtype)) + *loop-collection-cruft*)) + (t (unless (eq (loop-collector-class cruft) class) + (loop-error + "Incompatible kinds of LOOP value accumulation specified for collecting~@ + ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S." + name (car (loop-collector-history cruft)) collector)) + (unless (equal dtype (loop-collector-dtype cruft)) + (loop-warn + "Unequal datatypes specified in different LOOP value accumulations~@ + into ~S: ~S and ~S." + name dtype (loop-collector-dtype cruft)) + (when (eq (loop-collector-dtype cruft) t) + (setf (loop-collector-dtype cruft) dtype))) + (push collector (loop-collector-history cruft)))) (values cruft form)))) -(defun loop-list-collection (specifically) ;NCONC, LIST, or APPEND +(defun loop-list-collection (specifically) ;NCONC, LIST, or APPEND (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list) (let ((tempvars (loop-collector-tempvars lc))) (unless tempvars - (setf (loop-collector-tempvars lc) - (setq tempvars (list* (loop-gentemp 'loop-list-head-) - (loop-gentemp 'loop-list-tail-) - (and (loop-collector-name lc) - (list (loop-collector-name lc)))))) - (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) - (unless (loop-collector-name lc) - (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars))))) + (setf (loop-collector-tempvars lc) + (setq tempvars (list* (loop-gentemp 'loop-list-head-) + (loop-gentemp 'loop-list-tail-) + (and (loop-collector-name lc) + (list (loop-collector-name lc)))))) + (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) + (unless (loop-collector-name lc) + (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars))))) (ecase specifically - (list (setq form `(list ,form))) - (nconc nil) - (append (unless (and (consp form) (eq (car form) 'list)) - (setq form `(loop-copylist* ,form))))) + (list (setq form `(list ,form))) + (nconc nil) + (append (unless (and (consp form) (eq (car form) 'list)) + (setq form `(loop-copylist* ,form))))) (loop-emit-body `(loop-collect-rplacd ,tempvars ,form))))) @@ -1448,27 +1448,27 @@ collected result will be returned as the value of the LOOP." -(defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT +(defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT (multiple-value-bind (lc form) (loop-get-collection-info specifically 'sum default-type) (loop-check-data-type (loop-collector-dtype lc) required-type) (let ((tempvars (loop-collector-tempvars lc))) (unless tempvars - (setf (loop-collector-tempvars lc) - (setq tempvars (list (loop-make-variable - (or (loop-collector-name lc) - (loop-gentemp 'loop-sum-)) - nil (loop-collector-dtype lc))))) - (unless (loop-collector-name lc) - (loop-emit-final-value (car (loop-collector-tempvars lc))))) + (setf (loop-collector-tempvars lc) + (setq tempvars (list (loop-make-variable + (or (loop-collector-name lc) + (loop-gentemp 'loop-sum-)) + nil (loop-collector-dtype lc))))) + (unless (loop-collector-name lc) + (loop-emit-final-value (car (loop-collector-tempvars lc))))) (loop-emit-body - (if (eq specifically 'count) - `(when ,form - (setq ,(car tempvars) - ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars))))) - `(setq ,(car tempvars) - (+ ,(hide-variable-reference t (car tempvars) (car tempvars)) - ,form))))))) + (if (eq specifically 'count) + `(when ,form + (setq ,(car tempvars) + ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars))))) + `(setq ,(car tempvars) + (+ ,(hide-variable-reference t (car tempvars) (car tempvars)) + ,form))))))) @@ -1478,12 +1478,12 @@ collected result will be returned as the value of the LOOP." (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*) (let ((data (loop-collector-data lc))) (unless data - (setf (loop-collector-data lc) - (setq data (make-loop-minimax - (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-)) - (loop-collector-dtype lc)))) - (unless (loop-collector-name lc) - (loop-emit-final-value (loop-minimax-answer-variable data)))) + (setf (loop-collector-data lc) + (setq data (make-loop-minimax + (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-)) + (loop-collector-dtype lc)))) + (unless (loop-collector-name lc) + (loop-emit-final-value (loop-minimax-answer-variable data)))) (loop-note-minimax-operation specifically data) (push `(with-minimax-value ,data) *loop-wrappers*) (loop-emit-body `(loop-accumulate-minimax-value ,data ,specifically ,form)) @@ -1499,7 +1499,7 @@ collected result will be returned as the value of the LOOP." (when restrictive (loop-disallow-conditional)) (loop-disallow-anonymous-collectors) (loop-emit-body `(,(if negate 'when 'unless) ,form - ,(loop-construct-return nil))) + ,(loop-construct-return nil))) (loop-emit-final-value t))) @@ -1511,7 +1511,7 @@ collected result will be returned as the value of the LOOP." (loop-disallow-anonymous-collectors) (loop-emit-final-value) (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form)) - ,(loop-construct-return *loop-when-it-variable*)))) + ,(loop-construct-return *loop-when-it-variable*)))) (defun loop-do-while (negate kwd &aux (form (loop-get-form))) @@ -1523,39 +1523,39 @@ collected result will be returned as the value of the LOOP." (loop-disallow-conditional :with) (do ((var) (val) (dtype)) (nil) (setq var (loop-pop-source) - dtype (loop-optional-type var) - val (cond ((loop-tequal (car *loop-source-code*) :=) - (loop-pop-source) - (loop-get-form)) - (t nil))) + dtype (loop-optional-type var) + val (cond ((loop-tequal (car *loop-source-code*) :=) + (loop-pop-source) + (loop-get-form)) + (t nil))) (when (and var (loop-variable-p var)) (loop-error "Variable ~S has already been used" var)) (loop-make-variable var val dtype) (if (loop-tequal (car *loop-source-code*) :and) - (loop-pop-source) - (return (loop-bind-block))))) + (loop-pop-source) + (return (loop-bind-block))))) ;;;; The iteration driver (defun loop-hack-iteration (entry) (flet ((make-endtest (list-of-forms) - (cond ((null list-of-forms) nil) - ((member t list-of-forms) '(go end-loop)) - (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) - (car list-of-forms) - (cons 'or list-of-forms)) - (go end-loop)))))) + (cond ((null list-of-forms) nil) + ((member t list-of-forms) '(go end-loop)) + (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) + (car list-of-forms) + (cons 'or list-of-forms)) + (go end-loop)))))) (do ((pre-step-tests nil) - (steps nil) - (post-step-tests nil) - (pseudo-steps nil) - (pre-loop-pre-step-tests nil) - (pre-loop-steps nil) - (pre-loop-post-step-tests nil) - (pre-loop-pseudo-steps nil) - (tem) (data)) - (nil) + (steps nil) + (post-step-tests nil) + (pseudo-steps nil) + (pre-loop-pre-step-tests nil) + (pre-loop-steps nil) + (pre-loop-post-step-tests nil) + (pre-loop-pseudo-steps nil) + (tem) (data)) + (nil) ;; Note we collect endtests in reverse order, but steps in correct ;; order. MAKE-ENDTEST does the nreverse for us. (setq tem (setq data (apply (symbol-function (first entry)) (rest entry)))) @@ -1565,33 +1565,33 @@ collected result will be returned as the value of the LOOP." (setq pseudo-steps (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem)))))) (setq tem (cdr tem)) (when *loop-emitted-body* - (loop-error "Iteration in LOOP follows body code.")) + (loop-error "Iteration in LOOP follows body code.")) (unless tem (setq tem data)) (when (car tem) (push (car tem) pre-loop-pre-step-tests)) (setq pre-loop-steps (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem)))))) (when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests)) (setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem)))) (unless (loop-tequal (car *loop-source-code*) :and) - (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps) - (make-endtest pre-loop-post-step-tests) - (loop-make-psetq pre-loop-steps) - (make-endtest pre-loop-pre-step-tests) - *loop-before-loop*) - *loop-after-body* (list* (loop-make-desetq pseudo-steps) - (make-endtest post-step-tests) - (loop-make-psetq steps) - (make-endtest pre-step-tests) - *loop-after-body*)) - (loop-bind-block) - (return nil)) - (loop-pop-source) ; flush the "AND" + (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps) + (make-endtest pre-loop-post-step-tests) + (loop-make-psetq pre-loop-steps) + (make-endtest pre-loop-pre-step-tests) + *loop-before-loop*) + *loop-after-body* (list* (loop-make-desetq pseudo-steps) + (make-endtest post-step-tests) + (loop-make-psetq steps) + (make-endtest pre-step-tests) + *loop-after-body*)) + (loop-bind-block) + (return nil)) + (loop-pop-source) ; flush the "AND" (when (and (not (loop-universe-implicit-for-required *loop-universe*)) - (setq tem (loop-lookup-keyword - (car *loop-source-code*) - (loop-universe-iteration-keywords *loop-universe*)))) - ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied. - (loop-pop-source) - (setq entry tem))))) + (setq tem (loop-lookup-keyword + (car *loop-source-code*) + (loop-universe-iteration-keywords *loop-universe*)))) + ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied. + (loop-pop-source) + (setq entry tem))))) ;;;; Main Iteration Drivers @@ -1600,22 +1600,22 @@ collected result will be returned as the value of the LOOP." ;FOR variable keyword ..args.. (defun loop-do-for () (let* ((var (or (loop-pop-source) (loop-gentemp 'loop-do-for-anon-))) - (data-type (loop-optional-type var)) - (keyword (loop-pop-source)) - (first-arg nil) - (tem nil)) + (data-type (loop-optional-type var)) + (keyword (loop-pop-source)) + (first-arg nil) + (tem nil)) (setq first-arg (loop-get-form)) (unless (and (symbolp keyword) - (setq tem (loop-lookup-keyword - keyword - (loop-universe-for-keywords *loop-universe*)))) + (setq tem (loop-lookup-keyword + keyword + (loop-universe-for-keywords *loop-universe*)))) (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." keyword)) (apply (car tem) var first-arg data-type (cdr tem)))) (defun loop-do-repeat () (loop-disallow-conditional :repeat) (let ((form (loop-get-form)) - (type 'real)) + (type 'real)) (let ((var (loop-make-variable (loop-gentemp) form type))) (push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*) (push `(when (minusp (decf ,var)) (go end-loop)) *loop-after-body*) @@ -1631,7 +1631,7 @@ collected result will be returned as the value of the LOOP." (defun loop-when-it-variable () (or *loop-when-it-variable* (setq *loop-when-it-variable* - (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) + (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) ;;;; Various FOR/AS Subdispatches @@ -1645,82 +1645,82 @@ collected result will be returned as the value of the LOOP." (defun loop-ansi-for-equals (var val data-type) (loop-make-iteration-variable var nil data-type) (cond ((loop-tequal (car *loop-source-code*) :then) - ;;Then we are the same as "FOR x FIRST y THEN z". - (loop-pop-source) - `(() (,var ,(loop-get-form)) () () - () (,var ,val) () ())) - (t ;;We are the same as "FOR x = y". - ;; Let me document here what this is returning. Look at - ;; loop-hack-iteration for more info. But anyway, we return a list of - ;; 8 items, in this order: PRE-STEP-TESTS, STEPS, POST-STEP-TESTS, - ;; PSEUDO-STEPS, PRE-LOOP-PRE-STEP-TESTS, PRE-LOOP-STEPS, - ;; PRE-LOOP-POST-STEP-TESTS, PRE-LOOP-PSEUDO-STEPS. (We should add - ;; something to make it easier to figure out what these args are!) - ;; - ;; For a "FOR x = y" clause without the THEN, we want the STEPS item to - ;; step the variable VAR with the value VAL. This gets placed in the - ;; body of the loop. The original code just did that. It seems that - ;; the STEPS form is placed in *loop-before-loop* and in - ;; *loop-after-loop*. Loop optimization would then see the same form - ;; in both, and move them into the beginning of body. This is ok, - ;; except that if there are :initially forms that were placed into the - ;; loop prologue, the :initially forms might refer to incorrectly - ;; initialized variables, because the optimizer moved STEPS from from - ;; *loop-before-loop* into the body. - ;; - ;; To solve this, we add a PRE-LOOP-PSEUDO-STEP form that is identical - ;; to the STEPS form. This gets placed in *loop-before-loop*. But - ;; this won't match any *loop-after-loop* form, so it won't get moved, - ;; and we maintain the proper sequencing such that the - ;; PRE-LOOP-PSEUDO-STEP form is in *loop-before-loop*, before any - ;; :initially clauses that might refer to this. So all is well. Whew. - ;; - ;; I hope this doesn't break anything else. - `(() (,var ,val) () () - () () () (,var ,val)) - ))) + ;;Then we are the same as "FOR x FIRST y THEN z". + (loop-pop-source) + `(() (,var ,(loop-get-form)) () () + () (,var ,val) () ())) + (t ;;We are the same as "FOR x = y". + ;; Let me document here what this is returning. Look at + ;; loop-hack-iteration for more info. But anyway, we return a list of + ;; 8 items, in this order: PRE-STEP-TESTS, STEPS, POST-STEP-TESTS, + ;; PSEUDO-STEPS, PRE-LOOP-PRE-STEP-TESTS, PRE-LOOP-STEPS, + ;; PRE-LOOP-POST-STEP-TESTS, PRE-LOOP-PSEUDO-STEPS. (We should add + ;; something to make it easier to figure out what these args are!) + ;; + ;; For a "FOR x = y" clause without the THEN, we want the STEPS item to + ;; step the variable VAR with the value VAL. This gets placed in the + ;; body of the loop. The original code just did that. It seems that + ;; the STEPS form is placed in *loop-before-loop* and in + ;; *loop-after-loop*. Loop optimization would then see the same form + ;; in both, and move them into the beginning of body. This is ok, + ;; except that if there are :initially forms that were placed into the + ;; loop prologue, the :initially forms might refer to incorrectly + ;; initialized variables, because the optimizer moved STEPS from from + ;; *loop-before-loop* into the body. + ;; + ;; To solve this, we add a PRE-LOOP-PSEUDO-STEP form that is identical + ;; to the STEPS form. This gets placed in *loop-before-loop*. But + ;; this won't match any *loop-after-loop* form, so it won't get moved, + ;; and we maintain the proper sequencing such that the + ;; PRE-LOOP-PSEUDO-STEP form is in *loop-before-loop*, before any + ;; :initially clauses that might refer to this. So all is well. Whew. + ;; + ;; I hope this doesn't break anything else. + `(() (,var ,val) () () + () () () (,var ,val)) + ))) (defun loop-for-across (var val data-type) (loop-make-iteration-variable var nil data-type) (let ((vector-var (loop-gentemp 'loop-across-vector-)) - (index-var (loop-gentemp 'loop-across-index-))) + (index-var (loop-gentemp 'loop-across-index-))) (multiple-value-bind (vector-form constantp vector-value) - (loop-constant-fold-if-possible val 'vector) + (loop-constant-fold-if-possible val 'vector) (loop-make-variable - vector-var vector-form - (if (and (consp vector-form) (eq (car vector-form) 'the)) - (cadr vector-form) - 'vector)) + vector-var vector-form + (if (and (consp vector-form) (eq (car vector-form) 'the)) + (cadr vector-form) + 'vector)) #+Genera (push `(system:array-register ,vector-var) *loop-declarations*) (loop-make-variable index-var 0 'fixnum) (let* ((length 0) - (length-form (cond ((not constantp) - (let ((v (loop-gentemp 'loop-across-limit-))) - ;; This used to just push the length - ;; computation into the prologue code. I - ;; (rtoy) don't think that's right, - ;; especially since the prologue is supposed - ;; to happen AFTER other initializations. - ;; So, this puts the computation in - ;; *loop-before-body*. We need a matching - ;; entry for *loop-after-body*, so stuff a - ;; NIL there. - (push `(setq ,v (length ,vector-var)) *loop-before-loop*) - (push nil *loop-after-body*) - (loop-make-variable v 0 'fixnum))) - (t (setq length (length vector-value))))) - (first-test `(>= ,index-var ,length-form)) - (other-test first-test) - (step `(,var (aref ,vector-var ,index-var))) - (pstep `(,index-var (1+ ,index-var)))) - (declare (fixnum length)) - (when constantp - (setq first-test (= length 0)) - (when (<= length 1) - (setq other-test t))) - `(,other-test ,step () ,pstep - ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep))))))) + (length-form (cond ((not constantp) + (let ((v (loop-gentemp 'loop-across-limit-))) + ;; This used to just push the length + ;; computation into the prologue code. I + ;; (rtoy) don't think that's right, + ;; especially since the prologue is supposed + ;; to happen AFTER other initializations. + ;; So, this puts the computation in + ;; *loop-before-body*. We need a matching + ;; entry for *loop-after-body*, so stuff a + ;; NIL there. + (push `(setq ,v (length ,vector-var)) *loop-before-loop*) + (push nil *loop-after-body*) + (loop-make-variable v 0 'fixnum))) + (t (setq length (length vector-value))))) + (first-test `(>= ,index-var ,length-form)) + (other-test first-test) + (step `(,var (aref ,vector-var ,index-var))) + (pstep `(,index-var (1+ ,index-var)))) + (declare (fixnum length)) + (when constantp + (setq first-test (= length 0)) + (when (<= length 1) + (setq other-test t))) + `(,other-test ,step () ,pstep + ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep))))))) @@ -1734,55 +1734,55 @@ collected result will be returned as the value of the LOOP." ;;While a Discerning Compiler may deal intelligently with (funcall 'foo ...), not ;; recognizing FOO may defeat some LOOP optimizations. (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by) - (loop-pop-source) - (loop-get-form)) - (t '(function cdr))))) + (loop-pop-source) + (loop-get-form)) + (t '(function cdr))))) (cond ((and (consp stepper) (eq (car stepper) 'quote)) - (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") - (values `(funcall ,stepper ,listvar) nil)) - ((and (consp stepper) (eq (car stepper) 'function)) - (values (list (cadr stepper) listvar) (cadr stepper))) - (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function) - ,listvar) - nil))))) + (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") + (values `(funcall ,stepper ,listvar) nil)) + ((and (consp stepper) (eq (car stepper) 'function)) + (values (list (cadr stepper) listvar) (cadr stepper))) + (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function) + ,listvar) + nil))))) (defun loop-for-on (var val data-type) (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) (let ((listvar var)) (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type)) - (t (loop-make-variable (setq listvar (loop-gentemp)) list 't) - (loop-make-iteration-variable var nil data-type))) + (t (loop-make-variable (setq listvar (loop-gentemp)) list 't) + (loop-make-iteration-variable var nil data-type))) (multiple-value-bind (list-step step-function) (loop-list-step listvar) - (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function)) - ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind. - (let* ((first-endtest - (hide-variable-reference - (eq var listvar) - listvar - ;; the following should use `atom' instead of `endp', per - ;; [bug2428] - `(atom ,listvar))) - (other-endtest first-endtest)) - (when (and constantp (listp list-value)) - (setq first-endtest (null list-value))) - (cond ((eq var listvar) - ;;Contour of the loop is different because we use the user's variable... - `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest - () () () ,first-endtest ())) - #+LOOP-Prefer-POP - ((and step-function - (let ((n (cdr (assoc step-function '((cdr . 1) (cddr . 2) - (cdddr . 3) (cddddr . 4)))))) - (and n (do ((l var (cdr l)) (i 0 (1+ i))) - ((atom l) (and (null l) (= i n))) - (declare (fixnum i)))))) - (let ((step (mapcan #'(lambda (x) (list x `(pop ,listvar))) var))) - `(,other-endtest () () ,step ,first-endtest () () ,step))) - (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step))) - `(,other-endtest ,step () ,pseudo - ,@(and (not (eq first-endtest other-endtest)) - `(,first-endtest ,step () ,pseudo))))))))))) + (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function)) + ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind. + (let* ((first-endtest + (hide-variable-reference + (eq var listvar) + listvar + ;; the following should use `atom' instead of `endp', per + ;; [bug2428] + `(atom ,listvar))) + (other-endtest first-endtest)) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + (cond ((eq var listvar) + ;;Contour of the loop is different because we use the user's variable... + `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest + () () () ,first-endtest ())) + #+LOOP-Prefer-POP + ((and step-function + (let ((n (cdr (assoc step-function '((cdr . 1) (cddr . 2) + (cdddr . 3) (cddddr . 4)))))) + (and n (do ((l var (cdr l)) (i 0 (1+ i))) + ((atom l) (and (null l) (= i n))) + (declare (fixnum i)))))) + (let ((step (mapcan #'(lambda (x) (list x `(pop ,listvar))) var))) + `(,other-endtest () () ,step ,first-endtest () () ,step))) + (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step))) + `(,other-endtest ,step () ,pseudo + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo))))))))))) (defun loop-for-in (var val data-type) @@ -1791,26 +1791,26 @@ collected result will be returned as the value of the LOOP." (loop-make-iteration-variable var nil data-type) (loop-make-variable listvar list 'list) (multiple-value-bind (list-step step-function) (loop-list-step listvar) - #-LOOP-Prefer-POP (declare (ignore step-function)) - (let* ((first-endtest `(endp ,listvar)) - (other-endtest first-endtest) - (step `(,var (car ,listvar))) - (pseudo-step `(,listvar ,list-step))) - (when (and constantp (listp list-value)) - (setq first-endtest (null list-value))) - #+LOOP-Prefer-POP (when (eq step-function 'cdr) - (setq step `(,var (pop ,listvar)) pseudo-step nil)) - `(,other-endtest ,step () ,pseudo-step - ,@(and (not (eq first-endtest other-endtest)) - `(,first-endtest ,step () ,pseudo-step)))))))) + #-LOOP-Prefer-POP (declare (ignore step-function)) + (let* ((first-endtest `(endp ,listvar)) + (other-endtest first-endtest) + (step `(,var (car ,listvar))) + (pseudo-step `(,listvar ,list-step))) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + #+LOOP-Prefer-POP (when (eq step-function 'cdr) + (setq step `(,var (pop ,listvar)) pseudo-step nil)) + `(,other-endtest ,step () ,pseudo-step + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo-step)))))))) ;;;; Iteration Paths (defstruct (loop-path - (:copier nil) - (:predicate nil)) + (:copier nil) + (:predicate nil)) names preposition-groups inclusive-permitted @@ -1829,7 +1829,7 @@ collected result will be returned as the value of the LOOP." :function function :user-data user-data :preposition-groups (mapcar #'(lambda (x) (if (listp x) x (list x))) preposition-groups) - :inclusive-permitted inclusive-permitted))) + :inclusive-permitted inclusive-permitted))) (dolist (name names) (setf (gethash (symbol-name name) ht) lp)) lp))) @@ -1840,46 +1840,46 @@ collected result will be returned as the value of the LOOP." ;; FOR var BEING each/the pathname prep-phrases using-stuff... ;; each/the = EACH or THE. Not clear if it is optional, so I guess we'll warn. (let ((path nil) - (data nil) - (inclusive nil) - (stuff nil) - (initial-prepositions nil)) + (data nil) + (inclusive nil) + (stuff nil) + (initial-prepositions nil)) (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source))) - ((loop-tequal (car *loop-source-code*) :and) - (loop-pop-source) - (setq inclusive t) - (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her)) - (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax." - (car *loop-source-code*))) - (loop-pop-source) - (setq path (loop-pop-source)) - (setq initial-prepositions `((:in ,val)))) - (t (loop-error "Unrecognizable LOOP iteration path syntax. Missing EACH or THE?"))) + ((loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (setq inclusive t) + (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her)) + (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax." + (car *loop-source-code*))) + (loop-pop-source) + (setq path (loop-pop-source)) + (setq initial-prepositions `((:in ,val)))) + (t (loop-error "Unrecognizable LOOP iteration path syntax. Missing EACH or THE?"))) (cond ((not (symbolp path)) - (loop-error "~S found where a LOOP iteration path name was expected." path)) - ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) - (loop-error "~S is not the name of a LOOP iteration path." path)) - ((and inclusive (not (loop-path-inclusive-permitted data))) - (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) + (loop-error "~S found where a LOOP iteration path name was expected." path)) + ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) + (loop-error "~S is not the name of a LOOP iteration path." path)) + ((and inclusive (not (loop-path-inclusive-permitted data))) + (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) (let ((fun (loop-path-function data)) - (preps (nconc initial-prepositions - (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t))) - (user-data (loop-path-user-data data))) + (preps (nconc initial-prepositions + (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t))) + (user-data (loop-path-user-data data))) (when (symbolp fun) (setq fun (symbol-function fun))) (setq stuff (if inclusive - (apply fun var data-type preps :inclusive t user-data) - (apply fun var data-type preps user-data)))) + (apply fun var data-type preps :inclusive t user-data) + (apply fun var data-type preps user-data)))) (when *loop-named-variables* (loop-error "Unused USING variables: ~S." *loop-named-variables*)) ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the system from the user ;; and the user from himself. (unless (member (length stuff) '(6 10)) (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." - path)) + path)) (do ((l (car stuff) (cdr l)) (x)) ((null l)) (if (atom (setq x (car l))) - (loop-make-iteration-variable x nil nil) - (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) + (loop-make-iteration-variable x nil nil) + (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) (cddr stuff))) @@ -1891,151 +1891,151 @@ collected result will be returned as the value of the LOOP." (let ((tem (loop-tassoc name *loop-named-variables*))) (declare (list tem)) (cond ((null tem) (values (loop-gentemp) nil)) - (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) - (values (cdr tem) t))))) + (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) + (values (cdr tem) t))))) (defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases) (flet ((in-group-p (x group) (car (loop-tmember x group)))) (do ((token nil) - (prepositional-phrases initial-phrases) - (this-group nil nil) - (this-prep nil nil) - (disallowed-prepositions - (mapcan #'(lambda (x) - (loop-copylist* - (find (car x) preposition-groups :test #'in-group-p))) - initial-phrases)) - (used-prepositions (mapcar #'car initial-phrases))) - ((null *loop-source-code*) (nreverse prepositional-phrases)) + (prepositional-phrases initial-phrases) + (this-group nil nil) + (this-prep nil nil) + (disallowed-prepositions + (mapcan #'(lambda (x) + (loop-copylist* + (find (car x) preposition-groups :test #'in-group-p))) + initial-phrases)) + (used-prepositions (mapcar #'car initial-phrases))) + ((null *loop-source-code*) (nreverse prepositional-phrases)) (declare (symbol this-prep)) (setq token (car *loop-source-code*)) (dolist (group preposition-groups) - (when (setq this-prep (in-group-p token group)) - (return (setq this-group group)))) + (when (setq this-prep (in-group-p token group)) + (return (setq this-group group)))) (cond (this-group - (when (member this-prep disallowed-prepositions) - (loop-error - (if (member this-prep used-prepositions) - "A ~S prepositional phrase occurs multiply for some LOOP clause." - "Preposition ~S used when some other preposition has subsumed it.") - token)) - (setq used-prepositions (if (listp this-group) - (append this-group used-prepositions) - (cons this-group used-prepositions))) - (loop-pop-source) - (push (list this-prep (loop-get-form)) prepositional-phrases)) - ((and USING-allowed (loop-tequal token 'using)) - (loop-pop-source) - (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) - (when (cadr z) - (if (setq tem (loop-tassoc (car z) *loop-named-variables*)) - (loop-error - "The variable substitution for ~S occurs twice in a USING phrase,~@ - with ~S and ~S." - (car z) (cadr z) (cadr tem)) - (push (cons (car z) (cadr z)) *loop-named-variables*))) - (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*))) - (return nil)))) - (t (return (nreverse prepositional-phrases))))))) + (when (member this-prep disallowed-prepositions) + (loop-error + (if (member this-prep used-prepositions) + "A ~S prepositional phrase occurs multiply for some LOOP clause." + "Preposition ~S used when some other preposition has subsumed it.") + token)) + (setq used-prepositions (if (listp this-group) + (append this-group used-prepositions) + (cons this-group used-prepositions))) + (loop-pop-source) + (push (list this-prep (loop-get-form)) prepositional-phrases)) + ((and USING-allowed (loop-tequal token 'using)) + (loop-pop-source) + (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) + (when (cadr z) + (if (setq tem (loop-tassoc (car z) *loop-named-variables*)) + (loop-error + "The variable substitution for ~S occurs twice in a USING phrase,~@ + with ~S and ~S." + (car z) (cadr z) (cadr tem)) + (push (cons (car z) (cadr z)) *loop-named-variables*))) + (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*))) + (return nil)))) + (t (return (nreverse prepositional-phrases))))))) ;;;; Master Sequencer Function (defun loop-sequencer (indexv indexv-type indexv-user-specified-p - variable variable-type - sequence-variable sequence-type - step-hack default-top - prep-phrases) - (let ((endform nil) ;Form (constant or variable) with limit value. - (sequencep nil) ;T if sequence arg has been provided. - (testfn nil) ;endtest function - (test nil) ;endtest form. - (stepby (1+ (or (loop-typed-init indexv-type) 0))) ;Our increment. - (stepby-constantp t) - (step nil) ;step form. - (dir nil) ;Direction of stepping: NIL, :UP, :DOWN. - (inclusive-iteration nil) ;T if include last index. - (start-given nil) ;T when prep phrase has specified start - (start-value nil) - (start-constantp nil) - (limit-given nil) ;T when prep phrase has specified end - (limit-constantp nil) - (limit-value nil) - ) + variable variable-type + sequence-variable sequence-type + step-hack default-top + prep-phrases) + (let ((endform nil) ;Form (constant or variable) with limit value. + (sequencep nil) ;T if sequence arg has been provided. + (testfn nil) ;endtest function + (test nil) ;endtest form. + (stepby (1+ (or (loop-typed-init indexv-type) 0))) ;Our increment. + (stepby-constantp t) + (step nil) ;step form. + (dir nil) ;Direction of stepping: NIL, :UP, :DOWN. + (inclusive-iteration nil) ;T if include last index. + (start-given nil) ;T when prep phrase has specified start + (start-value nil) + (start-constantp nil) + (limit-given nil) ;T when prep phrase has specified end + (limit-constantp nil) + (limit-value nil) + ) (when variable (loop-make-iteration-variable variable nil variable-type)) (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) (setq prep (caar l) form (cadar l)) (case prep - ((:of :in) - (setq sequencep t) - (loop-make-variable sequence-variable form sequence-type)) - ((:from :downfrom :upfrom) - (setq start-given t) - (cond ((eq prep :downfrom) (setq dir ':down)) - ((eq prep :upfrom) (setq dir ':up))) - (multiple-value-setq (form start-constantp start-value) - (loop-constant-fold-if-possible form indexv-type)) - (loop-make-iteration-variable indexv form indexv-type)) - ((:upto :to :downto :above :below) - (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up))) - ((loop-tequal prep :to) (setq inclusive-iteration t)) - ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down))) - ((loop-tequal prep :above) (setq dir ':down)) - ((loop-tequal prep :below) (setq dir ':up))) - (setq limit-given t) - (multiple-value-setq (form limit-constantp limit-value) - (loop-constant-fold-if-possible form indexv-type)) - (setq endform (if limit-constantp - `',limit-value - (loop-make-variable - (loop-gentemp 'loop-limit-) form indexv-type)))) - (:by - (multiple-value-setq (form stepby-constantp stepby) - (loop-constant-fold-if-possible form indexv-type)) - (unless stepby-constantp - (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-)) form indexv-type))) - (t (loop-error - "~S invalid preposition in sequencing or sequence path.~@ - Invalid prepositions specified in iteration path descriptor or something?" - prep))) + ((:of :in) + (setq sequencep t) + (loop-make-variable sequence-variable form sequence-type)) + ((:from :downfrom :upfrom) + (setq start-given t) + (cond ((eq prep :downfrom) (setq dir ':down)) + ((eq prep :upfrom) (setq dir ':up))) + (multiple-value-setq (form start-constantp start-value) + (loop-constant-fold-if-possible form indexv-type)) + (loop-make-iteration-variable indexv form indexv-type)) + ((:upto :to :downto :above :below) + (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up))) + ((loop-tequal prep :to) (setq inclusive-iteration t)) + ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down))) + ((loop-tequal prep :above) (setq dir ':down)) + ((loop-tequal prep :below) (setq dir ':up))) + (setq limit-given t) + (multiple-value-setq (form limit-constantp limit-value) + (loop-constant-fold-if-possible form indexv-type)) + (setq endform (if limit-constantp + `',limit-value + (loop-make-variable + (loop-gentemp 'loop-limit-) form indexv-type)))) + (:by + (multiple-value-setq (form stepby-constantp stepby) + (loop-constant-fold-if-possible form indexv-type)) + (unless stepby-constantp + (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-)) form indexv-type))) + (t (loop-error + "~S invalid preposition in sequencing or sequence path.~@ + Invalid prepositions specified in iteration path descriptor or something?" + prep))) (when (and odir dir (not (eq dir odir))) - (loop-error "Conflicting stepping directions in LOOP sequencing path")) + (loop-error "Conflicting stepping directions in LOOP sequencing path")) (setq odir dir)) (when (and sequence-variable (not sequencep)) (loop-error "Missing OF or IN phrase in sequence path")) ;; Now fill in the defaults. (unless start-given (loop-make-iteration-variable - indexv - (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0)) - indexv-type)) + indexv + (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0)) + indexv-type)) (cond ((member dir '(nil :up)) - (when (or limit-given default-top) - (unless limit-given - (loop-make-variable (setq endform (loop-gentemp 'loop-seq-limit-)) - nil indexv-type) - (push `(setq ,endform ,default-top) *loop-prologue*)) - (setq testfn (if inclusive-iteration '> '>=))) - (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) - (t (unless start-given - (unless default-top - (loop-error "Don't know where to start stepping.")) - (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) - (when (and default-top (not endform)) - (setq endform (loop-typed-init indexv-type) inclusive-iteration t)) - (when endform (setq testfn (if inclusive-iteration '< '<=))) - (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) + (when (or limit-given default-top) + (unless limit-given + (loop-make-variable (setq endform (loop-gentemp 'loop-seq-limit-)) + nil indexv-type) + (push `(setq ,endform ,default-top) *loop-prologue*)) + (setq testfn (if inclusive-iteration '> '>=))) + (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) + (t (unless start-given + (unless default-top + (loop-error "Don't know where to start stepping.")) + (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) + (when (and default-top (not endform)) + (setq endform (loop-typed-init indexv-type) inclusive-iteration t)) + (when endform (setq testfn (if inclusive-iteration '< '<=))) + (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) (when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform)))) (when step-hack (setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack)))) (let ((first-test test) (remaining-tests test)) (when (and stepby-constantp start-constantp limit-constantp) - (when (setq first-test (funcall (symbol-function testfn) start-value limit-value)) - (setq remaining-tests t))) + (when (setq first-test (funcall (symbol-function testfn) start-value limit-value)) + (setq remaining-tests t))) `(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack - () () ,first-test ,step-hack)))) + () () ,first-test ,step-hack)))) ;;;; Interfaces to the Master Sequencer @@ -2052,22 +2052,22 @@ collected result will be returned as the value of the LOOP." (defun loop-sequence-elements-path (variable data-type prep-phrases - &key fetch-function size-function sequence-type element-type) + &key fetch-function size-function sequence-type element-type) (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index) (let ((sequencev (named-variable 'sequence))) #+Genera (when (and sequencev - (symbolp sequencev) - sequence-type - (subtypep sequence-type 'vector) - (not (member (the symbol sequencev) *loop-nodeclare*))) - (push `(sys:array-register ,sequencev) *loop-declarations*)) - (list* nil nil ; dummy bindings and prologue - (loop-sequencer - indexv 'fixnum indexv-user-specified-p - variable (or data-type element-type) - sequencev sequence-type - `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev) - prep-phrases))))) + (symbolp sequencev) + sequence-type + (subtypep sequence-type 'vector) + (not (member (the symbol sequencev) *loop-nodeclare*))) + (push `(sys:array-register ,sequencev) *loop-declarations*)) + (list* nil nil ; dummy bindings and prologue + (loop-sequencer + indexv 'fixnum indexv-user-specified-p + variable (or data-type element-type) + sequencev sequence-type + `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev) + prep-phrases))))) ;;;; Builtin LOOP Iteration Paths @@ -2083,86 +2083,86 @@ collected result will be returned as the value of the LOOP." (defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which) (check-type which (member hash-key hash-value)) (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) - (loop-error "Too many prepositions!")) - ((null prep-phrases) (loop-error "Missing OF or IN in ~S iteration path."))) + (loop-error "Too many prepositions!")) + ((null prep-phrases) (loop-error "Missing OF or IN in ~S iteration path."))) (let ((ht-var (loop-gentemp 'loop-hashtab-)) - (next-fn (loop-gentemp 'loop-hashtab-next-)) - (dummy-predicate-var nil) - (post-steps nil)) + (next-fn (loop-gentemp 'loop-hashtab-next-)) + (dummy-predicate-var nil) + (post-steps nil)) (multiple-value-bind (other-var other-p) - (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key)) + (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key)) ;;@@@@ named-variable returns a second value of T if the name was actually ;; specified, so clever code can throw away the gensym'ed up variable if ;; it isn't really needed. ;;The following is for those implementations in which we cannot put dummy NILs ;; into multiple-value-setq variable lists. #-Genera (setq other-p t - dummy-predicate-var (loop-when-it-variable)) + dummy-predicate-var (loop-when-it-variable)) (let* ((key-var nil) - (val-var nil) - (temp-val-var (loop-gentemp 'loop-hash-val-temp-)) - (temp-key-var (loop-gentemp 'loop-hash-key-temp-)) - (temp-predicate-var (loop-gentemp 'loop-hash-predicate-var-)) - (variable (or variable (loop-gentemp))) - (bindings `((,variable nil ,data-type) - (,ht-var ,(cadar prep-phrases)) - ,@(and other-p other-var `((,other-var nil)))))) - (if (eq which 'hash-key) - (setq key-var variable val-var (and other-p other-var)) - (setq key-var (and other-p other-var) val-var variable)) - (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) - (when (consp key-var) - (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-)) - ,@post-steps)) - (push `(,key-var nil) bindings)) - (when (consp val-var) - (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-)) - ,@post-steps)) - (push `(,val-var nil) bindings)) - `(,bindings ;bindings - () ;prologue - () ;pre-test - () ;parallel steps - (not - (multiple-value-bind (,temp-predicate-var ,temp-key-var ,temp-val-var) - (,next-fn) - ;; We use M-V-BIND instead of M-V-SETQ because we only - ;; want to assign values to the key and val vars when we - ;; are in the hash table. When we reach the end, - ;; TEMP-PREDICATE-VAR is NIL, and so are temp-key-var and - ;; temp-val-var. This might break any type declarations - ;; on the key and val vars. - (when ,temp-predicate-var - (setq ,val-var ,temp-val-var) - (setq ,key-var ,temp-key-var)) - (setq ,dummy-predicate-var ,temp-predicate-var) - )) ;post-test - ,post-steps))))) + (val-var nil) + (temp-val-var (loop-gentemp 'loop-hash-val-temp-)) + (temp-key-var (loop-gentemp 'loop-hash-key-temp-)) + (temp-predicate-var (loop-gentemp 'loop-hash-predicate-var-)) + (variable (or variable (loop-gentemp))) + (bindings `((,variable nil ,data-type) + (,ht-var ,(cadar prep-phrases)) + ,@(and other-p other-var `((,other-var nil)))))) + (if (eq which 'hash-key) + (setq key-var variable val-var (and other-p other-var)) + (setq key-var (and other-p other-var) val-var variable)) + (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) + (when (consp key-var) + (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-)) + ,@post-steps)) + (push `(,key-var nil) bindings)) + (when (consp val-var) + (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-)) + ,@post-steps)) + (push `(,val-var nil) bindings)) + `(,bindings ;bindings + () ;prologue + () ;pre-test + () ;parallel steps + (not + (multiple-value-bind (,temp-predicate-var ,temp-key-var ,temp-val-var) + (,next-fn) + ;; We use M-V-BIND instead of M-V-SETQ because we only + ;; want to assign values to the key and val vars when we + ;; are in the hash table. When we reach the end, + ;; TEMP-PREDICATE-VAR is NIL, and so are temp-key-var and + ;; temp-val-var. This might break any type declarations + ;; on the key and val vars. + (when ,temp-predicate-var + (setq ,val-var ,temp-val-var) + (setq ,key-var ,temp-key-var)) + (setq ,dummy-predicate-var ,temp-predicate-var) + )) ;post-test + ,post-steps))))) (defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types) (cond ((and prep-phrases (cdr prep-phrases)) - (loop-error "Too many prepositions!")) - ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) - (loop-error "Unknow preposition ~S" (caar prep-phrases)))) + (loop-error "Too many prepositions!")) + ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) + (loop-error "Unknow preposition ~S" (caar prep-phrases)))) (unless (symbolp variable) (loop-error "Destructuring is not valid for package symbol iteration.")) (let ((pkg-var (loop-gentemp 'loop-pkgsym-)) - (next-fn (loop-gentemp 'loop-pkgsym-next-)) - (variable (or variable (loop-gentemp))) - (pkg (or (cadar prep-phrases) '*package*))) + (next-fn (loop-gentemp 'loop-pkgsym-next-)) + (variable (or variable (loop-gentemp))) + (pkg (or (cadar prep-phrases) '*package*))) (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*) `(((,variable nil ,data-type) (,pkg-var ,pkg)) () () () (not (multiple-value-setq (,(progn - ;;@@@@ If an implementation can get away without actually - ;; using a variable here, so much the better. - #+Genera NIL - #-Genera (loop-when-it-variable)) - ,variable) - (,next-fn))) + ;;@@@@ If an implementation can get away without actually + ;; using a variable here, so much the better. + #+Genera NIL + #-Genera (loop-when-it-variable)) + ,variable) + (,next-fn))) ()))) ;;;; ANSI Loop @@ -2191,14 +2191,14 @@ collected result will be returned as the value of the LOOP." (minimize (loop-maxmin-collection min)) (maximizing (loop-maxmin-collection max)) (minimizing (loop-maxmin-collection min)) - (always (loop-do-always t nil)) ; Normal, do always - (never (loop-do-always t t)) ; Negate the test on always. + (always (loop-do-always t nil)) ; Normal, do always + (never (loop-do-always t t)) ; Negate the test on always. (thereis (loop-do-thereis t)) - (while (loop-do-while nil :while)) ; Normal, do while - (until (loop-do-while t :until)) ; Negate the test on while - (when (loop-do-if when nil)) ; Normal, do when - (if (loop-do-if if nil)) ; synonymous - (unless (loop-do-if unless t)) ; Negate the test on when + (while (loop-do-while nil :while)) ; Normal, do while + (until (loop-do-while t :until)) ; Negate the test on while + (when (loop-do-if when nil)) ; Normal, do when + (if (loop-do-if if nil)) ; synonymous + (unless (loop-do-if unless t)) ; Negate the test on when (with (loop-do-with)) (repeat (loop-do-repeat))) :for-keywords '((= (loop-ansi-for-equals)) @@ -2229,9 +2229,9 @@ collected result will be returned as the value of the LOOP." :type-keywords nil :ansi (if extended-p :extended t)))) (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:which hash-key)) + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which hash-key)) (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil @@ -2239,7 +2239,7 @@ collected result will be returned as the value of the LOOP." (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil - :user-data '(:symbol-types (:internal :external :inherited))) + :user-data '(:symbol-types (:internal :external :inherited))) (add-loop-path '(external-symbol external-symbols) 'loop-package-symbols-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil @@ -2258,7 +2258,7 @@ collected result will be returned as the value of the LOOP." (if (and keywords-and-forms (symbolp (car keywords-and-forms))) (loop-translate keywords-and-forms environment universe) (let ((tag (gensym))) - `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag)))))) + `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag)))))) ) ;; eval-when @@ -2266,7 +2266,7 @@ collected result will be returned as the value of the LOOP." ;;;INTERFACE: ANSI (defmacro loop (&environment env &rest keywords-and-forms) #+Genera (declare (compiler:do-not-record-macroexpansions) - (zwei:indentation . zwei:indent-loop)) + (zwei:indentation . zwei:indent-loop)) (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*)) #+allegro diff --git a/sql/base-classes.lisp b/sql/base-classes.lisp index 8e0cc49..297b22f 100644 --- a/sql/base-classes.lisp +++ b/sql/base-classes.lisp @@ -5,7 +5,7 @@ ;;;; Name: classes.lisp ;;;; Purpose: Classes for High-level SQL interface ;;;; Programmers: Kevin M. Rosenberg based on -;;;; original code by Pierre R. Mai +;;;; original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; ;;;; $Id$ @@ -25,9 +25,9 @@ ((name :initform nil :initarg :name :reader database-name) (connection-spec :initform nil :initarg :connection-spec :reader connection-spec - :documentation "Require to use connection pool") + :documentation "Require to use connection pool") (database-type :initarg :database-type :initform :unknown - :reader database-type) + :reader database-type) (state :initform :closed :reader database-state) (autocommit :initform t :accessor database-autocommit) (command-recording-stream :accessor command-recording-stream :initform nil) @@ -37,9 +37,9 @@ (transaction-level :initform 0 :accessor transaction-level) (transaction :initform nil :accessor transaction) (conn-pool :initform nil :initarg :conn-pool :accessor conn-pool) - (attribute-cache :initform (make-hash-table :size 100 :test 'equal) - :accessor attribute-cache - :documentation "Internal cache of table attributes. It is keyed by table-name. Values + (attribute-cache :initform (make-hash-table :size 100 :test 'equal) + :accessor attribute-cache + :documentation "Internal cache of table attributes. It is keyed by table-name. Values are a list of ACTION specified for table and any cached value of list-attributes-types.")) (:documentation "This class is the supertype of all databases handled by CLSQL.")) @@ -47,10 +47,10 @@ are a list of ACTION specified for table and any cached value of list-attributes (defmethod print-object ((object database) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "~A ~A" - (if (slot-boundp object 'name) - (database-name object) - "") - (database-state object))) + (if (slot-boundp object 'name) + (database-name object) + "") + (database-state object))) object) (setf (documentation 'database-name 'function) diff --git a/sql/cmucl-compat.lisp b/sql/cmucl-compat.lisp index 9853ab8..5944363 100644 --- a/sql/cmucl-compat.lisp +++ b/sql/cmucl-compat.lisp @@ -54,16 +54,16 @@ Needs to be a macro to overwrite value of VEC." (adjust-array ,vec ,len)) ((typep ,vec 'simple-array) (let ((,new-vec (make-array ,len :element-type - (array-element-type ,vec)))) - (check-type ,len fixnum) - (locally (declare (optimize (speed 3) (safety 0) (space 0)) ) - (dotimes (i ,len) - (declare (fixnum i)) - (setf (aref ,new-vec i) (aref ,vec i)))) - (setq ,vec ,new-vec))) + (array-element-type ,vec)))) + (check-type ,len fixnum) + (locally (declare (optimize (speed 3) (safety 0) (space 0)) ) + (dotimes (i ,len) + (declare (fixnum i)) + (setf (aref ,new-vec i) (aref ,vec i)))) + (setq ,vec ,new-vec))) ((typep ,vec 'vector) - (setf (fill-pointer ,vec) ,len) - ,vec) + (setf (fill-pointer ,vec) ,len) + ,vec) (t (error "Unable to shrink vector ~S which is type-of ~S" ,vec (type-of ,vec))) ))) diff --git a/sql/conditions.lisp b/sql/conditions.lisp index 5e805e1..549f8f8 100644 --- a/sql/conditions.lisp +++ b/sql/conditions.lisp @@ -22,7 +22,7 @@ to :warn. May also be set to :error to signal an error or :ignore/nil to silently ignore the warning.") ;;; CommonSQL-compatible conditions - + (define-condition sql-condition () ()) @@ -30,52 +30,52 @@ or :ignore/nil to silently ignore the warning.") ()) (define-condition sql-database-error (sql-error) - ((error-id :initarg :error-id - :initform nil - :reader sql-error-error-id) + ((error-id :initarg :error-id + :initform nil + :reader sql-error-error-id) (secondary-error-id :initarg :secondary-error-id - :initform nil - :reader sql-error-secondary-error-id) + :initform nil + :reader sql-error-secondary-error-id) (database-message :initarg :message - :initform nil - :reader sql-error-database-message) + :initform nil + :reader sql-error-database-message) (database :initarg :database - :initform nil - :reader sql-error-database)) + :initform nil + :reader sql-error-database)) (:report (lambda (c stream) - (format stream "A database error occurred~@[ on database ~A~]: ~A / ~A~% ~A" - (sql-error-database c) - (sql-error-error-id c) - (sql-error-secondary-error-id c) - (sql-error-database-message c)))) + (format stream "A database error occurred~@[ on database ~A~]: ~A / ~A~% ~A" + (sql-error-database c) + (sql-error-error-id c) + (sql-error-secondary-error-id c) + (sql-error-database-message c)))) (:documentation "Used to signal an error in a CLSQL database interface.")) (define-condition sql-connection-error (sql-database-error) ((database-type :initarg :database-type :initform nil - :reader sql-error-database-type) + :reader sql-error-database-type) (connection-spec :initarg :connection-spec :initform nil - :reader sql-error-connection-spec)) + :reader sql-error-connection-spec)) (:report (lambda (c stream) - (format stream "While trying to connect to database ~A~% using database-type ~A:~% Error ~D / ~A~% has occurred." - (when (and (sql-error-connection-spec c) - (sql-error-database-type c)) - (database-name-from-spec - (sql-error-connection-spec c) - (sql-error-database-type c))) - (sql-error-database-type c) - (sql-error-error-id c) - (sql-error-database-message c)))) + (format stream "While trying to connect to database ~A~% using database-type ~A:~% Error ~D / ~A~% has occurred." + (when (and (sql-error-connection-spec c) + (sql-error-database-type c)) + (database-name-from-spec + (sql-error-connection-spec c) + (sql-error-database-type c))) + (sql-error-database-type c) + (sql-error-error-id c) + (sql-error-database-message c)))) (:documentation "Used to signal an error in connecting to a database.")) (define-condition sql-database-data-error (sql-database-error) - ((expression :initarg :expression :initarg nil - :reader sql-error-expression)) + ((expression :initarg :expression :initarg nil + :reader sql-error-expression)) (:report (lambda (c stream) - (format stream "While accessing database ~A~% with expression ~S:~% Error ~D / ~A~% has occurred." - (sql-error-database c) - (sql-error-expression c) - (sql-error-error-id c) - (sql-error-database-message c)))) + (format stream "While accessing database ~A~% with expression ~S:~% Error ~D / ~A~% has occurred." + (sql-error-database c) + (sql-error-expression c) + (sql-error-error-id c) + (sql-error-database-message c)))) (:documentation "Used to signal an error with the SQL data passed to a database.")) @@ -98,11 +98,11 @@ connection is no longer usable.")) (define-condition sql-user-error (sql-error) ((message :initarg :message - :initform "Unspecified error" - :reader sql-user-error-message)) + :initform "Unspecified error" + :reader sql-user-error-message)) (:report (lambda (c stream) - (format stream "A CLSQL lisp code error occurred: ~A " - (sql-user-error-message c)))) + (format stream "A CLSQL lisp code error occurred: ~A " + (sql-user-error-message c)))) (:documentation "Used to signal lisp errors inside CLSQL.")) @@ -111,15 +111,15 @@ connection is no longer usable.")) (defun signal-closed-database-error (database) (error 'sql-fatal-error - :database database - :connection-spec (when database (connection-spec database)) - :database-type (when database (database-type database)) - :message "Database is closed.")) + :database database + :connection-spec (when database (connection-spec database)) + :database-type (when database (database-type database)) + :message "Database is closed.")) (defun signal-no-database-error (database) (error 'sql-database-error - :database database - :message (format nil "~A is not a database." database))) + :database database + :message (format nil "~A is not a database." database))) ;;; CLSQL Extensions @@ -127,12 +127,12 @@ connection is no longer usable.")) (define-condition sql-warning (warning sql-condition) ((message :initarg :message :initform nil :reader sql-warning-message)) (:report (lambda (c stream) - (format stream "~A" (sql-warning-message c))))) + (format stream "~A" (sql-warning-message c))))) (define-condition sql-database-warning (sql-warning) ((database :initarg :database :reader sql-warning-database)) (:report (lambda (c stream) - (format stream - "While accessing database ~A~% Warning: ~A~% has occurred." - (sql-warning-database c) - (sql-warning-message c))))) + (format stream + "While accessing database ~A~% Warning: ~A~% has occurred." + (sql-warning-database c) + (sql-warning-message c))))) diff --git a/sql/database.lisp b/sql/database.lisp index c07cf7b..9b71644 100644 --- a/sql/database.lisp +++ b/sql/database.lisp @@ -61,18 +61,18 @@ error is signalled." (cerror "Return nil." 'sql-database-error :message - (format nil "There exists ~A database called ~A." - (if (zerop count) "no" "more than one") - database))))) + (format nil "There exists ~A database called ~A." + (if (zerop count) "no" "more than one") + database))))) (null (error "A database must be specified rather than NIL.")))) (defun connect (connection-spec - &key (if-exists *connect-if-exists*) - (make-default t) + &key (if-exists *connect-if-exists*) + (make-default t) (pool nil) - (database-type *default-database-type*)) + (database-type *default-database-type*)) "Connects to a database of the supplied DATABASE-TYPE which defaults to *DEFAULT-DATABASE-TYPE*, using the type-specific connection specification CONNECTION-SPEC. The value of IF-EXISTS, @@ -97,9 +97,9 @@ be taken from this pool." (unless (member database-type *loaded-database-types*) (asdf:operate 'asdf:load-op (ensure-keyword - (concatenate 'string - (symbol-name '#:clsql-) - (symbol-name database-type))))) + (concatenate 'string + (symbol-name '#:clsql-) + (symbol-name database-type))))) (if pool (let ((conn (acquire-from-pool connection-spec database-type pool))) @@ -116,17 +116,17 @@ be taken from this pool." (setq result (database-connect connection-spec database-type)) (warn 'sql-warning - :message - (format nil - "Created new connection ~A to database ~A~%, although there is an existing connection (~A)." - result (database-name result) old-db))) - (:error + :message + (format nil + "Created new connection ~A to database ~A~%, although there is an existing connection (~A)." + result (database-name result) old-db))) + (:error (restart-case - (error 'sql-connection-error - :message - (format nil "There is an existing connection ~A to database ~A." - old-db - (database-name old-db))) + (error 'sql-connection-error + :message + (format nil "There is an existing connection ~A to database ~A." + old-db + (database-name old-db))) (create-new () :report "Create a new connection." (setq result @@ -137,17 +137,17 @@ be taken from this pool." (:warn-old (setq result old-db) (warn 'sql-warning - :message - (format nil - "Using existing connection ~A to database ~A." - old-db - (database-name old-db)))) + :message + (format nil + "Using existing connection ~A to database ~A." + old-db + (database-name old-db)))) (:old (setq result old-db))) (setq result (database-connect connection-spec database-type))) (when result - (setf (slot-value result 'state) :open) + (setf (slot-value result 'state) :open) (pushnew result *connected-databases*) (when make-default (setq *default-database* result)) result)))) @@ -194,10 +194,10 @@ is called by database backends." (error 'sql-user-error :message (format nil - "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A" - ,connection-spec - ,database-type - (quote ,template)))))) + "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A" + ,connection-spec + ,database-type + (quote ,template)))))) (defun reconnect (&key (database *default-database*) (error nil) (force t)) "Reconnects DATABASE which defaults to *DEFAULT-DATABASE* to @@ -213,21 +213,21 @@ closed, if FORCE is non-nil, as it is by default, the connection is closed and errors are suppressed. If force is nil and the database connection cannot be closed, an error is signalled." (let ((db (etypecase database - (database database) - ((or string list) - (let ((db (find-database database :errorp nil))) - (when (null db) - (if (and database error) - (error 'sql-connection-error - :message - (format nil "Unable to find database with connection-spec ~A." database)) - (return-from reconnect nil))) - db))))) + (database database) + ((or string list) + (let ((db (find-database database :errorp nil))) + (when (null db) + (if (and database error) + (error 'sql-connection-error + :message + (format nil "Unable to find database with connection-spec ~A." database)) + (return-from reconnect nil))) + db))))) (when (is-database-open db) (if force - (ignore-errors (disconnect :database db)) - (disconnect :database db :error nil))) + (ignore-errors (disconnect :database db)) + (disconnect :database db :error nil))) (connect (connection-spec db)))) @@ -240,24 +240,24 @@ database is printed." (flet ((get-data () (let ((data '())) (dolist (db (connected-databases) data) - (push - (append - (list (if (equal db *default-database*) "*" "") - (database-name db) - (string-downcase (string (database-type db))) - (cond ((and (command-recording-stream db) - (result-recording-stream db)) - "Both") - ((command-recording-stream db) "Commands") - ((result-recording-stream db) "Results") - (t "nil"))) - (when full - (list - (if (conn-pool db) "t" "nil") - (format nil "~A" (length (database-list-tables db))) - (format nil "~A" (length (database-list-views db)))))) - data)))) - (compute-sizes (data) + (push + (append + (list (if (equal db *default-database*) "*" "") + (database-name db) + (string-downcase (string (database-type db))) + (cond ((and (command-recording-stream db) + (result-recording-stream db)) + "Both") + ((command-recording-stream db) "Commands") + ((result-recording-stream db) "Results") + (t "nil"))) + (when full + (list + (if (conn-pool db) "t" "nil") + (format nil "~A" (length (database-list-tables db))) + (format nil "~A" (length (database-list-views db)))))) + data)))) + (compute-sizes (data) (mapcar #'(lambda (x) (apply #'max (mapcar #'length x))) (apply #'mapcar (cons #'list data)))) (print-separator (size) @@ -266,9 +266,9 @@ database is printed." (let ((data (get-data))) (when data (let* ((titles (if full - (list "" "DATABASE" "TYPE" "RECORDING" "POOLED" - "TABLES" "VIEWS") - (list "" "DATABASE" "TYPE" "RECORDING"))) + (list "" "DATABASE" "TYPE" "RECORDING" "POOLED" + "TABLES" "VIEWS") + (list "" "DATABASE" "TYPE" "RECORDING"))) (sizes (compute-sizes (cons titles data))) (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles))))) (control-string (format nil "~~&~~{~{~~~AA ~}~~}" sizes))) diff --git a/sql/db-interface.lisp b/sql/db-interface.lisp index 10b25d9..ada842d 100644 --- a/sql/db-interface.lisp +++ b/sql/db-interface.lisp @@ -6,7 +6,7 @@ ;;;; Purpose: Generic function definitions for DB interfaces ;;;; Programmers: Kevin M. Rosenberg based on ;;;; Original code by Pierre R. Mai. Additions from -;;;; onShoreD to support UncommonSQL front-end +;;;; onShoreD to support UncommonSQL front-end ;;;; Date Started: Feb 2002 ;;;; ;;;; $Id$ @@ -44,47 +44,47 @@ was called with the connection-spec.")) (defgeneric database-reconnect (database) (:method ((database t)) - (signal-no-database-error database)) + (signal-no-database-error database)) (:documentation "Internal generic implementation of reconnect.")) (defgeneric database-disconnect (database) (:method ((database t)) - (signal-no-database-error database)) + (signal-no-database-error database)) (:documentation "Internal generic implementation of disconnect.")) (defgeneric database-query (query-expression database result-types field-names) (:method (query-expression (database t) result-types field-names) - (declare (ignore query-expression result-types field-names)) - (signal-no-database-error database)) + (declare (ignore query-expression result-types field-names)) + (signal-no-database-error database)) (:method (query-expression (database database) result-types field-names) - (declare (ignore query-expression result-types field-names)) - (warn "database-query not implemented for database type ~A." - (database-type database))) + (declare (ignore query-expression result-types field-names)) + (warn "database-query not implemented for database type ~A." + (database-type database))) (:documentation "Internal generic implementation of query.")) (defgeneric database-execute-command (sql-expression database) (:method (sql-expression (database t)) - (declare (ignore sql-expression)) - (signal-no-database-error database)) + (declare (ignore sql-expression)) + (signal-no-database-error database)) (:method (sql-expression (database database)) - (declare (ignore sql-expression)) - (warn "database-execute-command not implemented for database type ~A." - (database-type database))) + (declare (ignore sql-expression)) + (warn "database-execute-command not implemented for database type ~A." + (database-type database))) (:documentation "Internal generic implementation of execute-command.")) ;;; Mapping and iteration (defgeneric database-query-result-set (query-expression database &key full-set result-types) (:method (query-expression (database t) &key full-set result-types) - (declare (ignore query-expression full-set result-types)) - (signal-no-database-error database) - (values nil nil nil)) + (declare (ignore query-expression full-set result-types)) + (signal-no-database-error database) + (values nil nil nil)) (:method (query-expression (database database) &key full-set result-types) - (declare (ignore query-expression full-set result-types)) - (warn "database-query-result-set not implemented for database type ~A." - (database-type database)) - (values nil nil nil)) + (declare (ignore query-expression full-set result-types)) + (warn "database-query-result-set not implemented for database type ~A." + (database-type database)) + (values nil nil nil)) (:documentation "Internal generic implementation of query mapping. Starts the query specified by query-expression on the given database and returns @@ -102,22 +102,22 @@ function should signal a sql-database-data-error.")) (defgeneric database-dump-result-set (result-set database) (:method (result-set (database t)) - (declare (ignore result-set)) - (signal-no-database-error database)) + (declare (ignore result-set)) + (signal-no-database-error database)) (:method (result-set (database database)) - (declare (ignore result-set)) - (warn "database-dump-result-set not implemented for database type ~A." - (database-type database))) + (declare (ignore result-set)) + (warn "database-dump-result-set not implemented for database type ~A." + (database-type database))) (:documentation "Dumps the received result-set.")) (defgeneric database-store-next-row (result-set database list) (:method (result-set (database t) list) - (declare (ignore result-set list)) - (signal-no-database-error database)) + (declare (ignore result-set list)) + (signal-no-database-error database)) (:method (result-set (database database) list) - (declare (ignore result-set list)) - (warn "database-store-next-row not implemented for database type ~A." - (database-type database))) + (declare (ignore result-set list)) + (warn "database-store-next-row not implemented for database type ~A." + (database-type database))) (:documentation "Returns t and stores the next row in the result set in list or returns nil when result-set is finished.")) @@ -131,7 +131,7 @@ returns nil when result-set is finished.")) (declare (ignore spec)) (warn "database-proe not support for database-type ~A." type)) (:documentation - "Probes for the existence of a database, returns T if database found or NIL + "Probes for the existence of a database, returns T if database found or NIL if not found. May signal an error if unable to communicate with database server.")) (defgeneric database-list (connection-spec type) @@ -175,17 +175,17 @@ if unable to destory.")) (defgeneric database-start-transaction (database) (:documentation "Start a transaction in DATABASE.") (:method ((database t)) - (signal-no-database-error database))) + (signal-no-database-error database))) (defgeneric database-commit-transaction (database) (:documentation "Commit current transaction in DATABASE.") (:method ((database t)) - (signal-no-database-error database))) + (signal-no-database-error database))) (defgeneric database-abort-transaction (database) (:documentation "Abort current transaction in DATABASE.") (:method ((database t)) - (signal-no-database-error database))) + (signal-no-database-error database))) (defgeneric database-get-type-specifier (type args database db-underlying-type) (:documentation "Return the type SQL type specifier as a string, for @@ -194,37 +194,37 @@ the given lisp type and parameters.")) (defgeneric database-list-tables (database &key owner) (:documentation "List all tables in the given database") (:method ((database database) &key owner) - (declare (ignore owner)) - (warn "database-list-tables not implemented for database type ~A." - (database-type database))) + (declare (ignore owner)) + (warn "database-list-tables not implemented for database type ~A." + (database-type database))) (:method ((database t) &key owner) - (declare (ignore owner)) - (signal-no-database-error database))) + (declare (ignore owner)) + (signal-no-database-error database))) (defgeneric database-list-tables-and-sequences (database &key owner) (:documentation "List all tables in the given database, may include seqeneces") (:method ((database t) &key owner) - (declare (ignore owner)) - (signal-no-database-error database)) + (declare (ignore owner)) + (signal-no-database-error database)) (:method ((database database) &key owner) - (database-list-tables database :owner owner))) - + (database-list-tables database :owner owner))) + (defgeneric database-list-views (database &key owner) (:documentation "List all views in the DATABASE.") (:method ((database database) &key owner) - (declare (ignore owner)) - (warn "database-list-views not implemented for database type ~A." - (database-type database))) + (declare (ignore owner)) + (warn "database-list-views not implemented for database type ~A." + (database-type database))) (:method ((database t) &key owner) - (declare (ignore owner)) - (signal-no-database-error database))) + (declare (ignore owner)) + (signal-no-database-error database))) (defgeneric database-list-indexes (database &key owner) (:documentation "List all indexes in the DATABASE.") (:method ((database database) &key owner) - (declare (ignore owner)) - (warn "database-list-indexes not implemented for database type ~A." - (database-type database))) + (declare (ignore owner)) + (warn "database-list-indexes not implemented for database type ~A." + (database-type database))) (:method ((database t) &key owner) (declare (ignore owner)) (signal-no-database-error database))) @@ -232,53 +232,53 @@ the given lisp type and parameters.")) (defgeneric database-list-table-indexes (table database &key owner) (:documentation "List all indexes for a table in the DATABASE.") (:method (table (database database) &key owner) - (declare (ignore table owner)) - (warn "database-list-table-indexes not implemented for database type ~A." - (database-type database))) - (:method (table (database t) &key owner) - (declare (ignore table owner)) - (signal-no-database-error database))) + (declare (ignore table owner)) + (warn "database-list-table-indexes not implemented for database type ~A." + (database-type database))) + (:method (table (database t) &key owner) + (declare (ignore table owner)) + (signal-no-database-error database))) (defgeneric database-list-attributes (table database &key owner) (:documentation "List all attributes in TABLE.") (:method (table (database database) &key owner) - (declare (ignore table owner)) - (warn "database-list-attributes not implemented for database type ~A." - (database-type database))) + (declare (ignore table owner)) + (warn "database-list-attributes not implemented for database type ~A." + (database-type database))) (:method (table (database t) &key owner) - (declare (ignore table owner)) - (signal-no-database-error database))) + (declare (ignore table owner)) + (signal-no-database-error database))) (defgeneric database-attribute-type (attribute table database &key owner) (:documentation "Return the type of ATTRIBUTE in TABLE. Returns multiple values of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.") (:method (attribute table (database database) &key owner) - (declare (ignore attribute table owner)) - (warn "database-list-attribute-type not implemented for database type ~A." - (database-type database))) + (declare (ignore attribute table owner)) + (warn "database-list-attribute-type not implemented for database type ~A." + (database-type database))) (:method (attribute table (database t) &key owner) - (declare (ignore attribute table owner)) - (signal-no-database-error database))) + (declare (ignore attribute table owner)) + (signal-no-database-error database))) (defgeneric database-add-attribute (table attribute database) (:documentation "Add the attribute to the table.") (:method (table attribute (database database)) - (declare (ignore table attribute)) - (warn "database-add-attribute not implemented for database type ~A." - (database-type database))) + (declare (ignore table attribute)) + (warn "database-add-attribute not implemented for database type ~A." + (database-type database))) (:method (table attribute (database t)) - (declare (ignore table attribute)) - (signal-no-database-error database))) + (declare (ignore table attribute)) + (signal-no-database-error database))) (defgeneric database-rename-attribute (table oldatt newname database) (:documentation "Rename the attribute in the table to NEWNAME.") (:method (table oldatt newname (database database)) - (declare (ignore table oldatt newname)) - (warn "database-rename-attribute not implemented for database type ~A." - (database-type database))) + (declare (ignore table oldatt newname)) + (warn "database-rename-attribute not implemented for database type ~A." + (database-type database))) (:method (table oldatt newname (database t)) - (declare (ignore table oldatt newname)) - (signal-no-database-error database))) + (declare (ignore table oldatt newname)) + (signal-no-database-error database))) (defgeneric oid (object) (:documentation "Return the unique ID of a database object.")) @@ -292,72 +292,72 @@ of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.") (defgeneric db-type-use-column-on-drop-index? (db-type) (:method (db-type) - (declare (ignore db-type)) - nil) + (declare (ignore db-type)) + nil) (:documentation "NIL [default] if database-type does not use column name on DROP INDEX.")) (defgeneric db-type-use-fully-qualified-column-on-drop-index? (db-type) (:method (db-type) - (declare (ignore db-type)) - nil) + (declare (ignore db-type)) + nil) (:documentation "NIL [default] if database-type does not require fully qualified column name on DROP INDEX.")) (defgeneric db-type-has-views? (db-type) (:method (db-type) - (declare (ignore db-type)) - ;; SQL92 has views - t) + (declare (ignore db-type)) + ;; SQL92 has views + t) (:documentation "T [default] if database-type supports views.")) (defgeneric db-type-has-bigint? (db-type) (:method (db-type) - (declare (ignore db-type)) - ;; SQL92 has bigint - t) + (declare (ignore db-type)) + ;; SQL92 has bigint + t) (:documentation "T [default] if database-type supports bigint.")) (defgeneric db-type-default-case (db-type) (:method (db-type) - (declare (ignore db-type)) - ;; By default, CommonSQL converts identifiers to UPPER case. - :upper) + (declare (ignore db-type)) + ;; By default, CommonSQL converts identifiers to UPPER case. + :upper) (:documentation ":upper [default] if means identifiers mapped to UPPER case SQL like CommonSQL API. However, Postgresql maps identifiers to lower case, so PostgreSQL uses a value of :lower for this result.")) (defgeneric db-type-has-fancy-math? (db-type) (:method (db-type) - (declare (ignore db-type)) - nil) + (declare (ignore db-type)) + nil) (:documentation "NIL [default] if database-type does not have fancy math.")) (defgeneric db-type-has-subqueries? (db-type) (:method (db-type) - (declare (ignore db-type)) - t) + (declare (ignore db-type)) + t) (:documentation "T [default] if database-type supports views.")) (defgeneric db-type-has-boolean-where? (db-type) (:method (db-type) - (declare (ignore db-type)) - ;; SQL99 has boolean where - t) + (declare (ignore db-type)) + ;; SQL99 has boolean where + t) (:documentation "T [default] if database-type supports boolean WHERE clause, such as 'WHERE MARRIED'.")) (defgeneric db-type-has-union? (db-type) (:method (db-type) - (declare (ignore db-type)) - t) + (declare (ignore db-type)) + t) (:documentation "T [default] if database-type supports boolean UNION.")) (defgeneric db-backend-has-create/destroy-db? (db-type) (:method (db-type) - (declare (ignore db-type)) - t) + (declare (ignore db-type)) + t) (:documentation "T [default] if backend can destroy and create databases.")) (defgeneric db-type-transaction-capable? (db database) (:method (db database) - (declare (ignore db database)) - t) + (declare (ignore db database)) + t) (:documentation "T [default] if database can supports transactions.")) (defgeneric db-type-has-prepared-stmt? (db-type) @@ -367,14 +367,14 @@ of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.") (defgeneric db-type-has-intersect? (db-type) (:method (db-type) - (declare (ignore db-type)) - t) + (declare (ignore db-type)) + t) (:documentation "T [default] if database-type supports INTERSECT.")) (defgeneric db-type-has-except? (db-type) (:method (db-type) - (declare (ignore db-type)) - t) + (declare (ignore db-type)) + t) (:documentation "T [default] if database-type supports EXCEPT.")) ;;; Large objects support (Marc Battyani) @@ -400,22 +400,22 @@ of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.") (:method (stmt types (database database) result-types field-names) (declare (ignore stmt types result-types field-names)) (error 'sql-database-error - :message - (format nil "DATABASE-PREPARE not implemented for ~S" database))) + :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))) + :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))) + :message (format nil "database-run-prepared not specialized for ~S" pstmt))) (:documentation "Execute a prepared statement.")) (defgeneric database-free-prepared (prepared-stmt) @@ -430,8 +430,8 @@ of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.") (unless (is-database-open database) (signal-closed-database-error database))) -(defmethod database-query :before (query-expression (database database) - result-set field-names) +(defmethod database-query :before (query-expression (database database) + result-set field-names) (declare (ignore query-expression result-set field-names)) (unless (is-database-open database) (signal-closed-database-error database))) @@ -451,7 +451,7 @@ of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.") (declare (ignore result-set)) (unless (is-database-open database) (signal-closed-database-error database))) - + (defmethod database-store-next-row :before (result-set (database database) list) (declare (ignore result-set list)) (unless (is-database-open database) diff --git a/sql/expressions.lisp b/sql/expressions.lisp index 93c97d9..df9cfc0 100644 --- a/sql/expressions.lisp +++ b/sql/expressions.lisp @@ -114,8 +114,8 @@ (write-string (convert-to-db-default-case (etypecase name - (string name) - (symbol (symbol-name name))) + (string name) + (symbol (symbol-name name))) database) *sql-stream*)) t) @@ -152,30 +152,30 @@ (defmethod output-sql ((expr sql-ident-attribute) database) (with-slots (qualifier name type) expr (if (and (not qualifier) (not type)) - (etypecase name - ;; Honor care of name - (string - (write-string name *sql-stream*)) - (symbol - (write-string (sql-escape (convert-to-db-default-case - (symbol-name name) database)) *sql-stream*))) - - ;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it + (etypecase name + ;; Honor care of name + (string + (write-string name *sql-stream*)) + (symbol + (write-string (sql-escape (convert-to-db-default-case + (symbol-name name) database)) *sql-stream*))) + + ;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it ;;; should not be output in SQL statements #+ignore (format *sql-stream* "~@[~A.~]~A~@[ ~A~]" - (when qualifier - (convert-to-db-default-case (sql-escape qualifier) database)) - (sql-escape (convert-to-db-default-case name database)) - (when type - (convert-to-db-default-case (symbol-name type) database))) + (when qualifier + (convert-to-db-default-case (sql-escape qualifier) database)) + (sql-escape (convert-to-db-default-case name database)) + (when type + (convert-to-db-default-case (symbol-name type) database))) (format *sql-stream* "~@[~A.~]~A" - (when qualifier + (when qualifier (typecase qualifier (string (format nil "~s" qualifier)) (t (convert-to-db-default-case (sql-escape qualifier) database)))) - (sql-escape (convert-to-db-default-case name database)))) + (sql-escape (convert-to-db-default-case name database)))) t)) (defmethod output-sql-hash-key ((expr sql-ident-attribute) database) @@ -412,9 +412,9 @@ (output-sql (car components) database) (when components (mapc #'(lambda (comp) - (write-string ", " *sql-stream*) - (output-sql comp database)) - (cdr components)))) + (write-string ", " *sql-stream*) + (output-sql comp database)) + (cdr components)))) t) (defclass sql-set-exp (%sql-expression) @@ -544,26 +544,26 @@ uninclusive, and the args from that keyword to the end." (find-class arg nil))) target-args)))) (multiple-value-bind (selections arglist) - (query-get-selections args) + (query-get-selections args) (if (select-objects selections) - (destructuring-bind (&key flatp refresh &allow-other-keys) arglist - (make-instance 'sql-object-query :objects selections - :flatp flatp :refresh refresh - :exp arglist)) - (destructuring-bind (&key all flatp set-operation distinct from where - group-by having order-by - offset limit inner-join on &allow-other-keys) - arglist - (if (null selections) - (error "No target columns supplied to select statement.")) - (if (null from) - (error "No source tables supplied to select statement.")) - (make-instance 'sql-query :selections selections - :all all :flatp flatp :set-operation set-operation - :distinct distinct :from from :where where - :limit limit :offset offset - :group-by group-by :having having :order-by order-by - :inner-join inner-join :on on)))))) + (destructuring-bind (&key flatp refresh &allow-other-keys) arglist + (make-instance 'sql-object-query :objects selections + :flatp flatp :refresh refresh + :exp arglist)) + (destructuring-bind (&key all flatp set-operation distinct from where + group-by having order-by + offset limit inner-join on &allow-other-keys) + arglist + (if (null selections) + (error "No target columns supplied to select statement.")) + (if (null from) + (error "No source tables supplied to select statement.")) + (make-instance 'sql-query :selections selections + :all all :flatp flatp :set-operation set-operation + :distinct distinct :from from :where where + :limit limit :offset offset + :group-by group-by :having having :order-by order-by + :inner-join inner-join :on on)))))) (defmethod output-sql ((query sql-query) database) (with-slots (distinct selections from where group-by having order-by @@ -795,8 +795,8 @@ uninclusive, and the args from that keyword to the end." (write-char #\Space *sql-stream*) (write-string (if (stringp db-type) db-type ; override definition - (database-get-type-specifier (car type) (cdr type) database - (database-underlying-type database))) + (database-get-type-specifier (car type) (cdr type) database + (database-underlying-type database))) *sql-stream*) (let ((constraints (database-constraint-statement (if (and db-type (symbolp db-type)) @@ -823,9 +823,9 @@ uninclusive, and the args from that keyword to the end." (write-string (car modifier) *sql-stream*))) (write-char #\) *sql-stream*) (when (and (eq :mysql (database-underlying-type database)) - transactions - (db-type-transaction-capable? :mysql database)) - (write-string " Type=InnoDB" *sql-stream*)))) + transactions + (db-type-transaction-capable? :mysql database)) + (write-string " Type=InnoDB" *sql-stream*)))) t) @@ -855,7 +855,7 @@ uninclusive, and the args from that keyword to the end." (defmethod database-output-sql ((str string) database) (declare (optimize (speed 3) (safety 1) - #+cmu (extensions:inhibit-warnings 3))) + #+cmu (extensions:inhibit-warnings 3))) (let ((len (length str))) (declare (type fixnum len)) (cond ((zerop len) @@ -865,13 +865,13 @@ uninclusive, and the args from that keyword to the end." (concatenate 'string "'" str "'")) (t (let ((buf (make-string (+ (* len 2) 2) :initial-element #\'))) - (declare (simple-string buf)) - (do* ((i 0 (incf i)) + (declare (simple-string buf)) + (do* ((i 0 (incf i)) (j 1 (incf j))) ((= i len) (subseq buf 0 (1+ j))) (declare (type fixnum i j)) (let ((char (aref str i))) - (declare (character char)) + (declare (character char)) (cond ((char= char #\') (setf (aref buf j) #\') (incf j) @@ -923,8 +923,8 @@ uninclusive, and the args from that keyword to the end." (defmethod database-output-sql ((arg vector) database) (format nil "~{~A~^,~}" (map 'list #'(lambda (val) - (sql-output val database)) - arg))) + (sql-output val database)) + arg))) (defmethod output-sql-hash-key ((arg vector) database) (list 'vector (map 'list (lambda (arg) @@ -950,13 +950,13 @@ uninclusive, and the args from that keyword to the end." (defmethod database-output-sql (thing database) (if (or (null thing) - (eq 'null thing)) + (eq 'null thing)) +null-string+ (error 'sql-user-error :message - (format nil - "No type conversion to SQL for ~A is defined for DB ~A." - (type-of thing) (type-of database))))) + (format nil + "No type conversion to SQL for ~A is defined for DB ~A." + (type-of thing) (type-of database))))) ;; @@ -991,7 +991,7 @@ uninclusive, and the args from that keyword to the end." (if (null output) (error 'sql-user-error :message (format nil "unsupported column constraint '~A'" - constraint)) + constraint)) (setq string (concatenate 'string string (cdr output)))) (if (< 1 (length constraint)) (setq string (concatenate 'string string " ")))))))) diff --git a/sql/fddl.lisp b/sql/fddl.lisp index 3b5b1bd..6363f26 100644 --- a/sql/fddl.lisp +++ b/sql/fddl.lisp @@ -22,14 +22,14 @@ (defun database-identifier (name database) (sql-escape (etypecase name - ;; honor case of strings + ;; honor case of strings (string name - #+nil (convert-to-db-default-case name database)) + #+nil (convert-to-db-default-case name database)) (sql-ident (sql-output name database)) (symbol (sql-output name database))))) -;; Truncate database +;; Truncate database (defun truncate-database (&key (database *default-database*)) "Drops all tables, views, indexes and sequences in DATABASE which @@ -54,7 +54,7 @@ defaults to *DEFAULT-DATABASE*." (values)) -;; Tables +;; Tables (defun create-table (name description &key (database *default-database*) (constraints nil) (transactions t)) @@ -67,7 +67,7 @@ the table. CONSTRAINTS is a string representing an SQL table constraint expression or a list of such strings. With MySQL databases, if TRANSACTIONS is t an InnoDB table is created which supports transactions." - (let* ((table-name (etypecase name + (let* ((table-name (etypecase name (symbol (sql-expression :attribute name)) (string (sql-expression :attribute name)) (sql-ident name))) @@ -75,11 +75,11 @@ supports transactions." :name table-name :columns description :modifiers constraints - :transactions transactions))) + :transactions transactions))) (execute-command stmt :database database))) (defun drop-table (name &key (if-does-not-exist :error) - (database *default-database*) + (database *default-database*) (owner nil)) "Drops the table called NAME from DATABASE which defaults to *DEFAULT-DATABASE*. If the table does not exist and @@ -93,15 +93,15 @@ an error is signalled if IF-DOES-NOT-EXIST is :error." (return-from drop-table nil))) (:error t)) - + ;; Fixme: move to clsql-oracle (let ((expr (concatenate 'string "DROP TABLE " table-name))) (when (and (find-package 'clsql-oracle) - (eq :oracle (database-type database)) - (eql 10 (slot-value database - (intern (symbol-name '#:major-server-version) - (symbol-name '#:clsql-oracle))))) - (setq expr (concatenate 'string expr " PURGE"))) + (eq :oracle (database-type database)) + (eql 10 (slot-value database + (intern (symbol-name '#:major-server-version) + (symbol-name '#:clsql-oracle))))) + (setq expr (concatenate 'string expr " PURGE"))) (execute-command expr :database database)))) @@ -126,7 +126,7 @@ examined." t)) -;; Views +;; Views (defun create-view (name &key as column-list (with-check-option nil) (database *default-database*)) @@ -136,7 +136,7 @@ the columns of the view may be specified using the COLUMN-LIST parameter. The WITH-CHECK-OPTION is nil by default but if it has a non-nil value, then all insert/update commands on the view are checked to ensure that the new data satisfy the query AS." - (let* ((view-name (etypecase name + (let* ((view-name (etypecase name (symbol (sql-expression :attribute name)) (string (sql-expression :attribute (make-symbol name))) (sql-ident name))) @@ -183,7 +183,7 @@ examined. If OWNER is :all then all views are examined." t)) -;; Indexes +;; Indexes (defun create-index (name &key on (unique nil) attributes (database *default-database*)) @@ -236,15 +236,15 @@ tables. Meaningful values for ON are nil (the default) which means that all tables are considered, a string, symbol or SQL expression representing a table name in DATABASE or a list of such table identifiers." - (if (null on) + (if (null on) (database-list-indexes database :owner owner) (let ((tables (typecase on (cons on) (t (list on))))) - (reduce #'append - (mapcar #'(lambda (table) (database-list-table-indexes + (reduce #'append + (mapcar #'(lambda (table) (database-list-table-indexes (database-identifier table database) database :owner owner)) tables))))) - + (defun index-exists-p (name &key (owner nil) (database *default-database*)) "Tests for the existence of an SQL index called NAME in DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is nil by default @@ -257,9 +257,9 @@ examined." :test #'string-equal) t)) -;; Attributes +;; Attributes -(defvar *cache-table-queries-default* nil +(defvar *cache-table-queries-default* nil "Specifies the default behaivour for caching of attribute types. Meaningful values are t, nil and :flush as described for the action argument to CACHE-TABLE-QUERIES.") @@ -282,38 +282,38 @@ caching action has not been explicitly set." (cond ((stringp table) (multiple-value-bind (val found) (gethash table attribute-cache) - (cond - ((and found (eq action :flush)) - (setf (gethash table attribute-cache) (list t nil))) - ((and found (eq action t)) - (setf (gethash table attribute-cache) (list t (second val)))) - ((and found (null action)) - (setf (gethash table attribute-cache) (list nil nil))) - ((not found) - (setf (gethash table attribute-cache) (list action nil)))))) + (cond + ((and found (eq action :flush)) + (setf (gethash table attribute-cache) (list t nil))) + ((and found (eq action t)) + (setf (gethash table attribute-cache) (list t (second val)))) + ((and found (null action)) + (setf (gethash table attribute-cache) (list nil nil))) + ((not found) + (setf (gethash table attribute-cache) (list action nil)))))) ((eq table t) (maphash (lambda (k v) - (cond - ((eq action :flush) - (setf (gethash k attribute-cache) (list t nil))) - ((null action) - (setf (gethash k attribute-cache) (list nil nil))) - ((eq t action) - (setf (gethash k attribute-cache) (list t (second v)))))) - attribute-cache)) + (cond + ((eq action :flush) + (setf (gethash k attribute-cache) (list t nil))) + ((null action) + (setf (gethash k attribute-cache) (list nil nil))) + ((eq t action) + (setf (gethash k attribute-cache) (list t (second v)))))) + attribute-cache)) ((eq table :default) (maphash (lambda (k v) - (when (eq (first v) :unspecified) - (cond - ((eq action :flush) - (setf (gethash k attribute-cache) (list t nil))) - ((null action) - (setf (gethash k attribute-cache) (list nil nil))) - ((eq t action) - (setf (gethash k attribute-cache) (list t (second v))))))) - attribute-cache)))) + (when (eq (first v) :unspecified) + (cond + ((eq action :flush) + (setf (gethash k attribute-cache) (list t nil))) + ((null action) + (setf (gethash k attribute-cache) (list nil nil))) + ((eq t action) + (setf (gethash k attribute-cache) (list t (second v))))))) + attribute-cache)))) (values)) - + (defun list-attributes (name &key (owner nil) (database *default-database*)) "Returns a list of strings representing the attributes of table @@ -322,7 +322,7 @@ nil by default which means that only attributes owned by users are listed. If OWNER is a string denoting a user name, only attributes owned by OWNER are listed. If OWNER is :all then all attributes are listed." - (database-list-attributes (database-identifier name database) database + (database-list-attributes (database-identifier name database) database :owner owner)) (defun attribute-type (attribute table &key (owner nil) @@ -357,30 +357,30 @@ the attribute accepts null values and otherwise 0." (with-slots (attribute-cache) database (let ((table-ident (database-identifier table database))) (multiple-value-bind (val found) (gethash table-ident attribute-cache) - (if (and found (second val)) - (second val) - (let ((types (mapcar #'(lambda (attribute) - (cons attribute - (multiple-value-list - (database-attribute-type - (database-identifier attribute + (if (and found (second val)) + (second val) + (let ((types (mapcar #'(lambda (attribute) + (cons attribute + (multiple-value-list + (database-attribute-type + (database-identifier attribute database) - table-ident - database - :owner owner)))) - (list-attributes table :database database + table-ident + database + :owner owner)))) + (list-attributes table :database database :owner owner)))) - (cond - ((and (not found) (eq t *cache-table-queries-default*)) - (setf (gethash table-ident attribute-cache) + (cond + ((and (not found) (eq t *cache-table-queries-default*)) + (setf (gethash table-ident attribute-cache) (list :unspecified types))) - ((and found (eq t (first val)) - (setf (gethash table-ident attribute-cache) + ((and found (eq t (first val)) + (setf (gethash table-ident attribute-cache) (list t types))))) - types)))))) - + types)))))) -;; Sequences + +;; Sequences (defun create-sequence (name &key (database *default-database*)) "Creates a sequence called NAME in DATABASE which defaults to @@ -425,7 +425,7 @@ sequences are examined." (list-sequences :owner owner :database database) :test #'string-equal) t)) - + (defun sequence-next (name &key (database *default-database*)) "Increment and return the next value in the sequence called NAME in DATABASE which defaults to *DEFAULT-DATABASE*." @@ -435,7 +435,7 @@ sequences are examined." "Explicitly set the the position of the sequence called NAME in DATABASE, which defaults to *DEFAULT-DATABSE*, to POSITION which is returned." - (database-set-sequence-position (database-identifier name database) + (database-set-sequence-position (database-identifier name database) position database)) (defun sequence-last (name &key (database *default-database*)) diff --git a/sql/fdml.lisp b/sql/fdml.lisp index 9b0e8b7..3406262 100644 --- a/sql/fdml.lisp +++ b/sql/fdml.lisp @@ -3,7 +3,7 @@ ;;;; ;;;; $Id$ ;;;; -;;;; The CLSQL Functional Data Manipulation Language (FDML). +;;;; The CLSQL Functional Data Manipulation Language (FDML). ;;;; ;;;; This file is part of CLSQL. ;;;; @@ -13,7 +13,7 @@ ;;;; ************************************************************************* (in-package #:clsql-sys) - + ;;; Basic operations on databases (defmethod database-query-result-set ((expr %sql-expression) database @@ -36,15 +36,15 @@ (defmethod query ((query-expression string) &key (database *default-database*) (result-types :auto) (flatp nil) (field-names t)) (record-sql-command query-expression database) - (multiple-value-bind (rows names) + (multiple-value-bind (rows names) (database-query query-expression database result-types field-names) (let ((result (if (and flatp (= 1 (length (car rows)))) (mapcar #'car rows) rows))) (record-sql-result result database) (if field-names - (values result names) - result)))) + (values result names) + result)))) (defmethod query ((expr %sql-expression) &key (database *default-database*) (result-types :auto) (flatp nil) (field-names t)) @@ -52,19 +52,19 @@ :result-types result-types :field-names field-names)) (defmethod query ((expr sql-object-query) &key (database *default-database*) - (result-types :auto) (flatp nil) (field-names t)) + (result-types :auto) (flatp nil) (field-names t)) (declare (ignore result-types field-names)) (apply #'select (append (slot-value expr 'objects) - (slot-value expr 'exp) - (when (slot-value expr 'refresh) - (list :refresh (sql-output expr database))) - (when (or flatp (slot-value expr 'flatp) ) - (list :flatp t)) - (list :database database)))) + (slot-value expr 'exp) + (when (slot-value expr 'refresh) + (list :refresh (sql-output expr database))) + (when (or flatp (slot-value expr 'flatp) ) + (list :flatp t)) + (list :database database)))) (defun print-query (query-exp &key titles (formats t) (sizes t) (stream t) - (database *default-database*)) + (database *default-database*)) "Prints a tabular report of the results returned by the SQL query QUERY-EXP, which may be a symbolic SQL expression or a string, in DATABASE which defaults to *DEFAULT-DATABASE*. The @@ -80,8 +80,8 @@ selected by QUERY-EXP. The default value of FORMATS is t meaning that ~A is used to format all columns or ~VA if column sizes are used." (flet ((compute-sizes (data) - (mapcar #'(lambda (x) - (apply #'max (mapcar #'(lambda (y) + (mapcar #'(lambda (x) + (apply #'max (mapcar #'(lambda (y) (if (null y) 3 (length y))) x))) (apply #'mapcar (cons #'list data)))) @@ -92,9 +92,9 @@ used." (let* ((query-exp (etypecase query-exp (string query-exp) (sql-query (sql-output query-exp database)))) - (data (query query-exp :database database :result-types nil + (data (query query-exp :database database :result-types nil :field-names nil)) - (sizes (if (or (null sizes) (listp sizes)) sizes + (sizes (if (or (null sizes) (listp sizes)) sizes (compute-sizes (if titles (cons titles data) data)))) (formats (if (or (null formats) (not (listp formats))) (make-list (length (car data)) :initial-element @@ -105,11 +105,11 @@ used." (dolist (d data (values)) (format-record d control-string sizes))))) (defun insert-records (&key (into nil) - (attributes nil) - (values nil) - (av-pairs nil) - (query nil) - (database *default-database*)) + (attributes nil) + (values nil) + (av-pairs nil) + (query nil) + (database *default-database*)) "Inserts records into the table specified by INTO in DATABASE which defaults to *DEFAULT-DATABASE*. There are five ways of specifying the values inserted into each row. In the first VALUES @@ -126,38 +126,38 @@ and ATTRIBUTES is a list of column names and QUERY is a symbolic SQL query expression which returns values for the specified columns." (let ((stmt (make-sql-insert :into into :attrs attributes - :vals values :av-pairs av-pairs - :subquery query))) + :vals values :av-pairs av-pairs + :subquery query))) (execute-command stmt :database database))) (defun make-sql-insert (&key (into nil) - (attrs nil) - (vals nil) - (av-pairs nil) - (subquery nil)) + (attrs nil) + (vals nil) + (av-pairs nil) + (subquery nil)) (unless into (error 'sql-user-error :message ":into keyword not supplied")) (let ((insert (make-instance 'sql-insert :into into))) (with-slots (attributes values query) insert (cond ((and vals (not attrs) (not query) (not av-pairs)) - (setf values vals)) - ((and vals attrs (not subquery) (not av-pairs)) - (setf attributes attrs) - (setf values vals)) - ((and av-pairs (not vals) (not attrs) (not subquery)) - (setf attributes (mapcar #'car av-pairs)) - (setf values (mapcar #'cadr av-pairs))) - ((and subquery (not vals) (not attrs) (not av-pairs)) - (setf query subquery)) - ((and subquery attrs (not vals) (not av-pairs)) - (setf attributes attrs) - (setf query subquery)) - (t - (error 'sql-user-error + (setf values vals)) + ((and vals attrs (not subquery) (not av-pairs)) + (setf attributes attrs) + (setf values vals)) + ((and av-pairs (not vals) (not attrs) (not subquery)) + (setf attributes (mapcar #'car av-pairs)) + (setf values (mapcar #'cadr av-pairs))) + ((and subquery (not vals) (not attrs) (not av-pairs)) + (setf query subquery)) + ((and subquery attrs (not vals) (not av-pairs)) + (setf attributes attrs) + (setf query subquery)) + (t + (error 'sql-user-error :message "bad or ambiguous keyword combination."))) insert))) - + (defun delete-records (&key (from nil) (where nil) (database *default-database*)) @@ -168,10 +168,10 @@ defaults to *DEFAULT-DATABASE*." (execute-command stmt :database database))) (defun update-records (table &key (attributes nil) - (values nil) - (av-pairs nil) - (where nil) - (database *default-database*)) + (values nil) + (av-pairs nil) + (where nil) + (database *default-database*)) "Updates the attribute values of existing records satsifying the SQL expression WHERE in the table specified by TABLE in DATABASE which defaults to *DEFAULT-DATABASE*. There are three @@ -186,17 +186,17 @@ are nil and AV-PAIRS is an alist of (attribute value) pairs." (setf attributes (mapcar #'car av-pairs) values (mapcar #'cadr av-pairs))) (let ((stmt (make-instance 'sql-update :table table - :attributes attributes - :values values - :where where))) + :attributes attributes + :values values + :where where))) (execute-command stmt :database database))) ;;; Iteration (defmacro do-query (((&rest args) query-expression - &key (database '*default-database*) (result-types :auto)) - &body body) + &key (database '*default-database*) (result-types :auto)) + &body body) "Repeatedly executes BODY within a binding of ARGS on the fields of each row selected by the SQL query QUERY-EXPRESSION, which may be a string or a symbolic SQL expression, in DATABASE @@ -207,36 +207,36 @@ QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned as strings whereas the default value of :auto means that the lisp types are automatically computed for each field." (let ((result-set (gensym "RESULT-SET-")) - (qe (gensym "QUERY-EXPRESSION-")) - (columns (gensym "COLUMNS-")) - (row (gensym "ROW-")) - (db (gensym "DB-"))) + (qe (gensym "QUERY-EXPRESSION-")) + (columns (gensym "COLUMNS-")) + (row (gensym "ROW-")) + (db (gensym "DB-"))) `(let ((,qe ,query-expression)) (typecase ,qe - (sql-object-query + (sql-object-query (dolist (,row (query ,qe)) - (destructuring-bind ,args + (destructuring-bind ,args ,row ,@body))) - (t - ;; Functional query - (let ((,db ,database)) - (multiple-value-bind (,result-set ,columns) - (database-query-result-set ,qe ,db - :full-set nil - :result-types ,result-types) - (when ,result-set - (unwind-protect - (do ((,row (make-list ,columns))) - ((not (database-store-next-row ,result-set ,db ,row)) - nil) - (destructuring-bind ,args ,row - ,@body)) - (database-dump-result-set ,result-set ,db)))))))))) + (t + ;; Functional query + (let ((,db ,database)) + (multiple-value-bind (,result-set ,columns) + (database-query-result-set ,qe ,db + :full-set nil + :result-types ,result-types) + (when ,result-set + (unwind-protect + (do ((,row (make-list ,columns))) + ((not (database-store-next-row ,result-set ,db ,row)) + nil) + (destructuring-bind ,args ,row + ,@body)) + (database-dump-result-set ,result-set ,db)))))))))) (defun map-query (output-type-spec function query-expression - &key (database *default-database*) - (result-types :auto)) + &key (database *default-database*) + (result-types :auto)) "Map the function FUNCTION over the attribute values of each row selected by the SQL query QUERY-EXPRESSION, which may be a string or a symbolic SQL expression, in DATABASE which defaults @@ -250,35 +250,35 @@ computed for each field." (typecase query-expression (sql-object-query (map output-type-spec #'(lambda (x) (apply function x)) - (query query-expression))) + (query query-expression))) (t - ;; Functional query + ;; Functional query (macrolet ((type-specifier-atom (type) - `(if (atom ,type) ,type (car ,type)))) + `(if (atom ,type) ,type (car ,type)))) (case (type-specifier-atom output-type-spec) - ((nil) - (map-query-for-effect function query-expression database - result-types)) - (list - (map-query-to-list function query-expression database result-types)) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string - simple-base-string) - (map-query-to-simple output-type-spec function query-expression - database result-types)) - (t - (funcall #'map-query - (cmucl-compat:result-type-or-lose output-type-spec t) - function query-expression :database database - :result-types result-types))))))) - + ((nil) + (map-query-for-effect function query-expression database + result-types)) + (list + (map-query-to-list function query-expression database result-types)) + ((simple-vector simple-string vector string array simple-array + bit-vector simple-bit-vector base-string + simple-base-string) + (map-query-to-simple output-type-spec function query-expression + database result-types)) + (t + (funcall #'map-query + (cmucl-compat:result-type-or-lose output-type-spec t) + function query-expression :database database + :result-types result-types))))))) + (defun map-query-for-effect (function query-expression database result-types) (multiple-value-bind (result-set columns) (database-query-result-set query-expression database :full-set nil - :result-types result-types) - (let ((flatp (and (= columns 1) - (typep query-expression 'sql-query) - (slot-value query-expression 'flatp)))) + :result-types result-types) + (let ((flatp (and (= columns 1) + (typep query-expression 'sql-query) + (slot-value query-expression 'flatp)))) (when result-set (unwind-protect (do ((row (make-list columns))) @@ -288,14 +288,14 @@ computed for each field." (apply function row) (funcall function row))) (database-dump-result-set result-set database)))))) - + (defun map-query-to-list (function query-expression database result-types) (multiple-value-bind (result-set columns) (database-query-result-set query-expression database :full-set nil - :result-types result-types) - (let ((flatp (and (= columns 1) - (typep query-expression 'sql-query) - (slot-value query-expression 'flatp)))) + :result-types result-types) + (let ((flatp (and (= columns 1) + (typep query-expression 'sql-query) + (slot-value query-expression 'flatp)))) (when result-set (unwind-protect (let ((result (list nil))) @@ -303,8 +303,8 @@ computed for each field." (current-cons result (cdr current-cons))) ((not (database-store-next-row result-set database row)) (cdr result)) - (rplacd current-cons - (list (if flatp + (rplacd current-cons + (list (if flatp (apply function row) (funcall function (copy-list row))))))) (database-dump-result-set result-set database)))))) @@ -312,10 +312,10 @@ computed for each field." (defun map-query-to-simple (output-type-spec function query-expression database result-types) (multiple-value-bind (result-set columns rows) (database-query-result-set query-expression database :full-set t - :result-types result-types) - (let ((flatp (and (= columns 1) - (typep query-expression 'sql-query) - (slot-value query-expression 'flatp)))) + :result-types result-types) + (let ((flatp (and (= columns 1) + (typep query-expression 'sql-query) + (slot-value query-expression 'flatp)))) (when result-set (unwind-protect (if rows @@ -328,7 +328,7 @@ computed for each field." result) (declare (fixnum index)) (setf (aref result index) - (if flatp + (if flatp (apply function row) (funcall function (copy-list row))))) ;; Database can't report row count in advance, so we have @@ -345,7 +345,7 @@ computed for each field." (setq allocated-length (* allocated-length 2) result (adjust-array result allocated-length))) (setf (aref result index) - (if flatp + (if flatp (apply function row) (funcall function (copy-list row)))))) (database-dump-result-set result-set database)))))) @@ -355,32 +355,32 @@ computed for each field." (defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body) (let ((d (gensym "DISTINCT-")) - (bind-fields (loop for f in fields collect (car f))) - (w (gensym "WHERE-")) - (o (gensym "ORDER-BY-")) - (frm (gensym "FROM-")) - (l (gensym "LIMIT-")) - (q (gensym "QUERY-"))) + (bind-fields (loop for f in fields collect (car f))) + (w (gensym "WHERE-")) + (o (gensym "ORDER-BY-")) + (frm (gensym "FROM-")) + (l (gensym "LIMIT-")) + (q (gensym "QUERY-"))) `(let ((,frm ,from) - (,w ,where) - (,d ,distinct) - (,l ,limit) - (,o ,order-by)) + (,w ,where) + (,d ,distinct) + (,l ,limit) + (,o ,order-by)) (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l))) - (loop for tuple in (query ,q) - collect (destructuring-bind ,bind-fields tuple - ,@body)))))) + (loop for tuple in (query ,q) + collect (destructuring-bind ,bind-fields tuple + ,@body)))))) (defun query-string (fields from where distinct order-by limit) (concatenate 'string - (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}" - (if distinct "distinct " "") (field-names fields) - (from-names from)) + (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}" + (if distinct "distinct " "") (field-names fields) + (from-names from)) (if where (format nil " where ~{~A~^ ~}" - (where-strings where)) "") + (where-strings where)) "") (if order-by (format nil " order by ~{~A~^, ~}" - (order-by-strings order-by))) + (order-by-strings order-by))) (if limit (format nil " limit ~D" limit) ""))) (defun lisp->sql-name (field) @@ -393,32 +393,32 @@ computed for each field." (defun field-names (field-forms) "Return a list of field name strings from a fields form" (loop for field-form in field-forms - collect - (lisp->sql-name - (if (cadr field-form) - (cadr field-form) - (car field-form))))) + collect + (lisp->sql-name + (if (cadr field-form) + (cadr field-form) + (car field-form))))) (defun from-names (from) "Return a list of field name strings from a fields form" (loop for table in (if (atom from) (list from) from) - collect (lisp->sql-name table))) + collect (lisp->sql-name table))) (defun where-strings (where) (loop for w in (if (atom (car where)) (list where) where) - collect - (if (consp w) - (format nil "~A ~A ~A" (second w) (first w) (third w)) - (format nil "~A" w)))) + collect + (if (consp w) + (format nil "~A ~A ~A" (second w) (first w) (third w)) + (format nil "~A" w)))) (defun order-by-strings (order-by) (loop for o in order-by - collect - (if (atom o) - (lisp->sql-name o) - (format nil "~A ~A" (lisp->sql-name (car o)) - (lisp->sql-name (cadr o)))))) + collect + (if (atom o) + (lisp->sql-name o) + (format nil "~A ~A" (lisp->sql-name (car o)) + (lisp->sql-name (cadr o)))))) ;;; Large objects support @@ -455,11 +455,11 @@ A type can be (:string n) " (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)))) + (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)) diff --git a/sql/generic-odbc.lisp b/sql/generic-odbc.lisp index 563e1f8..91310fb 100644 --- a/sql/generic-odbc.lisp +++ b/sql/generic-odbc.lisp @@ -34,39 +34,39 @@ (unless pkg (error "dbi-package is nil.")) (setf (slot-value db 'disconnect-fn) - (intern (symbol-name '#:disconnect) pkg) - (slot-value db 'sql-fn) - (intern (symbol-name '#:sql) pkg) - (slot-value db 'close-query-fn) - (intern (symbol-name '#:close-query) pkg) - (slot-value db 'fetch-row) - (intern (symbol-name '#:fetch-row) pkg) - (slot-value db 'list-all-database-tables-fn) - (intern (symbol-name '#:list-all-database-tables) pkg) - (slot-value db 'list-all-table-columns-fn) - (intern (symbol-name '#:list-all-table-columns) pkg)))) + (intern (symbol-name '#:disconnect) pkg) + (slot-value db 'sql-fn) + (intern (symbol-name '#:sql) pkg) + (slot-value db 'close-query-fn) + (intern (symbol-name '#:close-query) pkg) + (slot-value db 'fetch-row) + (intern (symbol-name '#:fetch-row) pkg) + (slot-value db 'list-all-database-tables-fn) + (intern (symbol-name '#:list-all-database-tables) pkg) + (slot-value db 'list-all-table-columns-fn) + (intern (symbol-name '#:list-all-table-columns) pkg)))) ;;; Object methods (defmethod read-sql-value (val (type (eql 'boolean)) - (database generic-odbc-database) - (db-type (eql :postgresql))) + (database generic-odbc-database) + (db-type (eql :postgresql))) (if (string= "0" val) nil t)) (defmethod read-sql-value (val (type (eql 'generalized-boolean)) - (database generic-odbc-database) - (db-type (eql :postgresql))) + (database generic-odbc-database) + (db-type (eql :postgresql))) (if (string= "0" val) nil t)) (defmethod read-sql-value (val (type (eql 'boolean)) database - (db-type (eql :mssql))) + (db-type (eql :mssql))) (declare (ignore database)) (etypecase val (string (if (string= "0" val) nil t)) (integer (if (zerop val) nil t)))) (defmethod read-sql-value (val (type (eql 'generalized-boolean)) database - (db-type (eql :mssql))) + (db-type (eql :mssql))) (declare (ignore database)) (etypecase val (string (if (string= "0" val) nil t)) @@ -75,7 +75,7 @@ ;;; Type methods (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database - (db-type (eql :mssql))) + (db-type (eql :mssql))) (declare (ignore args database)) "DATETIME") @@ -97,12 +97,12 @@ (t "'Y'"))) (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database - (db-type (eql :mssql))) + (db-type (eql :mssql))) (declare (ignore database)) (if val 1 0)) (defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database - (db-type (eql :mssql))) + (db-type (eql :mssql))) (declare (ignore database)) (if val 1 0)) @@ -128,33 +128,33 @@ t) (defmethod database-query (query-expression (database generic-odbc-database) - result-types field-names) + result-types field-names) (handler-case (funcall (sql-fn database) - query-expression :db (odbc-conn database) - :result-types result-types - :column-names field-names) + query-expression :db (odbc-conn database) + :result-types result-types + :column-names field-names) #+ignore (error () (error 'sql-database-data-error - :database database - :expression query-expression - :message "Query failed")))) + :database database + :expression query-expression + :message "Query failed")))) (defmethod database-execute-command (sql-expression (database generic-odbc-database)) (handler-case (funcall (sql-fn database) - sql-expression :db (odbc-conn database)) + sql-expression :db (odbc-conn database)) #+ignore (sql-error (e) (error e)) #+ignore (error () (error 'sql-database-data-error - :database database - :expression sql-expression - :message "Execute command failed")))) + :database database + :expression sql-expression + :message "Execute command failed")))) (defstruct odbc-result-set @@ -166,49 +166,49 @@ (defmethod database-query-result-set ((query-expression string) - (database generic-odbc-database) - &key full-set result-types) + (database generic-odbc-database) + &key full-set result-types) (handler-case (multiple-value-bind (query column-names) - (funcall (sql-fn database) - query-expression - :db (odbc-conn database) - :row-count nil - :column-names t - :query t - :result-types result-types) - (values - (make-odbc-result-set :query query :full-set full-set - :types result-types) - (length column-names) - nil ;; not able to return number of rows with odbc - )) + (funcall (sql-fn database) + query-expression + :db (odbc-conn database) + :row-count nil + :column-names t + :query t + :result-types result-types) + (values + (make-odbc-result-set :query query :full-set full-set + :types result-types) + (length column-names) + nil ;; not able to return number of rows with odbc + )) (error () (error 'sql-database-data-error - :database database - :expression query-expression - :message "Query result set failed")))) + :database database + :expression query-expression + :message "Query result set failed")))) (defmethod database-dump-result-set (result-set (database generic-odbc-database)) (funcall (close-query-fn database) (odbc-result-set-query result-set)) t) (defmethod database-store-next-row (result-set - (database generic-odbc-database) - list) + (database generic-odbc-database) + list) (let ((row (funcall (fetch-row-fn database) - (odbc-result-set-query result-set) nil 'eof))) + (odbc-result-set-query result-set) nil 'eof))) (if (eq row 'eof) - nil + nil (progn - (loop for elem in row - for rest on list - do - (setf (car rest) elem)) - list)))) + (loop for elem in row + for rest on list + do + (setf (car rest) elem)) + list)))) (defmethod database-list-tables ((database generic-odbc-database) - &key (owner nil)) + &key (owner nil)) (declare (ignore owner)) (multiple-value-bind (rows col-names) (funcall (list-all-database-tables-fn database) :db (odbc-conn database)) @@ -216,15 +216,15 @@ ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager ;; TABLE_NAME in third column, TABLE_TYPE in fourth column (loop for row in rows - when (and (not (string-equal "information_schema" (nth 1 row))) - (string-equal "TABLE" (nth 3 row)) + when (and (not (string-equal "information_schema" (nth 1 row))) + (string-equal "TABLE" (nth 3 row)) (not (and (eq :mssql (database-underlying-type database)) (string-equal "dtproperties" (nth 2 row))))) - collect (nth 2 row)))) + collect (nth 2 row)))) (defmethod database-list-views ((database generic-odbc-database) - &key (owner nil)) + &key (owner nil)) (declare (ignore owner)) (multiple-value-bind (rows col-names) (funcall (list-all-database-tables-fn database) :db (odbc-conn database)) @@ -232,11 +232,11 @@ ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager ;; TABLE_NAME in third column, TABLE_TYPE in fourth column (loop for row in rows - when (and (not (string-equal "information_schema" (nth 1 row))) - (string-equal "VIEW" (nth 3 row)) + when (and (not (string-equal "information_schema" (nth 1 row))) + (string-equal "VIEW" (nth 3 row)) (not (and (eq :mssql (database-underlying-type database)) (member (nth 2 row) '("sysconstraints" "syssegments") :test #'string-equal)))) - collect (nth 2 row)))) + collect (nth 2 row)))) (defmethod database-list-attributes ((table string) (database generic-odbc-database) @@ -244,18 +244,18 @@ (declare (ignore owner)) (multiple-value-bind (rows col-names) (funcall (list-all-table-columns-fn database) table - :db (odbc-conn database)) + :db (odbc-conn database)) (declare (ignore col-names)) ;; COLUMN_NAME is hard-coded by odbc spec as fourth position (loop for row in rows - collect (fourth row)))) + collect (fourth row)))) (defmethod database-attribute-type ((attribute string) (table string) (database generic-odbc-database) - &key (owner nil)) + &key (owner nil)) (declare (ignore owner)) (multiple-value-bind (rows col-names) (funcall (list-all-table-columns-fn database) table - :db (odbc-conn database)) + :db (odbc-conn database)) (declare (ignore col-names)) ;; COLUMN_NAME is hard-coded by odbc spec as fourth position ;; TYPE_NAME is the sixth column @@ -263,12 +263,12 @@ ;; SCALE/DECIMAL_DIGITS is the ninth column ;; NULLABLE is the eleventh column (loop for row in rows - when (string-equal attribute (fourth row)) - do - (let ((size (seventh row)) - (precision (ninth row)) - (scale (nth 10 row))) - (return (values (ensure-keyword (sixth row)) - (when size (parse-integer size)) - (when precision (parse-integer precision)) - (when scale (parse-integer scale)))))))) + when (string-equal attribute (fourth row)) + do + (let ((size (seventh row)) + (precision (ninth row)) + (scale (nth 10 row))) + (return (values (ensure-keyword (sixth row)) + (when size (parse-integer size)) + (when precision (parse-integer precision)) + (when scale (parse-integer scale)))))))) diff --git a/sql/generic-postgresql.lisp b/sql/generic-postgresql.lisp index a2dd437..70a8e9f 100644 --- a/sql/generic-postgresql.lisp +++ b/sql/generic-postgresql.lisp @@ -23,29 +23,29 @@ ;; Object functions (defmethod database-get-type-specifier (type args database - (db-type (eql :postgresql))) + (db-type (eql :postgresql))) (declare (ignore type args database)) "VARCHAR") (defmethod database-get-type-specifier ((type (eql 'string)) args database - (db-type (eql :postgresql))) + (db-type (eql :postgresql))) (declare (ignore database)) (if args (format nil "CHAR(~A)" (car args)) "VARCHAR")) (defmethod database-get-type-specifier ((type (eql 'tinyint)) args database - (db-type (eql :postgresql))) + (db-type (eql :postgresql))) (declare (ignore args database)) "INT2") (defmethod database-get-type-specifier ((type (eql 'smallint)) args database - (db-type (eql :postgresql))) + (db-type (eql :postgresql))) (declare (ignore args database)) "INT2") (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database - (db-type (eql :postgresql))) + (db-type (eql :postgresql))) (declare (ignore args database)) "TIMESTAMP WITHOUT TIME ZONE") @@ -91,8 +91,8 @@ (defun database-list-objects-of-type (database type owner) (mapcar #'car - (database-query - (format nil + (database-query + (format nil (if (and (has-table-pg_roles database) (not (eq owner :all))) " @@ -106,9 +106,9 @@ ~A" "SELECT relname FROM pg_class WHERE (relkind = '~A')~A") - type - (owner-clause owner)) - database nil nil))) + type + (owner-clause owner)) + database nil nil))) (defmethod database-list-tables ((database generic-postgresql-database) &key (owner nil)) @@ -124,26 +124,26 @@ (defmethod database-list-table-indexes (table (database generic-postgresql-database) - &key (owner nil)) + &key (owner nil)) (let ((indexrelids - (database-query - (format - nil - "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)" - (string-downcase table) - (owner-clause owner)) - database :auto nil)) - (result nil)) + (database-query + (format + nil + "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)" + (string-downcase table) + (owner-clause owner)) + database :auto nil)) + (result nil)) (dolist (indexrelid indexrelids (nreverse result)) (push (caar (database-query - (format nil "select relname from pg_class where relfilenode='~A'" - (car indexrelid)) - database nil nil)) + (format nil "select relname from pg_class where relfilenode='~A'" + (car indexrelid)) + database nil nil)) result)))) (defmethod database-list-attributes ((table string) - (database generic-postgresql-database) + (database generic-postgresql-database) &key (owner nil)) (let* ((owner-clause (cond ((stringp owner) @@ -151,9 +151,9 @@ ((null owner) " AND (not (relowner=1))") (t ""))) (result - (mapcar #'car - (database-query - (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND attisdropped = FALSE AND relname='~A'~A" + (mapcar #'car + (database-query + (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND attisdropped = FALSE AND relname='~A'~A" (string-downcase table) owner-clause) database nil nil)))) @@ -169,14 +169,14 @@ result)))) (defmethod database-attribute-type (attribute (table string) - (database generic-postgresql-database) + (database generic-postgresql-database) &key (owner nil)) (let ((row (car (database-query - (format nil "SELECT pg_type.typname,pg_attribute.attlen,pg_attribute.atttypmod,pg_attribute.attnotnull FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A" - (string-downcase table) - (string-downcase attribute) - (owner-clause owner)) - database nil nil)))) + (format nil "SELECT pg_type.typname,pg_attribute.attlen,pg_attribute.atttypmod,pg_attribute.attnotnull FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A" + (string-downcase table) + (string-downcase attribute) + (owner-clause owner)) + database nil nil)))) (when row (destructuring-bind (typname attlen atttypmod attnull) row @@ -203,13 +203,13 @@ (values coltype collen colprec colnull)))))) (defmethod database-create-sequence (sequence-name - (database generic-postgresql-database)) + (database generic-postgresql-database)) (database-execute-command (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) database)) (defmethod database-drop-sequence (sequence-name - (database generic-postgresql-database)) + (database generic-postgresql-database)) (database-execute-command (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database)) @@ -227,7 +227,7 @@ database nil nil))))) (defmethod database-sequence-next (sequence-name - (database generic-postgresql-database)) + (database generic-postgresql-database)) (values (parse-integer (caar @@ -247,15 +247,15 @@ (destructuring-bind (host name user password) connection-spec (declare (ignore name)) (let ((database (database-connect (list host "template1" user password) - type))) + type))) (unwind-protect - (progn - (setf (slot-value database 'clsql-sys::state) :open) - (mapcar #'car (database-query "select datname from pg_database" - database nil nil))) - (progn - (database-disconnect database) - (setf (slot-value database 'clsql-sys::state) :closed)))))) + (progn + (setf (slot-value database 'clsql-sys::state) :open) + (mapcar #'car (database-query "select datname from pg_database" + database nil nil))) + (progn + (database-disconnect database) + (setf (slot-value database 'clsql-sys::state) :closed)))))) (defmethod database-list (connection-spec (type (eql :postgresql))) (postgresql-database-list connection-spec type)) @@ -302,45 +302,45 @@ ((and (consp type) (in (car type) :char :varchar)) "VARCHAR") (t (error 'sql-user-error - :message - (format nil "Unknown clsql type ~A." type))))) + :message + (format nil "Unknown clsql type ~A." type))))) (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)) + (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))))))) + (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)) + 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))))) + :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)) @@ -355,18 +355,18 @@ (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)))) + 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))) + (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)) + (values (nth-value 0 (database-query query database result-types nil)) + field-names)) (t - (database-query query database result-types field-names)))))) + (database-query query database result-types field-names)))))) ;;; Capabilities diff --git a/sql/generics.lisp b/sql/generics.lisp index d8066cf..792a9de 100644 --- a/sql/generics.lisp +++ b/sql/generics.lisp @@ -19,7 +19,7 @@ (in-package #:clsql-sys) -;; FDML +;; FDML (defgeneric execute-command (expression &key database) (:documentation @@ -48,7 +48,7 @@ record selected by QUERY-EXPRESSION, the results are returned as elements of a list.")) -;; OODML +;; OODML (defgeneric update-record-from-slot (object slot &key database) (:documentation @@ -63,7 +63,7 @@ attributes having default values. Furthermore, OBJECT becomes associated with DATABASE.")) (defgeneric update-record-from-slots (object slots &key database) - (:documentation + (:documentation "Updates the values stored in the columns represented by the slots, specified by the CLOS slot names SLOTS, of View Class instance OBJECT. DATABASE defaults to *DEFAULT-DATABASE* and @@ -109,8 +109,8 @@ database, *DEFAULT-DATABASE*. Join slots are updated but instances of the class on which the join is made are not updated.")) -(defgeneric instance-refreshed (object) - (:documentation +(defgeneric instance-refreshed (object) + (:documentation "Provides a hook which is called within an object oriented call to SELECT with a non-nil value of REFRESH when the View Class instance OBJECT has been updated from the database. A @@ -143,7 +143,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) ) -;; Generation of SQL strings from lisp expressions +;; Generation of SQL strings from lisp expressions (defgeneric output-sql (expr database) (:documentation "Writes an SQL string appropriate for DATABASE diff --git a/sql/initialize.lisp b/sql/initialize.lisp index f678d3f..fd06c3e 100644 --- a/sql/initialize.lisp +++ b/sql/initialize.lisp @@ -4,7 +4,7 @@ ;;;; ;;;; Name: initialize.lisp ;;;; Purpose: Initializion routines for backend -;;;; Programmers: Kevin M. Rosenberg +;;;; Programmers: Kevin M. Rosenberg ;;;; Date Started: May 2002 ;;;; ;;;; $Id$ @@ -49,13 +49,13 @@ DATABASE-TYPE and, if DATABASE-TYPE has not been initialised, it is added to *INITIALIZED-DATABASE-TYPES*. " (when (member database-type *initialized-database-types*) (return-from initialize-database-type database-type)) - - (let ((system (intern (concatenate 'string - (symbol-name '#:clsql-) - (symbol-name database-type))))) + + (let ((system (intern (concatenate 'string + (symbol-name '#:clsql-) + (symbol-name database-type))))) (when (not (find-package system)) (asdf:operate 'asdf:load-op system))) - + (when (database-initialize-database-type database-type) (push database-type *initialized-database-types*) (setf *default-database-type* database-type) diff --git a/sql/kmr-mop.lisp b/sql/kmr-mop.lisp index 8fccf57..c628dc2 100644 --- a/sql/kmr-mop.lisp +++ b/sql/kmr-mop.lisp @@ -25,8 +25,8 @@ (defmacro process-class-option (metaclass slot-name &optional required) #+lispworks `(defmethod clos:process-a-class-option ((class ,metaclass) - (name (eql ,slot-name)) - value) + (name (eql ,slot-name)) + value) (when (and ,required (null value)) (error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name)) (list name `',value)) @@ -37,10 +37,10 @@ (defmacro process-slot-option (metaclass slot-name) #+lispworks `(defmethod clos:process-a-slot-option ((class ,metaclass) - (option (eql ,slot-name)) - value - already-processed-options - slot) + (option (eql ,slot-name)) + value + already-processed-options + slot) (list* option `',value already-processed-options)) #-lispworks (declare (ignore metaclass slot-name)) @@ -55,7 +55,7 @@ (ecase (slot-definition-name (first slots)) (a) (b (pushnew :mop-slot-order-reversed cl:*features*))))) - + (defun ordered-class-slots (class) #+mop-slot-order-reversed (reverse (class-slots class)) #-mop-slot-order-reversed (class-slots class)) diff --git a/sql/loop-extension.lisp b/sql/loop-extension.lisp index b18447a..666457e 100644 --- a/sql/loop-extension.lisp +++ b/sql/loop-extension.lisp @@ -16,9 +16,9 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defpackage #:ansi-loop (:import-from #+sbcl #:sb-loop #+allegro #:excl - #:*loop-epilogue* - #:*loop-ansi-universe* - #:add-loop-path))) + #:*loop-epilogue* + #:*loop-ansi-universe* + #:add-loop-path))) #+(or allegro sbcl) (defun ansi-loop::loop-gentemp (&optional (pref 'loopva-)) @@ -31,33 +31,33 @@ #+(or allegro clisp-aloop cmu openmcl sbcl scl) (defun loop-record-iteration-path (variable data-type prep-phrases) (let ((in-phrase nil) - (from-phrase nil)) + (from-phrase nil)) (loop for (prep . rest) in prep-phrases - do - (case prep - ((:in :of) - (when in-phrase - (error 'clsql:sql-user-error - :message - (format nil - "Duplicate OF or IN iteration path: ~S." - (cons prep rest)))) - (setq in-phrase rest)) - ((:from) - (when from-phrase - (error 'clsql:sql-user-error - :message - (format nil - "Duplicate FROM iteration path: ~S." - (cons prep rest)))) - (setq from-phrase rest)) - (t - (error 'clsql:sql-user-error - :message - (format nil"Unknown preposition: ~S." prep))))) + do + (case prep + ((:in :of) + (when in-phrase + (error 'clsql:sql-user-error + :message + (format nil + "Duplicate OF or IN iteration path: ~S." + (cons prep rest)))) + (setq in-phrase rest)) + ((:from) + (when from-phrase + (error 'clsql:sql-user-error + :message + (format nil + "Duplicate FROM iteration path: ~S." + (cons prep rest)))) + (setq from-phrase rest)) + (t + (error 'clsql:sql-user-error + :message + (format nil"Unknown preposition: ~S." prep))))) (unless in-phrase (error 'clsql:sql-user-error - :message "Missing OF or IN iteration path.")) + :message "Missing OF or IN iteration path.")) (unless from-phrase (setq from-phrase '(*default-database*))) @@ -67,69 +67,69 @@ (cond ;; object query ((and (consp (first in-phrase)) - (string-equal "sql-query" (symbol-name (caar in-phrase))) - (consp (second (first in-phrase))) - (eq 'quote (first (second (first in-phrase)))) - (symbolp (second (second (first in-phrase))))) + (string-equal "sql-query" (symbol-name (caar in-phrase))) + (consp (second (first in-phrase))) + (eq 'quote (first (second (first in-phrase)))) + (symbolp (second (second (first in-phrase))))) (let ((result-var (ansi-loop::loop-gentemp - 'loop-record-result-)) - (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) - `(((,variable nil ,@(and data-type (list data-type))) - (,result-var (query ,(first in-phrase))) - (,step-var nil)) - () - () - () - (if (null ,result-var) - t - (progn - (setq ,step-var (first ,result-var)) - (setq ,result-var (rest ,result-var)) - nil)) - (,variable ,step-var) - (null ,result-var) - () - (if (null ,result-var) - t - (progn - (setq ,step-var (first ,result-var)) - (setq ,result-var (rest ,result-var)) - nil)) - (,variable ,step-var)))) + 'loop-record-result-)) + (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) + `(((,variable nil ,@(and data-type (list data-type))) + (,result-var (query ,(first in-phrase))) + (,step-var nil)) + () + () + () + (if (null ,result-var) + t + (progn + (setq ,step-var (first ,result-var)) + (setq ,result-var (rest ,result-var)) + nil)) + (,variable ,step-var) + (null ,result-var) + () + (if (null ,result-var) + t + (progn + (setq ,step-var (first ,result-var)) + (setq ,result-var (rest ,result-var)) + nil)) + (,variable ,step-var)))) ((consp variable) (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) - (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) - (result-set-var (ansi-loop::loop-gentemp - 'loop-record-result-set-)) - (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) - (push `(when ,result-set-var - (database-dump-result-set ,result-set-var ,db-var)) - ansi-loop::*loop-epilogue*) - `(((,variable nil ,@(and data-type (list data-type))) - (,query-var ,(first in-phrase)) - (,db-var ,(first from-phrase)) - (,result-set-var t) - (,step-var nil)) - ((multiple-value-bind (%rs %cols) - (database-query-result-set ,query-var ,db-var :result-types :auto) - (setq ,result-set-var %rs ,step-var (make-list %cols)))) - () - () - (not (database-store-next-row ,result-set-var ,db-var ,step-var)) - (,variable ,step-var) - (not ,result-set-var) - () - (not (database-store-next-row ,result-set-var ,db-var ,step-var)) - (,variable ,step-var))))))) + (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) + (result-set-var (ansi-loop::loop-gentemp + 'loop-record-result-set-)) + (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) + (push `(when ,result-set-var + (database-dump-result-set ,result-set-var ,db-var)) + ansi-loop::*loop-epilogue*) + `(((,variable nil ,@(and data-type (list data-type))) + (,query-var ,(first in-phrase)) + (,db-var ,(first from-phrase)) + (,result-set-var t) + (,step-var nil)) + ((multiple-value-bind (%rs %cols) + (database-query-result-set ,query-var ,db-var :result-types :auto) + (setq ,result-set-var %rs ,step-var (make-list %cols)))) + () + () + (not (database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var) + (not ,result-set-var) + () + (not (database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var))))))) #+(or allegro clisp-aloop cmu openmcl sbcl scl) (ansi-loop::add-loop-path '(record records tuple tuples) - 'loop-record-iteration-path - ansi-loop::*loop-ansi-universe* - :preposition-groups '((:of :in) (:from)) - :inclusive-permitted nil) + 'loop-record-iteration-path + ansi-loop::*loop-ansi-universe* + :preposition-groups '((:of :in) (:from)) + :inclusive-permitted nil) #+lispworks @@ -139,34 +139,34 @@ #+lispworks (defun clsql-loop-method (method-name iter-var iter-var-data-type - prep-phrases inclusive? allowed-preps - method-specific-data) + prep-phrases inclusive? allowed-preps + method-specific-data) (declare (ignore method-name iter-var-data-type inclusive? allowed-preps method-specific-data)) (let ((in-phrase nil) - (from-phrase nil)) + (from-phrase nil)) (loop for (prep . rest) in prep-phrases - do - (cond - ((or (eq prep 'loop::in) (eq prep 'loop::of)) - (when in-phrase - (error 'clsql:sql-user-error - :message - (format nil "Duplicate OF or IN iteration path: ~S." - (cons prep rest)))) - (setq in-phrase rest)) - ((eq prep 'loop::from) - (when from-phrase - (error 'clsql:sql-user-error - :message - (format nil "Duplicate FROM iteration path: ~S." - (cons prep rest)))) - (setq from-phrase rest)) - (t - (error 'clsql:sql-user-error - :message (format nil "Unknown preposition: ~S." prep))))) + do + (cond + ((or (eq prep 'loop::in) (eq prep 'loop::of)) + (when in-phrase + (error 'clsql:sql-user-error + :message + (format nil "Duplicate OF or IN iteration path: ~S." + (cons prep rest)))) + (setq in-phrase rest)) + ((eq prep 'loop::from) + (when from-phrase + (error 'clsql:sql-user-error + :message + (format nil "Duplicate FROM iteration path: ~S." + (cons prep rest)))) + (setq from-phrase rest)) + (t + (error 'clsql:sql-user-error + :message (format nil "Unknown preposition: ~S." prep))))) (unless in-phrase (error 'clsql:sql-user-error - :message "Missing OF or IN iteration path.")) + :message "Missing OF or IN iteration path.")) (unless from-phrase (setq from-phrase '(clsql:*default-database*))) @@ -176,70 +176,70 @@ (cond ;; object query ((and (consp in-phrase) - (string-equal "sql-query" (symbol-name (car in-phrase))) - (consp (second in-phrase)) - (eq 'quote (first (second in-phrase))) - (symbolp (second (second in-phrase)))) + (string-equal "sql-query" (symbol-name (car in-phrase))) + (consp (second in-phrase)) + (eq 'quote (first (second in-phrase))) + (symbolp (second (second in-phrase)))) (let ((result-var (gensym "LOOP-RECORD-RESULT-")) - (step-var (gensym "LOOP-RECORD-STEP-"))) - (values - t - nil - `(,@(mapcar (lambda (v) `(,v nil)) iter-var) - (,result-var (clsql:query ,in-phrase)) - (,step-var nil)) - () - () - () - `((if (null ,result-var) - t - (progn - (setq ,step-var (first ,result-var)) - (setq ,result-var (rest ,result-var)) - nil))) - `(,iter-var ,step-var) - `((if (null ,result-var) - t - (progn - (setq ,step-var (first ,result-var)) - (setq ,result-var (rest ,result-var)) - nil))) - `(,iter-var ,step-var) - () - () - ))) + (step-var (gensym "LOOP-RECORD-STEP-"))) + (values + t + nil + `(,@(mapcar (lambda (v) `(,v nil)) iter-var) + (,result-var (clsql:query ,in-phrase)) + (,step-var nil)) + () + () + () + `((if (null ,result-var) + t + (progn + (setq ,step-var (first ,result-var)) + (setq ,result-var (rest ,result-var)) + nil))) + `(,iter-var ,step-var) + `((if (null ,result-var) + t + (progn + (setq ,step-var (first ,result-var)) + (setq ,result-var (rest ,result-var)) + nil))) + `(,iter-var ,step-var) + () + () + ))) ((consp iter-var) (let ((query-var (gensym "LOOP-RECORD-")) - (db-var (gensym "LOOP-RECORD-DATABASE-")) - (result-set-var (gensym "LOOP-RECORD-RESULT-SET-")) - (step-var (gensym "LOOP-RECORD-STEP-"))) - (values - t - nil - `(,@(mapcar (lambda (v) `(,v nil)) iter-var) - (,query-var ,in-phrase) - (,db-var ,(first from-phrase)) - (,result-set-var nil) - (,step-var nil)) - `((multiple-value-bind (%rs %cols) - (clsql-sys:database-query-result-set ,query-var ,db-var :result-types :auto) - (setq ,result-set-var %rs ,step-var (make-list %cols)))) - () - () - `((unless (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var) - (when ,result-set-var - (clsql-sys:database-dump-result-set ,result-set-var ,db-var)) - t)) - `(,iter-var ,step-var) - `((unless (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var) - (when ,result-set-var - (clsql-sys:database-dump-result-set ,result-set-var ,db-var)) - t)) - `(,iter-var ,step-var) - () - ())))))) + (db-var (gensym "LOOP-RECORD-DATABASE-")) + (result-set-var (gensym "LOOP-RECORD-RESULT-SET-")) + (step-var (gensym "LOOP-RECORD-STEP-"))) + (values + t + nil + `(,@(mapcar (lambda (v) `(,v nil)) iter-var) + (,query-var ,in-phrase) + (,db-var ,(first from-phrase)) + (,result-set-var nil) + (,step-var nil)) + `((multiple-value-bind (%rs %cols) + (clsql-sys:database-query-result-set ,query-var ,db-var :result-types :auto) + (setq ,result-set-var %rs ,step-var (make-list %cols)))) + () + () + `((unless (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var) + (when ,result-set-var + (clsql-sys:database-dump-result-set ,result-set-var ,db-var)) + t)) + `(,iter-var ,step-var) + `((unless (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var) + (when ,result-set-var + (clsql-sys:database-dump-result-set ,result-set-var ,db-var)) + t)) + `(,iter-var ,step-var) + () + ())))))) #+clisp-aloop diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index 6a5f6e9..d1fba15 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -16,21 +16,21 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (when (>= (length (generic-function-lambda-list - (ensure-generic-function - 'compute-effective-slot-definition))) - 3) + (ensure-generic-function + 'compute-effective-slot-definition))) + 3) (pushnew :kmr-normal-cesd cl:*features*)) (when (>= (length (generic-function-lambda-list - (ensure-generic-function - 'direct-slot-definition-class))) - 3) + (ensure-generic-function + 'direct-slot-definition-class))) + 3) (pushnew :kmr-normal-dsdc cl:*features*)) (when (>= (length (generic-function-lambda-list - (ensure-generic-function - 'effective-slot-definition-class))) - 3) + (ensure-generic-function + 'effective-slot-definition-class))) + 3) (pushnew :kmr-normal-esdc cl:*features*))) @@ -57,7 +57,7 @@ ;;; Lispworks 4.2 and before requires special processing of extra slot and class options (defvar +extra-slot-options+ '(:column :db-kind :db-type :db-reader :void-value :db-constraints - :db-writer :db-info)) + :db-writer :db-info)) (defvar +extra-class-options+ '(:base-table)) #+lispworks @@ -69,57 +69,57 @@ (eval `(process-class-option standard-db-class ,class-option))) (defmethod validate-superclass ((class standard-db-class) - (superclass standard-class)) + (superclass standard-class)) t) (defun table-name-from-arg (arg) (cond ((symbolp arg) - arg) - ((typep arg 'sql-ident) - (slot-value arg 'name)) - ((stringp arg) - (intern arg)))) + arg) + ((typep arg 'sql-ident) + (slot-value arg 'name)) + ((stringp arg) + (intern arg)))) (defun column-name-from-arg (arg) (cond ((symbolp arg) - arg) - ((typep arg 'sql-ident) - (slot-value arg 'name)) - ((stringp arg) - (intern (symbol-name-default-case arg))))) + arg) + ((typep arg 'sql-ident) + (slot-value arg 'name)) + ((stringp arg) + (intern (symbol-name-default-case arg))))) (defun remove-keyword-arg (arglist akey) (let ((mylist arglist) - (newlist ())) + (newlist ())) (labels ((pop-arg (alist) - (let ((arg (pop alist)) - (val (pop alist))) - (unless (equal arg akey) - (setf newlist (append (list arg val) newlist))) - (when alist (pop-arg alist))))) + (let ((arg (pop alist)) + (val (pop alist))) + (unless (equal arg akey) + (setf newlist (append (list arg val) newlist))) + (when alist (pop-arg alist))))) (pop-arg mylist)) newlist)) (defmethod initialize-instance :around ((class standard-db-class) &rest all-keys - &key direct-superclasses base-table + &key direct-superclasses base-table qualifier - &allow-other-keys) + &allow-other-keys) (let ((root-class (find-class 'standard-db-object nil)) - (vmc 'standard-db-class)) + (vmc 'standard-db-class)) (setf (view-class-qualifier class) (car qualifier)) (if root-class - (if (some #'(lambda (super) (typep super vmc)) + (if (some #'(lambda (super) (typep super vmc)) direct-superclasses) - (call-next-method) + (call-next-method) (apply #'call-next-method class - :direct-superclasses (append (list root-class) + :direct-superclasses (append (list root-class) direct-superclasses) - (remove-keyword-arg all-keys :direct-superclasses))) - (call-next-method)) + (remove-keyword-arg all-keys :direct-superclasses))) + (call-next-method)) (setf (view-table class) (table-name-from-arg (sql-escape (or (and base-table (if (listp base-table) @@ -135,7 +135,7 @@ direct-superclasses qualifier &allow-other-keys) (let ((root-class (find-class 'standard-db-object nil)) - (vmc 'standard-db-class)) + (vmc 'standard-db-class)) (setf (view-table class) (table-name-from-arg (sql-escape (or (and base-table (if (listp base-table) @@ -145,14 +145,14 @@ (setf (view-class-qualifier class) (car qualifier)) (if (and root-class (not (equal class root-class))) - (if (some #'(lambda (super) (typep super vmc)) + (if (some #'(lambda (super) (typep super vmc)) direct-superclasses) - (call-next-method) + (call-next-method) (apply #'call-next-method class :direct-superclasses (append (list root-class) direct-superclasses) - (remove-keyword-arg all-keys :direct-superclasses))) + (remove-keyword-arg all-keys :direct-superclasses))) (call-next-method))) (register-metaclass class (nth (1+ (position :direct-slots all-keys)) all-keys))) @@ -194,16 +194,16 @@ (setf (object-definition class) all-slots)) #-(or sbcl allegro) (setf (key-slots class) (remove-if-not (lambda (slot) - (eql (slot-value slot 'db-kind) - :key)) - (ordered-class-slots class))))) + (eql (slot-value slot 'db-kind) + :key)) + (ordered-class-slots class))))) #+(or sbcl allegro) (defmethod finalize-inheritance :after ((class standard-db-class)) (setf (key-slots class) (remove-if-not (lambda (slot) - (eql (slot-value slot 'db-kind) - :key)) - (ordered-class-slots class)))) + (eql (slot-value slot 'db-kind) + :key)) + (ordered-class-slots class)))) ;; return the deepest view-class ancestor for a given view class @@ -300,49 +300,49 @@ column definition in the database.") (defparameter *db-info-lambda-list* '(&key join-class - home-key - foreign-key + home-key + foreign-key (key-join nil) (target-slot nil) - (retrieval :immmediate) - (set nil))) + (retrieval :immmediate) + (set nil))) (defun parse-db-info (db-info-list) (destructuring-bind - (&key join-class home-key key-join foreign-key (delete-rule nil) - (target-slot nil) (retrieval :deferred) (set t)) + (&key join-class home-key key-join foreign-key (delete-rule nil) + (target-slot nil) (retrieval :deferred) (set t)) db-info-list (let ((ih (make-hash-table :size 6))) (if join-class - (setf (gethash :join-class ih) join-class) - (error "Must specify :join-class in :db-info")) + (setf (gethash :join-class ih) join-class) + (error "Must specify :join-class in :db-info")) (if home-key - (setf (gethash :home-key ih) home-key) - (error "Must specify :home-key in :db-info")) + (setf (gethash :home-key ih) home-key) + (error "Must specify :home-key in :db-info")) (when delete-rule - (setf (gethash :delete-rule ih) delete-rule)) + (setf (gethash :delete-rule ih) delete-rule)) (if foreign-key - (setf (gethash :foreign-key ih) foreign-key) - (error "Must specify :foreign-key in :db-info")) + (setf (gethash :foreign-key ih) foreign-key) + (error "Must specify :foreign-key in :db-info")) (when key-join (setf (gethash :key-join ih) t)) (when target-slot - (setf (gethash :target-slot ih) target-slot)) + (setf (gethash :target-slot ih) target-slot)) (when set - (setf (gethash :set ih) set)) + (setf (gethash :set ih) set)) (when retrieval - (progn - (setf (gethash :retrieval ih) retrieval) - (if (eql retrieval :immediate) - (setf (gethash :set ih) nil)))) + (progn + (setf (gethash :retrieval ih) retrieval) + (if (eql retrieval :immediate) + (setf (gethash :set ih) nil)))) ih))) (defclass view-class-direct-slot-definition (view-class-slot-definition-mixin - standard-direct-slot-definition) + standard-direct-slot-definition) ()) (defclass view-class-effective-slot-definition (view-class-slot-definition-mixin - standard-effective-slot-definition) + standard-effective-slot-definition) ()) (defmethod direct-slot-definition-class ((class standard-db-class) @@ -352,8 +352,8 @@ column definition in the database.") (find-class 'view-class-direct-slot-definition)) (defmethod effective-slot-definition-class ((class standard-db-class) - #+kmr-normal-esdc &rest - initargs) + #+kmr-normal-esdc &rest + initargs) (declare (ignore initargs)) (find-class 'view-class-effective-slot-definition)) @@ -368,17 +368,17 @@ column definition in the database.") "Need to sort order of class slots so they are the same across implementations." (let ((slots (call-next-method)) - desired-sequence - output-slots) + desired-sequence + output-slots) (dolist (c (compute-class-precedence-list class)) (dolist (s (class-direct-slots c)) - (let ((name (slot-definition-name s))) - (unless (find name desired-sequence) - (push name desired-sequence))))) + (let ((name (slot-definition-name s))) + (unless (find name desired-sequence) + (push name desired-sequence))))) (dolist (desired desired-sequence) (let ((slot (find desired slots :key #'slot-definition-name))) - (assert slot) - (push slot output-slots))) + (assert slot) + (push slot output-slots))) output-slots)) (defun compute-lisp-type-from-specified-type (specified-type db-constraints) @@ -452,8 +452,8 @@ implementations." (setq initargs (cddr initargs)))) (defmethod compute-effective-slot-definition ((class standard-db-class) - #+kmr-normal-cesd slot-name - direct-slots) + #+kmr-normal-cesd slot-name + direct-slots) #+kmr-normal-cesd (declare (ignore slot-name)) ;; KMR: store the user-specified type and then compute @@ -461,67 +461,67 @@ implementations." (let ((dsd (car direct-slots))) (let ((esd (call-next-method))) (typecase dsd - (view-class-slot-definition-mixin - ;; Use the specified :column argument if it is supplied, otherwise - ;; the column slot is filled in with the slot-name, but transformed - ;; to be sql safe, - to _ and such. - (setf (slot-value esd 'column) - (column-name-from-arg - (if (slot-boundp dsd 'column) - (delistify-dsd (view-class-slot-column dsd)) - (column-name-from-arg - (sql-escape (slot-definition-name dsd)))))) - - (setf (slot-value esd 'db-type) - (when (slot-boundp dsd 'db-type) - (delistify-dsd - (view-class-slot-db-type dsd)))) - - (setf (slot-value esd 'void-value) - (delistify-dsd - (view-class-slot-void-value dsd))) - - ;; :db-kind slot value defaults to :base (store slot value in - ;; database) - - (setf (slot-value esd 'db-kind) - (if (slot-boundp dsd 'db-kind) - (delistify-dsd (view-class-slot-db-kind dsd)) - :base)) - - (setf (slot-value esd 'db-reader) - (when (slot-boundp dsd 'db-reader) - (delistify-dsd (view-class-slot-db-reader dsd)))) - (setf (slot-value esd 'db-writer) - (when (slot-boundp dsd 'db-writer) - (delistify-dsd (view-class-slot-db-writer dsd)))) - (setf (slot-value esd 'db-constraints) - (when (slot-boundp dsd 'db-constraints) - (delistify-dsd (view-class-slot-db-constraints dsd)))) - - ;; I wonder if this slot option and the previous could be merged, - ;; so that :base and :key remain keyword options, but :db-kind - ;; :join becomes :db-kind (:join )? - - (setf (slot-value esd 'db-info) - (when (slot-boundp dsd 'db-info) - (let ((dsd-info (view-class-slot-db-info dsd))) - (cond - ((atom dsd-info) - dsd-info) - ((and (listp dsd-info) (> (length dsd-info) 1) - (atom (car dsd-info))) - (parse-db-info dsd-info)) - ((and (listp dsd-info) (= 1 (length dsd-info)) - (listp (car dsd-info))) - (parse-db-info (car dsd-info))))))) - - (setf (specified-type esd) - (delistify-dsd (specified-type dsd))) - - ) - ;; all other slots - (t + (view-class-slot-definition-mixin + ;; Use the specified :column argument if it is supplied, otherwise + ;; the column slot is filled in with the slot-name, but transformed + ;; to be sql safe, - to _ and such. + (setf (slot-value esd 'column) + (column-name-from-arg + (if (slot-boundp dsd 'column) + (delistify-dsd (view-class-slot-column dsd)) + (column-name-from-arg + (sql-escape (slot-definition-name dsd)))))) + + (setf (slot-value esd 'db-type) + (when (slot-boundp dsd 'db-type) + (delistify-dsd + (view-class-slot-db-type dsd)))) + + (setf (slot-value esd 'void-value) + (delistify-dsd + (view-class-slot-void-value dsd))) + + ;; :db-kind slot value defaults to :base (store slot value in + ;; database) + + (setf (slot-value esd 'db-kind) + (if (slot-boundp dsd 'db-kind) + (delistify-dsd (view-class-slot-db-kind dsd)) + :base)) + + (setf (slot-value esd 'db-reader) + (when (slot-boundp dsd 'db-reader) + (delistify-dsd (view-class-slot-db-reader dsd)))) + (setf (slot-value esd 'db-writer) + (when (slot-boundp dsd 'db-writer) + (delistify-dsd (view-class-slot-db-writer dsd)))) + (setf (slot-value esd 'db-constraints) + (when (slot-boundp dsd 'db-constraints) + (delistify-dsd (view-class-slot-db-constraints dsd)))) + + ;; I wonder if this slot option and the previous could be merged, + ;; so that :base and :key remain keyword options, but :db-kind + ;; :join becomes :db-kind (:join )? + + (setf (slot-value esd 'db-info) + (when (slot-boundp dsd 'db-info) + (let ((dsd-info (view-class-slot-db-info dsd))) + (cond + ((atom dsd-info) + dsd-info) + ((and (listp dsd-info) (> (length dsd-info) 1) + (atom (car dsd-info))) + (parse-db-info dsd-info)) + ((and (listp dsd-info) (= 1 (length dsd-info)) + (listp (car dsd-info))) + (parse-db-info (car dsd-info))))))) + + (setf (specified-type esd) + (delistify-dsd (specified-type dsd))) + + ) + ;; all other slots + (t (unless (typep esd 'view-class-effective-slot-definition) (warn "Non view-class-direct-slot object with non-view-class-effective-slot-definition in compute-effective-slot-definition") @@ -533,26 +533,26 @@ implementations." #+openmcl (setf (slot-value esd 'ccl::type-predicate) type-predicate))) - (setf (slot-value esd 'column) - (column-name-from-arg - (sql-escape (slot-definition-name dsd)))) + (setf (slot-value esd 'column) + (column-name-from-arg + (sql-escape (slot-definition-name dsd)))) - (setf (slot-value esd 'db-info) nil) - (setf (slot-value esd 'db-kind) :virtual) - (setf (specified-type esd) (slot-definition-type dsd))) - ) + (setf (slot-value esd 'db-info) nil) + (setf (slot-value esd 'db-kind) :virtual) + (setf (specified-type esd) (slot-definition-type dsd))) + ) esd))) (defun slotdefs-for-slots-with-class (slots class) (let ((result nil)) (dolist (s slots) (let ((c (slotdef-for-slot-with-class s class))) - (if c (setf result (cons c result))))) + (if c (setf result (cons c result))))) result)) (defun slotdef-for-slot-with-class (slot class) (find-if #'(lambda (d) (eql slot (slot-definition-name d))) - (class-slots class))) + (class-slots class))) #+ignore (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp index 09d879a..9db898b 100644 --- a/sql/ooddl.lisp +++ b/sql/ooddl.lisp @@ -24,7 +24,7 @@ (defparameter *default-string-length* 255 "The length of a string which does not have a user-specified length.") -(defvar *db-auto-sync* nil +(defvar *db-auto-sync* nil "A non-nil value means that creating View Class instances or setting their slots automatically creates/updates the corresponding records in the underlying database.") @@ -36,8 +36,8 @@ (declare (optimize (speed 3))) (unless *db-deserializing* (let* ((slot-name (%svuc-slot-name slot-def)) - (slot-object (%svuc-slot-object slot-def class)) - (slot-kind (view-class-slot-db-kind slot-object))) + (slot-object (%svuc-slot-object slot-def class)) + (slot-kind (view-class-slot-db-kind slot-object))) (when (and (eql slot-kind :join) (not (slot-boundp instance slot-name))) (let ((*db-deserializing* t)) @@ -48,26 +48,26 @@ (call-next-method)) (defmethod (setf slot-value-using-class) (new-value (class standard-db-class) - instance slot-def) + instance slot-def) (declare (ignore new-value)) (let* ((slot-name (%svuc-slot-name slot-def)) - (slot-object (%svuc-slot-object slot-def class)) - (slot-kind (view-class-slot-db-kind slot-object))) + (slot-object (%svuc-slot-object slot-def class)) + (slot-kind (view-class-slot-db-kind slot-object))) (prog1 (call-next-method) - (when (and *db-auto-sync* + (when (and *db-auto-sync* (not *db-initializing*) (not *db-deserializing*) (not (eql slot-kind :virtual))) (update-record-from-slot instance slot-name))))) (defmethod initialize-instance ((object standard-db-object) - &rest all-keys &key &allow-other-keys) + &rest all-keys &key &allow-other-keys) (declare (ignore all-keys)) (let ((*db-initializing* t)) (call-next-method) (when (and *db-auto-sync* - (not *db-deserializing*)) + (not *db-deserializing*)) (update-records-from-instance object)))) ;; @@ -76,7 +76,7 @@ (defun create-view-from-class (view-class-name &key (database *default-database*) - (transactions t)) + (transactions t)) "Creates a table as defined by the View Class VIEW-CLASS-NAME in DATABASE which defaults to *DEFAULT-DATABASE*." (let ((tclass (find-class view-class-name))) @@ -87,29 +87,29 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." (values)) (defmethod %install-class ((self standard-db-class) database - &key (transactions t)) + &key (transactions t)) (let ((schemadef '())) (dolist (slotdef (ordered-class-slots self)) (let ((res (database-generate-column-definition (class-name self) - slotdef database))) - (when res - (push res schemadef)))) + slotdef database))) + (when res + (push res schemadef)))) (unless schemadef (error "Class ~s has no :base slots" self)) (create-table (sql-expression :table (view-table self)) (nreverse schemadef) - :database database - :transactions transactions - :constraints (database-pkey-constraint self database)) + :database database + :transactions transactions + :constraints (database-pkey-constraint self database)) (push self (database-view-classes database))) t) (defmethod database-pkey-constraint ((class standard-db-class) database) (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))) - (when keylist + (when keylist (convert-to-db-default-case (format nil "CONSTRAINT ~APK PRIMARY KEY~A" - (sql-output (view-table class) database) - (sql-output keylist database)) + (sql-output (view-table class) database) + (sql-output keylist database)) database)))) (defmethod database-generate-column-definition (class slotdef database) @@ -120,7 +120,7 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." (specified-type slotdef)))) (setf cdef (append cdef (list (view-class-slot-db-type slotdef)))) (let ((const (view-class-slot-db-constraints slotdef))) - (when const + (when const (setq cdef (append cdef (listify const))))) cdef))) @@ -156,19 +156,19 @@ DATABASE which defaults to *DEFAULT-DATABASE*." ;; (defun list-classes (&key (test #'identity) - (root-class (find-class 'standard-db-object)) - (database *default-database*)) + (root-class (find-class 'standard-db-object)) + (database *default-database*)) "Returns a list of all the View Classes which are connected to DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend from the class ROOT-CLASS and which satisfy the function TEST. By default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY." - (flet ((find-superclass (class) - (member root-class (class-precedence-list class)))) + (flet ((find-superclass (class) + (member root-class (class-precedence-list class)))) (let ((view-classes (and database (database-view-classes database)))) (when view-classes - (remove-if #'(lambda (c) (or (not (funcall test c)) - (not (find-superclass c)))) - view-classes))))) + (remove-if #'(lambda (c) (or (not (funcall test c)) + (not (find-superclass c)))) + view-classes))))) ;; ;; Define a new view class @@ -210,10 +210,10 @@ defaults to NIL. The :db-constraints slot option is a string representing an SQL table constraint expression or a list of such strings." `(progn - (defclass ,class ,supers ,slots + (defclass ,class ,supers ,slots ,@(if (find :metaclass `,cl-options :key #'car) - `,cl-options - (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) + `,cl-options + (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) (finalize-inheritance (find-class ',class)) (find-class ',class))) diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 03f0287..9bd2ab6 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -27,8 +27,8 @@ (slot-value obj (slot-definition-name k)) database)))) (let* ((keys (keyslots-for-class (class-of obj))) - (keyxprs (mapcar #'qfk (reverse keys)))) - (cond + (keyxprs (mapcar #'qfk (reverse keys)))) + (cond ((= (length keyxprs) 0) nil) ((= (length keyxprs) 1) (car keyxprs)) ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs))))))) @@ -41,10 +41,10 @@ (cond ((eq (view-class-slot-db-kind slotdef) :base) (sql-expression :attribute (view-class-slot-column slotdef) - :table (view-table vclass))) + :table (view-table vclass))) ((eq (view-class-slot-db-kind slotdef) :key) (sql-expression :attribute (view-class-slot-column slotdef) - :table (view-table vclass))) + :table (view-table vclass))) (t nil))) ;; @@ -55,10 +55,10 @@ (let ((sels nil)) (dolist (slotdef (ordered-class-slots vclass)) (let ((res (generate-attribute-reference vclass slotdef))) - (when res + (when res (push (cons slotdef res) sels)))) (if sels - sels + sels (error "No slots of type :base in view-class ~A" (class-name vclass))))) @@ -68,19 +68,19 @@ (let ((join-slotdefs nil)) (dolist (slotdef (ordered-class-slots vclass) join-slotdefs) (when (and (eq :join (view-class-slot-db-kind slotdef)) - (eq retrieval-method (gethash :retrieval (view-class-slot-db-info slotdef)))) - (push slotdef join-slotdefs))))) + (eq retrieval-method (gethash :retrieval (view-class-slot-db-info slotdef)))) + (push slotdef join-slotdefs))))) (defun generate-immediate-joins-selection-list (vclass) "Returns list of immediate join slots for a class." (let (sels) (dolist (joined-slot (generate-retrieval-joins-list vclass :immediate) sels) (let* ((join-class-name (gethash :join-class (view-class-slot-db-info joined-slot))) - (join-class (when join-class-name (find-class join-class-name)))) - (dolist (slotdef (ordered-class-slots join-class)) - (let ((res (generate-attribute-reference join-class slotdef))) - (when res - (push (cons slotdef res) sels)))))) + (join-class (when join-class-name (find-class join-class-name)))) + (dolist (slotdef (ordered-class-slots join-class)) + (let ((res (generate-attribute-reference join-class slotdef))) + (when res + (push (cons slotdef res) sels)))))) sels)) @@ -90,15 +90,15 @@ (defmethod update-slot-from-db ((instance standard-db-object) slotdef value) (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) (let* ((slot-reader (view-class-slot-db-reader slotdef)) - (slot-name (slot-definition-name slotdef)) - (slot-type (specified-type slotdef))) + (slot-name (slot-definition-name slotdef)) + (slot-type (specified-type slotdef))) (cond ((and value (null slot-reader)) (setf (slot-value instance slot-name) (read-sql-value value (delistify slot-type) (view-database instance) - (database-underlying-type - (view-database instance))))) - ((null value) + (database-underlying-type + (view-database instance))))) + ((null value) (update-slot-with-null instance slot-name slotdef)) ((typep slot-reader 'string) (setf (slot-value instance slot-name) @@ -115,7 +115,7 @@ (slot-type (specified-type slotdef))) (cond ((and value (null slot-reader)) (read-sql-value value (delistify slot-type) database - (database-underlying-type database))) + (database-underlying-type database))) ((null value) nil) ((typep slot-reader 'string) @@ -127,16 +127,16 @@ (defun db-value-from-slot (slotdef val database) (let ((dbwriter (view-class-slot-db-writer slotdef)) - (dbtype (specified-type slotdef))) + (dbtype (specified-type slotdef))) (typecase dbwriter (string (format nil dbwriter val)) ((and (or symbol function) (not null)) (apply dbwriter (list val))) (t (database-output-sql-as-type - (typecase dbtype - (cons (car dbtype)) - (t dbtype)) - val database (database-underlying-type database)))))) + (typecase dbtype + (cons (car dbtype)) + (t dbtype)) + val database (database-underlying-type database)))))) (defun check-slot-type (slotdef val) (let* ((slot-type (specified-type slotdef)) @@ -144,9 +144,9 @@ (when (and slot-type val) (unless (typep val basetype) (error 'sql-user-error - :message - (format nil "Invalid value ~A in slot ~A, not of type ~A." - val (slot-definition-name slotdef) slot-type)))))) + :message + (format nil "Invalid value ~A in slot ~A, not of type ~A." + val (slot-definition-name slotdef) slot-type)))))) ;; ;; Called by find-all @@ -154,14 +154,14 @@ (defmethod get-slot-values-from-view (obj slotdeflist values) (flet ((update-slot (slot-def values) - (update-slot-from-db obj slot-def values))) + (update-slot-from-db obj slot-def values))) (mapc #'update-slot slotdeflist values) obj)) (defmethod update-record-from-slot ((obj standard-db-object) slot &key - (database *default-database*)) + (database *default-database*)) (let* ((database (or (view-database obj) database)) - (vct (view-table (class-of obj))) + (vct (view-table (class-of obj))) (sd (slotdef-for-slot-with-class slot (class-of obj)))) (check-slot-type sd (slot-value obj slot)) (let* ((att (view-class-slot-column sd)) @@ -174,11 +174,11 @@ obj :database database) :database database)) ((and vct sd (not (view-database obj))) - (insert-records :into (sql-expression :table vct) + (insert-records :into (sql-expression :table vct) :attributes (list (sql-expression :attribute att)) :values (list val) - :database database) - (setf (slot-value obj 'view-database) database)) + :database database) + (setf (slot-value obj 'view-database) database)) (t (error "Unable to update record."))))) (values)) @@ -186,7 +186,7 @@ (defmethod update-record-from-slots ((obj standard-db-object) slots &key (database *default-database*)) (let* ((database (or (view-database obj) database)) - (vct (view-table (class-of obj))) + (vct (view-table (class-of obj))) (sds (slotdefs-for-slots-with-class slots (class-of obj))) (avps (mapcar #'(lambda (s) (let ((val (slot-value @@ -214,43 +214,43 @@ (defmethod update-records-from-instance ((obj standard-db-object) &key database) (let ((database (or database (view-database obj) *default-database*))) (labels ((slot-storedp (slot) - (and (member (view-class-slot-db-kind slot) '(:base :key)) - (slot-boundp obj (slot-definition-name slot)))) - (slot-value-list (slot) - (let ((value (slot-value obj (slot-definition-name slot)))) - (check-slot-type slot value) - (list (sql-expression :attribute (view-class-slot-column slot)) - (db-value-from-slot slot value database))))) + (and (member (view-class-slot-db-kind slot) '(:base :key)) + (slot-boundp obj (slot-definition-name slot)))) + (slot-value-list (slot) + (let ((value (slot-value obj (slot-definition-name slot)))) + (check-slot-type slot value) + (list (sql-expression :attribute (view-class-slot-column slot)) + (db-value-from-slot slot value database))))) (let* ((view-class (class-of obj)) - (view-class-table (view-table view-class)) - (slots (remove-if-not #'slot-storedp - (ordered-class-slots view-class))) - (record-values (mapcar #'slot-value-list slots))) - (unless record-values - (error "No settable slots.")) - (if (view-database obj) - (update-records (sql-expression :table view-class-table) - :av-pairs record-values - :where (key-qualifier-for-instance - obj :database database) - :database database) - (progn - (insert-records :into (sql-expression :table view-class-table) - :av-pairs record-values - :database database) - (setf (slot-value obj 'view-database) database)))))) + (view-class-table (view-table view-class)) + (slots (remove-if-not #'slot-storedp + (ordered-class-slots view-class))) + (record-values (mapcar #'slot-value-list slots))) + (unless record-values + (error "No settable slots.")) + (if (view-database obj) + (update-records (sql-expression :table view-class-table) + :av-pairs record-values + :where (key-qualifier-for-instance + obj :database database) + :database database) + (progn + (insert-records :into (sql-expression :table view-class-table) + :av-pairs record-values + :database database) + (setf (slot-value obj 'view-database) database)))))) (values)) (defmethod delete-instance-records ((instance standard-db-object)) (let ((vt (sql-expression :table (view-table (class-of instance)))) - (vd (view-database instance))) + (vd (view-database instance))) (if vd - (let ((qualifier (key-qualifier-for-instance instance :database vd))) - (delete-records :from vt :where qualifier :database vd) - (setf (record-caches vd) nil) - (setf (slot-value instance 'view-database) nil) + (let ((qualifier (key-qualifier-for-instance instance :database vd))) + (delete-records :from vt :where qualifier :database vd) + (setf (record-caches vd) nil) + (setf (slot-value instance 'view-database) nil) (values)) - (signal-no-database-error vd)))) + (signal-no-database-error vd)))) (defmethod update-instance-from-records ((instance standard-db-object) &key (database *default-database*)) @@ -262,8 +262,8 @@ (res (apply #'select (append (mapcar #'cdr sels) (list :from view-table :where view-qual - :result-types nil - :database vd))))) + :result-types nil + :database vd))))) (when res (get-slot-values-from-view instance (mapcar #'car sels) (car res))))) @@ -276,25 +276,25 @@ (slot-def (slotdef-for-slot-with-class slot view-class)) (att-ref (generate-attribute-reference view-class slot-def)) (res (select att-ref :from view-table :where view-qual - :result-types nil))) + :result-types nil))) (when res (get-slot-values-from-view instance (list slot-def) (car res))))) (defmethod update-slot-with-null ((object standard-db-object) - slotname - slotdef) + slotname + slotdef) (setf (slot-value object slotname) (slot-value slotdef 'void-value))) (defvar +no-slot-value+ '+no-slot-value+) (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*)) (let* ((class (find-class classname)) - (sld (slotdef-for-slot-with-class slot class))) + (sld (slotdef-for-slot-with-class slot class))) (if sld - (if (eq value +no-slot-value+) - (sql-expression :attribute (view-class-slot-column sld) - :table (view-table class)) + (if (eq value +no-slot-value+) + (sql-expression :attribute (view-class-slot-column sld) + :table (view-table class)) (db-value-from-slot sld value @@ -302,11 +302,11 @@ (error "Unknown slot ~A for class ~A" slot classname)))) (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*)) - (declare (ignore database)) - (let* ((class (find-class classname))) - (unless (view-table class) - (error "No view-table for class ~A" classname)) - (sql-expression :table (view-table class)))) + (declare (ignore database)) + (let* ((class (find-class classname))) + (unless (view-table class) + (error "No view-table for class ~A" classname)) + (sql-expression :table (view-table class)))) (defmethod database-get-type-specifier (type args database db-type) @@ -518,7 +518,7 @@ (declare (ignore database db-type)) (when (< 0 (length val)) (intern (symbol-name-default-case val) - (find-package '#:keyword)))) + (find-package '#:keyword)))) (defmethod read-sql-value (val (type (eql 'symbol)) database db-type) (declare (ignore database db-type)) @@ -607,81 +607,81 @@ #+ignore (defun fault-join-target-slot (class object slot-def) (let* ((res (fault-join-slot-raw class object slot-def)) - (dbi (view-class-slot-db-info slot-def)) - (target-name (gethash :target-slot dbi)) - (target-class (find-class target-name))) + (dbi (view-class-slot-db-info slot-def)) + (target-name (gethash :target-slot dbi)) + (target-class (find-class target-name))) (when res (mapcar (lambda (obj) - (list - (car - (fault-join-slot-raw - target-class - obj - (find target-name (class-slots (class-of obj)) - :key #'slot-definition-name))) - obj)) - res) + (list + (car + (fault-join-slot-raw + target-class + obj + (find target-name (class-slots (class-of obj)) + :key #'slot-definition-name))) + obj)) + res) #+ignore ;; this doesn't work when attempting to call slot-value (mapcar (lambda (obj) - (cons obj (slot-value obj ts))) res)))) + (cons obj (slot-value obj ts))) res)))) (defun fault-join-target-slot (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) - (ts (gethash :target-slot dbi)) - (jc (gethash :join-class dbi)) - (jc-view-table (view-table (find-class jc))) - (tdbi (view-class-slot-db-info - (find ts (class-slots (find-class jc)) - :key #'slot-definition-name))) - (retrieval (gethash :retrieval tdbi)) - (tsc (gethash :join-class tdbi)) - (ts-view-table (view-table (find-class tsc))) - (jq (join-qualifier class object slot-def)) - (key (slot-value object (gethash :home-key dbi)))) + (ts (gethash :target-slot dbi)) + (jc (gethash :join-class dbi)) + (jc-view-table (view-table (find-class jc))) + (tdbi (view-class-slot-db-info + (find ts (class-slots (find-class jc)) + :key #'slot-definition-name))) + (retrieval (gethash :retrieval tdbi)) + (tsc (gethash :join-class tdbi)) + (ts-view-table (view-table (find-class tsc))) + (jq (join-qualifier class object slot-def)) + (key (slot-value object (gethash :home-key dbi)))) (when jq (ecase retrieval - (:immediate - (let ((res - (find-all (list tsc) - :inner-join (sql-expression :table jc-view-table) - :on (sql-operation - '== - (sql-expression - :attribute (gethash :foreign-key tdbi) - :table ts-view-table) - (sql-expression - :attribute (gethash :home-key tdbi) - :table jc-view-table)) - :where jq - :result-types :auto - :database (view-database object)))) - (mapcar #'(lambda (i) - (let* ((instance (car i)) - (jcc (make-instance jc :view-database (view-database instance)))) - (setf (slot-value jcc (gethash :foreign-key dbi)) - key) - (setf (slot-value jcc (gethash :home-key tdbi)) - (slot-value instance (gethash :foreign-key tdbi))) - (list instance jcc))) - res))) - (:deferred - ;; just fill in minimal slots - (mapcar - #'(lambda (k) - (let ((instance (make-instance tsc :view-database (view-database object))) - (jcc (make-instance jc :view-database (view-database object))) - (fk (car k))) - (setf (slot-value instance (gethash :home-key tdbi)) fk) - (setf (slot-value jcc (gethash :foreign-key dbi)) - key) - (setf (slot-value jcc (gethash :home-key tdbi)) - fk) - (list instance jcc))) - (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table) - :from (sql-expression :table jc-view-table) - :where jq - :database (view-database object)))))))) + (:immediate + (let ((res + (find-all (list tsc) + :inner-join (sql-expression :table jc-view-table) + :on (sql-operation + '== + (sql-expression + :attribute (gethash :foreign-key tdbi) + :table ts-view-table) + (sql-expression + :attribute (gethash :home-key tdbi) + :table jc-view-table)) + :where jq + :result-types :auto + :database (view-database object)))) + (mapcar #'(lambda (i) + (let* ((instance (car i)) + (jcc (make-instance jc :view-database (view-database instance)))) + (setf (slot-value jcc (gethash :foreign-key dbi)) + key) + (setf (slot-value jcc (gethash :home-key tdbi)) + (slot-value instance (gethash :foreign-key tdbi))) + (list instance jcc))) + res))) + (:deferred + ;; just fill in minimal slots + (mapcar + #'(lambda (k) + (let ((instance (make-instance tsc :view-database (view-database object))) + (jcc (make-instance jc :view-database (view-database object))) + (fk (car k))) + (setf (slot-value instance (gethash :home-key tdbi)) fk) + (setf (slot-value jcc (gethash :foreign-key dbi)) + key) + (setf (slot-value jcc (gethash :home-key tdbi)) + fk) + (list instance jcc))) + (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table) + :from (sql-expression :table jc-view-table) + :where jq + :database (view-database object)))))))) ;;; Remote Joins @@ -691,8 +691,8 @@ UPDATE-OBJECT-JOINS.") (defun update-objects-joins (objects &key (slots t) (force-p t) - class-name (max-len - *default-update-objects-max-len*)) + class-name (max-len + *default-update-objects-max-len*)) "Updates from the records of the appropriate database tables the join slots specified by SLOTS in the supplied list of View Class instances OBJECTS. SLOTS is t by default which means that @@ -710,105 +710,105 @@ maximum of MAX-LEN instances updated in each query." (unless class-name (setq class-name (class-name (class-of (first objects))))) (let* ((class (find-class class-name)) - (class-slots (ordered-class-slots class)) - (slotdefs - (if (eq t slots) - (generate-retrieval-joins-list class :deferred) - (remove-if #'null - (mapcar #'(lambda (name) - (let ((slotdef (find name class-slots :key #'slot-definition-name))) - (unless slotdef - (warn "Unable to find slot named ~S in class ~S." name class)) - slotdef)) - slots))))) + (class-slots (ordered-class-slots class)) + (slotdefs + (if (eq t slots) + (generate-retrieval-joins-list class :deferred) + (remove-if #'null + (mapcar #'(lambda (name) + (let ((slotdef (find name class-slots :key #'slot-definition-name))) + (unless slotdef + (warn "Unable to find slot named ~S in class ~S." name class)) + slotdef)) + slots))))) (dolist (slotdef slotdefs) - (let* ((dbi (view-class-slot-db-info slotdef)) - (slotdef-name (slot-definition-name slotdef)) - (foreign-key (gethash :foreign-key dbi)) - (home-key (gethash :home-key dbi)) - (object-keys - (remove-duplicates - (if force-p - (mapcar #'(lambda (o) (slot-value o home-key)) objects) - (remove-if #'null - (mapcar - #'(lambda (o) (if (slot-boundp o slotdef-name) - nil - (slot-value o home-key))) - objects))))) - (n-object-keys (length object-keys)) - (query-len (or max-len n-object-keys))) - - (do ((i 0 (+ i query-len))) - ((>= i n-object-keys)) - (let* ((keys (if max-len - (subseq object-keys i (min (+ i query-len) n-object-keys)) - object-keys)) - (results (unless (gethash :target-slot dbi) - (find-all (list (gethash :join-class dbi)) - :where (make-instance 'sql-relational-exp - :operator 'in - :sub-expressions (list (sql-expression :attribute foreign-key) - keys)) - :result-types :auto - :flatp t)) )) - - (dolist (object objects) - (when (or force-p (not (slot-boundp object slotdef-name))) - (let ((res (if results - (remove-if-not #'(lambda (obj) - (equal obj (slot-value - object - home-key))) - results - :key #'(lambda (res) - (slot-value res - foreign-key))) - - (progn - (when (gethash :target-slot dbi) - (fault-join-target-slot class object slotdef)))))) - (when res - (setf (slot-value object slotdef-name) - (if (gethash :set dbi) res (car res))))))))))))) + (let* ((dbi (view-class-slot-db-info slotdef)) + (slotdef-name (slot-definition-name slotdef)) + (foreign-key (gethash :foreign-key dbi)) + (home-key (gethash :home-key dbi)) + (object-keys + (remove-duplicates + (if force-p + (mapcar #'(lambda (o) (slot-value o home-key)) objects) + (remove-if #'null + (mapcar + #'(lambda (o) (if (slot-boundp o slotdef-name) + nil + (slot-value o home-key))) + objects))))) + (n-object-keys (length object-keys)) + (query-len (or max-len n-object-keys))) + + (do ((i 0 (+ i query-len))) + ((>= i n-object-keys)) + (let* ((keys (if max-len + (subseq object-keys i (min (+ i query-len) n-object-keys)) + object-keys)) + (results (unless (gethash :target-slot dbi) + (find-all (list (gethash :join-class dbi)) + :where (make-instance 'sql-relational-exp + :operator 'in + :sub-expressions (list (sql-expression :attribute foreign-key) + keys)) + :result-types :auto + :flatp t)) )) + + (dolist (object objects) + (when (or force-p (not (slot-boundp object slotdef-name))) + (let ((res (if results + (remove-if-not #'(lambda (obj) + (equal obj (slot-value + object + home-key))) + results + :key #'(lambda (res) + (slot-value res + foreign-key))) + + (progn + (when (gethash :target-slot dbi) + (fault-join-target-slot class object slotdef)))))) + (when res + (setf (slot-value object slotdef-name) + (if (gethash :set dbi) res (car res))))))))))))) (values)) (defun fault-join-slot-raw (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) - (jc (gethash :join-class dbi))) + (jc (gethash :join-class dbi))) (let ((jq (join-qualifier class object slot-def))) (when jq (select jc :where jq :flatp t :result-types nil - :database (view-database object)))))) + :database (view-database object)))))) (defun fault-join-slot (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) - (ts (gethash :target-slot dbi))) + (ts (gethash :target-slot dbi))) (if (and ts (gethash :set dbi)) - (fault-join-target-slot class object slot-def) - (let ((res (fault-join-slot-raw class object slot-def))) - (when res - (cond - ((and ts (not (gethash :set dbi))) - (mapcar (lambda (obj) (slot-value obj ts)) res)) - ((and (not ts) (not (gethash :set dbi))) - (car res)) - ((and (not ts) (gethash :set dbi)) - res))))))) + (fault-join-target-slot class object slot-def) + (let ((res (fault-join-slot-raw class object slot-def))) + (when res + (cond + ((and ts (not (gethash :set dbi))) + (mapcar (lambda (obj) (slot-value obj ts)) res)) + ((and (not ts) (not (gethash :set dbi))) + (car res)) + ((and (not ts) (gethash :set dbi)) + res))))))) (defun join-qualifier (class object slot-def) (declare (ignore class)) (let* ((dbi (view-class-slot-db-info slot-def)) - (jc (find-class (gethash :join-class dbi))) - ;;(ts (gethash :target-slot dbi)) - ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc))) - (foreign-keys (gethash :foreign-key dbi)) - (home-keys (gethash :home-key dbi))) + (jc (find-class (gethash :join-class dbi))) + ;;(ts (gethash :target-slot dbi)) + ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc))) + (foreign-keys (gethash :foreign-key dbi)) + (home-keys (gethash :home-key dbi))) (when (every #'(lambda (slt) - (and (slot-boundp object slt) + (and (slot-boundp object slt) (not (null (slot-value object slt))))) - (if (listp home-keys) home-keys (list home-keys))) - (let ((jc + (if (listp home-keys) home-keys (list home-keys))) + (let ((jc (mapcar #'(lambda (hk fk) (let ((fksd (slotdef-for-slot-with-class fk jc))) (sql-operation '== @@ -842,67 +842,67 @@ maximum of MAX-LEN instances updated in each query." (defun build-objects (vals sclasses immediate-join-classes sels immediate-joins database refresh flatp instances) "Used by find-all to build objects." (labels ((build-object (vals vclass jclasses selects immediate-selects instance) - (let* ((db-vals (butlast vals (- (list-length vals) - (list-length selects)))) - (obj (if instance instance (make-instance (class-name vclass) :view-database database))) - (join-vals (subseq vals (list-length selects))) - (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database))) - jclasses))) - - ;;(format t "joins: ~S~%db-vals: ~S~%join-values: ~S~%selects: ~S~%immediate-selects: ~S~%" - ;;joins db-vals join-vals selects immediate-selects) - - ;; use refresh keyword here - (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals)) - (mapc #'(lambda (jo) - ;; find all immediate-select slots and join-vals for this object - (let* ((slots (class-slots (class-of jo))) - (pos-list (remove-if #'null - (mapcar - #'(lambda (s) - (position s immediate-selects - :key #'car - :test #'eq)) - slots)))) - (get-slot-values-from-view jo - (mapcar #'car - (mapcar #'(lambda (pos) - (nth pos immediate-selects)) - pos-list)) - (mapcar #'(lambda (pos) (nth pos join-vals)) - pos-list)))) - joins) - (mapc - #'(lambda (jc) - (let ((slot (find (class-name (class-of jc)) (class-slots vclass) - :key #'(lambda (slot) - (when (and (eq :join (view-class-slot-db-kind slot)) - (eq (slot-definition-name slot) - (gethash :join-class (view-class-slot-db-info slot)))) - (slot-definition-name slot)))))) - (when slot - (setf (slot-value obj (slot-definition-name slot)) jc)))) - joins) - (when refresh (instance-refreshed obj)) - obj))) + (let* ((db-vals (butlast vals (- (list-length vals) + (list-length selects)))) + (obj (if instance instance (make-instance (class-name vclass) :view-database database))) + (join-vals (subseq vals (list-length selects))) + (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database))) + jclasses))) + + ;;(format t "joins: ~S~%db-vals: ~S~%join-values: ~S~%selects: ~S~%immediate-selects: ~S~%" + ;;joins db-vals join-vals selects immediate-selects) + + ;; use refresh keyword here + (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals)) + (mapc #'(lambda (jo) + ;; find all immediate-select slots and join-vals for this object + (let* ((slots (class-slots (class-of jo))) + (pos-list (remove-if #'null + (mapcar + #'(lambda (s) + (position s immediate-selects + :key #'car + :test #'eq)) + slots)))) + (get-slot-values-from-view jo + (mapcar #'car + (mapcar #'(lambda (pos) + (nth pos immediate-selects)) + pos-list)) + (mapcar #'(lambda (pos) (nth pos join-vals)) + pos-list)))) + joins) + (mapc + #'(lambda (jc) + (let ((slot (find (class-name (class-of jc)) (class-slots vclass) + :key #'(lambda (slot) + (when (and (eq :join (view-class-slot-db-kind slot)) + (eq (slot-definition-name slot) + (gethash :join-class (view-class-slot-db-info slot)))) + (slot-definition-name slot)))))) + (when slot + (setf (slot-value obj (slot-definition-name slot)) jc)))) + joins) + (when refresh (instance-refreshed obj)) + obj))) (let* ((objects - (mapcar #'(lambda (sclass jclass sel immediate-join instance) - (prog1 - (build-object vals sclass jclass sel immediate-join instance) - (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join)) - vals)))) - sclasses immediate-join-classes sels immediate-joins instances))) + (mapcar #'(lambda (sclass jclass sel immediate-join instance) + (prog1 + (build-object vals sclass jclass sel immediate-join instance) + (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join)) + vals)))) + sclasses immediate-join-classes sels immediate-joins instances))) (if (and flatp (= (length sclasses) 1)) - (car objects) - objects)))) + (car objects) + objects)))) (defun find-all (view-classes - &rest args - &key all set-operation distinct from where group-by having - order-by offset limit refresh flatp result-types + &rest args + &key all set-operation distinct from where group-by having + order-by offset limit refresh flatp result-types inner-join on - (database *default-database*) - instances) + (database *default-database*) + instances) "Called by SELECT to generate object query results when the View Classes VIEW-CLASSES are passed as arguments to SELECT." (declare (ignore all set-operation group-by having offset limit inner-join on)) @@ -922,100 +922,100 @@ maximum of MAX-LEN instances updated in each query." (remf args :result-types) (remf args :instances) (let* ((*db-deserializing* t) - (sclasses (mapcar #'find-class view-classes)) - (immediate-join-slots - (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses)) - (immediate-join-classes - (mapcar #'(lambda (jcs) - (mapcar #'(lambda (slotdef) - (find-class (gethash :join-class (view-class-slot-db-info slotdef)))) - jcs)) - immediate-join-slots)) - (immediate-join-sels (mapcar #'generate-immediate-joins-selection-list sclasses)) - (sels (mapcar #'generate-selection-list sclasses)) - (fullsels (apply #'append (mapcar #'append sels immediate-join-sels))) - (sel-tables (collect-table-refs where)) - (tables (remove-if #'null - (remove-duplicates - (append (mapcar #'table-sql-expr sclasses) - (mapcan #'(lambda (jc-list) - (mapcar - #'(lambda (jc) (when jc (table-sql-expr jc))) - jc-list)) - immediate-join-classes) - sel-tables) - :test #'tables-equal))) - (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob))) - (listify order-by))) - (join-where nil)) + (sclasses (mapcar #'find-class view-classes)) + (immediate-join-slots + (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses)) + (immediate-join-classes + (mapcar #'(lambda (jcs) + (mapcar #'(lambda (slotdef) + (find-class (gethash :join-class (view-class-slot-db-info slotdef)))) + jcs)) + immediate-join-slots)) + (immediate-join-sels (mapcar #'generate-immediate-joins-selection-list sclasses)) + (sels (mapcar #'generate-selection-list sclasses)) + (fullsels (apply #'append (mapcar #'append sels immediate-join-sels))) + (sel-tables (collect-table-refs where)) + (tables (remove-if #'null + (remove-duplicates + (append (mapcar #'table-sql-expr sclasses) + (mapcan #'(lambda (jc-list) + (mapcar + #'(lambda (jc) (when jc (table-sql-expr jc))) + jc-list)) + immediate-join-classes) + sel-tables) + :test #'tables-equal))) + (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob))) + (listify order-by))) + (join-where nil)) ;;(format t "sclasses: ~W~%ijc: ~W~%tables: ~W~%" sclasses immediate-join-classes tables) (dolist (ob order-by-slots) - (when (and ob (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - order-by-slots))))) + (when (and ob (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels + (append fullsels (mapcar #'(lambda (att) (cons nil att)) + order-by-slots))))) (dolist (ob (listify distinct)) - (when (and (typep ob 'sql-ident) - (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) + (when (and (typep ob 'sql-ident) + (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels + (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) (mapcar #'(lambda (vclass jclasses jslots) - (when jclasses - (mapcar - #'(lambda (jclass jslot) - (let ((dbi (view-class-slot-db-info jslot))) - (setq join-where - (append - (list (sql-operation '== - (sql-expression - :attribute (gethash :foreign-key dbi) - :table (view-table jclass)) - (sql-expression - :attribute (gethash :home-key dbi) - :table (view-table vclass)))) - (when join-where (listify join-where)))))) - jclasses jslots))) - sclasses immediate-join-classes immediate-join-slots) + (when jclasses + (mapcar + #'(lambda (jclass jslot) + (let ((dbi (view-class-slot-db-info jslot))) + (setq join-where + (append + (list (sql-operation '== + (sql-expression + :attribute (gethash :foreign-key dbi) + :table (view-table jclass)) + (sql-expression + :attribute (gethash :home-key dbi) + :table (view-table vclass)))) + (when join-where (listify join-where)))))) + jclasses jslots))) + sclasses immediate-join-classes immediate-join-slots) ;; Reported buggy on clsql-devel ;; (when where (setq where (listify where))) (cond ((and where join-where) - (setq where (list (apply #'sql-and where join-where)))) + (setq where (list (apply #'sql-and where join-where)))) ((and (null where) (> (length join-where) 1)) - (setq where (list (apply #'sql-and join-where))))) + (setq where (list (apply #'sql-and join-where))))) (let* ((rows (apply #'select - (append (mapcar #'cdr fullsels) - (cons :from - (list (append (when from (listify from)) - (listify tables)))) - (list :result-types result-types) - (when where - (list :where where)) - args))) - (instances-to-add (- (length rows) (length instances))) - (perhaps-extended-instances - (if (plusp instances-to-add) - (append instances (do ((i 0 (1+ i)) - (res nil)) - ((= i instances-to-add) res) - (push (make-list (length sclasses) :initial-element nil) res))) - instances)) - (objects (mapcar - #'(lambda (row instance) - (build-objects row sclasses immediate-join-classes sels - immediate-join-sels database refresh flatp - (if (and flatp (atom instance)) - (list instance) - instance))) - rows perhaps-extended-instances))) - objects)))) + (append (mapcar #'cdr fullsels) + (cons :from + (list (append (when from (listify from)) + (listify tables)))) + (list :result-types result-types) + (when where + (list :where where)) + args))) + (instances-to-add (- (length rows) (length instances))) + (perhaps-extended-instances + (if (plusp instances-to-add) + (append instances (do ((i 0 (1+ i)) + (res nil)) + ((= i instances-to-add) res) + (push (make-list (length sclasses) :initial-element nil) res))) + instances)) + (objects (mapcar + #'(lambda (row instance) + (build-objects row sclasses immediate-join-classes sels + immediate-join-sels database refresh flatp + (if (and flatp (atom instance)) + (list instance) + instance))) + rows perhaps-extended-instances))) + objects)))) (defmethod instance-refreshed ((instance standard-db-object))) @@ -1154,18 +1154,18 @@ as elements of a list." (defun compute-records-cache-key (targets qualifiers) (list targets - (do ((args *select-arguments* (cdr args)) - (results nil)) - ((null args) results) - (let* ((arg (car args)) - (value (getf qualifiers arg))) - (when value - (push (list arg - (typecase value - (cons (cons (sql (car value)) (cdr value))) - (%sql-expression (sql value)) - (t value))) - results)))))) + (do ((args *select-arguments* (cdr args)) + (results nil)) + ((null args) results) + (let* ((arg (car args)) + (value (getf qualifiers arg))) + (when value + (push (list arg + (typecase value + (cons (cons (sql (car value)) (cdr value))) + (%sql-expression (sql value)) + (t value))) + results)))))) (defun records-cache-results (targets qualifiers database) (when (record-caches database) @@ -1174,12 +1174,12 @@ as elements of a list." (defun (setf records-cache-results) (results targets qualifiers database) (unless (record-caches database) (setf (record-caches database) - (make-hash-table :test 'equal - #+allegro :values #+allegro :weak - #+clisp :weak #+clisp :value + (make-hash-table :test 'equal + #+allegro :values #+allegro :weak + #+clisp :weak #+clisp :value #+lispworks :weak-kind #+lispworks :value))) (setf (gethash (compute-records-cache-key targets qualifiers) - (record-caches database)) results) + (record-caches database)) results) results) @@ -1190,12 +1190,12 @@ as elements of a list." "Writes an instance to a stream where it can be later be read. NOTE: an error will occur if a slot holds a value which can not be written readably." (let* ((class (class-of obj)) - (alist '())) + (alist '())) (dolist (slot (ordered-class-slots (class-of obj))) (let ((name (slot-definition-name slot))) - (when (and (not (eq 'view-database name)) - (slot-boundp obj name)) - (push (cons name (slot-value obj name)) alist)))) + (when (and (not (eq 'view-database name)) + (slot-boundp obj name)) + (push (cons name (slot-value obj name)) alist)))) (setq alist (reverse alist)) (write (cons (class-name class) alist) :stream stream :readably t)) obj) @@ -1204,6 +1204,6 @@ NOTE: an error will occur if a slot holds a value which can not be written reada (let ((raw (read stream nil nil))) (when raw (let ((obj (make-instance (car raw)))) - (dolist (pair (cdr raw)) - (setf (slot-value obj (car pair)) (cdr pair))) - obj)))) + (dolist (pair (cdr raw)) + (setf (slot-value obj (car pair)) (cdr pair))) + obj)))) diff --git a/sql/operations.lisp b/sql/operations.lisp index 94ee209..a3f6bbd 100644 --- a/sql/operations.lisp +++ b/sql/operations.lisp @@ -3,7 +3,7 @@ ;;;; ;;;; $Id$ ;;;; -;;;; Definition of SQL operations used with the symbolic SQL syntax. +;;;; Definition of SQL operations used with the symbolic SQL syntax. ;;;; ;;;; This file is part of CLSQL. ;;;; @@ -20,15 +20,15 @@ (defvar *sql-op-table* (make-hash-table :test #'equal)) -;; Define an SQL operation type. +;; Define an SQL operation type. (defmacro defsql (function definition-keys &body body) `(progn (defun ,function ,@body) (let ((symbol (cadr (member :symbol ',definition-keys)))) (setf (gethash (if symbol (symbol-name-default-case symbol) ',function) - *sql-op-table*) - ',function)))) + *sql-op-table*) + ',function)))) ;; SQL operations @@ -38,65 +38,65 @@ (defsql sql-any (:symbol "any") (&rest rest) (make-instance 'sql-function-exp - :name 'any :args rest)) + :name 'any :args rest)) (defsql sql-some (:symbol "some") (&rest rest) (make-instance 'sql-function-exp - :name 'some :args rest)) + :name 'some :args rest)) (defsql sql-all (:symbol "all") (&rest rest) (make-instance 'sql-function-exp - :name 'all :args rest)) + :name 'all :args rest)) (defsql sql-not (:symbol "not") (&rest rest) (make-instance 'sql-value-exp - :modifier 'not :components rest)) + :modifier 'not :components rest)) (defsql sql-union (:symbol "union") (&rest rest) (make-instance 'sql-set-exp - :operator 'union :sub-expressions rest)) + :operator 'union :sub-expressions rest)) (defsql sql-intersect (:symbol "intersect") (&rest rest) (make-instance 'sql-set-exp - :operator 'intersect :sub-expressions rest)) + :operator 'intersect :sub-expressions rest)) -(defsql sql-except (:symbol "except") (&rest rest) - (make-instance 'sql-set-exp - :operator 'except :sub-expressions rest)) +(defsql sql-except (:symbol "except") (&rest rest) + (make-instance 'sql-set-exp + :operator 'except :sub-expressions rest)) (defsql sql-minus (:symbol "minus") (&rest rest) - (make-instance 'sql-set-exp - :operator 'minus :sub-expressions rest)) + (make-instance 'sql-set-exp + :operator 'minus :sub-expressions rest)) (defsql sql-limit (:symbol "limit") (&rest rest) - (make-instance 'sql-query-modifier-exp - :modifier 'limit :components rest)) + (make-instance 'sql-query-modifier-exp + :modifier 'limit :components rest)) (defsql sql-group-by (:symbol "group-by") (&rest rest) - (make-instance 'sql-query-modifier-exp - :modifier '|group by| :components rest)) + (make-instance 'sql-query-modifier-exp + :modifier '|group by| :components rest)) (defsql sql-order-by (:symbol "order-by") (&rest rest) - (make-instance 'sql-query-modifier-exp - :modifier '|order by| :components rest)) + (make-instance 'sql-query-modifier-exp + :modifier '|order by| :components rest)) (defsql sql-having (:symbol "having") (&rest rest) - (make-instance 'sql-query-modifier-exp - :modifier 'having :components rest)) + (make-instance 'sql-query-modifier-exp + :modifier 'having :components rest)) (defsql sql-null (:symbol "null") (&rest rest) (if rest - (make-instance 'sql-relational-exp :operator 'is + (make-instance 'sql-relational-exp :operator 'is :sub-expressions (list (car rest) nil)) (make-instance 'sql-value-exp :components 'null))) (defsql sql-not-null (:symbol "not-null") () (make-instance 'sql-value-exp - :components '|NOT NULL|)) + :components '|NOT NULL|)) (defsql sql-exists (:symbol "exists") (&rest rest) (make-instance 'sql-function-exp - :name 'exists :args rest)) + :name 'exists :args rest)) (defsql sql-* (:symbol "*") (&rest rest) (if (zerop (length rest)) @@ -111,7 +111,7 @@ (defsql sql-/ (:symbol "/") (&rest rest) (make-instance 'sql-relational-exp - :operator '/ :sub-expressions rest)) + :operator '/ :sub-expressions rest)) (defsql sql-- (:symbol "-") (&rest rest) (if (cdr rest) @@ -121,19 +121,19 @@ (defsql sql-like (:symbol "like") (&rest rest) (make-instance 'sql-relational-exp - :operator 'like :sub-expressions rest)) + :operator 'like :sub-expressions rest)) (defsql sql-uplike (:symbol "uplike") (&rest rest) (make-instance 'sql-upcase-like - :sub-expressions rest)) + :sub-expressions rest)) (defsql sql-and (:symbol "and") (&rest rest) (make-instance 'sql-relational-exp - :operator 'and :sub-expressions rest)) + :operator 'and :sub-expressions rest)) (defsql sql-or (:symbol "or") (&rest rest) (make-instance 'sql-relational-exp - :operator 'or :sub-expressions rest)) + :operator 'or :sub-expressions rest)) (defsql sql-in (:symbol "in") (&rest rest) (make-instance 'sql-relational-exp @@ -141,44 +141,44 @@ (defsql sql-concat-op (:symbol "concat-op") (&rest rest) (make-instance 'sql-relational-exp - :operator '\|\| :sub-expressions rest)) + :operator '\|\| :sub-expressions rest)) (defsql sql-concat (:symbol "concat") (&rest rest) (make-instance 'sql-function-exp - :name 'concat :args rest)) + :name 'concat :args rest)) (defsql sql-substr (:symbol "substr") (&rest rest) (if (= (length rest) 3) - (make-instance 'sql-function-exp - :name 'substr :args rest) + (make-instance 'sql-function-exp + :name 'substr :args rest) (error 'sql-user-error :message "SUBSTR must have 3 arguments."))) (defsql sql-substring (:symbol "substring") (&rest rest) (if (= (length rest) 3) - (make-instance 'sql-function-exp - :name 'substring :args rest) + (make-instance 'sql-function-exp + :name 'substring :args rest) (error 'sql-user-error :message "SUBSTRING must have 3 arguments."))) (defsql sql-is (:symbol "is") (&rest rest) (make-instance 'sql-relational-exp - :operator 'is :sub-expressions rest)) + :operator 'is :sub-expressions rest)) (defsql sql-= (:symbol "=") (&rest rest) (make-instance 'sql-relational-exp - :operator '= :sub-expressions rest)) + :operator '= :sub-expressions rest)) (defsql sql-== (:symbol "==") (&rest rest) (make-instance 'sql-assignment-exp - :operator '= :sub-expressions rest)) + :operator '= :sub-expressions rest)) (defsql sql-< (:symbol "<") (&rest rest) (make-instance 'sql-relational-exp - :operator '< :sub-expressions rest)) + :operator '< :sub-expressions rest)) (defsql sql-> (:symbol ">") (&rest rest) (make-instance 'sql-relational-exp - :operator '> :sub-expressions rest)) + :operator '> :sub-expressions rest)) (defsql sql-<> (:symbol "<>") (&rest rest) (make-instance 'sql-relational-exp @@ -186,38 +186,38 @@ (defsql sql->= (:symbol ">=") (&rest rest) (make-instance 'sql-relational-exp - :operator '>= :sub-expressions rest)) + :operator '>= :sub-expressions rest)) (defsql sql-<= (:symbol "<=") (&rest rest) (make-instance 'sql-relational-exp - :operator '<= :sub-expressions rest)) + :operator '<= :sub-expressions rest)) (defsql sql-count (:symbol "count") (&rest rest) (make-instance 'sql-function-exp - :name 'count :args rest)) + :name 'count :args rest)) (defsql sql-max (:symbol "max") (&rest rest) (make-instance 'sql-function-exp - :name 'max :args rest)) + :name 'max :args rest)) (defsql sql-min (:symbol "min") (&rest rest) (make-instance 'sql-function-exp - :name 'min :args rest)) + :name 'min :args rest)) (defsql sql-avg (:symbol "avg") (&rest rest) (make-instance 'sql-function-exp - :name 'avg :args rest)) + :name 'avg :args rest)) (defsql sql-sum (:symbol "sum") (&rest rest) (make-instance 'sql-function-exp - :name 'sum :args rest)) + :name 'sum :args rest)) (defsql sql-the (:symbol "the") (&rest rest) (make-instance 'sql-typecast-exp - :modifier (first rest) :components (second rest))) + :modifier (first rest) :components (second rest))) (defsql sql-function (:symbol "function") (&rest args) - (make-instance 'sql-function-exp + (make-instance 'sql-function-exp :name (make-symbol (car args)) :args (cdr args))) (defsql sql-between (:symbol "between") (&rest rest) @@ -226,22 +226,22 @@ (error 'sql-user-error :message "BETWEEN must have 3 arguments."))) (defsql sql-distinct (:symbol "distinct") (&rest rest) - (make-instance 'sql-query-modifier-exp :modifier 'distinct - :components rest)) + (make-instance 'sql-query-modifier-exp :modifier 'distinct + :components rest)) (defsql sql-coalesce (:symbol "coalesce") (&rest rest) (make-instance 'sql-function-exp - :name 'coalesce :args rest)) + :name 'coalesce :args rest)) (defsql sql-nvl (:symbol "nvl") (&rest rest) - (if (= (length rest) 2) + (if (= (length rest) 2) (make-instance 'sql-function-exp :name 'coalesce :args rest) (error 'sql-user-error :message "NVL accepts exactly 2 arguments."))) (defsql sql-userenv (:symbol "userenv") (&rest rest) (make-instance 'sql-function-exp - :name 'userenv :args rest)) + :name 'userenv :args rest)) (defsql sql-lower (:symbol "lower") (&rest rest) (if (= (length rest) 1) diff --git a/sql/package.lisp b/sql/package.lisp index 8ef8381..fbb67b4 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -27,7 +27,7 @@ #+cmu (if (eq (symbol-package 'pcl:find-class) - (find-package 'common-lisp)) + (find-package 'common-lisp)) (pushnew :clsql-cmucl-mop cl:*features*) (pushnew :clsql-cmucl-pcl cl:*features*))) @@ -35,13 +35,13 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defpackage #:clsql-sys (:use #:common-lisp - #+clsql-sbcl-mop #:sb-mop - #+clsql-cmucl-mop #:mop - #+allegro #:mop - #+clisp #:clos - #+lispworks #:clos - #+scl #:clos - #+openmcl #:openmcl-mop) + #+clsql-sbcl-mop #:sb-mop + #+clsql-cmucl-mop #:mop + #+allegro #:mop + #+clisp #:clos + #+lispworks #:clos + #+scl #:clos + #+openmcl #:openmcl-mop) #+allegro (:shadowing-import-from @@ -233,22 +233,22 @@ #:*foreign-library-search-paths* #:push-library-path - ;; Condition system (conditions.lisp) - #:sql-user-error - #:sql-database-error - #:sql-database-data-error - #:sql-connection-error - #:sql-temporary-error + ;; Condition system (conditions.lisp) + #:sql-user-error + #:sql-database-error + #:sql-database-data-error + #:sql-connection-error + #:sql-temporary-error #:sql-timeout-error #:sql-fatal-error - #:sql-error-error-id - #:sql-error-secondary-error-id - #:sql-error-database-message - ;; CLSQL Extensions - #:sql-condition - #:sql-error - #:sql-warning - #:sql-database-warning + #:sql-error-error-id + #:sql-error-secondary-error-id + #:sql-error-database-message + ;; CLSQL Extensions + #:sql-condition + #:sql-error + #:sql-warning + #:sql-database-warning #:sql-error-database #:sql-error-database-type #:sql-error-connection-spec @@ -292,50 +292,50 @@ #:start-sql-recording #:stop-sql-recording - ;; FDDL (fddl.lisp) - #:create-table - #:drop-table - #:list-tables - #:table-exists-p - #:list-attributes - #:attribute-type - #:list-attribute-types - #:create-view - #:drop-view - #:create-index - #:drop-index + ;; FDDL (fddl.lisp) + #:create-table + #:drop-table + #:list-tables + #:table-exists-p + #:list-attributes + #:attribute-type + #:list-attribute-types + #:create-view + #:drop-view + #:create-index + #:drop-index ;; CLSQL Extensions #:truncate-database - #:list-views - #:view-exists-p - #:list-indexes - #:index-exists-p - #:create-sequence - #:drop-sequence - #:list-sequences - #:sequence-exists-p - #:sequence-next - #:sequence-last - #:set-sequence-position + #:list-views + #:view-exists-p + #:list-indexes + #:index-exists-p + #:create-sequence + #:drop-sequence + #:list-sequences + #:sequence-exists-p + #:sequence-next + #:sequence-last + #:set-sequence-position ;; FDML (fdml.lisp) - #:select - #:cache-table-queries - #:*cache-table-queries-default* - #:delete-records - #:insert-records - #:update-records - #:execute-command - #:query - #:print-query - #:do-query - #:map-query - #:loop + #:select + #:cache-table-queries + #:*cache-table-queries-default* + #:delete-records + #:insert-records + #:update-records + #:execute-command + #:query + #:print-query + #:do-query + #:map-query + #:loop ;; CLSQL Extensions - #:prepare-sql - #:bind-parameter - #:run-prepared-sql - #:free-prepared-sql + #:prepare-sql + #:bind-parameter + #:run-prepared-sql + #:free-prepared-sql ;; Transaction handling (transaction.lisp) #:with-transaction @@ -346,77 +346,77 @@ #:add-transaction-rollback-hook #:start-transaction #:in-transaction-p - #:set-autocommit - - ;; OODDL (ooddl.lisp) - #:standard-db-object - #:def-view-class - #:create-view-from-class - #:drop-view-from-class - #:list-classes - #:universal-time + #:set-autocommit + + ;; OODDL (ooddl.lisp) + #:standard-db-object + #:def-view-class + #:create-view-from-class + #:drop-view-from-class + #:list-classes + #:universal-time + ;; CLSQL Extensions + #:view-table + #:bigint + #:varchar + #:generalized-boolean + #:mediumint + #:smallint + #:tinyint + #:*default-string-length* + + ;; OODML (oodml.lisp) + #:instance-refreshed + #:update-objects-joins + #:*default-update-objects-max-len* + #:*default-caching* + #:update-slot-from-record + #:update-instance-from-records + #:update-records-from-instance + #:update-record-from-slot + #:update-record-from-slots + #:delete-instance-records ;; CLSQL Extensions - #:view-table - #:bigint - #:varchar - #:generalized-boolean - #:mediumint - #:smallint - #:tinyint - #:*default-string-length* - - ;; OODML (oodml.lisp) - #:instance-refreshed - #:update-objects-joins - #:*default-update-objects-max-len* - #:*default-caching* - #:update-slot-from-record - #:update-instance-from-records - #:update-records-from-instance - #:update-record-from-slot - #:update-record-from-slots - #:delete-instance-records - ;; CLSQL Extensions - #:*db-auto-sync* - #:write-instance-to-stream - #:read-instance-from-stream - - ;; Symbolic SQL Syntax (syntax.lisp) - #:sql - #:sql-expression - #:sql-operation - #:sql-operator - #:disable-sql-reader-syntax - #:enable-sql-reader-syntax - #:locally-disable-sql-reader-syntax - #:locally-enable-sql-reader-syntax - #:restore-sql-reader-syntax-state - - ;; SQL operations (operations.lisp) - #:sql-query - #:sql-object-query - #:sql-any + #:*db-auto-sync* + #:write-instance-to-stream + #:read-instance-from-stream + + ;; Symbolic SQL Syntax (syntax.lisp) + #:sql + #:sql-expression + #:sql-operation + #:sql-operator + #:disable-sql-reader-syntax + #:enable-sql-reader-syntax + #:locally-disable-sql-reader-syntax + #:locally-enable-sql-reader-syntax + #:restore-sql-reader-syntax-state + + ;; SQL operations (operations.lisp) + #:sql-query + #:sql-object-query + #:sql-any #:sql-some - #:sql-all - #:sql-not - #:sql-union - #:sql-intersect - #:sql-minus + #:sql-all + #:sql-not + #:sql-union + #:sql-intersect + #:sql-minus #:sql-except #:sql-order-by - #:sql-null - #:sql-* - #:sql-+ - #:sql-/ + #:sql-null + #:sql-* + #:sql-+ + #:sql-/ #:sql-- - #:sql-like - #:sql-and - #:sql-or - #:sql-in + #:sql-like + #:sql-and + #:sql-or + #:sql-in #:sql-substr #:sql-concat-op - #:sql-= - #:sql-< + #:sql-= + #:sql-< #:sql-> #:sql->= #:sql-<= @@ -433,16 +433,16 @@ #:sql-slot-value #:sql-userenv ;; CLSQL Extensions - #:sql-concat + #:sql-concat #:sql-substring #:sql-limit - #:sql-group-by - #:sql-having - #:sql-not-null - #:sql-exists - #:sql-uplike - #:sql-is - #:sql-== + #:sql-group-by + #:sql-having + #:sql-not-null + #:sql-exists + #:sql-uplike + #:sql-is + #:sql-== #:sql-the #:sql-coalesce #:sql-view-class @@ -454,10 +454,10 @@ #:current-year #:day-duration #:db-timestring - #:db-datestring + #:db-datestring #:decode-duration #:decode-time - #:decode-date + #:decode-date #:duration #:duration+ #:duration< @@ -476,9 +476,9 @@ #:extract-roman #:format-duration #:format-time - #:format-date + #:format-date #:get-time - #:get-date + #:get-date #:utime->time #:interval-clear #:interval-contained @@ -493,13 +493,13 @@ #:make-duration #:make-interval #:make-time - #:make-date + #:make-date #:merged-time #:midnight #:month-name #:parse-date-time #:parse-timestring - #:parse-datestring + #:parse-datestring #:parse-yearstring #:print-date #:roll @@ -525,23 +525,23 @@ #:time= #:time> #:time>= - #:date - #:date+ - #:date- - #:date-difference - #:date-compare - #:date-dow - #:date-element - #:date-max - #:date-min - #:date-mjd - #:date-p - #:date-ymd - #:date< - #:date<= - #:date= - #:date> - #:date>= + #:date + #:date+ + #:date- + #:date-difference + #:date-compare + #:date-dow + #:date-element + #:date-max + #:date-min + #:date-mjd + #:date-p + #:date-ymd + #:date< + #:date<= + #:date= + #:date> + #:date>= #:timezone #:universal-time #:wall-time @@ -572,12 +572,12 @@ ;; Note that this will no longer required for cmucl as of version 19a. (in-package #+cmu :pcl #+sbcl :sb-pcl) (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) - &body body) + &body body) `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) - (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) - slot-vars pv-parameters)) - ,@(mapcar #'(lambda (slot-var) `(declare (ignorable ,slot-var))) slot-vars) - ,@body)))) + (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) + slot-vars pv-parameters)) + ,@(mapcar #'(lambda (slot-var) `(declare (ignorable ,slot-var))) slot-vars) + ,@body)))) ;; see http://thread.gmane.org/gmane.lisp.lispworks.general/681 #+lispworks diff --git a/sql/pool.lisp b/sql/pool.lisp index 5573025..4573155 100644 --- a/sql/pool.lisp +++ b/sql/pool.lisp @@ -25,15 +25,15 @@ ((connection-spec :accessor connection-spec :initarg :connection-spec) (database-type :accessor pool-database-type :initarg :pool-database-type) (free-connections :accessor free-connections - :initform (make-array 5 :fill-pointer 0 :adjustable t)) + :initform (make-array 5 :fill-pointer 0 :adjustable t)) (all-connections :accessor all-connections - :initform (make-array 5 :fill-pointer 0 :adjustable t)) + :initform (make-array 5 :fill-pointer 0 :adjustable t)) (lock :accessor conn-pool-lock - :initform (make-process-lock "Connection pool")))) + :initform (make-process-lock "Connection pool")))) (defun acquire-from-conn-pool (pool) (or (with-process-lock ((conn-pool-lock pool) "Acquire from pool") - (when (plusp (length (free-connections pool))) + (when (plusp (length (free-connections pool))) (let ((pconn (vector-pop (free-connections pool)))) ;; test if connection still valid. ;; Currently, on supported on MySQL @@ -56,13 +56,13 @@ Disconnecting.~%" (t pconn))))) (let ((conn (connect (connection-spec pool) - :database-type (pool-database-type pool) - :if-exists :new + :database-type (pool-database-type pool) + :if-exists :new :make-default nil))) - (with-process-lock ((conn-pool-lock pool) "Acquire from pool") - (vector-push-extend conn (all-connections pool)) - (setf (conn-pool conn) pool)) - conn))) + (with-process-lock ((conn-pool-lock pool) "Acquire from pool") + (vector-push-extend conn (all-connections pool)) + (setf (conn-pool conn) pool)) + conn))) (defun release-to-conn-pool (conn) (let ((pool (conn-pool conn))) @@ -72,9 +72,9 @@ Disconnecting.~%" (defun clear-conn-pool (pool) (with-process-lock ((conn-pool-lock pool) "Clear pool") (loop for conn across (all-connections pool) - do (setf (conn-pool conn) nil) - ;; disconnect may error if remote side closed connection - (ignore-errors (disconnect :database conn))) + do (setf (conn-pool conn) nil) + ;; disconnect may error if remote side closed connection + (ignore-errors (disconnect :database conn))) (setf (fill-pointer (free-connections pool)) 0) (setf (fill-pointer (all-connections pool)) 0)) nil) @@ -84,12 +84,12 @@ Disconnecting.~%" if not found" (with-process-lock (*db-pool-lock* "Find-or-create connection") (let* ((key (list connection-spec database-type)) - (conn-pool (gethash key *db-pool*))) + (conn-pool (gethash key *db-pool*))) (unless conn-pool - (setq conn-pool (make-instance 'conn-pool - :connection-spec connection-spec - :pool-database-type database-type)) - (setf (gethash key *db-pool*) conn-pool)) + (setq conn-pool (make-instance 'conn-pool + :connection-spec connection-spec + :pool-database-type database-type)) + (setf (gethash key *db-pool*) conn-pool)) conn-pool))) (defun acquire-from-pool (connection-spec database-type &optional pool) @@ -105,8 +105,8 @@ if not found" (with-process-lock (*db-pool-lock* "Disconnect pooled") (maphash #'(lambda (key conn-pool) - (declare (ignore key)) - (clear-conn-pool conn-pool)) + (declare (ignore key)) + (clear-conn-pool conn-pool)) *db-pool*) (when clear (clrhash *db-pool*))) t) @@ -115,13 +115,13 @@ if not found" ; "Start all stream in the pool recording actions of TYPES" ; (dolist (con (pool-connections pool)) ; (start-sql-recording :type types -; :database (connection-database con)))) +; :database (connection-database con)))) ;(defun pool-stop-sql-recording (pool &key (types :command)) ; "Start all stream in the pool recording actions of TYPES" ; (dolist (con (pool-connections pool)) ; (stop-sql-recording :type types -; :database (connection-database con)))) +; :database (connection-database con)))) ;(defmacro with-database-connection (pool &body body) ; `(let ((connection (obtain-connection ,pool)) diff --git a/sql/recording.lisp b/sql/recording.lisp index 8bff335..4d0810a 100644 --- a/sql/recording.lisp +++ b/sql/recording.lisp @@ -50,7 +50,7 @@ by passing TYPE value of :both." (defun sql-recording-p (&key (type :commands) (database *default-database*)) "Predicate to test whether the SQL recording specified by TYPE -is currently enabled for DATABASE which defaults to *DEFAULT-DATABASE*. +is currently enabled for DATABASE which defaults to *DEFAULT-DATABASE*. TYPE may be one of :commands, :results, :both or :either, defaulting to :commands, otherwise nil is returned." (when (or (and (eq type :commands) @@ -88,7 +88,7 @@ both." (cons stream (list-sql-streams :type :results :database database)))))) stream) - + (defun delete-sql-stream (stream &key (type :commands) (database *default-database*)) "Removes the supplied stream STREAM from the recording broadcast @@ -142,12 +142,12 @@ returned is that used for recording SQL commands or results." (result-recording-stream database)) (t (error "Unknown recording type. ~A" type)))) - + (defun record-sql-command (expr database) (when database (with-slots (command-recording-stream) database - (when command-recording-stream + (when command-recording-stream (format command-recording-stream "~&;; ~A ~A => ~A~%" (iso-timestring (get-time)) (database-name database) @@ -157,11 +157,11 @@ returned is that used for recording SQL commands or results." (when database (with-slots (result-recording-stream) database - (when result-recording-stream + (when result-recording-stream (format result-recording-stream "~&;; ~A ~A <= ~A~%" (iso-timestring (get-time)) (database-name database) res))))) - + diff --git a/sql/sequences.lisp b/sql/sequences.lisp index b82b9b8..b96d78d 100644 --- a/sql/sequences.lisp +++ b/sql/sequences.lisp @@ -24,42 +24,42 @@ (defun %sequence-name-to-table (sequence-name database) (concatenate 'string - (convert-to-db-default-case "_CLSQL_SEQ_" database) - (sql-escape sequence-name))) + (convert-to-db-default-case "_CLSQL_SEQ_" database) + (sql-escape sequence-name))) (defun %table-name-to-sequence-name (table-name database) (and (>= (length table-name) 11) (string-equal (subseq table-name 0 11) - (convert-to-db-default-case "_CLSQL_SEQ_" database)) + (convert-to-db-default-case "_CLSQL_SEQ_" database)) (subseq table-name 11))) (defmethod database-create-sequence (sequence-name database) (let ((table-name (%sequence-name-to-table sequence-name database))) (database-execute-command (concatenate 'string "CREATE TABLE " table-name - " (last_value int NOT NULL PRIMARY KEY, increment_by int, min_value int, is_called char(1))") + " (last_value int NOT NULL PRIMARY KEY, increment_by int, min_value int, is_called char(1))") database) - (database-execute-command + (database-execute-command (concatenate 'string "INSERT INTO " table-name - " VALUES (1,1,1,'f')") + " VALUES (1,1,1,'f')") database))) (defmethod database-drop-sequence (sequence-name database) (database-execute-command - (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name database)) + (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name database)) database)) (defmethod database-list-sequences (database &key (owner nil)) (declare (ignore owner)) (mapcan #'(lambda (s) - (let ((sn (%table-name-to-sequence-name s database))) - (and sn (list sn)))) - (database-list-tables-and-sequences database))) + (let ((sn (%table-name-to-sequence-name s database))) + (and sn (list sn)))) + (database-list-tables-and-sequences database))) (defmethod database-set-sequence-position (sequence-name position database) (database-execute-command - (format nil "UPDATE ~A SET last_value=~A,is_called='t'" - (%sequence-name-to-table sequence-name database) + (format nil "UPDATE ~A SET last_value=~A,is_called='t'" + (%sequence-name-to-table sequence-name database) position) database) position) @@ -67,27 +67,27 @@ (defmethod database-sequence-next (sequence-name database) (without-interrupts (let* ((table-name (%sequence-name-to-table sequence-name database)) - (tuple - (car (database-query - (concatenate 'string "SELECT last_value,is_called FROM " - table-name) - database :auto nil)))) + (tuple + (car (database-query + (concatenate 'string "SELECT last_value,is_called FROM " + table-name) + database :auto nil)))) (cond ((char-equal (schar (second tuple) 0) #\f) - (database-execute-command - (format nil "UPDATE ~A SET is_called='t'" table-name) - database) - (car tuple)) + (database-execute-command + (format nil "UPDATE ~A SET is_called='t'" table-name) + database) + (car tuple)) (t - (let ((new-pos (1+ (car tuple)))) - (database-execute-command - (format nil "UPDATE ~A SET last_value=~D" table-name new-pos) - database) - new-pos)))))) - + (let ((new-pos (1+ (car tuple)))) + (database-execute-command + (format nil "UPDATE ~A SET last_value=~D" table-name new-pos) + database) + new-pos)))))) + (defmethod database-sequence-last (sequence-name database) (without-interrupts - (caar (database-query - (concatenate 'string "SELECT last_value FROM " - (%sequence-name-to-table sequence-name database)) - database :auto nil)))) + (caar (database-query + (concatenate 'string "SELECT last_value FROM " + (%sequence-name-to-table sequence-name database)) + database :auto nil)))) diff --git a/sql/syntax.lisp b/sql/syntax.lisp index f00545e..436c224 100644 --- a/sql/syntax.lisp +++ b/sql/syntax.lisp @@ -43,7 +43,7 @@ the current syntax state." (%disable-sql-reader-syntax))) (defun %disable-sql-reader-syntax () - (when *original-readtable* + (when *original-readtable* (setf *readtable* *original-readtable* *original-readtable* nil)) (values)) @@ -89,42 +89,42 @@ reader syntax is disabled." (let ((sqllist (read-delimited-list #\] stream t))) (unless *read-suppress* (handler-case - (cond ((string= (write-to-string (car sqllist)) "||") - (cons (sql-operator 'concat-op) (cdr sqllist))) - ((and (= (length sqllist) 1) (eql (car sqllist) '*)) - (apply #'generate-sql-reference sqllist)) - ((sql-operator (car sqllist)) - (cons (sql-operator (car sqllist)) (cdr sqllist))) - (t (apply #'generate-sql-reference sqllist))) - (sql-user-error (c) - (error 'sql-user-error - :message (format nil "Error ~A occured while attempting to parse '~A' at file position ~A" - (sql-user-error-message c) sqllist (file-position stream)))))))) + (cond ((string= (write-to-string (car sqllist)) "||") + (cons (sql-operator 'concat-op) (cdr sqllist))) + ((and (= (length sqllist) 1) (eql (car sqllist) '*)) + (apply #'generate-sql-reference sqllist)) + ((sql-operator (car sqllist)) + (cons (sql-operator (car sqllist)) (cdr sqllist))) + (t (apply #'generate-sql-reference sqllist))) + (sql-user-error (c) + (error 'sql-user-error + :message (format nil "Error ~A occured while attempting to parse '~A' at file position ~A" + (sql-user-error-message c) sqllist (file-position stream)))))))) (defun generate-sql-reference (&rest arglist) - (cond ((= (length arglist) 1) ; string, table or attribute - (if (stringp (car arglist)) - (sql-expression :string (car arglist)) + (cond ((= (length arglist) 1) ; string, table or attribute + (if (stringp (car arglist)) + (sql-expression :string (car arglist)) (sql-expression :attribute (car arglist)))) - ((<= 2 (length arglist)) - (let ((sqltype (when (keywordp (caddr arglist)) (caddr arglist) nil))) + ((<= 2 (length arglist)) + (let ((sqltype (when (keywordp (caddr arglist)) (caddr arglist) nil))) (cond ((stringp (cadr arglist)) - (sql-expression :table (car arglist) - :alias (cadr arglist) - :type sqltype)) - ((keywordp (cadr arglist)) - (sql-expression :attribute (car arglist) - :type (cadr arglist))) - (t - (sql-expression :attribute (cadr arglist) - :table (car arglist) - :type sqltype))))) - (t - (error 'sql-user-error :message "bad expression syntax")))) - - -;; Exported functions for dealing with SQL syntax + (sql-expression :table (car arglist) + :alias (cadr arglist) + :type sqltype)) + ((keywordp (cadr arglist)) + (sql-expression :attribute (car arglist) + :type (cadr arglist))) + (t + (sql-expression :attribute (cadr arglist) + :table (car arglist) + :type sqltype))))) + (t + (error 'sql-user-error :message "bad expression syntax")))) + + +;; Exported functions for dealing with SQL syntax (defun sql (&rest args) "Returns an SQL string generated from the expressions ARGS. The @@ -176,8 +176,8 @@ function and the remaining values in ARGS its arguments as strings." (if (sql-operator operator) (apply (symbol-function (sql-operator operator)) args) - (error 'sql-user-error - :message + (error 'sql-user-error + :message (format nil "~A is not a recognized SQL operator." operator)))) diff --git a/sql/time.lisp b/sql/time.lisp index 7512033..32c10b7 100644 --- a/sql/time.lisp +++ b/sql/time.lisp @@ -85,11 +85,11 @@ (declare (ignore depth)) (if *print-escape* (format stream "#" - (format-duration nil duration :precision :second)) + (format-duration nil duration :precision :second)) (format-duration stream duration :precision :second))) (defstruct (date (:constructor %make-date) - (:print-function %print-date)) + (:print-function %print-date)) (mjd 0 :type fixnum)) (defun %print-date (date stream depth) @@ -105,8 +105,8 @@ (minute (duration-minute duration)) (hour (duration-hour duration)) (day (duration-day duration)) - (month (duration-month duration)) - (year (duration-year duration))) + (month (duration-month duration)) + (year (duration-year duration))) (format nil "P~dY~dM~dD~dH~dM~dS" year month day hour minute second))) @@ -126,7 +126,7 @@ (defun make-date (&key (year 0) (month 1) (day 1) (hour 0) (minute 0) (second 0) (usec 0) (offset 0)) (time->date (make-time :year year :month month :day day :hour hour - :minute minute :second second :usec usec :offset offset))) + :minute minute :second second :usec usec :offset offset))) (defun copy-time (time) (%make-wall-time :mjd (time-mjd time) @@ -232,15 +232,15 @@ (* (duration-reduce duration :hour) 60))) (:hour (+ (if round - (floor (duration-minute duration) 30) - 0) - (duration-hour duration) - (* (duration-reduce duration :day) 24))) + (floor (duration-minute duration) 30) + 0) + (duration-hour duration) + (* (duration-reduce duration :day) 24))) (:day (+ (if round - (floor (duration-hour duration) 12) - 0) - (duration-day duration))))) + (floor (duration-hour duration) 12) + 0) + (duration-day duration))))) ;; ------------------------------------------------------------ @@ -309,19 +309,19 @@ (defun time/= (number &rest more-numbers) "Returns T if no two of its arguments are numerically equal, NIL otherwise." (do* ((head number (car nlist)) - (nlist more-numbers (cdr nlist))) + (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) (unless (do* ((nl nlist (cdr nl))) - ((atom nl) t) - (declare (list nl)) - (if (%time= head (car nl)) (return nil))) + ((atom nl) t) + (declare (list nl)) + (if (%time= head (car nl)) (return nil))) (return nil)))) (defun time< (number &rest more-numbers) "Returns T if its arguments are in strictly increasing order, NIL otherwise." (do* ((n number (car nlist)) - (nlist more-numbers (cdr nlist))) + (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) (if (not (%time< n (car nlist))) (return nil)))) @@ -329,7 +329,7 @@ (defun time> (number &rest more-numbers) "Returns T if its arguments are in strictly decreasing order, NIL otherwise." (do* ((n number (car nlist)) - (nlist more-numbers (cdr nlist))) + (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) (if (not (%time> n (car nlist))) (return nil)))) @@ -337,7 +337,7 @@ (defun time<= (number &rest more-numbers) "Returns T if arguments are in strictly non-decreasing order, NIL otherwise." (do* ((n number (car nlist)) - (nlist more-numbers (cdr nlist))) + (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) (if (not (%time<= n (car nlist))) (return nil)))) @@ -345,7 +345,7 @@ (defun time>= (number &rest more-numbers) "Returns T if arguments are in strictly non-increasing order, NIL otherwise." (do* ((n number (car nlist)) - (nlist more-numbers (cdr nlist))) + (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) (if (not (%time>= n (car nlist))) (return nil)))) @@ -392,28 +392,28 @@ (defun replace-string (string1 search-string replace-string &key (test #'string=)) "Search within string1 for search-string, replace with replace-string, non-destructively." (let ((replace-string-length (length replace-string)) - (search-string-length (length search-string))) + (search-string-length (length search-string))) (labels ((sub-replace-string (current-string position) - (let ((found-position (search search-string current-string :test test :start2 position))) - (if (null found-position) - current-string - (sub-replace-string (concatenate 'string - (subseq current-string 0 found-position) - replace-string - (subseq current-string (+ found-position search-string-length))) - (+ position replace-string-length)))))) + (let ((found-position (search search-string current-string :test test :start2 position))) + (if (null found-position) + current-string + (sub-replace-string (concatenate 'string + (subseq current-string 0 found-position) + replace-string + (subseq current-string (+ found-position search-string-length))) + (+ position replace-string-length)))))) (sub-replace-string string1 0)))) );eval-when (defmacro wrap-time-for-date (time-func &key (result-func)) - (let ((date-func (intern (replace-string (symbol-name time-func) + (let ((date-func (intern (replace-string (symbol-name time-func) (symbol-name-default-case "TIME") (symbol-name-default-case "DATE"))))) `(defun ,date-func (number &rest more-numbers) (let ((result (apply #',time-func (mapcar #'date->time (cons number more-numbers))))) - ,(if result-func - `(funcall #',result-func result) - 'result))))) + ,(if result-func + `(funcall #',result-func result) + 'result))))) (wrap-time-for-date time=) (wrap-time-for-date time/=) @@ -541,9 +541,9 @@ (defun sort-interval-list (list) (sort list (lambda (x y) - (case (interval-relation x y) - ((:precedes :contains) t) - ((:follows :overlaps :contained) nil))))) + (case (interval-relation x y) + ((:precedes :contains) t) + ((:follows :overlaps :contained) nil))))) ;; interval push will return its list of intervals in strict order. (defun interval-push (interval-list interval &optional container-rule) @@ -551,19 +551,19 @@ (let ((sorted-list (sort-interval-list interval-list))) (dotimes (x (length sorted-list)) (let ((elt (nth x sorted-list))) - (case (interval-relation elt interval) - (:follows - (return-from interval-push (insert-at-index x sorted-list interval))) - (:contains - (return-from interval-push - (replace-at-index x sorted-list - (make-interval :start (interval-start elt) - :end (interval-end elt) - :type (interval-type elt) - :contained (interval-push (interval-contained elt) interval) - :data (interval-data elt))))) - ((:overlaps :contained) - (error "Overlap"))))) + (case (interval-relation elt interval) + (:follows + (return-from interval-push (insert-at-index x sorted-list interval))) + (:contains + (return-from interval-push + (replace-at-index x sorted-list + (make-interval :start (interval-start elt) + :end (interval-end elt) + :type (interval-type elt) + :contained (interval-push (interval-contained elt) interval) + :data (interval-data elt))))) + ((:overlaps :contained) + (error "Overlap"))))) (append sorted-list (list interval)))) ;; interval lists @@ -574,9 +574,9 @@ (let ((list (sort-interval-list list))) (dotimes (x (length list)) (let ((elt (nth x list))) - (when (and (time<= (interval-start elt) time) - (time< time (interval-end elt))) - (return-from interval-match x)))))) + (when (and (time<= (interval-start elt) time) + (time< time (interval-end elt))) + (return-from interval-match x)))))) (defun interval-clear (list time) (dotimes (x (length list)) @@ -586,7 +586,7 @@ (if (interval-match (interval-contained elt) time) (return-from interval-clear (replace-at-index x list - (make-interval :start (interval-start elt) + (make-interval :start (interval-start elt) :end (interval-end elt) :type (interval-type elt) :contained (interval-clear (interval-contained elt) time) @@ -601,24 +601,24 @@ begins at time. If no changes are made, returns nil." (let ((list (sort-interval-list list))) (if (null list) nil (dotimes (x (length list)) - (let ((elt (nth x list))) - (when (and (time<= (interval-start elt) time) - (time< time (interval-end elt))) - (or (interval-edit (interval-contained elt) time start end tag) - (cond ((and (< 0 x) - (time< start (interval-end (nth (1- x) list)))) - (error "Overlap of previous interval")) - ((and (< x (1- (length list))) - (time< (interval-start (nth (1+ x) list)) end)) - (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end )) - ((time= (interval-start elt) time) - (return-from interval-edit - (replace-at-index x list - (make-interval :start start - :end end - :type (interval-type elt) - :contained (restrict-intervals (interval-contained elt) start end) - :data (or tag (interval-data elt)))))))))))))) + (let ((elt (nth x list))) + (when (and (time<= (interval-start elt) time) + (time< time (interval-end elt))) + (or (interval-edit (interval-contained elt) time start end tag) + (cond ((and (< 0 x) + (time< start (interval-end (nth (1- x) list)))) + (error "Overlap of previous interval")) + ((and (< x (1- (length list))) + (time< (interval-start (nth (1+ x) list)) end)) + (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end )) + ((time= (interval-start elt) time) + (return-from interval-edit + (replace-at-index x list + (make-interval :start start + :end end + :type (interval-type elt) + :contained (restrict-intervals (interval-contained elt) start end) + :data (or tag (interval-data elt)))))))))))))) (defun restrict-intervals (list start end &aux newlist) (let ((test-interval (make-interval :start start :end end))) @@ -797,18 +797,18 @@ TIME2." (let (day-diff sec-diff) (setf day-diff (- (time-mjd time2) - (time-mjd time1))) + (time-mjd time1))) (if (> day-diff 0) - (progn (decf day-diff) - (setf sec-diff (+ (time-second time2) - (- (* 60 60 24) - (time-second time1))))) + (progn (decf day-diff) + (setf sec-diff (+ (time-second time2) + (- (* 60 60 24) + (time-second time1))))) (setf sec-diff (- (time-second time2) - (time-second time1)))) + (time-second time1)))) (make-duration :day day-diff :second sec-diff)))) (if (time< time1 time2) - (do-diff time1 time2) + (do-diff time1 time2) (do-diff time2 time1)))) (defun date-difference (date1 date2) @@ -817,14 +817,14 @@ TIME2." (time-difference (date->time date1) (date->time date2))) (defun format-date (stream date &key format - (date-separator "-") - (internal-separator " ")) + (date-separator "-") + (internal-separator " ")) "produces on stream the datestring corresponding to the date with the given options" (format-time stream (date->time date) - :format format - :date-separator date-separator - :internal-separator internal-separator)) + :format format + :date-separator date-separator + :internal-separator internal-separator)) (defun format-time (stream time &key format (date-separator "-") @@ -834,29 +834,29 @@ with the given options" with the given options" (let ((*print-circle* nil)) (multiple-value-bind (usec second minute hour day month year dow) - (decode-time time) + (decode-time time) (case format - (:pretty - (format stream "~A ~A, ~A ~D, ~D" - (pretty-time hour minute) - (day-name dow) - (month-name month) - day - year)) - (:short-pretty - (format stream "~A, ~D/~D/~D" - (pretty-time hour minute) - month day year)) - (:iso - (let ((string (iso-timestring time))) - (if stream - (write-string string stream) + (:pretty + (format stream "~A ~A, ~A ~D, ~D" + (pretty-time hour minute) + (day-name dow) + (month-name month) + day + year)) + (:short-pretty + (format stream "~A, ~D/~D/~D" + (pretty-time hour minute) + month day year)) + (:iso + (let ((string (iso-timestring time))) + (if stream + (write-string string stream) string))) - (t - (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D.~6,'0D" - year date-separator month date-separator day - internal-separator hour time-separator minute time-separator - second usec)))))) + (t + (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D.~6,'0D" + year date-separator month date-separator day + internal-separator hour time-separator minute time-separator + second usec)))))) (defun pretty-time (hour minute) (cond @@ -1006,8 +1006,8 @@ with the given options" (minute (duration-minute duration)) (hour (duration-hour duration)) (day (duration-day duration)) - (month (duration-month duration)) - (year (duration-year duration)) + (month (duration-month duration)) + (year (duration-year duration)) (return (null stream)) (stream (or stream (make-string-output-stream)))) (ecase precision @@ -1022,17 +1022,17 @@ with the given options" (if (= 0 year month day hour minute) (format stream "0 minutes") (let ((sent? nil)) - (when (< 0 year) - (format stream "~d year~p" year year) - (setf sent? t)) - (when (< 0 month) - (when sent? - (write-char #\Space stream)) - (format stream "~d month~p" month month) - (setf sent? t)) + (when (< 0 year) + (format stream "~d year~p" year year) + (setf sent? t)) + (when (< 0 month) + (when sent? + (write-char #\Space stream)) + (format stream "~d month~p" month month) + (setf sent? t)) (when (< 0 day) - (when sent? - (write-char #\Space stream)) + (when sent? + (write-char #\Space stream)) (format stream "~d day~p" day day) (setf sent? t)) (when (< 0 hour) @@ -1160,7 +1160,7 @@ rules" (defun parse-yearstring (string) (let ((year (or (parse-integer-insensitively string) - (extract-roman string)))) + (extract-roman string)))) (when (and year (< 1500 year 2500)) (make-time :year year)))) @@ -1196,7 +1196,7 @@ rules" :initarg :bad-component :reader bad-component)) (:report (lambda (c stream) - (format stream "Bad component: ~A " (bad-component c))))) + (format stream "Bad component: ~A " (bad-component c))))) (defun parse-timestring (timestring &key (start 0) end junk-allowed) "parse a timestring and return the corresponding wall-time. If the @@ -1205,7 +1205,7 @@ formatted date string." (declare (ignore junk-allowed)) (let ((string (subseq timestring start end))) (if (char= (aref string 0) #\P) - (parse-iso-8601-duration string) + (parse-iso-8601-duration string) (parse-iso-8601-time string)))) (defun parse-datestring (datestring &key (start 0) end junk-allowed) @@ -1228,53 +1228,53 @@ Will throw a hissy fit if the date string is a duration. Will ignore any precisi (defun iso-8601-duration-subseq (string end) (let* ((pos (position-if #'iso-8601-delimiter string :end end :from-end t)) - (pos2 (when pos - (position-if-not #'digit-char-p string :end pos :from-end t))) - (number (when pos2 - (parse-integer - (subseq string (1+ pos2) pos) :junk-allowed t)))) + (pos2 (when pos + (position-if-not #'digit-char-p string :end pos :from-end t))) + (number (when pos2 + (parse-integer + (subseq string (1+ pos2) pos) :junk-allowed t)))) (when number (values number - (1+ pos) - (1+ pos2) - (iso-8601-delimiter (aref string pos)))))) + (1+ pos) + (1+ pos2) + (iso-8601-delimiter (aref string pos)))))) (defun parse-iso-8601-duration (string) "return a wall-time from a duration string" (block parse (let ((years 0) - (months 0) - (days 0) - (secs 0) - (hours 0) - (minutes 0) - (index (length string)) - (months/minutes nil)) + (months 0) + (days 0) + (secs 0) + (hours 0) + (minutes 0) + (index (length string)) + (months/minutes nil)) (loop (multiple-value-bind (duration next-index duration-type) (iso-8601-duration-subseq string index) (case duration-type - (:years - (incf years duration)) - (:months/minutes - (if months/minutes - (incf months duration) - (progn - (setq months/minutes t) - (incf minutes duration)))) + (:years + (incf years duration)) + (:months/minutes + (if months/minutes + (incf months duration) + (progn + (setq months/minutes t) + (incf minutes duration)))) (:days - (setq months/minutes t) + (setq months/minutes t) (incf days duration)) (:hours - (setq months/minutes t) + (setq months/minutes t) (incf hours duration)) (:seconds (incf secs duration)) (t (return-from parse - (make-duration - :year years :month months :day days :hour hours - :minute minutes :second secs)))) + (make-duration + :year years :month months :day days :hour hours + :minute minutes :second secs)))) (setf index next-index)))))) ;; e.g. 2000-11-11 00:00:00-06 @@ -1313,8 +1313,8 @@ Will throw a hissy fit if the date string is a duration. Will ignore any precisi 0)) (cond ((and (> strlen 19) - (or (char= #\, (char string 19)) - (char= #\. (char string 19)))) + (or (char= #\, (char string 19)) + (char= #\. (char string 19)))) (multiple-value-bind (parsed-usec usec-end) (parse-integer string :start 20 :junk-allowed t) (setf usec (or parsed-usec 0) @@ -1355,5 +1355,5 @@ Will throw a hissy fit if the date string is a duration. Will ignore any precisi `((year . ,year) (month . ,month) (day . ,day) (hour . ,hour) (minute . ,minute) (second . ,second) - (usec . ,usec) + (usec . ,usec) (timezone . ,gmt-sec-offset))))))))) diff --git a/sql/transaction.lisp b/sql/transaction.lisp index b7673d8..1c6e98b 100644 --- a/sql/transaction.lisp +++ b/sql/transaction.lisp @@ -18,9 +18,9 @@ ((commit-hooks :initform () :accessor commit-hooks) (rollback-hooks :initform () :accessor rollback-hooks) (previous-autocommit :initarg :previous-autocommit - :reader previous-autocommit) + :reader previous-autocommit) (status :initform nil :accessor transaction-status - :documentation "nil or :committed"))) + :documentation "nil or :committed"))) (defun add-transaction-commit-hook (commit-hook &key (database *default-database*)) @@ -41,8 +41,8 @@ is called on DATABASE which defaults to *DEFAULT-DATABASE*." (defmethod database-start-transaction ((database database)) (unless (transaction database) (setf (transaction database) - (make-instance 'transaction :previous-autocommit - (database-autocommit database)))) + (make-instance 'transaction :previous-autocommit + (database-autocommit database)))) (setf (database-autocommit database) nil) (when (= (incf (transaction-level database)) 1) (let ((transaction (transaction database))) @@ -61,30 +61,30 @@ is called on DATABASE which defaults to *DEFAULT-DATABASE*." (with-slots (transaction transaction-level autocommit) database (if (plusp transaction-level) (when (zerop (decf transaction-level)) - (case (database-underlying-type database) - (:mssql (execute-command "COMMIT TRANSACTION" :database database)) - (t (execute-command "COMMIT" :database database))) - (setf autocommit (previous-autocommit transaction)) + (case (database-underlying-type database) + (:mssql (execute-command "COMMIT TRANSACTION" :database database)) + (t (execute-command "COMMIT" :database database))) + (setf autocommit (previous-autocommit transaction)) (map nil #'funcall (commit-hooks transaction))) (warn 'sql-warning :message - (format nil "Cannot commit transaction against ~A because there is no transaction in progress." - database))))) + (format nil "Cannot commit transaction against ~A because there is no transaction in progress." + database))))) (defmethod database-abort-transaction ((database database)) (with-slots (transaction transaction-level autocommit) database (if (plusp transaction-level) (when (zerop (decf transaction-level)) (unwind-protect - (case (database-underlying-type database) - (:mssql (execute-command "ROLLBACK TRANSACTION" :database database)) - (t (execute-command "ROLLBACK" :database database))) - (setf autocommit (previous-autocommit transaction)) + (case (database-underlying-type database) + (:mssql (execute-command "ROLLBACK TRANSACTION" :database database)) + (t (execute-command "ROLLBACK" :database database))) + (setf autocommit (previous-autocommit transaction)) (map nil #'funcall (rollback-hooks transaction)))) (warn 'sql-warning - :message - (format nil "Cannot abort transaction against ~A because there is no transaction in progress." - database))))) + :message + (format nil "Cannot abort transaction against ~A because there is no transaction in progress." + database))))) (defun mark-transaction-committed (database) (when (and (transaction database) diff --git a/sql/utils.lisp b/sql/utils.lisp index d0402e8..e6176cb 100644 --- a/sql/utils.lisp +++ b/sql/utils.lisp @@ -53,8 +53,8 @@ (defun sql-escape (identifier) "Change hyphens to underscores, ensure string" (let ((unescaped (etypecase identifier - (symbol (symbol-name identifier)) - (string identifier)))) + (symbol (symbol-name identifier)) + (string identifier)))) (substitute #\_ #\- unescaped))) (defmacro without-interrupts (&body body) @@ -65,7 +65,7 @@ #+openmcl `(ccl:without-interrupts ,@body) #+sbcl `(sb-sys::without-interrupts ,@body)) -(defun make-process-lock (name) +(defun make-process-lock (name) #+allegro (mp:make-process-lock :name name) #+cmu (mp:make-lock name) #+lispworks (mp:make-lock :name name) @@ -88,53 +88,53 @@ #+sb-thread (sb-thread:with-recursive-lock (,l) ,@body) )) #+scl `(thread:with-lock-held (,lock ,desc) ,@body) - #-(or cmu allegro lispworks openmcl sb-thread scl) (declare - (ignore lock desc)) + #-(or cmu allegro lispworks openmcl sb-thread scl) (declare + (ignore lock desc)) #-(or cmu allegro lispworks openmcl sb-thread scl) `(progn ,@body)) (defun sql-escape-quotes (s) "Escape quotes for SQL string writing" (substitute-string-for-char s #\' "''")) -(defun substitute-string-for-char (procstr match-char subst-str) +(defun substitute-string-for-char (procstr match-char subst-str) "Substitutes a string for a single matching character of a string" (let ((pos (position match-char procstr))) (if pos - (concatenate 'string - (subseq procstr 0 pos) subst-str - (substitute-string-for-char - (subseq procstr (1+ pos)) match-char subst-str)) + (concatenate 'string + (subseq procstr 0 pos) subst-str + (substitute-string-for-char + (subseq procstr (1+ pos)) match-char subst-str)) procstr))) (defun position-char (char string start max) "From KMRCL." (declare (optimize (speed 3) (safety 0) (space 0)) - (fixnum start max) (simple-string string)) + (fixnum start max) (simple-string string)) (do* ((i start (1+ i))) ((= i max) nil) (declare (fixnum i)) (when (char= char (schar string i)) (return i)))) -(defun delimited-string-to-list (string &optional (separator #\space) - skip-terminal) +(defun delimited-string-to-list (string &optional (separator #\space) + skip-terminal) "Split a string with delimiter, from KMRCL." (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)) - (type string string) - (type character separator)) + (type string string) + (type character separator)) (do* ((len (length string)) - (output '()) - (pos 0) - (end (position-char separator string pos len) - (position-char separator string pos len))) + (output '()) + (pos 0) + (end (position-char separator string pos len) + (position-char separator string pos len))) ((null end) - (if (< pos len) - (push (subseq string pos) output) - (when (or (not skip-terminal) (zerop len)) - (push "" output))) - (nreverse output)) + (if (< pos len) + (push (subseq string pos) output) + (when (or (not skip-terminal) (zerop len)) + (push "" output))) + (nreverse output)) (declare (type fixnum pos len) - (type (or null fixnum) end)) + (type (or null fixnum) end)) (push (subseq string pos end) output) (setq pos (1+ end)))) @@ -144,7 +144,7 @@ ((and at-pos (> (length str) at-pos)) ;; Connection spec is SQL*NET format (cons (subseq str (1+ at-pos)) - (delimited-string-to-list (subseq str 0 at-pos) #\/))) + (delimited-string-to-list (subseq str 0 at-pos) #\/))) (t (delimited-string-to-list str #\/))))) @@ -159,92 +159,92 @@ (multiple-value-bind (output error status) (apply #'%command-output control-string args) (values - (concatenate 'string (if output output "") - (if error error "")) + (concatenate 'string (if output output "") + (if error error "")) status))) (defun read-stream-to-string (in) (with-output-to-string (out) - (let ((eof (gensym))) - (do ((line (read-line in nil eof) - (read-line in nil eof))) - ((eq line eof)) - (format out "~A~%" line))))) - + (let ((eof (gensym))) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) + (format out "~A~%" line))))) + ;; From KMRCL (defun %command-output (control-string &rest args) "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and -synchronously execute the result using a Bourne-compatible shell, +synchronously execute the result using a Bourne-compatible shell, returns (VALUES string-output error-output exit-status)" (let ((command (apply #'format nil control-string args))) #+sbcl - (let* ((process (sb-ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output :stream :error :stream)) - (output (read-stream-to-string (sb-impl::process-output process))) - (error (read-stream-to-string (sb-impl::process-error process)))) + (let* ((process (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream)) + (output (read-stream-to-string (sb-impl::process-output process))) + (error (read-stream-to-string (sb-impl::process-error process)))) (close (sb-impl::process-output process)) (close (sb-impl::process-error process)) (values output error - (sb-impl::process-exit-code process))) + (sb-impl::process-exit-code process))) + - #+(or cmu scl) - (let* ((process (ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output :stream :error :stream)) - (output (read-stream-to-string (ext::process-output process))) - (error (read-stream-to-string (ext::process-error process)))) + (let* ((process (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream)) + (output (read-stream-to-string (ext::process-output process))) + (error (read-stream-to-string (ext::process-error process)))) (close (ext::process-output process)) (close (ext::process-error process)) (values output error - (ext::process-exit-code process))) + (ext::process-exit-code process))) #+allegro (multiple-value-bind (output error status) - (excl.osi:command-output command :whole t) + (excl.osi:command-output command :whole t) (values output error status)) - + #+lispworks ;; BUG: Lispworks combines output and error streams (let ((output (make-string-output-stream))) (unwind-protect - (let ((status - (system:call-system-showing-output - command - :shell-type "/bin/sh" - :output-stream output))) - (values (get-output-stream-string output) nil status)) - (close output))) - - #+clisp + (let ((status + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :output-stream output))) + (values (get-output-stream-string output) nil status)) + (close output))) + + #+clisp ;; BUG: CLisp doesn't allow output to user-specified stream (values nil nil (ext:run-shell-command command :output :terminal :wait t)) - + #+openmcl - (let* ((process (ccl:run-program - "/bin/sh" - (list "-c" command) - :input nil :output :stream :error :stream - :wait t)) - (output (read-stream-to-string (ccl::external-process-output-stream process))) - (error (read-stream-to-string (ccl::external-process-error-stream process)))) + (let* ((process (ccl:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream + :wait t)) + (output (read-stream-to-string (ccl::external-process-output-stream process))) + (error (read-stream-to-string (ccl::external-process-error-stream process)))) (close (ccl::external-process-output-stream process)) (close (ccl::external-process-error-stream process)) (values output - error - (nth-value 1 (ccl::external-process-status process)))) - + error + (nth-value 1 (ccl::external-process-status process)))) + #-(or openmcl clisp lispworks allegro scl cmu sbcl) (error "COMMAND-OUTPUT not implemented for this Lisp") @@ -259,53 +259,53 @@ returns (VALUES string-output error-output exit-status)" choices))))) ;; From KMRCL -(defun substitute-char-string (procstr match-char subst-str) +(defun substitute-char-string (procstr match-char subst-str) "Substitutes a string for a single matching character of a string" (substitute-chars-strings procstr (list (cons match-char subst-str)))) (defun replaced-string-length (str repl-alist) (declare (simple-string str) - (optimize (speed 3) (safety 0) (space 0))) + (optimize (speed 3) (safety 0) (space 0))) (do* ((i 0 (1+ i)) - (orig-len (length str)) - (new-len orig-len)) - ((= i orig-len) new-len) + (orig-len (length str)) + (new-len orig-len)) + ((= i orig-len) new-len) (declare (fixnum i orig-len new-len)) (let* ((c (char str i)) - (match (assoc c repl-alist :test #'char=))) - (declare (character c)) - (when match - (incf new-len (1- (length - (the simple-string (cdr match))))))))) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (when match + (incf new-len (1- (length + (the simple-string (cdr match))))))))) (defun substitute-chars-strings (str repl-alist) "Replace all instances of a chars with a string. repl-alist is an assoc list of characters and replacement strings." (declare (simple-string str) - (optimize (speed 3) (safety 0) (space 0))) + (optimize (speed 3) (safety 0) (space 0))) (do* ((orig-len (length str)) - (new-string (make-string (replaced-string-length str repl-alist))) - (spos 0 (1+ spos)) - (dpos 0)) + (new-string (make-string (replaced-string-length str repl-alist))) + (spos 0 (1+ spos)) + (dpos 0)) ((>= spos orig-len) new-string) (declare (fixnum spos dpos) (simple-string new-string)) (let* ((c (char str spos)) - (match (assoc c repl-alist :test #'char=))) + (match (assoc c repl-alist :test #'char=))) (declare (character c)) (if match - (let* ((subst (cdr match)) - (len (length subst))) - (declare (fixnum len) - (simple-string subst)) - (dotimes (j len) - (declare (fixnum j)) - (setf (char new-string dpos) (char subst j)) - (incf dpos))) - (progn - (setf (char new-string dpos) c) - (incf dpos)))))) + (let* ((subst (cdr match)) + (len (length subst))) + (declare (fixnum len) + (simple-string subst)) + (dotimes (j len) + (declare (fixnum j)) + (setf (char new-string dpos) (char subst j)) + (incf dpos))) + (progn + (setf (char new-string dpos) c) + (incf dpos)))))) (defun getenv (var) @@ -332,12 +332,12 @@ list of characters and replacement strings." (defun convert-to-db-default-case (str database) (if database (case (db-type-default-case (database-underlying-type database)) - (:upper (string-upcase str)) - (:lower (string-downcase str)) - (t str)) + (:upper (string-upcase str)) + (:lower (string-downcase str)) + (t str)) ;; Default CommonSQL behavior is to upcase strings (string-upcase str))) - + (defun ensure-keyword (name) "Returns keyword for a name" (etypecase name diff --git a/tests/benchmarks.lisp b/tests/benchmarks.lisp index 66800eb..a39f49b 100644 --- a/tests/benchmarks.lisp +++ b/tests/benchmarks.lisp @@ -26,18 +26,18 @@ :type (string 100)) (c :initarg :c :type float))) - + (defun run-benchmarks (&key (report-stream *standard-output*) (sexp-report-stream nil) (count 10000)) (let ((specs (read-specs)) - (*report-stream* report-stream) - (*sexp-report-stream* sexp-report-stream)) + (*report-stream* report-stream) + (*sexp-report-stream* sexp-report-stream)) (unless specs (warn "Not running benchmarks because test configuration file is missing") (return-from run-benchmarks :skipped)) (load-necessary-systems specs) (dolist (db-type +all-db-types+) (dolist (spec (db-type-spec db-type specs)) - (do-benchmarks-for-backend db-type spec count)))) + (do-benchmarks-for-backend db-type spec count)))) (values)) (defun do-benchmarks-for-backend (db-type spec count) @@ -75,10 +75,10 @@ (format *report-stream* "~&~%*** JOINED OBJECT QUERY RETRIEVAL DEFERRED ***~%") (let* ((slotdef (find 'address (clsql-sys::class-slots (find-class 'employee-address)) - :key #'clsql-sys::slot-definition-name)) - (dbi (when slotdef (clsql-sys::view-class-slot-db-info slotdef)))) + :key #'clsql-sys::slot-definition-name)) + (dbi (when slotdef (clsql-sys::view-class-slot-db-info slotdef)))) (setf (gethash :retrieval dbi) :deferred) (time (dotimes (i (truncate n 10)) - (mapcar #'(lambda (ea) (slot-value ea 'address)) (select 'employee-address :flatp t)))) + (mapcar #'(lambda (ea) (slot-value ea 'address)) (select 'employee-address :flatp t)))) (setf (gethash :retrieval dbi) :immediate)))) diff --git a/tests/package.lisp b/tests/package.lisp index 02983a1..9103a32 100644 --- a/tests/package.lisp +++ b/tests/package.lisp @@ -18,13 +18,13 @@ (defpackage #:clsql-tests (:use #:clsql #:common-lisp #:rtest) - (:export - #:run-tests + (:export + #:run-tests #:run-tests-append-report-file - #:run-benchmarks + #:run-benchmarks #:run-benchmarks-append-report-file #:summarize-test-report - #:test-initialise-database + #:test-initialise-database #:test-connect-to-database ) (:documentation "Regression tests for CLSQL.")) diff --git a/tests/test-basic.lisp b/tests/test-basic.lisp index 24ef372..cbcd8fa 100644 --- a/tests/test-basic.lisp +++ b/tests/test-basic.lisp @@ -21,171 +21,171 @@ (setq *rt-basic* '( (deftest :basic/type/1 - (let ((results '())) - (dolist (row (query "select * from TYPE_TABLE" :result-types :auto) - results) - (destructuring-bind (int float str) row - (push (list (integerp int) - (typep float 'double-float) - (stringp str)) - results)))) + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types :auto) + results) + (destructuring-bind (int float str) row + (push (list (integerp int) + (typep float 'double-float) + (stringp str)) + results)))) ((t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t))) (deftest :basic/type/2 - (let ((results '())) - (dolist (row (query "select * from TYPE_TABLE" :result-types :auto) - results) - (destructuring-bind (int float str) row - (setq results - (cons (list (double-float-equal - (transform-float-1 int) - float) - (double-float-equal - (parse-double str) - float)) - results)))) - results) + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types :auto) + results) + (destructuring-bind (int float str) row + (setq results + (cons (list (double-float-equal + (transform-float-1 int) + float) + (double-float-equal + (parse-double str) + float)) + results)))) + results) ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) (deftest :basic/select/1 - (let ((rows (query "select * from TYPE_TABLE" :result-types :auto))) - (values - (length rows) - (length (car rows)))) + (let ((rows (query "select * from TYPE_TABLE" :result-types :auto))) + (values + (length rows) + (length (car rows)))) 11 3) - + (deftest :BASIC/SELECT/2 - (let ((results '())) - (dolist (row (query "select * from TYPE_TABLE" :result-types nil) - results) - (destructuring-bind (int float str) row - (push (list (stringp int) - (stringp float) - (stringp str)) - results)))) + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types nil) + results) + (destructuring-bind (int float str) row + (push (list (stringp int) + (stringp float) + (stringp str)) + results)))) ((t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t))) - + (deftest :basic/select/3 - (let ((results '())) - (dolist (row (query "select * from TYPE_TABLE" :result-types nil) - results) - (destructuring-bind (int float str) row - (push (list (double-float-equal - (transform-float-1 (parse-integer int)) - (parse-double float)) - (double-float-equal - (parse-double str) - (parse-double float))) - results)))) + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types nil) + results) + (destructuring-bind (int float str) row + (push (list (double-float-equal + (transform-float-1 (parse-integer int)) + (parse-double float)) + (double-float-equal + (parse-double str) + (parse-double float))) + results)))) ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) (deftest :basic/map/1 - (let ((results '()) - (rows (map-query 'vector #'identity "select * from TYPE_TABLE" - :result-types nil))) - (declare (type (simple-array list (*)) rows)) - (dotimes (i (length rows) results) - (push - (list - (listp (aref rows i)) - (length (aref rows i)) - (eql (- i 5) - (parse-integer (first (aref rows i)) - :junk-allowed nil)) - (double-float-equal - (transform-float-1 (parse-integer (first (aref rows i)))) - (parse-double (second (aref rows i))))) - results))) + (let ((results '()) + (rows (map-query 'vector #'identity "select * from TYPE_TABLE" + :result-types nil))) + (declare (type (simple-array list (*)) rows)) + (dotimes (i (length rows) results) + (push + (list + (listp (aref rows i)) + (length (aref rows i)) + (eql (- i 5) + (parse-integer (first (aref rows i)) + :junk-allowed nil)) + (double-float-equal + (transform-float-1 (parse-integer (first (aref rows i)))) + (parse-double (second (aref rows i))))) + 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" - :result-types nil))) - (dotimes (i (length rows) results) - (push - (list - (listp (nth i rows)) - (length (nth i rows)) - (eql (- i 5) - (parse-integer (first (nth i rows)) - :junk-allowed nil)) - (double-float-equal - (transform-float-1 (parse-integer (first (nth i rows)))) - (parse-double (second (nth i rows))))) - results))) + (let ((results '()) + (rows (map-query 'list #'identity "select * from TYPE_TABLE" + :result-types nil))) + (dotimes (i (length rows) results) + (push + (list + (listp (nth i rows)) + (length (nth i rows)) + (eql (- i 5) + (parse-integer (first (nth i rows)) + :junk-allowed nil)) + (double-float-equal + (transform-float-1 (parse-integer (first (nth i rows)))) + (parse-double (second (nth i rows))))) + 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/3 - (let ((results '()) - (rows (map-query 'list #'identity "select * from TYPE_TABLE" - :result-types :auto))) - (dotimes (i (length rows) results) - (push - (list - (listp (nth i rows)) - (length (nth i rows)) - (eql (- i 5) - (first (nth i rows))) - (double-float-equal - (transform-float-1 (first (nth i rows))) - (second (nth i rows)))) - results))) + (let ((results '()) + (rows (map-query 'list #'identity "select * from TYPE_TABLE" + :result-types :auto))) + (dotimes (i (length rows) results) + (push + (list + (listp (nth i rows)) + (length (nth i rows)) + (eql (- i 5) + (first (nth i rows))) + (double-float-equal + (transform-float-1 (first (nth i rows))) + (second (nth i rows)))) + 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)))) + (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) - (let ((int-number (parse-integer int))) - (setq results - (cons (list (double-float-equal (transform-float-1 - int-number) - (parse-double float)) - (double-float-equal (parse-double str) - (parse-double float))) - results)))) - results) + (let ((results '())) + (do-query ((int float str) "select * from TYPE_TABLE" :result-types nil) + (let ((int-number (parse-integer int))) + (setq results + (cons (list (double-float-equal (transform-float-1 + int-number) + (parse-double float)) + (double-float-equal (parse-double str) + (parse-double float))) + results)))) + results) ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) (deftest :basic/do/2 - (let ((results '())) - (do-query ((int float str) "select * from TYPE_TABLE" :result-types :auto) - (setq results - (cons - (list (double-float-equal - (transform-float-1 int) - float) - (double-float-equal - (parse-double str) - float)) - results))) - results) + (let ((results '())) + (do-query ((int float str) "select * from TYPE_TABLE" :result-types :auto) + (setq results + (cons + (list (double-float-equal + (transform-float-1 int) + float) + (double-float-equal + (parse-double str) + float)) + results))) + results) ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) (deftest :basic/bigint/1 - (let ((results '())) - (dolist (row (query "select * from TYPE_BIGINT" :result-types :auto) - results) - (destructuring-bind (int bigint) row - (push (list (integerp int) - (if (and (eq :odbc *test-database-type*) - (eq :postgresql *test-database-underlying-type*)) - ;; ODBC/Postgresql may return returns bigints as strings or integer - ;; depending upon the platform - t - (integerp bigint))) - results)))) + (let ((results '())) + (dolist (row (query "select * from TYPE_BIGINT" :result-types :auto) + results) + (destructuring-bind (int bigint) row + (push (list (integerp int) + (if (and (eq :odbc *test-database-type*) + (eq :postgresql *test-database-underlying-type*)) + ;; ODBC/Postgresql may return returns bigints as strings or integer + ;; depending upon the platform + t + (integerp bigint))) + results)))) ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) )) @@ -196,7 +196,7 @@ (clsql:execute-command "DROP TABLE TYPE_TABLE") (clsql:execute-command "DROP TABLE TYPE_BIGINT")) - (clsql:execute-command + (clsql:execute-command "CREATE TABLE TYPE_TABLE (t_int integer, t_float double precision, t_str VARCHAR(30))") (if (clsql-sys:db-type-has-bigint? *test-database-type*) @@ -205,19 +205,19 @@ (dotimes (i 11) (let* ((test-int (- i 5)) - (test-flt (transform-float-1 test-int))) + (test-flt (transform-float-1 test-int))) (clsql:execute-command (format nil "INSERT INTO TYPE_TABLE VALUES (~a,~a,'~a')" - test-int - (clsql-sys:number-to-sql-string test-flt) - (clsql-sys:number-to-sql-string test-flt) - )) + test-int + (clsql-sys:number-to-sql-string test-flt) + (clsql-sys:number-to-sql-string test-flt) + )) (when (clsql-sys:db-type-has-bigint? *test-database-type*) - (clsql:execute-command - (format nil "INSERT INTO TYPE_BIGINT VALUES (~a,~a)" - test-int - (transform-bigint-1 test-int) - )))))) + (clsql:execute-command + (format nil "INSERT INTO TYPE_BIGINT VALUES (~a,~a)" + test-int + (transform-bigint-1 test-int) + )))))) ;;;; Testing functions @@ -234,9 +234,9 @@ (defun double-float-equal (a b) (if (zerop a) (if (zerop b) - t - nil) + t + nil) (let ((diff (abs (/ (- a b) a)))) - (if (> diff (* 10 double-float-epsilon)) - nil - t)))) + (if (> diff (* 10 double-float-epsilon)) + nil + t)))) diff --git a/tests/test-fddl.lisp b/tests/test-fddl.lisp index 50e5254..ff9dc9e 100644 --- a/tests/test-fddl.lisp +++ b/tests/test-fddl.lisp @@ -25,7 +25,7 @@ ;; list current tables (deftest :fddl/table/1 (sort (mapcar #'string-downcase - (clsql:list-tables :owner *test-database-user*)) + (clsql:list-tables :owner *test-database-user*)) #'string<) ("addr" "big" "company" "ea_join" "employee" "type_bigint" "type_table")) @@ -71,11 +71,11 @@ (deftest :fddl/table/5 (prog1 - (progn - (clsql:create-table "MyMixedCase" '(([a] integer))) - (clsql:execute-command "insert into MyMixedCase values (5)") - (clsql:insert-records :into "MyMixedCase" :values '(6)) - (clsql:select [a] :from "MyMixedCase" :order-by '((a :asc)))) + (progn + (clsql:create-table "MyMixedCase" '(([a] integer))) + (clsql:execute-command "insert into MyMixedCase values (5)") + (clsql:insert-records :into "MyMixedCase" :values '(6)) + (clsql:select [a] :from "MyMixedCase" :order-by '((a :asc)))) (clsql:drop-table "MyMixedCase")) ((5) (6))) @@ -125,7 +125,7 @@ (sort (mapcar #'string-downcase (clsql:list-attributes [employee] - :owner *test-database-user*)) + :owner *test-database-user*)) #'string<)) "bd_utime" "birthday" "ecompanyid" "email" "emplid" "first_name" "groupid" "height" "last_name" "managerid" "married") @@ -147,7 +147,7 @@ (deftest :fddl/attributes/4 (multiple-value-bind (type length scale nullable) - (clsql:attribute-type [first-name] [employee]) + (clsql:attribute-type [first-name] [employee]) (values (clsql-sys:in type :varchar :varchar2) length scale nullable)) t 30 nil 1) @@ -167,68 +167,68 @@ ;; create a view, test for existence, drop it and test again (deftest :fddl/view/1 (progn (clsql:create-view [lenins-group] - :as [select [first-name] [last-name] [email] - :from [employee] - :where [= [managerid] 1]]) - (values - (clsql:view-exists-p [lenins-group] :owner *test-database-user*) - (progn - (clsql:drop-view [lenins-group] :if-does-not-exist :ignore) - (clsql:view-exists-p [lenins-group] :owner *test-database-user*)))) + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) + (values + (clsql:view-exists-p [lenins-group] :owner *test-database-user*) + (progn + (clsql:drop-view [lenins-group] :if-does-not-exist :ignore) + (clsql:view-exists-p [lenins-group] :owner *test-database-user*)))) t nil) ;; create a view, list its attributes and drop it (when (clsql-sys:db-type-has-views? *test-database-underlying-type*) (deftest :fddl/view/2 (progn (clsql:create-view [lenins-group] - :as [select [first-name] [last-name] [email] - :from [employee] - :where [= [managerid] 1]]) - (prog1 - (sort (mapcar #'string-downcase - (clsql:list-attributes [lenins-group])) - #'string<) - (clsql:drop-view [lenins-group] :if-does-not-exist :ignore))) + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) + (prog1 + (sort (mapcar #'string-downcase + (clsql:list-attributes [lenins-group])) + #'string<) + (clsql:drop-view [lenins-group] :if-does-not-exist :ignore))) ("email" "first_name" "last_name"))) ;; create a view, select stuff from it and drop it (deftest :fddl/view/3 (progn (clsql:create-view [lenins-group] - :as [select [first-name] [last-name] [email] - :from [employee] - :where [= [managerid] 1]]) - (let ((result - (list - ;; Shouldn't exist - (clsql:select [first-name] [last-name] [email] - :from [lenins-group] - :where [= [last-name] "Lenin"]) - ;; Should exist - (car (clsql:select [first-name] [last-name] [email] - :from [lenins-group] - :where [= [last-name] "Stalin"]))))) - (clsql:drop-view [lenins-group] :if-does-not-exist :ignore) - (apply #'values result))) + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) + (let ((result + (list + ;; Shouldn't exist + (clsql:select [first-name] [last-name] [email] + :from [lenins-group] + :where [= [last-name] "Lenin"]) + ;; Should exist + (car (clsql:select [first-name] [last-name] [email] + :from [lenins-group] + :where [= [last-name] "Stalin"]))))) + (clsql:drop-view [lenins-group] :if-does-not-exist :ignore) + (apply #'values result))) nil ("Josef" "Stalin" "stalin@soviet.org")) (deftest :fddl/view/4 (progn (clsql:create-view [lenins-group] - :column-list '([forename] [surname] [email]) - :as [select [first-name] [last-name] [email] - :from [employee] - :where [= [managerid] 1]]) - (let ((result - (list - ;; Shouldn't exist - (clsql:select [forename] [surname] [email] - :from [lenins-group] - :where [= [surname] "Lenin"]) - ;; Should exist - (car (clsql:select [forename] [surname] [email] - :from [lenins-group] - :where [= [surname] "Stalin"]))))) - (clsql:drop-view [lenins-group] :if-does-not-exist :ignore) - (apply #'values result))) + :column-list '([forename] [surname] [email]) + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) + (let ((result + (list + ;; Shouldn't exist + (clsql:select [forename] [surname] [email] + :from [lenins-group] + :where [= [surname] "Lenin"]) + ;; Should exist + (car (clsql:select [forename] [surname] [email] + :from [lenins-group] + :where [= [surname] "Stalin"]))))) + (clsql:drop-view [lenins-group] :if-does-not-exist :ignore) + (apply #'values result))) nil ("Josef" "Stalin" "stalin@soviet.org")) ;; create an index, test for existence, drop it and test again @@ -238,8 +238,8 @@ (values (clsql:index-exists-p [bar] :owner *test-database-user*) (progn - (clsql:drop-index [bar] :on [employee] - :if-does-not-exist :ignore) + (clsql:drop-index [bar] :on [employee] + :if-does-not-exist :ignore) (clsql:index-exists-p [bar] :owner *test-database-user*)))) t nil) @@ -250,7 +250,7 @@ (dolist (name names) (clsql:create-index name :on [employee] :attributes '([last-name])) (push (clsql:index-exists-p name :owner *test-database-user*) result) - (clsql:drop-index name :on [employee] :if-does-not-exist :ignore)) + (clsql:drop-index name :on [employee] :if-does-not-exist :ignore)) (apply #'values result)) t t t) @@ -258,7 +258,7 @@ (deftest :fddl/index/3 (progn (clsql:create-table [i3test] '(([a] (string 10)) - ([b] integer))) + ([b] integer))) (clsql:create-index [foo] :on [i3test] :attributes '([b]) :unique nil) (clsql:create-index [bar] :on [i3test] :attributes @@ -268,15 +268,15 @@ (clsql:index-exists-p [foo]) (clsql:index-exists-p [bar]) (sort - (mapcar - #'string-downcase - (clsql:list-indexes :on [i3test] :owner *test-database-user*)) - #'string-lessp) + (mapcar + #'string-downcase + (clsql:list-indexes :on [i3test] :owner *test-database-user*)) + #'string-lessp) (progn - (clsql:drop-index [bar] :on [i3test]) - (clsql:drop-index [foo] :on [i3test]) - (clsql:drop-table [i3test]) - t))) + (clsql:drop-index [bar] :on [i3test]) + (clsql:drop-index [foo] :on [i3test]) + (clsql:drop-table [i3test]) + t))) t t t ("bar" "foo") t) ;; create an sequence, test for existence, drop it and test again @@ -314,20 +314,20 @@ (values (length rows) (do ((i 0 (1+ i)) - (max (expt 2 60)) - (rest rows (cdr rest))) - ((= i (length rows)) t) - (let ((index (1+ i)) - (int (first (car rest))) - (bigint (second (car rest)))) - (when (and (or (eq *test-database-type* :oracle) - (and (eq *test-database-type* :odbc) - (eq *test-database-underlying-type* :postgresql))) - (stringp bigint)) - (setf bigint (parse-integer bigint))) - (unless (and (eql int index) - (eql bigint (truncate max index))) - (return nil)))))) + (max (expt 2 60)) + (rest rows (cdr rest))) + ((= i (length rows)) t) + (let ((index (1+ i)) + (int (first (car rest))) + (bigint (second (car rest)))) + (when (and (or (eq *test-database-type* :oracle) + (and (eq *test-database-type* :odbc) + (eq *test-database-underlying-type* :postgresql))) + (stringp bigint)) + (setf bigint (parse-integer bigint))) + (unless (and (eql int index) + (eql bigint (truncate max index))) + (return nil)))))) 555 t) (deftest :fddl/owner/1 diff --git a/tests/test-fdml.lisp b/tests/test-fdml.lisp index 0fbcb17..f48078f 100644 --- a/tests/test-fdml.lisp +++ b/tests/test-fdml.lisp @@ -21,14 +21,14 @@ (setq *rt-fdml* '( - -;; inserts a record using all values only and then deletes it + +;; inserts a record using all values only and then deletes it (deftest :fdml/insert/1 (let ((now (get-universal-time))) - (clsql:insert-records :into [employee] + (clsql:insert-records :into [employee] :values `(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" - 1 1 1.85 t ,(clsql:utime->time now) ,now)) - (values + 1 1 1.85 t ,(clsql:utime->time now) ,now)) + (values (clsql:select [first-name] [last-name] [email] :from [employee] :where [= [emplid] 11]) (progn (clsql:delete-records :from [employee] :where [= [emplid] 11]) @@ -38,12 +38,12 @@ ;; inserts a record using attributes and values and then deletes it (deftest :fdml/insert/2 (progn - (clsql:insert-records :into [employee] + (clsql:insert-records :into [employee] :attributes '(emplid groupid first_name last_name email ecompanyid managerid) :values '(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" 1 1)) - (values + (values (clsql:select [first-name] [last-name] [email] :from [employee] :where [= [emplid] 11]) (progn (clsql:delete-records :from [employee] :where [= [emplid] 11]) @@ -53,13 +53,13 @@ ;; inserts a record using av-pairs and then deletes it (deftest :fdml/insert/3 (progn - (clsql:insert-records :into [employee] + (clsql:insert-records :into [employee] :av-pairs'((emplid 11) (groupid 1) (first_name "Yuri") (last_name "Gagarin") (email "gagarin@soviet.org") (ecompanyid 1) (managerid 1))) - (values + (values (clsql:select [first-name] [last-name] [email] :from [employee] :where [= [emplid] 11]) (progn (clsql:delete-records :from [employee] :where [= [emplid] 11]) @@ -67,16 +67,16 @@ :where [= [emplid] 11])))) (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) -;; inserts a records using a query from another table +;; inserts a records using a query from another table (deftest :fdml/insert/4 (progn (clsql:create-table [employee2] '(([forename] string) - ([surname] string) - ([email] string))) - (clsql:insert-records :into [employee2] - :query [select [first-name] [last-name] [email] - :from [employee]] - :attributes '(forename surname email)) + ([surname] string) + ([email] string))) + (clsql:insert-records :into [employee2] + :query [select [first-name] [last-name] [email] + :from [employee]] + :attributes '(forename surname email)) (prog1 (equal (clsql:select [*] :from [employee2]) (clsql:select [first-name] [last-name] [email] @@ -87,15 +87,15 @@ ;; updates a record using attributes and values and then deletes it (deftest :fdml/update/1 (progn - (clsql:update-records [employee] + (clsql:update-records [employee] :attributes '(first_name last_name email) :values '("Yuri" "Gagarin" "gagarin@soviet.org") :where [= [emplid] 1]) - (values + (values (clsql:select [first-name] [last-name] [email] :from [employee] :where [= [emplid] 1]) (progn - (clsql:update-records [employee] + (clsql:update-records [employee] :av-pairs'((first_name "Vladimir") (last_name "Lenin") (email "lenin@soviet.org")) @@ -108,12 +108,12 @@ ;; updates a record using av-pairs and then deletes it (deftest :fdml/update/2 (progn - (clsql:update-records [employee] + (clsql:update-records [employee] :av-pairs'((first_name "Yuri") (last_name "Gagarin") (email "gagarin@soviet.org")) :where [= [emplid] 1]) - (values + (values (clsql:select [first-name] [last-name] [email] :from [employee] :where [= [emplid] 1]) (progn @@ -132,14 +132,14 @@ (deftest :fdml/query/1 (let ((count (caar (clsql:query "SELECT COUNT(*) FROM EMPLOYEE WHERE (EMAIL LIKE '%org')" :field-names nil)))) (if (stringp count) - (nth-value 0 (parse-integer count)) - (nth-value 0 (truncate count)))) + (nth-value 0 (parse-integer count)) + (nth-value 0 (truncate count)))) 10) (deftest :fdml/query/2 (multiple-value-bind (rows field-names) - (clsql:query - "SELECT FIRST_NAME,LAST_NAME FROM EMPLOYEE WHERE (EMPLID <= 5) ORDER BY LAST_NAME") + (clsql:query + "SELECT FIRST_NAME,LAST_NAME FROM EMPLOYEE WHERE (EMPLID <= 5) ORDER BY LAST_NAME") (values rows (mapcar 'string-upcase field-names))) (("Leonid" "Brezhnev") ("Nikita" "Kruschev") ("Vladimir" "Lenin") ("Josef" "Stalin") ("Leon" "Trotsky")) @@ -148,43 +148,43 @@ (deftest :fdml/query/3 (caar (clsql:query "SELECT EMPLID FROM EMPLOYEE WHERE LAST_NAME = 'Andropov'" :field-names nil)) 6) - + (deftest :fdml/query/4 (typep (caar (clsql:query "SELECT HEIGHT FROM EMPLOYEE WHERE LAST_NAME = 'Andropov'" :field-names nil)) 'float) t) - + (deftest :fdml/query/5 - (let ((res (clsql:query (clsql:sql [select [first-name] [sum [emplid]] :from [employee]] - [group-by [first-name]] [order-by [sum [emplid]]]) - :field-names nil :result-types nil))) + (let ((res (clsql:query (clsql:sql [select [first-name] [sum [emplid]] :from [employee]] + [group-by [first-name]] [order-by [sum [emplid]]]) + :field-names nil :result-types nil))) (mapcar (lambda (p) (list (car p) (truncate (read-from-string (second p))))) - res)) + res)) (("Josef" 2) ("Leon" 3) ("Nikita" 4) ("Leonid" 5) ("Yuri" 6) ("Konstantin" 7) ("Mikhail" 8) ("Boris" 9) ("Vladimir" 11))) (deftest :fdml/query/6 - (let ((res (clsql:query (clsql:sql [union [select [emplid] :from [employee]] - [select [groupid] :from [company]]]) - :field-names nil :result-types nil :flatp t))) + (let ((res (clsql:query (clsql:sql [union [select [emplid] :from [employee]] + [select [groupid] :from [company]]]) + :field-names nil :result-types nil :flatp t))) (values (every #'stringp res) - (mapcar #'(lambda (f) (truncate (read-from-string f))) res))) + (mapcar #'(lambda (f) (truncate (read-from-string f))) res))) t (1 2 3 4 5 6 7 8 9 10)) (deftest :fdml/query/7 - (let ((res (car (clsql:query (clsql:sql [intersect [select [emplid] :from [employee]] - [select [groupid] :from [company]]]) - :field-names nil :result-types nil :flatp t)))) + (let ((res (car (clsql:query (clsql:sql [intersect [select [emplid] :from [employee]] + [select [groupid] :from [company]]]) + :field-names nil :result-types nil :flatp t)))) (values (stringp res) - (nth-value 0 (truncate (read-from-string res))))) + (nth-value 0 (truncate (read-from-string res))))) t 1) (deftest :fdml/query/8 - (let ((res (clsql:query (clsql:sql [except [select [emplid] :from [employee]] - [select [groupid] :from [company]]]) - :field-names nil :result-types nil :flatp t))) + (let ((res (clsql:query (clsql:sql [except [select [emplid] :from [employee]] + [select [groupid] :from [company]]]) + :field-names nil :result-types nil :flatp t))) (values (every #'stringp res) - (mapcar #'(lambda (f) (truncate (read-from-string f))) res))) + (mapcar #'(lambda (f) (truncate (read-from-string f))) res))) t (2 3 4 5 6 7 8 9 10)) @@ -201,139 +201,139 @@ ;; compare min, max and average hieghts in inches (they're quite short -;; these guys!) +;; these guys!) (deftest :fdml/select/1 (let ((max (clsql:select [function "floor" - [/ [* [max [height]] 100] 2.54]] - :from [employee] - :result-types nil - :flatp t)) - (min (clsql:select [function "floor" - [/ [* [min [height]] 100] 2.54]] - :from [employee] - :result-types nil - :flatp t)) - (avg (clsql:select [function "floor" - [avg [/ [* [height] 100] 2.54]]] - :from [employee] - :result-types nil - :flatp t))) + [/ [* [max [height]] 100] 2.54]] + :from [employee] + :result-types nil + :flatp t)) + (min (clsql:select [function "floor" + [/ [* [min [height]] 100] 2.54]] + :from [employee] + :result-types nil + :flatp t)) + (avg (clsql:select [function "floor" + [avg [/ [* [height] 100] 2.54]]] + :from [employee] + :result-types nil + :flatp t))) (apply #'< (mapcar #'(lambda (s) (parse-integer s :junk-allowed t)) - (append min avg max)))) + (append min avg max)))) t) (deftest :fdml/select/2 (clsql:select [first-name] :from [employee] :flatp t :distinct t - :field-names nil - :result-types nil + :field-names nil + :result-types nil :order-by [first-name]) ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladimir" "Yuri")) (deftest :fdml/select/3 (let ((res (clsql:select [first-name] [count [*]] :from [employee] - :result-types nil - :group-by [first-name] - :order-by [first-name] - :field-names nil))) + :result-types nil + :group-by [first-name] + :order-by [first-name] + :field-names nil))) (mapcar (lambda (p) (list (car p) (truncate (read-from-string (second p))))) - res)) + res)) (("Boris" 1) ("Josef" 1) ("Konstantin" 1) ("Leon" 1) ("Leonid" 1) ("Mikhail" 1) ("Nikita" 1) ("Vladimir" 2) ("Yuri" 1))) (deftest :fdml/select/4 - (clsql:select [last-name] :from [employee] - :where [like [email] "%org"] - :order-by [last-name] - :field-names nil - :result-types nil - :flatp t) + (clsql:select [last-name] :from [employee] + :where [like [email] "%org"] + :order-by [last-name] + :field-names nil + :result-types nil + :flatp t) ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" "Stalin" "Trotsky" "Yeltsin")) (deftest :fdml/select/5 - (clsql:select [email] :from [employee] :flatp t :result-types nil - :where [in [employee emplid] - [select [managerid] :from [employee]]] - :field-names nil) + (clsql:select [email] :from [employee] :flatp t :result-types nil + :where [in [employee emplid] + [select [managerid] :from [employee]]] + :field-names nil) ("lenin@soviet.org")) (deftest :fdml/select/6 (if (clsql-sys:db-type-has-fancy-math? *test-database-underlying-type*) (mapcar #'(lambda (s) (parse-integer s :junk-allowed t)) - (clsql:select [function "trunc" [height]] :from [employee] - :result-types nil - :field-names nil - :flatp t)) - (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t))) - (clsql:select [height] :from [employee] :flatp t - :field-names nil :result-types nil))) + (clsql:select [function "trunc" [height]] :from [employee] + :result-types nil + :field-names nil + :flatp t)) + (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t))) + (clsql:select [height] :from [employee] :flatp t + :field-names nil :result-types nil))) (1 1 1 1 1 1 1 1 1 1)) (deftest :fdml/select/7 - (let ((result (car (clsql:select [max [emplid]] :from [employee] :flatp t - :field-names nil :result-types nil)))) - (values + (let ((result (car (clsql:select [max [emplid]] :from [employee] :flatp t + :field-names nil :result-types nil)))) + (values (stringp result) (nth-value 0 (truncate (read-from-string result))))) t 10) (deftest :fdml/select/8 - (let ((result (car (clsql:select [min [emplid]] :from [employee] :flatp t - :field-names nil :result-types nil)))) + (let ((result (car (clsql:select [min [emplid]] :from [employee] :flatp t + :field-names nil :result-types nil)))) (values (stringp result) (nth-value 0 (truncate (read-from-string result))))) t 1) (deftest :fdml/select/9 - (subseq - (car - (clsql:select [avg [emplid]] :from [employee] :flatp t - :field-names nil :result-types nil)) + (subseq + (car + (clsql:select [avg [emplid]] :from [employee] :flatp t + :field-names nil :result-types nil)) 0 3) "5.5") (deftest :fdml/select/10 (clsql:select [last-name] :from [employee] - :where [not [in [emplid] - [select [managerid] :from [company]]]] - :result-types nil - :field-names nil - :flatp t - :order-by [last-name]) + :where [not [in [emplid] + [select [managerid] :from [company]]]] + :result-types nil + :field-names nil + :flatp t + :order-by [last-name]) ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" "Trotsky" "Yeltsin")) (deftest :fdml/select/11 (clsql:select [last-name] :from [employee] :where [married] :flatp t - :field-names nil :order-by [emplid] :result-types nil) + :field-names nil :order-by [emplid] :result-types nil) ("Lenin" "Stalin" "Trotsky")) (deftest :fdml/select/12 (let ((v 1)) (clsql:select [last-name] :from [employee] :where [= [emplid] v] - :field-names nil :result-types nil)) + :field-names nil :result-types nil)) (("Lenin"))) (deftest :fdml/select/13 - (multiple-value-bind (results field-names) - (clsql:select [emplid] [last-name] :from [employee] - :where [= [emplid] 1]) + (multiple-value-bind (results field-names) + (clsql:select [emplid] [last-name] :from [employee] + :where [= [emplid] 1]) (values results (mapcar #'string-downcase field-names))) ((1 "Lenin")) ("emplid" "last_name")) (deftest :fdml/select/14 - (floatp (car (clsql:select [height] :from [employee] :where [= [emplid] 1] - :flatp t))) + (floatp (car (clsql:select [height] :from [employee] :where [= [emplid] 1] + :flatp t))) t) (deftest :fdml/select/15 (multiple-value-bind (rows field-names) - (clsql:select [addressid] [street-number] [street-name] [city_field] [zip] - :from [addr] - :where [= 1 [addressid]]) + (clsql:select [addressid] [street-number] [street-name] [city_field] [zip] + :from [addr] + :where [= 1 [addressid]]) (values rows (mapcar #'string-downcase field-names))) @@ -356,23 +356,23 @@ (("1" "Lenin"))) (deftest :fdml/select/19 - (clsql:select [emplid] :from [employee] :order-by [emplid] + (clsql:select [emplid] :from [employee] :order-by [emplid] :where [between [* [emplid] 10] [* 5 10] [* 10 10]] :field-names nil :result-types nil :flatp t) ("5" "6" "7" "8" "9" "10")) (deftest :fdml/select/20 - (clsql:select [emplid] :from [employee] :order-by [emplid] + (clsql:select [emplid] :from [employee] :order-by [emplid] :where [not [between [* [emplid] 10] [* 5 10] [* 10 10]]] :field-names nil :result-types nil :flatp t) ("1" "2" "3" "4")) -(deftest :fdml/select/21 - (clsql:select [substring [first-name] 1 4] :from [employee] +(deftest :fdml/select/21 + (clsql:select [substring [first-name] 1 4] :from [employee] :flatp t :order-by [emplid] :field-names nil) ("Vlad" "Jose" "Leon" "Niki" "Leon" "Yuri" "Kons" "Mikh" "Bori" "Vlad")) -(deftest :fdml/select/22 +(deftest :fdml/select/22 (case *test-database-underlying-type* (:mssql (clsql:select [+ [first-name] " " [last-name]] :from [employee] :flatp t :order-by [emplid] :field-names nil)) @@ -397,50 +397,50 @@ (deftest :fdml/select/25 (clsql:select [first-name] :from (clsql-sys:convert-to-db-default-case "employee" *default-database*) :flatp t :distinct t - :field-names nil - :result-types nil + :field-names nil + :result-types nil :order-by [first-name]) ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladimir" "Yuri")) (deftest :fdml/select/26 - (clsql:select ["table" first-name] ["table" last-name] + (clsql:select ["table" first-name] ["table" last-name] :from '([employee "table"] [employee "join"]) - :where [and [= ["table" first-name] + :where [and [= ["table" first-name] ["join" first-name]] - [not [= ["table" emplid] + [not [= ["table" emplid] ["join" emplid]]]] :order-by '(["table" last-name]) :result-types nil :field-names nil) (("Vladimir" "Lenin") ("Vladimir" "Putin"))) -(deftest :fdml/select/27 +(deftest :fdml/select/27 (mapcar (lambda (f) (truncate (read-from-string f))) (clsql:select [coalesce [managerid] 10] :from [employee] :order-by [emplid] - :field-names nil :result-types nil :flatp t)) + :field-names nil :result-types nil :flatp t)) (10 1 1 1 1 1 1 1 1 1)) - -(deftest :fdml/select/28 + +(deftest :fdml/select/28 (mapcar (lambda (f) (truncate (read-from-string (car f)))) - (loop for column in `([*] [emplid]) collect - (clsql:select [count column] :from [employee] - :flatp t :result-types nil :field-names nil))) + (loop for column in `([*] [emplid]) collect + (clsql:select [count column] :from [employee] + :flatp t :result-types nil :field-names nil))) (10 10)) -(deftest :fdml/select/29 - (clsql:select [first-name] [last-name] :from [employee] - :result-types nil :field-names nil +(deftest :fdml/select/29 + (clsql:select [first-name] [last-name] :from [employee] + :result-types nil :field-names nil :order-by '(([first-name] :asc) ([last-name] :desc))) (("Boris" "Yeltsin") ("Josef" "Stalin") ("Konstantin" "Chernenko") ("Leon" "Trotsky") ("Leonid" "Brezhnev") ("Mikhail" "Gorbachev") ("Nikita" "Kruschev") ("Vladimir" "Putin") ("Vladimir" "Lenin") ("Yuri" "Andropov"))) -(deftest :fdml/select/30 - (clsql:select [first-name] [last-name] :from [employee] - :result-types nil :field-names nil +(deftest :fdml/select/30 + (clsql:select [first-name] [last-name] :from [employee] + :result-types nil :field-names nil :order-by '(([first-name] :asc) ([last-name] :asc))) (("Boris" "Yeltsin") ("Josef" "Stalin") ("Konstantin" "Chernenko") ("Leon" "Trotsky") ("Leonid" "Brezhnev") ("Mikhail" "Gorbachev") @@ -448,11 +448,11 @@ ("Yuri" "Andropov"))) (deftest :fdml/select/31 - (clsql:select [last-name] :from [employee] + (clsql:select [last-name] :from [employee] :set-operation [union [select [first-name] :from [employee] :order-by [last-name]]] :flatp t - :result-types nil + :result-types nil :field-names nil) ("Andropov" "Boris" "Brezhnev" "Chernenko" "Gorbachev" "Josef" "Konstantin" "Kruschev" "Lenin" "Leon" "Leonid" "Mikhail" "Nikita" "Putin" "Stalin" @@ -465,9 +465,9 @@ ("1")) (deftest :fdml/select/33 - (clsql:select [last-name] :from [employee] + (clsql:select [last-name] :from [employee] :where [> [emplid] [all [select [groupid] :from [employee]]]] - :order-by [last-name] + :order-by [last-name] :flatp t :result-types nil :field-names nil) ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" "Trotsky" "Yeltsin")) @@ -476,37 +476,37 @@ (loop for x from 1 below 5 collect (car - (clsql:select [last-name] :from [employee] - :where [= [emplid] x] - :flatp t :result-types nil :field-names nil))) + (clsql:select [last-name] :from [employee] + :where [= [emplid] x] + :flatp t :result-types nil :field-names nil))) ("Lenin" "Stalin" "Trotsky" "Kruschev")) -;; test escaping of single quotes -(deftest :fdml/select/35 +;; test escaping of single quotes +(deftest :fdml/select/35 (clsql:select "What's up doc?" :from [employee] :flatp t :field-names nil) ("What's up doc?" "What's up doc?" "What's up doc?" "What's up doc?" "What's up doc?" "What's up doc?" "What's up doc?" "What's up doc?" "What's up doc?" "What's up doc?")) -;; test proper treatment of backslash (depending on backend) +;; test proper treatment of backslash (depending on backend) (deftest :fdml/select/36 (clsql:select "foo\\bar\\baz" :from [employee] :flatp t :field-names nil) - ("foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" - "foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" + ("foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" + "foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz")) (deftest :fdml/select/37 - (clsql:select [emplid] :from [employee] + (clsql:select [emplid] :from [employee] :order-by [emplid] - :limit 5 + :limit 5 :field-names nil :flatp t) (1 2 3 4 5)) (deftest :fdml/select/38 - (clsql:select [emplid] :from [employee] + (clsql:select [emplid] :from [employee] :order-by [emplid] - :limit 5 + :limit 5 :offset 3 :field-names nil :flatp t) @@ -519,7 +519,7 @@ (push name result)) result) ("Yeltsin" "Trotsky" "Stalin" "Putin" "Lenin" "Kruschev" "Gorbachev" - "Chernenko" "Brezhnev" "Andropov")) + "Chernenko" "Brezhnev" "Andropov")) (deftest :fdml/map-query/1 (clsql:map-query 'list #'identity @@ -535,21 +535,21 @@ #("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" "Stalin" "Trotsky" "Yeltsin")) -(deftest :fdml/map-query/3 +(deftest :fdml/map-query/3 (clsql:map-query 'list #'identity [select [last-name] :from [employee] :order-by [last-name]]) (("Andropov") ("Brezhnev") ("Chernenko") ("Gorbachev") ("Kruschev") ("Lenin") ("Putin") ("Stalin") ("Trotsky") ("Yeltsin"))) -(deftest :fdml/map-query/4 +(deftest :fdml/map-query/4 (clsql:map-query 'list #'identity - [select [first-name] [last-name] :from [employee] + [select [first-name] [last-name] :from [employee] :order-by [last-name]]) (("Yuri" "Andropov") ("Leonid" "Brezhnev") ("Konstantin" "Chernenko") ("Mikhail" "Gorbachev") ("Nikita" "Kruschev") ("Vladimir" "Lenin") - ("Vladimir" "Putin") ("Josef" "Stalin") ("Leon" "Trotsky") + ("Vladimir" "Putin") ("Josef" "Stalin") ("Leon" "Trotsky") ("Boris" "Yeltsin"))) - + (deftest :fdml/loop/1 (loop for (forename surname) being each tuple in @@ -573,26 +573,26 @@ collect addressid) (1 2)) -;; starts a transaction deletes a record and then rolls back the deletion +;; starts a transaction deletes a record and then rolls back the deletion (deftest :fdml/transaction/1 (let ((results '())) ;; test if we are in a transaction (push (clsql:in-transaction-p) results) - ;;start a transaction + ;;start a transaction (clsql:start-transaction) ;; test if we are in a transaction (push (clsql:in-transaction-p) results) ;;Putin has got to go (clsql:delete-records :from [employee] :where [= [last-name] "Putin"]) - ;;Should be nil - (push + ;;Should be nil + (push (clsql:select [*] :from [employee] :where [= [last-name] "Putin"]) results) ;;Oh no, he's still there (clsql:rollback) ;; test that we are out of the transaction (push (clsql:in-transaction-p) results) - ;; Check that we got him back alright + ;; Check that we got him back alright (push (clsql:select [email] :from [employee] :where [= [last-name] "Putin"] :flatp t) results) @@ -604,7 +604,7 @@ (let ((results '())) ;; test if we are in a transaction (push (clsql:in-transaction-p) results) - ;;start a transaction + ;;start a transaction (clsql:start-transaction) ;; test if we are in a transaction (push (clsql:in-transaction-p) results) @@ -612,7 +612,7 @@ (clsql:update-records [employee] :av-pairs '((email "putin-nospam@soviet.org")) :where [= [last-name] "Putin"]) - ;;Should be new value + ;;Should be new value (push (clsql:select [email] :from [employee] :where [= [last-name] "Putin"] :flatp t) @@ -621,41 +621,41 @@ (clsql:rollback) ;; test that we are out of the transaction (push (clsql:in-transaction-p) results) - ;; Check that we got him back alright + ;; Check that we got him back alright (push (clsql:select [email] :from [employee] :where [= [last-name] "Putin"] :flatp t) results) (apply #'values (nreverse results))) - nil t ("putin-nospam@soviet.org") nil ("putin@soviet.org")) + nil t ("putin-nospam@soviet.org") nil ("putin@soviet.org")) ;; runs an update within a transaction and checks it is committed (deftest :fdml/transaction/3 (let ((results '())) - ;; check status + ;; check status (push (clsql:in-transaction-p) results) - ;; update records + ;; update records (push - (clsql:with-transaction () - (clsql:update-records [employee] + (clsql:with-transaction () + (clsql:update-records [employee] :av-pairs '((email "lenin-nospam@soviet.org")) :where [= [emplid] 1])) results) - ;; check status + ;; check status (push (clsql:in-transaction-p) results) - ;; check that was committed + ;; check that was committed (push (clsql:select [email] :from [employee] :where [= [emplid] 1] :flatp t) results) - ;; undo the changes + ;; undo the changes (push - (clsql:with-transaction () - (clsql:update-records [employee] + (clsql:with-transaction () + (clsql:update-records [employee] :av-pairs '((email "lenin@soviet.org")) :where [= [emplid] 1])) results) - ;; and check status + ;; and check status (push (clsql:in-transaction-p) results) - ;; check that was committed + ;; check that was committed (push (clsql:select [email] :from [employee] :where [= [emplid] 1] :flatp t) results) @@ -663,27 +663,27 @@ nil nil nil ("lenin-nospam@soviet.org") nil nil ("lenin@soviet.org")) ;; runs a valid update and an invalid one within a transaction and checks -;; that the valid update is rolled back when the invalid one fails. +;; that the valid update is rolled back when the invalid one fails. (deftest :fdml/transaction/4 (let ((results '())) ;; check status (push (clsql:in-transaction-p) results) - (handler-case - (clsql:with-transaction () - ;; valid update - (clsql:update-records [employee] - :av-pairs '((email "lenin-nospam@soviet.org")) - :where [= [emplid] 1]) - ;; invalid update which generates an error - (clsql:update-records [employee] - :av-pairs - '((emale "lenin-nospam@soviet.org")) - :where [= [emplid] 1])) + (handler-case + (clsql:with-transaction () + ;; valid update + (clsql:update-records [employee] + :av-pairs '((email "lenin-nospam@soviet.org")) + :where [= [emplid] 1]) + ;; invalid update which generates an error + (clsql:update-records [employee] + :av-pairs + '((emale "lenin-nospam@soviet.org")) + :where [= [emplid] 1])) (clsql:sql-database-error () (progn - ;; check status + ;; check status (push (clsql:in-transaction-p) results) - ;; and check nothing done + ;; and check nothing done (push (clsql:select [email] :from [employee] :where [= [emplid] 1] :flatp t) results) diff --git a/tests/test-init.lisp b/tests/test-init.lisp index 1353853..8064aa0 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -77,9 +77,9 @@ :accessor employee-company :db-kind :join :db-info (:join-class company - :home-key ecompanyid - :foreign-key companyid - :set nil)) + :home-key ecompanyid + :foreign-key companyid + :set nil)) (managerid :type integer :initarg :managerid) @@ -87,17 +87,17 @@ :accessor employee-manager :db-kind :join :db-info (:join-class employee - :home-key managerid - :foreign-key emplid - :set nil)) + :home-key managerid + :foreign-key emplid + :set nil)) (addresses :accessor employee-addresses :db-kind :join :db-info (:join-class employee-address - :home-key emplid - :foreign-key aemplid - :target-slot address - :set t))) + :home-key emplid + :foreign-key aemplid + :target-slot address + :set t))) (:base-table employee)) (def-view-class company () @@ -121,16 +121,16 @@ :reader president :db-kind :join :db-info (:join-class employee - :home-key presidentid - :foreign-key emplid - :set nil)) + :home-key presidentid + :foreign-key emplid + :set nil)) (employees :reader company-employees :db-kind :join :db-info (:join-class employee - :home-key (companyid groupid) - :foreign-key (ecompanyid groupid) - :set t)))) + :home-key (companyid groupid) + :foreign-key (ecompanyid groupid) + :set t)))) (def-view-class address () ((addressid @@ -163,15 +163,15 @@ (aaddressid :type integer :initarg :addressid) (verified :type boolean :initarg :verified) (address :db-kind :join - :db-info (:join-class address - :home-key aaddressid - :foreign-key addressid - :retrieval :immediate)) + :db-info (:join-class address + :home-key aaddressid + :foreign-key addressid + :retrieval :immediate)) (employee :db-kind :join - :db-info (:join-class employee - :home-key aemplid - :foreign-key emplid - :retrieval :immediate))) + :db-info (:join-class employee + :home-key aemplid + :foreign-key emplid + :retrieval :immediate))) (:base-table "ea_join")) (def-view-class deferred-employee-address () @@ -179,11 +179,11 @@ (aaddressid :type integer :initarg :addressid) (verified :type boolean :initarg :verified) (address :db-kind :join - :db-info (:join-class address - :home-key aaddressid - :foreign-key addressid - :retrieval :deferred - :set nil))) + :db-info (:join-class address + :home-key aaddressid + :foreign-key addressid + :retrieval :deferred + :set nil))) (:base-table "ea_join")) (def-view-class big () @@ -203,15 +203,15 @@ ;; Connect to the database (clsql:connect spec - :database-type db-type - :make-default t - :if-exists :old) + :database-type db-type + :make-default t + :if-exists :old) ;; Ensure database is empty (truncate-database :database *default-database*) (setf *test-database-underlying-type* - (clsql-sys:database-underlying-type *default-database*)) + (clsql-sys:database-underlying-type *default-database*)) *default-database*) @@ -237,9 +237,9 @@ (defun test-initialise-database () (test-basic-initialize) (let ((*backend-warning-behavior* - (if (member *test-database-type* '(:postgresql :postgresql-socket)) - :ignore - :warn))) + (if (member *test-database-type* '(:postgresql :postgresql-socket)) + :ignore + :warn))) (clsql:create-view-from-class 'employee) (clsql:create-view-from-class 'company) (clsql:create-view-from-class 'address) @@ -248,162 +248,162 @@ (setq *test-start-utime* (get-universal-time)) (let* ((*db-auto-sync* t) - (now-time (clsql:utime->time *test-start-utime*))) + (now-time (clsql:utime->time *test-start-utime*))) (setf company1 (make-instance 'company - :presidentid 1 - :companyid 1 - :groupid 1 - :name "Widgets Inc.") - employee1 (make-instance 'employee - :emplid 1 - :groupid 1 - :married t - :height (1+ (random 1.00)) - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Vladimir" - :last-name "Lenin" - :email "lenin@soviet.org" - :companyid 1) - employee2 (make-instance 'employee - :emplid 2 - :groupid 1 - :height (1+ (random 1.00)) - :married t - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Josef" - :last-name "Stalin" - :email "stalin@soviet.org" - :managerid 1 - :companyid 1) - employee3 (make-instance 'employee - :emplid 3 - :groupid 1 - :height (1+ (random 1.00)) - :married t - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Leon" - :last-name "Trotsky" - :email "trotsky@soviet.org" - :managerid 1 - :companyid 1) - employee4 (make-instance 'employee - :emplid 4 - :groupid 1 - :height (1+ (random 1.00)) - :married nil - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Nikita" - :last-name "Kruschev" - :email "kruschev@soviet.org" - :managerid 1 - :companyid 1) - employee5 (make-instance 'employee - :emplid 5 - :groupid 1 - :married nil - :height (1+ (random 1.00)) - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Leonid" - :last-name "Brezhnev" - :email "brezhnev@soviet.org" - :managerid 1 - :companyid 1) - employee6 (make-instance 'employee - :emplid 6 - :groupid 1 - :married nil - :height (1+ (random 1.00)) - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Yuri" - :last-name "Andropov" - :email "andropov@soviet.org" - :managerid 1 - :companyid 1) - employee7 (make-instance 'employee - :emplid 7 - :groupid 1 - :height (1+ (random 1.00)) - :married nil - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Konstantin" - :last-name "Chernenko" - :email "chernenko@soviet.org" - :managerid 1 - :companyid 1) - employee8 (make-instance 'employee - :emplid 8 - :groupid 1 - :height (1+ (random 1.00)) - :married nil - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Mikhail" - :last-name "Gorbachev" - :email "gorbachev@soviet.org" - :managerid 1 - :companyid 1) - employee9 (make-instance 'employee - :emplid 9 - :groupid 1 - :married nil - :height (1+ (random 1.00)) - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Boris" - :last-name "Yeltsin" - :email "yeltsin@soviet.org" - :managerid 1 - :companyid 1) - employee10 (make-instance 'employee - :emplid 10 - :groupid 1 - :married nil - :height (1+ (random 1.00)) - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Vladimir" - :last-name "Putin" - :email "putin@soviet.org" - :managerid 1 - :companyid 1) - address1 (make-instance 'address - :addressid 1 - :street-number 10 - :street-name "Park Place" - :city "Leningrad" - :postal-code 123) - address2 (make-instance 'address - :addressid 2) - employee-address1 (make-instance 'employee-address - :emplid 1 - :addressid 1 - :verified t) - employee-address2 (make-instance 'employee-address - :emplid 2 - :addressid 2 - :verified t) - employee-address3 (make-instance 'employee-address - :emplid 3 - :addressid 1 - :verified nil) - employee-address4 (make-instance 'employee-address - :emplid 1 - :addressid 2 - :verified nil) - employee-address5 (make-instance 'employee-address - :emplid 3 - :addressid 2)) + :presidentid 1 + :companyid 1 + :groupid 1 + :name "Widgets Inc.") + employee1 (make-instance 'employee + :emplid 1 + :groupid 1 + :married t + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Vladimir" + :last-name "Lenin" + :email "lenin@soviet.org" + :companyid 1) + employee2 (make-instance 'employee + :emplid 2 + :groupid 1 + :height (1+ (random 1.00)) + :married t + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Josef" + :last-name "Stalin" + :email "stalin@soviet.org" + :managerid 1 + :companyid 1) + employee3 (make-instance 'employee + :emplid 3 + :groupid 1 + :height (1+ (random 1.00)) + :married t + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Leon" + :last-name "Trotsky" + :email "trotsky@soviet.org" + :managerid 1 + :companyid 1) + employee4 (make-instance 'employee + :emplid 4 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Nikita" + :last-name "Kruschev" + :email "kruschev@soviet.org" + :managerid 1 + :companyid 1) + employee5 (make-instance 'employee + :emplid 5 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Leonid" + :last-name "Brezhnev" + :email "brezhnev@soviet.org" + :managerid 1 + :companyid 1) + employee6 (make-instance 'employee + :emplid 6 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Yuri" + :last-name "Andropov" + :email "andropov@soviet.org" + :managerid 1 + :companyid 1) + employee7 (make-instance 'employee + :emplid 7 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Konstantin" + :last-name "Chernenko" + :email "chernenko@soviet.org" + :managerid 1 + :companyid 1) + employee8 (make-instance 'employee + :emplid 8 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Mikhail" + :last-name "Gorbachev" + :email "gorbachev@soviet.org" + :managerid 1 + :companyid 1) + employee9 (make-instance 'employee + :emplid 9 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Boris" + :last-name "Yeltsin" + :email "yeltsin@soviet.org" + :managerid 1 + :companyid 1) + employee10 (make-instance 'employee + :emplid 10 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Vladimir" + :last-name "Putin" + :email "putin@soviet.org" + :managerid 1 + :companyid 1) + address1 (make-instance 'address + :addressid 1 + :street-number 10 + :street-name "Park Place" + :city "Leningrad" + :postal-code 123) + address2 (make-instance 'address + :addressid 2) + employee-address1 (make-instance 'employee-address + :emplid 1 + :addressid 1 + :verified t) + employee-address2 (make-instance 'employee-address + :emplid 2 + :addressid 2 + :verified t) + employee-address3 (make-instance 'employee-address + :emplid 3 + :addressid 1 + :verified nil) + employee-address4 (make-instance 'employee-address + :emplid 1 + :addressid 2 + :verified nil) + employee-address5 (make-instance 'employee-address + :emplid 3 + :addressid 2)) (let ((max (expt 2 60))) (dotimes (i 555) - (make-instance 'big :i (1+ i) :bi (truncate max (1+ i)))))) + (make-instance 'big :i (1+ i) :bi (truncate max (1+ i)))))) ;; sleep to ensure birthdays are no longer at current time (sleep 1) @@ -457,17 +457,17 @@ (defun run-function-append-report-file (function report-file) (let* ((report-path (etypecase report-file - (pathname report-file) - (string (parse-namestring report-file)))) - (sexp-report-path (make-pathname :defaults report-path - :type "sexp"))) + (pathname report-file) + (string (parse-namestring report-file)))) + (sexp-report-path (make-pathname :defaults report-path + :type "sexp"))) (with-open-file (rs report-path :direction :output - :if-exists :append - :if-does-not-exist :create) - (with-open-file (srs sexp-report-path :direction :output - :if-exists :append - :if-does-not-exist :create) - (funcall function :report-stream rs :sexp-report-stream srs))))) + :if-exists :append + :if-does-not-exist :create) + (with-open-file (srs sexp-report-path :direction :output + :if-exists :append + :if-does-not-exist :create) + (funcall function :report-stream rs :sexp-report-stream srs))))) (defun run-tests-append-report-file (report-file) (run-function-append-report-file 'run-tests report-file)) @@ -475,10 +475,10 @@ (defun run-tests (&key (report-stream *standard-output*) (sexp-report-stream nil)) (let ((specs (read-specs)) - (*report-stream* report-stream) - (*sexp-report-stream* sexp-report-stream) - (*error-count* 0) - (*error-list* nil)) + (*report-stream* report-stream) + (*sexp-report-stream* sexp-report-stream) + (*error-count* 0) + (*error-list* nil)) (unless specs (warn "Not running tests because test configuration file is missing") (return-from run-tests :skipped)) @@ -497,7 +497,7 @@ (defun write-report-banner (report-type db-type stream) (format stream - "~& + "~& ****************************************************************************** *** CLSQL ~A begun at ~A *** ~A @@ -505,19 +505,19 @@ *** Database ~:@(~A~) backend~A. ****************************************************************************** " - report-type - (clsql:format-time - nil - (clsql:utime->time (get-universal-time))) - (lisp-implementation-type) - (lisp-implementation-version) - (machine-type) - db-type - (if (not (eq db-type *test-database-underlying-type*)) - (format nil " with underlying type ~:@(~A~)" - *test-database-underlying-type*) - "") - )) + report-type + (clsql:format-time + nil + (clsql:utime->time (get-universal-time))) + (lisp-implementation-type) + (lisp-implementation-version) + (machine-type) + db-type + (if (not (eq db-type *test-database-underlying-type*)) + (format nil " with underlying type ~:@(~A~)" + *test-database-underlying-type*) + "") + )) (defun do-tests-for-backend (db-type spec) (test-connect-to-database db-type spec) @@ -561,69 +561,69 @@ (defun compute-tests-for-backend (db-type db-underlying-type) (let ((test-forms '()) - (skip-tests '())) + (skip-tests '())) (dolist (test-form (append *rt-internal* *rt-connection* *rt-basic* *rt-fddl* *rt-fdml* - *rt-ooddl* *rt-oodml* *rt-syntax*)) + *rt-ooddl* *rt-oodml* *rt-syntax*)) (let ((test (second test-form))) - (cond - ((and (null (clsql-sys:db-type-has-views? db-underlying-type)) - (clsql-sys:in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4)) - (push (cons test "views not supported") skip-tests)) - ((and (null (clsql-sys:db-type-has-boolean-where? db-underlying-type)) - (clsql-sys:in test :fdml/select/11 :oodml/select/5)) - (push (cons test "boolean where not supported") skip-tests)) - ((and (null (clsql-sys:db-type-has-subqueries? db-underlying-type)) - (clsql-sys:in test :fdml/select/5 :fdml/select/10 + (cond + ((and (null (clsql-sys:db-type-has-views? db-underlying-type)) + (clsql-sys:in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4)) + (push (cons test "views not supported") skip-tests)) + ((and (null (clsql-sys:db-type-has-boolean-where? db-underlying-type)) + (clsql-sys:in test :fdml/select/11 :oodml/select/5)) + (push (cons test "boolean where not supported") skip-tests)) + ((and (null (clsql-sys:db-type-has-subqueries? db-underlying-type)) + (clsql-sys:in test :fdml/select/5 :fdml/select/10 :fdml/select/32 :fdml/select/33)) - (push (cons test "subqueries not supported") skip-tests)) - ((and (null (clsql-sys:db-type-transaction-capable? db-underlying-type - *default-database*)) - (clsql-sys:in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4)) - (push (cons test "transactions not supported") skip-tests)) - ((and (null (clsql-sys:db-type-has-fancy-math? db-underlying-type)) - (clsql-sys:in test :fdml/select/1)) - (push (cons test "fancy math not supported") skip-tests)) - ((and (eql *test-database-type* :sqlite) - (clsql-sys:in test :fddl/view/4 :fdml/select/10 - :fdml/select/21 :fdml/select/32 + (push (cons test "subqueries not supported") skip-tests)) + ((and (null (clsql-sys:db-type-transaction-capable? db-underlying-type + *default-database*)) + (clsql-sys:in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4)) + (push (cons test "transactions not supported") skip-tests)) + ((and (null (clsql-sys:db-type-has-fancy-math? db-underlying-type)) + (clsql-sys:in test :fdml/select/1)) + (push (cons test "fancy math not supported") skip-tests)) + ((and (eql *test-database-type* :sqlite) + (clsql-sys:in test :fddl/view/4 :fdml/select/10 + :fdml/select/21 :fdml/select/32 :fdml/select/33)) - (push (cons test "not supported by sqlite") skip-tests)) - ((and (eql *test-database-type* :sqlite3) - (clsql-sys:in test :fddl/view/4 :fdml/select/10 - :fdml/select/21 :fdml/select/32 - :fdml/select/33)) - (push (cons test "not supported by sqlite3") skip-tests)) - ((and (not (clsql-sys:db-type-has-bigint? db-type)) - (clsql-sys:in test :basic/bigint/1)) - (push (cons test "bigint not supported") skip-tests)) - ((and (eql *test-database-underlying-type* :mysql) - (clsql-sys:in test :fdml/select/26)) - (push (cons test "string table aliases not supported on all mysql versions") skip-tests)) - ((and (eql *test-database-underlying-type* :mysql) - (clsql-sys:in test :fdml/select/22 :fdml/query/5 - :fdml/query/7 :fdml/query/8)) - (push (cons test "not supported by mysql") skip-tests)) - ((and (null (clsql-sys:db-type-has-union? db-underlying-type)) - (clsql-sys:in test :fdml/query/6 :fdml/select/31)) - (push (cons test "union not supported") skip-tests)) - ((and (eq *test-database-type* :oracle) - (clsql-sys:in test :fdml/query/8 :fdml/select/21 + (push (cons test "not supported by sqlite") skip-tests)) + ((and (eql *test-database-type* :sqlite3) + (clsql-sys:in test :fddl/view/4 :fdml/select/10 + :fdml/select/21 :fdml/select/32 + :fdml/select/33)) + (push (cons test "not supported by sqlite3") skip-tests)) + ((and (not (clsql-sys:db-type-has-bigint? db-type)) + (clsql-sys:in test :basic/bigint/1)) + (push (cons test "bigint not supported") skip-tests)) + ((and (eql *test-database-underlying-type* :mysql) + (clsql-sys:in test :fdml/select/26)) + (push (cons test "string table aliases not supported on all mysql versions") skip-tests)) + ((and (eql *test-database-underlying-type* :mysql) + (clsql-sys:in test :fdml/select/22 :fdml/query/5 + :fdml/query/7 :fdml/query/8)) + (push (cons test "not supported by mysql") skip-tests)) + ((and (null (clsql-sys:db-type-has-union? db-underlying-type)) + (clsql-sys:in test :fdml/query/6 :fdml/select/31)) + (push (cons test "union not supported") skip-tests)) + ((and (eq *test-database-type* :oracle) + (clsql-sys:in test :fdml/query/8 :fdml/select/21 :fddl/table/6)) - (push (cons test "syntax not supported") skip-tests)) + (push (cons test "syntax not supported") skip-tests)) ((and (eq *test-database-type* :odbc) - (eq *test-database-underlying-type* :postgresql) - (clsql-sys:in test :fddl/owner/1)) + (eq *test-database-underlying-type* :postgresql) + (clsql-sys:in test :fddl/owner/1)) (push (cons test "table ownership not supported by postgresql odbc driver") skip-tests)) - ((and (not (member *test-database-underlying-type* + ((and (not (member *test-database-underlying-type* '(:postgresql :oracle))) - (clsql-sys:in test :fddl/owner/1)) + (clsql-sys:in test :fddl/owner/1)) (push (cons test "table ownership not supported") skip-tests)) ((and (null (clsql-sys:db-type-has-intersect? db-underlying-type)) - (clsql-sys:in test :fdml/query/7)) - (push (cons test "intersect not supported") skip-tests)) + (clsql-sys:in test :fdml/query/7)) + (push (cons test "intersect not supported") skip-tests)) ((and (null (clsql-sys:db-type-has-except? db-underlying-type)) - (clsql-sys:in test :fdml/query/8)) - (push (cons test "except not supported") skip-tests)) + (clsql-sys:in test :fdml/query/8)) + (push (cons test "except not supported") skip-tests)) ((and (eq *test-database-underlying-type* :mssql) (clsql-sys:in test :fdml/select/9)) (push (cons test "mssql uses integer math for AVG") skip-tests)) @@ -631,8 +631,8 @@ '(:postgresql :mysql :sqlite3))) (clsql-sys:in test :fdml/select/37 :fdml/select/38)) (push (cons test "LIMIT keyword not supported in SELECT") skip-tests)) - (t - (push test-form test-forms))))) + (t + (push test-form test-forms))))) (values (nreverse test-forms) (nreverse skip-tests)))) (defun rapid-load (type &optional (position 0)) diff --git a/tests/test-internal.lisp b/tests/test-internal.lisp index 1b4cbf9..92e7ff7 100644 --- a/tests/test-internal.lisp +++ b/tests/test-internal.lisp @@ -21,24 +21,24 @@ (setq *rt-internal* '( (deftest :int/convert/1 - (clsql-sys::prepared-sql-to-postgresql-sql "SELECT FOO FROM BAR") + (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=?") + (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=?") + (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=?") + (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=?") + (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") - + )) diff --git a/tests/test-ooddl.lisp b/tests/test-ooddl.lisp index d2b73f4..bd54611 100644 --- a/tests/test-ooddl.lisp +++ b/tests/test-ooddl.lisp @@ -22,10 +22,10 @@ (setq *rt-ooddl* '( - + ;; Ensure slots inherited from standard-classes are :virtual (deftest :ooddl/metaclass/1 - (values + (values (clsql-sys::view-class-slot-db-kind (clsql-sys::slotdef-for-slot-with-class 'extraterrestrial (find-class 'person))) @@ -66,8 +66,8 @@ (clsql:execute-command "set datestyle to 'iso'")) (clsql:update-records [employee] :av-pairs `((birthday ,now)) :where [= [emplid] 1]) - (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now] - :flatp t)))) + (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now] + :flatp t)))) (values (slot-value dbobj 'last-name) (clsql:time= (slot-value dbobj 'birthday) now)))) @@ -82,7 +82,7 @@ (clsql:update-records [employee] :av-pairs `((birthday ,now)) :where [= [emplid] 1]) (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now] - :flatp t)))) + :flatp t)))) (unless (clsql:time= (slot-value dbobj 'birthday) now) (setf fail-index x)) (setf now (clsql:roll now :day (* 10 x))))) @@ -92,13 +92,13 @@ (deftest :ooddl/time/3 (progn (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket)) - (clsql:execute-command "set datestyle to 'iso'")) + (clsql:execute-command "set datestyle to 'iso'")) (let ((dbobj (car (clsql:select 'employee :where [= [emplid] 10] - :flatp t)))) - (list - (eql *test-start-utime* (slot-value dbobj 'bd-utime)) - (clsql:time= (slot-value dbobj 'birthday) - (clsql:utime->time (slot-value dbobj 'bd-utime)))))) + :flatp t)))) + (list + (eql *test-start-utime* (slot-value dbobj 'bd-utime)) + (clsql:time= (slot-value dbobj 'birthday) + (clsql:utime->time (slot-value dbobj 'bd-utime)))))) (t t)) )) diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index 87d897f..0e91f2d 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -21,524 +21,524 @@ (setq *rt-oodml* '( - - (deftest :oodml/select/1 - (mapcar #'(lambda (e) (slot-value e 'last-name)) - (clsql:select 'employee :order-by [last-name] :flatp t :caching nil)) - ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" - "Stalin" "Trotsky" "Yeltsin")) - - (deftest :oodml/select/2 - (mapcar #'(lambda (e) (slot-value e 'name)) - (clsql:select 'company :flatp t :caching nil)) - ("Widgets Inc.")) - - (deftest :oodml/select/3 - (mapcar #'(lambda (e) (slot-value e 'ecompanyid)) - (clsql:select 'employee - :where [and [= [slot-value 'employee 'ecompanyid] - [slot-value 'company 'companyid]] - [= [slot-value 'company 'name] - "Widgets Inc."]] - :flatp t - :caching nil)) - (1 1 1 1 1 1 1 1 1 1)) - - (deftest :oodml/select/4 - (mapcar #'(lambda (e) - (concatenate 'string (slot-value e 'first-name) - " " - (slot-value e 'last-name))) - (clsql:select 'employee :where [= [slot-value 'employee 'first-name] - "Vladimir"] - :flatp t - :order-by [last-name] - :caching nil)) - ("Vladimir Lenin" "Vladimir Putin")) - - (deftest :oodml/select/5 - (length (clsql:select 'employee :where [married] :flatp t :caching nil)) - 3) - - (deftest :oodml/select/6 - (let ((a (caar (clsql:select 'address :where [= 1 [addressid]] :caching nil)))) - (values - (slot-value a 'street-number) - (slot-value a 'street-name) - (slot-value a 'city) - (slot-value a 'postal-code))) - 10 "Park Place" "Leningrad" 123) - - (deftest :oodml/select/7 - (let ((a (caar (clsql:select 'address :where [= 2 [addressid]] :caching nil)))) - (values - (slot-value a 'street-number) - (slot-value a 'street-name) - (slot-value a 'city) - (slot-value a 'postal-code))) - nil "" "no city" 0) - - (deftest :oodml/select/8 - (mapcar #'(lambda (e) (slot-value e 'married)) - (clsql:select 'employee :flatp t :order-by [emplid] :caching nil)) - (t t t nil nil nil nil nil nil nil)) - - (deftest :oodml/select/9 - (mapcar #'(lambda (pair) - (list - (typep (car pair) 'address) - (typep (second pair) 'employee-address) - (slot-value (car pair) 'addressid) - (slot-value (second pair) 'aaddressid) - (slot-value (second pair) 'aemplid))) - (employee-addresses employee1)) - ((t t 1 1 1) (t t 2 2 1))) - - (deftest :oodml/select/10 - (mapcar #'(lambda (pair) - (list - (typep (car pair) 'address) - (typep (second pair) 'employee-address) - (slot-value (car pair) 'addressid) - (slot-value (second pair) 'aaddressid) - (slot-value (second pair) 'aemplid))) - (employee-addresses employee2)) - ((t t 2 2 2))) - - (deftest :oodml/select/11 + + (deftest :oodml/select/1 + (mapcar #'(lambda (e) (slot-value e 'last-name)) + (clsql:select 'employee :order-by [last-name] :flatp t :caching nil)) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin")) + + (deftest :oodml/select/2 + (mapcar #'(lambda (e) (slot-value e 'name)) + (clsql:select 'company :flatp t :caching nil)) + ("Widgets Inc.")) + + (deftest :oodml/select/3 + (mapcar #'(lambda (e) (slot-value e 'ecompanyid)) + (clsql:select 'employee + :where [and [= [slot-value 'employee 'ecompanyid] + [slot-value 'company 'companyid]] + [= [slot-value 'company 'name] + "Widgets Inc."]] + :flatp t + :caching nil)) + (1 1 1 1 1 1 1 1 1 1)) + + (deftest :oodml/select/4 + (mapcar #'(lambda (e) + (concatenate 'string (slot-value e 'first-name) + " " + (slot-value e 'last-name))) + (clsql:select 'employee :where [= [slot-value 'employee 'first-name] + "Vladimir"] + :flatp t + :order-by [last-name] + :caching nil)) + ("Vladimir Lenin" "Vladimir Putin")) + + (deftest :oodml/select/5 + (length (clsql:select 'employee :where [married] :flatp t :caching nil)) + 3) + + (deftest :oodml/select/6 + (let ((a (caar (clsql:select 'address :where [= 1 [addressid]] :caching nil)))) + (values + (slot-value a 'street-number) + (slot-value a 'street-name) + (slot-value a 'city) + (slot-value a 'postal-code))) + 10 "Park Place" "Leningrad" 123) + + (deftest :oodml/select/7 + (let ((a (caar (clsql:select 'address :where [= 2 [addressid]] :caching nil)))) + (values + (slot-value a 'street-number) + (slot-value a 'street-name) + (slot-value a 'city) + (slot-value a 'postal-code))) + nil "" "no city" 0) + + (deftest :oodml/select/8 + (mapcar #'(lambda (e) (slot-value e 'married)) + (clsql:select 'employee :flatp t :order-by [emplid] :caching nil)) + (t t t nil nil nil nil nil nil nil)) + + (deftest :oodml/select/9 + (mapcar #'(lambda (pair) + (list + (typep (car pair) 'address) + (typep (second pair) 'employee-address) + (slot-value (car pair) 'addressid) + (slot-value (second pair) 'aaddressid) + (slot-value (second pair) 'aemplid))) + (employee-addresses employee1)) + ((t t 1 1 1) (t t 2 2 1))) + + (deftest :oodml/select/10 + (mapcar #'(lambda (pair) + (list + (typep (car pair) 'address) + (typep (second pair) 'employee-address) + (slot-value (car pair) 'addressid) + (slot-value (second pair) 'aaddressid) + (slot-value (second pair) 'aemplid))) + (employee-addresses employee2)) + ((t t 2 2 2))) + + (deftest :oodml/select/11 (values (mapcar #'(lambda (x) (slot-value x 'emplid)) - (clsql:select 'employee :order-by '(([emplid] :asc)) + (clsql:select 'employee :order-by '(([emplid] :asc)) :flatp t)) (mapcar #'(lambda (x) (slot-value x 'emplid)) - (clsql:select 'employee :order-by '(([emplid] :desc)) - :flatp t))) + (clsql:select 'employee :order-by '(([emplid] :desc)) + :flatp t))) (1 2 3 4 5 6 7 8 9 10) (10 9 8 7 6 5 4 3 2 1)) - ;; test retrieval is deferred - (deftest :oodm/retrieval/1 - (every #'(lambda (e) (not (slot-boundp e 'company))) - (select 'employee :flatp t :caching nil)) - t) - - (deftest :oodm/retrieval/2 - (every #'(lambda (e) (not (slot-boundp e 'address))) - (select 'deferred-employee-address :flatp t :caching nil)) - t) - - ;; :retrieval :immediate should be boundp before accessed - (deftest :oodm/retrieval/3 - (every #'(lambda (ea) (slot-boundp ea 'address)) - (select 'employee-address :flatp t :caching nil)) - t) - - (deftest :oodm/retrieval/4 - (mapcar #'(lambda (ea) (typep (slot-value ea 'address) 'address)) - (select 'employee-address :flatp t :caching nil)) - (t t t t t)) - - (deftest :oodm/retrieval/5 - (mapcar #'(lambda (ea) (typep (slot-value ea 'address) 'address)) - (select 'deferred-employee-address :flatp t :caching nil)) - (t t t t t)) - - (deftest :oodm/retrieval/6 - (every #'(lambda (ea) (slot-boundp (slot-value ea 'address) 'addressid)) - (select 'employee-address :flatp t :caching nil)) - t) - - (deftest :oodm/retrieval/7 - (every #'(lambda (ea) (slot-boundp (slot-value ea 'address) 'addressid)) - (select 'deferred-employee-address :flatp t :caching nil)) - t) - - (deftest :oodm/retrieval/8 - (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) - (select 'employee-address :flatp t :order-by [aaddressid] :caching nil)) - (10 10 nil nil nil)) - - (deftest :oodm/retrieval/9 - (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) - (select 'deferred-employee-address :flatp t :order-by [aaddressid] :caching nil)) - (10 10 nil nil nil)) - - ;; tests update-records-from-instance - (deftest :oodml/update-records/1 - (values - (progn - (let ((lenin (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil)))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin)))) - (progn - (setf (slot-value employee1 'first-name) "Dimitriy" - (slot-value employee1 'last-name) "Ivanovich" - (slot-value employee1 'email) "ivanovich@soviet.org") - (clsql:update-records-from-instance employee1) - (let ((lenin (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil)))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin)))) - (progn - (setf (slot-value employee1 'first-name) "Vladimir" - (slot-value employee1 'last-name) "Lenin" - (slot-value employee1 'email) "lenin@soviet.org") - (clsql:update-records-from-instance employee1) - (let ((lenin (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil)))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin))))) - "Vladimir Lenin: lenin@soviet.org" - "Dimitriy Ivanovich: ivanovich@soviet.org" - "Vladimir Lenin: lenin@soviet.org") - - ;; tests update-record-from-slot - (deftest :oodml/update-records/2 - (values - (employee-email - (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] 1] - :flatp t - :caching nil))) - (progn - (setf (slot-value employee1 'email) "lenin-nospam@soviet.org") - (clsql:update-record-from-slot employee1 'email) - (employee-email - (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] 1] - :flatp t - :caching nil)))) - (progn - (setf (slot-value employee1 'email) "lenin@soviet.org") - (clsql:update-record-from-slot employee1 'email) - (employee-email - (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] 1] - :flatp t - :caching nil))))) - "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") - - ;; tests update-record-from-slots - (deftest :oodml/update-records/3 - (values - (let ((lenin (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil)))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin))) - (progn - (setf (slot-value employee1 'first-name) "Dimitriy" - (slot-value employee1 'last-name) "Ivanovich" - (slot-value employee1 'email) "ivanovich@soviet.org") - (clsql:update-record-from-slots employee1 '(first-name last-name email)) - (let ((lenin (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil)))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin)))) - (progn - (setf (slot-value employee1 'first-name) "Vladimir" - (slot-value employee1 'last-name) "Lenin" - (slot-value employee1 'email) "lenin@soviet.org") - (clsql:update-record-from-slots employee1 '(first-name last-name email)) - (let ((lenin (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil)))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin))))) - "Vladimir Lenin: lenin@soviet.org" - "Dimitriy Ivanovich: ivanovich@soviet.org" - "Vladimir Lenin: lenin@soviet.org") - - ;; tests update-instance-from-records - (deftest :oodml/update-instance/1 - (values - (concatenate 'string - (slot-value employee1 'first-name) - " " - (slot-value employee1 'last-name) - ": " - (slot-value employee1 'email)) - (progn - (clsql:update-records [employee] - :av-pairs '(([first-name] "Ivan") - ([last-name] "Petrov") - ([email] "petrov@soviet.org")) - :where [= [emplid] 1]) - (clsql:update-instance-from-records employee1) - (concatenate 'string - (slot-value employee1 'first-name) - " " - (slot-value employee1 'last-name) - ": " - (slot-value employee1 'email))) - (progn - (clsql:update-records [employee] - :av-pairs '(([first-name] "Vladimir") - ([last-name] "Lenin") - ([email] "lenin@soviet.org")) - :where [= [emplid] 1]) - (clsql:update-instance-from-records employee1) - (concatenate 'string - (slot-value employee1 'first-name) - " " - (slot-value employee1 'last-name) - ": " - (slot-value employee1 'email)))) - "Vladimir Lenin: lenin@soviet.org" - "Ivan Petrov: petrov@soviet.org" - "Vladimir Lenin: lenin@soviet.org") - - ;; tests update-slot-from-record - (deftest :oodml/update-instance/2 - (values - (slot-value employee1 'email) - (progn - (clsql:update-records [employee] - :av-pairs '(([email] "lenin-nospam@soviet.org")) - :where [= [emplid] 1]) - (clsql:update-slot-from-record employee1 'email) - (slot-value employee1 'email)) - (progn - (clsql:update-records [employee] - :av-pairs '(([email] "lenin@soviet.org")) - :where [= [emplid] 1]) - (clsql:update-slot-from-record employee1 'email) - (slot-value employee1 'email))) - "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") - - - (deftest :oodml/do-query/1 - (let ((result '())) - (clsql:do-query ((e) [select 'employee :order-by [emplid]]) - (push (slot-value e 'last-name) result)) - result) - ("Putin" "Yeltsin" "Gorbachev" "Chernenko" "Andropov" "Brezhnev" "Kruschev" - "Trotsky" "Stalin" "Lenin")) - - (deftest :oodml/do-query/2 - (let ((result '())) - (clsql:do-query ((e c) [select 'employee 'company - :where [= [slot-value 'employee 'last-name] - "Lenin"]]) - (push (list (slot-value e 'last-name) (slot-value c 'name)) - result)) - result) - (("Lenin" "Widgets Inc."))) - - (deftest :oodml/map-query/1 - (clsql:map-query 'list #'last-name [select 'employee :order-by [emplid]]) - ("Lenin" "Stalin" "Trotsky" "Kruschev" "Brezhnev" "Andropov" "Chernenko" - "Gorbachev" "Yeltsin" "Putin")) - - (deftest :oodml/map-query/2 - (clsql:map-query 'list #'(lambda (e c) (list (slot-value e 'last-name) - (slot-value c 'name))) - [select 'employee 'company :where [= [slot-value 'employee 'last-name] - "Lenin"]]) - (("Lenin" "Widgets Inc."))) - - (deftest :oodml/iteration/3 - (loop for (e) being the records in - [select 'employee :where [< [emplid] 4] :order-by [emplid]] - collect (slot-value e 'last-name)) - ("Lenin" "Stalin" "Trotsky")) + ;; test retrieval is deferred + (deftest :oodm/retrieval/1 + (every #'(lambda (e) (not (slot-boundp e 'company))) + (select 'employee :flatp t :caching nil)) + t) + + (deftest :oodm/retrieval/2 + (every #'(lambda (e) (not (slot-boundp e 'address))) + (select 'deferred-employee-address :flatp t :caching nil)) + t) + + ;; :retrieval :immediate should be boundp before accessed + (deftest :oodm/retrieval/3 + (every #'(lambda (ea) (slot-boundp ea 'address)) + (select 'employee-address :flatp t :caching nil)) + t) + + (deftest :oodm/retrieval/4 + (mapcar #'(lambda (ea) (typep (slot-value ea 'address) 'address)) + (select 'employee-address :flatp t :caching nil)) + (t t t t t)) + + (deftest :oodm/retrieval/5 + (mapcar #'(lambda (ea) (typep (slot-value ea 'address) 'address)) + (select 'deferred-employee-address :flatp t :caching nil)) + (t t t t t)) + + (deftest :oodm/retrieval/6 + (every #'(lambda (ea) (slot-boundp (slot-value ea 'address) 'addressid)) + (select 'employee-address :flatp t :caching nil)) + t) + + (deftest :oodm/retrieval/7 + (every #'(lambda (ea) (slot-boundp (slot-value ea 'address) 'addressid)) + (select 'deferred-employee-address :flatp t :caching nil)) + t) + + (deftest :oodm/retrieval/8 + (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) + (select 'employee-address :flatp t :order-by [aaddressid] :caching nil)) + (10 10 nil nil nil)) + + (deftest :oodm/retrieval/9 + (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) + (select 'deferred-employee-address :flatp t :order-by [aaddressid] :caching nil)) + (10 10 nil nil nil)) + + ;; tests update-records-from-instance + (deftest :oodml/update-records/1 + (values + (progn + (let ((lenin (car (clsql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil)))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin)))) + (progn + (setf (slot-value employee1 'first-name) "Dimitriy" + (slot-value employee1 'last-name) "Ivanovich" + (slot-value employee1 'email) "ivanovich@soviet.org") + (clsql:update-records-from-instance employee1) + (let ((lenin (car (clsql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil)))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin)))) + (progn + (setf (slot-value employee1 'first-name) "Vladimir" + (slot-value employee1 'last-name) "Lenin" + (slot-value employee1 'email) "lenin@soviet.org") + (clsql:update-records-from-instance employee1) + (let ((lenin (car (clsql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil)))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin))))) + "Vladimir Lenin: lenin@soviet.org" + "Dimitriy Ivanovich: ivanovich@soviet.org" + "Vladimir Lenin: lenin@soviet.org") + + ;; tests update-record-from-slot + (deftest :oodml/update-records/2 + (values + (employee-email + (car (clsql:select 'employee + :where [= [slot-value 'employee 'emplid] 1] + :flatp t + :caching nil))) + (progn + (setf (slot-value employee1 'email) "lenin-nospam@soviet.org") + (clsql:update-record-from-slot employee1 'email) + (employee-email + (car (clsql:select 'employee + :where [= [slot-value 'employee 'emplid] 1] + :flatp t + :caching nil)))) + (progn + (setf (slot-value employee1 'email) "lenin@soviet.org") + (clsql:update-record-from-slot employee1 'email) + (employee-email + (car (clsql:select 'employee + :where [= [slot-value 'employee 'emplid] 1] + :flatp t + :caching nil))))) + "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") + + ;; tests update-record-from-slots + (deftest :oodml/update-records/3 + (values + (let ((lenin (car (clsql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil)))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin))) + (progn + (setf (slot-value employee1 'first-name) "Dimitriy" + (slot-value employee1 'last-name) "Ivanovich" + (slot-value employee1 'email) "ivanovich@soviet.org") + (clsql:update-record-from-slots employee1 '(first-name last-name email)) + (let ((lenin (car (clsql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil)))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin)))) + (progn + (setf (slot-value employee1 'first-name) "Vladimir" + (slot-value employee1 'last-name) "Lenin" + (slot-value employee1 'email) "lenin@soviet.org") + (clsql:update-record-from-slots employee1 '(first-name last-name email)) + (let ((lenin (car (clsql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil)))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin))))) + "Vladimir Lenin: lenin@soviet.org" + "Dimitriy Ivanovich: ivanovich@soviet.org" + "Vladimir Lenin: lenin@soviet.org") + + ;; tests update-instance-from-records + (deftest :oodml/update-instance/1 + (values + (concatenate 'string + (slot-value employee1 'first-name) + " " + (slot-value employee1 'last-name) + ": " + (slot-value employee1 'email)) + (progn + (clsql:update-records [employee] + :av-pairs '(([first-name] "Ivan") + ([last-name] "Petrov") + ([email] "petrov@soviet.org")) + :where [= [emplid] 1]) + (clsql:update-instance-from-records employee1) + (concatenate 'string + (slot-value employee1 'first-name) + " " + (slot-value employee1 'last-name) + ": " + (slot-value employee1 'email))) + (progn + (clsql:update-records [employee] + :av-pairs '(([first-name] "Vladimir") + ([last-name] "Lenin") + ([email] "lenin@soviet.org")) + :where [= [emplid] 1]) + (clsql:update-instance-from-records employee1) + (concatenate 'string + (slot-value employee1 'first-name) + " " + (slot-value employee1 'last-name) + ": " + (slot-value employee1 'email)))) + "Vladimir Lenin: lenin@soviet.org" + "Ivan Petrov: petrov@soviet.org" + "Vladimir Lenin: lenin@soviet.org") + + ;; tests update-slot-from-record + (deftest :oodml/update-instance/2 + (values + (slot-value employee1 'email) + (progn + (clsql:update-records [employee] + :av-pairs '(([email] "lenin-nospam@soviet.org")) + :where [= [emplid] 1]) + (clsql:update-slot-from-record employee1 'email) + (slot-value employee1 'email)) + (progn + (clsql:update-records [employee] + :av-pairs '(([email] "lenin@soviet.org")) + :where [= [emplid] 1]) + (clsql:update-slot-from-record employee1 'email) + (slot-value employee1 'email))) + "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") + + + (deftest :oodml/do-query/1 + (let ((result '())) + (clsql:do-query ((e) [select 'employee :order-by [emplid]]) + (push (slot-value e 'last-name) result)) + result) + ("Putin" "Yeltsin" "Gorbachev" "Chernenko" "Andropov" "Brezhnev" "Kruschev" + "Trotsky" "Stalin" "Lenin")) + + (deftest :oodml/do-query/2 + (let ((result '())) + (clsql:do-query ((e c) [select 'employee 'company + :where [= [slot-value 'employee 'last-name] + "Lenin"]]) + (push (list (slot-value e 'last-name) (slot-value c 'name)) + result)) + result) + (("Lenin" "Widgets Inc."))) + + (deftest :oodml/map-query/1 + (clsql:map-query 'list #'last-name [select 'employee :order-by [emplid]]) + ("Lenin" "Stalin" "Trotsky" "Kruschev" "Brezhnev" "Andropov" "Chernenko" + "Gorbachev" "Yeltsin" "Putin")) + + (deftest :oodml/map-query/2 + (clsql:map-query 'list #'(lambda (e c) (list (slot-value e 'last-name) + (slot-value c 'name))) + [select 'employee 'company :where [= [slot-value 'employee 'last-name] + "Lenin"]]) + (("Lenin" "Widgets Inc."))) + + (deftest :oodml/iteration/3 + (loop for (e) being the records in + [select 'employee :where [< [emplid] 4] :order-by [emplid]] + collect (slot-value e 'last-name)) + ("Lenin" "Stalin" "Trotsky")) (deftest :oodml/cache/1 - (progn - (setf (clsql-sys:record-caches *default-database*) nil) - (let ((employees (select 'employee))) - (every #'(lambda (a b) (eq a b)) - employees (select 'employee)))) - t) - - (deftest :oodml/cache/2 - (let ((employees (select 'employee))) - (equal employees (select 'employee :flatp t))) - nil) - - (deftest :oodml/refresh/1 - (let ((addresses (select 'address))) - (equal addresses (select 'address :refresh t))) - t) - - (deftest :oodml/refresh/2 - (let* ((addresses (select 'address :order-by [addressid] :flatp t :refresh t)) - (city (slot-value (car addresses) 'city))) - (clsql:update-records [addr] + (progn + (setf (clsql-sys:record-caches *default-database*) nil) + (let ((employees (select 'employee))) + (every #'(lambda (a b) (eq a b)) + employees (select 'employee)))) + t) + + (deftest :oodml/cache/2 + (let ((employees (select 'employee))) + (equal employees (select 'employee :flatp t))) + nil) + + (deftest :oodml/refresh/1 + (let ((addresses (select 'address))) + (equal addresses (select 'address :refresh t))) + t) + + (deftest :oodml/refresh/2 + (let* ((addresses (select 'address :order-by [addressid] :flatp t :refresh t)) + (city (slot-value (car addresses) 'city))) + (clsql:update-records [addr] :av-pairs '((city_field "A new city")) :where [= [addressid] (slot-value (car addresses) 'addressid)]) - (let* ((new-addresses (select 'address :order-by [addressid] :refresh t :flatp t)) - (new-city (slot-value (car addresses) 'city)) + (let* ((new-addresses (select 'address :order-by [addressid] :refresh t :flatp t)) + (new-city (slot-value (car addresses) 'city)) ) - (clsql:update-records [addr] - :av-pairs `((city_field ,city)) - :where [= [addressid] (slot-value (car addresses) 'addressid)]) - (values (equal addresses new-addresses) - city - new-city))) - t "Leningrad" "A new city") - - (deftest :oodml/refresh/3 - (let* ((addresses (select 'address :order-by [addressid] :flatp t))) - (values - (equal addresses (select 'address :refresh t :flatp t)) - (equal addresses (select 'address :flatp t)))) - nil nil) - - (deftest :oodml/refresh/4 - (let* ((addresses (select 'address :order-by [addressid] :flatp t :refresh t)) - (*db-auto-sync* t)) - (make-instance 'address :addressid 1000 :city "A new address city") - (let ((new-addresses (select 'address :order-by [addressid] :flatp t :refresh t))) - (delete-records :from [addr] :where [= [addressid] 1000]) - (values - (length addresses) - (length new-addresses) - (eq (first addresses) (first new-addresses)) - (eq (second addresses) (second new-addresses))))) - 2 3 t t) - - - (deftest :oodml/uoj/1 - (progn - (let* ((dea-list (select 'deferred-employee-address :caching nil :order-by [ea_join aaddressid] - :flatp t)) - (dea-list-copy (copy-seq dea-list)) - (initially-unbound (every #'(lambda (dea) (not (slot-boundp dea 'address))) dea-list))) - (update-objects-joins dea-list) - (values - initially-unbound - (equal dea-list dea-list-copy) - (every #'(lambda (dea) (slot-boundp dea 'address)) dea-list) - (every #'(lambda (dea) (typep (slot-value dea 'address) 'address)) dea-list) - (mapcar #'(lambda (dea) (slot-value (slot-value dea 'address) 'addressid)) dea-list)))) - t t t t (1 1 2 2 2)) - - ;; update-object-joins needs to be fixed for multiple keys - #+ignore - (deftest :oodml/uoj/2 - (progn - (clsql:update-objects-joins (list company1)) - (mapcar #'(lambda (e) - (slot-value e 'ecompanyid)) - (company-employees company1))) - (1 1 1 1 1 1 1 1 1 1)) - - (deftest :oodml/big/1 - (let ((objs (clsql:select 'big :order-by [i] :flatp t))) - (values - (length objs) - (do ((i 0 (1+ i)) - (max (expt 2 60)) - (rest objs (cdr rest))) - ((= i (length objs)) t) - (let ((obj (car rest)) - (index (1+ i))) - (unless (and (eql (slot-value obj 'i) index) - (eql (slot-value obj 'bi) (truncate max index))) - (print index) - (describe obj) - (return nil)))))) - 555 t) - - (deftest :oodml/db-auto-sync/1 + (clsql:update-records [addr] + :av-pairs `((city_field ,city)) + :where [= [addressid] (slot-value (car addresses) 'addressid)]) + (values (equal addresses new-addresses) + city + new-city))) + t "Leningrad" "A new city") + + (deftest :oodml/refresh/3 + (let* ((addresses (select 'address :order-by [addressid] :flatp t))) + (values + (equal addresses (select 'address :refresh t :flatp t)) + (equal addresses (select 'address :flatp t)))) + nil nil) + + (deftest :oodml/refresh/4 + (let* ((addresses (select 'address :order-by [addressid] :flatp t :refresh t)) + (*db-auto-sync* t)) + (make-instance 'address :addressid 1000 :city "A new address city") + (let ((new-addresses (select 'address :order-by [addressid] :flatp t :refresh t))) + (delete-records :from [addr] :where [= [addressid] 1000]) + (values + (length addresses) + (length new-addresses) + (eq (first addresses) (first new-addresses)) + (eq (second addresses) (second new-addresses))))) + 2 3 t t) + + + (deftest :oodml/uoj/1 + (progn + (let* ((dea-list (select 'deferred-employee-address :caching nil :order-by [ea_join aaddressid] + :flatp t)) + (dea-list-copy (copy-seq dea-list)) + (initially-unbound (every #'(lambda (dea) (not (slot-boundp dea 'address))) dea-list))) + (update-objects-joins dea-list) + (values + initially-unbound + (equal dea-list dea-list-copy) + (every #'(lambda (dea) (slot-boundp dea 'address)) dea-list) + (every #'(lambda (dea) (typep (slot-value dea 'address) 'address)) dea-list) + (mapcar #'(lambda (dea) (slot-value (slot-value dea 'address) 'addressid)) dea-list)))) + t t t t (1 1 2 2 2)) + + ;; update-object-joins needs to be fixed for multiple keys + #+ignore + (deftest :oodml/uoj/2 + (progn + (clsql:update-objects-joins (list company1)) + (mapcar #'(lambda (e) + (slot-value e 'ecompanyid)) + (company-employees company1))) + (1 1 1 1 1 1 1 1 1 1)) + + (deftest :oodml/big/1 + (let ((objs (clsql:select 'big :order-by [i] :flatp t))) + (values + (length objs) + (do ((i 0 (1+ i)) + (max (expt 2 60)) + (rest objs (cdr rest))) + ((= i (length objs)) t) + (let ((obj (car rest)) + (index (1+ i))) + (unless (and (eql (slot-value obj 'i) index) + (eql (slot-value obj 'bi) (truncate max index))) + (print index) + (describe obj) + (return nil)))))) + 555 t) + + (deftest :oodml/db-auto-sync/1 (values - (progn - (make-instance 'employee :emplid 20 :groupid 1 + (progn + (make-instance 'employee :emplid 20 :groupid 1 :last-name "Ivanovich") (select [last-name] :from [employee] :where [= [emplid] 20] :flatp t :field-names nil)) (let ((*db-auto-sync* t)) - (make-instance 'employee :emplid 20 :groupid 1 + (make-instance 'employee :emplid 20 :groupid 1 :last-name "Ivanovich") (prog1 (select [last-name] :from [employee] :flatp t - :field-names nil + :field-names nil :where [= [emplid] 20]) (delete-records :from [employee] :where [= [emplid] 20])))) nil ("Ivanovich")) (deftest :oodml/db-auto-sync/2 (values - (let ((instance (make-instance 'employee :emplid 20 :groupid 1 + (let ((instance (make-instance 'employee :emplid 20 :groupid 1 :last-name "Ivanovich"))) (setf (slot-value instance 'last-name) "Bulgakov") (select [last-name] :from [employee] :where [= [emplid] 20] :flatp t :field-names nil)) (let* ((*db-auto-sync* t) - (instance (make-instance 'employee :emplid 20 :groupid 1 + (instance (make-instance 'employee :emplid 20 :groupid 1 :last-name "Ivanovich"))) (setf (slot-value instance 'last-name) "Bulgakov") (prog1 (select [last-name] :from [employee] :flatp t - :field-names nil + :field-names nil :where [= [emplid] 20]) (delete-records :from [employee] :where [= [emplid] 20])))) nil ("Bulgakov")) - - (deftest :oodml/setf-slot-value/1 + + (deftest :oodml/setf-slot-value/1 (let* ((*db-auto-sync* t) (instance (make-instance 'employee :emplid 20 :groupid 1))) - (prog1 - (setf + (prog1 + (setf (slot-value instance 'first-name) "Mikhail" (slot-value instance 'last-name) "Bulgakov") (delete-records :from [employee] :where [= [emplid] 20]))) "Bulgakov") - (deftest :oodml/float/1 - (let* ((emp1 (car (select 'employee - :where [= [slot-value 'employee 'emplid] + (deftest :oodml/float/1 + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] 1] - :flatp t + :flatp t :caching nil))) (height (slot-value emp1 'height))) - (prog1 - (progn + (prog1 + (progn (setf (slot-value emp1 'height) 1.0E0) (clsql:update-record-from-slot emp1 'height) - (= (car (clsql:select [height] :from [employee] - :where [= [emplid] 1] - :flatp t + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t :field-names nil)) 1)) (setf (slot-value emp1 'height) height) @@ -546,19 +546,19 @@ t) (deftest :oodml/float/2 - (let* ((emp1 (car (select 'employee - :where [= [slot-value 'employee 'emplid] + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] 1] - :flatp t + :flatp t :caching nil))) (height (slot-value emp1 'height))) - (prog1 - (progn + (prog1 + (progn (setf (slot-value emp1 'height) 1.0S0) (clsql:update-record-from-slot emp1 'height) - (= (car (clsql:select [height] :from [employee] - :where [= [emplid] 1] - :flatp t + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t :field-names nil)) 1)) (setf (slot-value emp1 'height) height) @@ -566,19 +566,19 @@ t) (deftest :oodml/float/3 - (let* ((emp1 (car (select 'employee - :where [= [slot-value 'employee 'emplid] + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] 1] - :flatp t + :flatp t :caching nil))) (height (slot-value emp1 'height))) - (prog1 - (progn + (prog1 + (progn (setf (slot-value emp1 'height) 1.0F0) (clsql:update-record-from-slot emp1 'height) - (= (car (clsql:select [height] :from [employee] - :where [= [emplid] 1] - :flatp t + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t :field-names nil)) 1)) (setf (slot-value emp1 'height) height) @@ -586,19 +586,19 @@ t) (deftest :oodml/float/4 - (let* ((emp1 (car (select 'employee - :where [= [slot-value 'employee 'emplid] + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] 1] - :flatp t + :flatp t :caching nil))) (height (slot-value emp1 'height))) - (prog1 - (progn + (prog1 + (progn (setf (slot-value emp1 'height) 1.0D0) (clsql:update-record-from-slot emp1 'height) - (= (car (clsql:select [height] :from [employee] - :where [= [emplid] 1] - :flatp t + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t :field-names nil)) 1)) (setf (slot-value emp1 'height) height) @@ -606,26 +606,26 @@ t) (deftest :oodml/float/5 - (let* ((emp1 (car (select 'employee - :where [= [slot-value 'employee 'emplid] + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] 1] - :flatp t + :flatp t :caching nil))) (height (slot-value emp1 'height))) - (prog1 - (progn + (prog1 + (progn (setf (slot-value emp1 'height) 1.0L0) (clsql:update-record-from-slot emp1 'height) - (= (car (clsql:select [height] :from [employee] - :where [= [emplid] 1] - :flatp t + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t :field-names nil)) 1)) (setf (slot-value emp1 'height) height) (clsql:update-record-from-slot emp1 'height))) t) - )) + )) diff --git a/tests/test-time.lisp b/tests/test-time.lisp index 92cf022..9b4b857 100644 --- a/tests/test-time.lisp +++ b/tests/test-time.lisp @@ -7,62 +7,62 @@ (in-package #:clsql-tests) -(setq *rt-time* +(setq *rt-time* '( ;; relations of intervals (deftest :time/1 (let* ((time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) - (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) - (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) - (time-4 (clsql:parse-timestring "2002-01-01 13:00:00")) - (interval-1 (clsql:make-interval :start time-1 :end time-2)) - (interval-2 (clsql:make-interval :start time-2 :end time-3)) - (interval-3 (clsql:make-interval :start time-3 :end time-4)) - (interval-4 (clsql:make-interval :start time-1 :end time-3)) - (interval-5 (clsql:make-interval :start time-2 :end time-4)) - (interval-6 (clsql:make-interval :start time-1 :end time-4))) + (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) + (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) + (time-4 (clsql:parse-timestring "2002-01-01 13:00:00")) + (interval-1 (clsql:make-interval :start time-1 :end time-2)) + (interval-2 (clsql:make-interval :start time-2 :end time-3)) + (interval-3 (clsql:make-interval :start time-3 :end time-4)) + (interval-4 (clsql:make-interval :start time-1 :end time-3)) + (interval-5 (clsql:make-interval :start time-2 :end time-4)) + (interval-6 (clsql:make-interval :start time-1 :end time-4))) (flet ((my-assert (number relation i1 i2) - (declare (ignore number)) - (let ((found-relation (clsql:interval-relation i1 i2))) - (equal relation found-relation)))) - (and - (my-assert 1 :contains interval-1 interval-1) - (my-assert 2 :precedes interval-1 interval-2) - (my-assert 3 :precedes interval-1 interval-3) - (my-assert 4 :contained interval-1 interval-4) - (my-assert 5 :precedes interval-1 interval-5) - (my-assert 6 :contained interval-1 interval-6) - (my-assert 7 :follows interval-2 interval-1) - (my-assert 8 :contains interval-2 interval-2) - (my-assert 9 :precedes interval-2 interval-3) - (my-assert 10 :contained interval-2 interval-4) - (my-assert 11 :contained interval-2 interval-5) - (my-assert 12 :contained interval-2 interval-6) - (my-assert 13 :follows interval-3 interval-1) - (my-assert 14 :follows interval-3 interval-2) - (my-assert 15 :contains interval-3 interval-3) - (my-assert 16 :follows interval-3 interval-4) - (my-assert 17 :contained interval-3 interval-5) - (my-assert 18 :contained interval-3 interval-6) - (my-assert 19 :contains interval-4 interval-1) - (my-assert 20 :contains interval-4 interval-2) - (my-assert 21 :precedes interval-4 interval-3) - (my-assert 22 :contains interval-4 interval-4) - (my-assert 23 :overlaps interval-4 interval-5) - (my-assert 24 :contained interval-4 interval-6) - (my-assert 25 :follows interval-5 interval-1) - (my-assert 26 :contains interval-5 interval-2) - (my-assert 27 :contains interval-5 interval-3) - (my-assert 28 :overlaps interval-5 interval-4) - (my-assert 29 :contains interval-5 interval-5) - (my-assert 30 :contained interval-5 interval-6) - (my-assert 31 :contains interval-6 interval-1) - (my-assert 32 :contains interval-6 interval-2) - (my-assert 33 :contains interval-6 interval-3) - (my-assert 34 :contains interval-6 interval-4) - (my-assert 35 :contains interval-6 interval-5) - (my-assert 36 :contains interval-6 interval-6)))) + (declare (ignore number)) + (let ((found-relation (clsql:interval-relation i1 i2))) + (equal relation found-relation)))) + (and + (my-assert 1 :contains interval-1 interval-1) + (my-assert 2 :precedes interval-1 interval-2) + (my-assert 3 :precedes interval-1 interval-3) + (my-assert 4 :contained interval-1 interval-4) + (my-assert 5 :precedes interval-1 interval-5) + (my-assert 6 :contained interval-1 interval-6) + (my-assert 7 :follows interval-2 interval-1) + (my-assert 8 :contains interval-2 interval-2) + (my-assert 9 :precedes interval-2 interval-3) + (my-assert 10 :contained interval-2 interval-4) + (my-assert 11 :contained interval-2 interval-5) + (my-assert 12 :contained interval-2 interval-6) + (my-assert 13 :follows interval-3 interval-1) + (my-assert 14 :follows interval-3 interval-2) + (my-assert 15 :contains interval-3 interval-3) + (my-assert 16 :follows interval-3 interval-4) + (my-assert 17 :contained interval-3 interval-5) + (my-assert 18 :contained interval-3 interval-6) + (my-assert 19 :contains interval-4 interval-1) + (my-assert 20 :contains interval-4 interval-2) + (my-assert 21 :precedes interval-4 interval-3) + (my-assert 22 :contains interval-4 interval-4) + (my-assert 23 :overlaps interval-4 interval-5) + (my-assert 24 :contained interval-4 interval-6) + (my-assert 25 :follows interval-5 interval-1) + (my-assert 26 :contains interval-5 interval-2) + (my-assert 27 :contains interval-5 interval-3) + (my-assert 28 :overlaps interval-5 interval-4) + (my-assert 29 :contains interval-5 interval-5) + (my-assert 30 :contained interval-5 interval-6) + (my-assert 31 :contains interval-6 interval-1) + (my-assert 32 :contains interval-6 interval-2) + (my-assert 33 :contains interval-6 interval-3) + (my-assert 34 :contains interval-6 interval-4) + (my-assert 35 :contains interval-6 interval-5) + (my-assert 36 :contains interval-6 interval-6)))) t) ;; adjacent intervals in list @@ -71,145 +71,145 @@ (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) (time-4 (clsql:parse-timestring "2002-01-01 13:00:00"))) - (setf interval-list - (clsql:interval-push interval-list (clsql:make-interval :start time-1 :end time-3 - :type :open))) - (setf interval-list - (clsql:interval-push interval-list (clsql:make-interval :start time-3 :end time-4 - :type :open))) + (setf interval-list + (clsql:interval-push interval-list (clsql:make-interval :start time-1 :end time-3 + :type :open))) + (setf interval-list + (clsql:interval-push interval-list (clsql:make-interval :start time-3 :end time-4 + :type :open))) (clsql:interval-relation (car interval-list) (cadr interval-list))) :precedes) ;; nested intervals in list (deftest :time/3 (let* ((interval-list nil) - (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) - (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) - (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) - (time-4 (clsql:parse-timestring "2002-01-01 13:00:00"))) - (setf interval-list - (clsql:interval-push interval-list (clsql:make-interval :start time-1 - :end time-4 - :type :open))) - (setf interval-list - (clsql:interval-push interval-list (clsql:make-interval :start time-2 - :end time-3 - :type :closed))) + (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) + (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) + (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) + (time-4 (clsql:parse-timestring "2002-01-01 13:00:00"))) + (setf interval-list + (clsql:interval-push interval-list (clsql:make-interval :start time-1 + :end time-4 + :type :open))) + (setf interval-list + (clsql:interval-push interval-list (clsql:make-interval :start time-2 + :end time-3 + :type :closed))) (let* ((interval (car interval-list)) - (interval-contained - (when interval (car (clsql:interval-contained interval))))) - (when (and interval interval-contained) - (and (clsql:time= (clsql:interval-start interval) time-1) - (clsql:time= (clsql:interval-end interval) time-4) - (eq (clsql:interval-type interval) :open) - (clsql:time= (clsql:interval-start interval-contained) time-2) - (clsql:time= (clsql:interval-end interval-contained) time-3) - (eq (clsql:interval-type interval-contained) :closed))))) + (interval-contained + (when interval (car (clsql:interval-contained interval))))) + (when (and interval interval-contained) + (and (clsql:time= (clsql:interval-start interval) time-1) + (clsql:time= (clsql:interval-end interval) time-4) + (eq (clsql:interval-type interval) :open) + (clsql:time= (clsql:interval-start interval-contained) time-2) + (clsql:time= (clsql:interval-end interval-contained) time-3) + (eq (clsql:interval-type interval-contained) :closed))))) t) ;; interval-edit - nonoverlapping (deftest :time/4 (let* ((interval-list nil) - (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) - (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) - (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) - (time-4 (clsql:parse-timestring "2002-01-01 13:00:00"))) + (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) + (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) + (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) + (time-4 (clsql:parse-timestring "2002-01-01 13:00:00"))) (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-1 :end time-2 :type :open))) (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-3 :end time-4 :type :closed))) (setf interval-list (clsql:interval-edit interval-list time-1 time-1 time-3)) - ;; should be time-3 not time-2 + ;; should be time-3 not time-2 (clsql:time= (clsql:interval-end (car interval-list)) time-3)) t) ;; interval-edit - overlapping (deftest :time/5 (let* ((interval-list nil) - (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) - (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) - (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) - (time-4 (clsql:parse-timestring "2002-01-01 13:00:00"))) + (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) + (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) + (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) + (time-4 (clsql:parse-timestring "2002-01-01 13:00:00"))) (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-1 :end time-2 :type :open))) (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-2 :end time-4 :type :closed))) (let ((pass t)) - (handler-case - (progn - (setf interval-list - (clsql:interval-edit interval-list time-1 time-1 time-3)) - (setf pass nil)) - (error nil)) - pass)) + (handler-case + (progn + (setf interval-list + (clsql:interval-edit interval-list time-1 time-1 time-3)) + (setf pass nil)) + (error nil)) + pass)) t) ;; interval-edit - nested intervals in list (deftest :time/6 (let* ((interval-list nil) - (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) - (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) - (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) - (time-4 (clsql:parse-timestring "2002-01-01 13:00:00")) - (time-5 (clsql:parse-timestring "2002-01-01 14:00:00")) - (time-6 (clsql:parse-timestring "2002-01-01 15:00:00"))) + (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) + (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) + (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) + (time-4 (clsql:parse-timestring "2002-01-01 13:00:00")) + (time-5 (clsql:parse-timestring "2002-01-01 14:00:00")) + (time-6 (clsql:parse-timestring "2002-01-01 15:00:00"))) (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-1 :end time-6 :type :open))) (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-2 :end time-3 :type :closed))) (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-4 :end time-5 :type :closed))) (setf interval-list (clsql:interval-edit interval-list time-1 time-1 time-4)) - ;; should be time-4 not time-6 + ;; should be time-4 not time-6 (clsql:time= (clsql:interval-end (car interval-list)) time-4)) t) - + ;; Test the boundaries of Local Time with granularity of 1 year (deftest :time/7 (let ((sec-in-year (* 60 60 24 365)) - (year (clsql:time-element (clsql:make-time) :year))) + (year (clsql:time-element (clsql:make-time) :year))) (dotimes (n 50 n) - (let ((date (clsql:make-time :second (* n sec-in-year)))) - (unless (= (+ year n) - (clsql:time-element date :year)) - (return n))))) + (let ((date (clsql:make-time :second (* n sec-in-year)))) + (unless (= (+ year n) + (clsql:time-element date :year)) + (return n))))) 50) ;; Test db-timestring (deftest :time/9 (flet ((grab-year (dbstring) - (parse-integer (subseq dbstring 1 5)))) + (parse-integer (subseq dbstring 1 5)))) (let ((second-in-year (* 60 60 24 365))) - (dotimes (n 2000 n) - (let* ((second (* -1 n second-in-year)) - (date (clsql:make-time :year 2525 :second second))) - (unless + (dotimes (n 2000 n) + (let* ((second (* -1 n second-in-year)) + (date (clsql:make-time :year 2525 :second second))) + (unless (= (grab-year (clsql:db-timestring date)) (clsql:time-element date :year)) - (return n)))))) + (return n)))))) 2000) ;; Conversion between MJD and Gregorian (deftest :time/10 (dotimes (base 10000 base) (unless (= (apply #'clsql:gregorian-to-mjd (clsql:mjd-to-gregorian base)) - base) - (return base))) + base) + (return base))) 10000) - + ;; Clsql:Roll by minutes: +90 (deftest :time/11 (let ((now (clsql:get-time))) (clsql:time= (clsql:time+ now (clsql:make-duration :minute 90)) - (clsql:roll now :minute 90))) + (clsql:roll now :minute 90))) t) ;;Clsql:Roll by minutes: +900 (deftest :time/12 (let ((now (clsql:get-time))) (clsql:time= (clsql:time+ now (clsql:make-duration :minute 900)) - (clsql:roll now :minute 900))) + (clsql:roll now :minute 900))) t) ;; Clsql:Roll by minutes: +900 (deftest :time/13 (let* ((now (clsql:get-time)) - (add-time (clsql:time+ now (clsql:make-duration :minute 9000))) - (roll-time (clsql:roll now :minute 9000))) + (add-time (clsql:time+ now (clsql:make-duration :minute 9000))) + (roll-time (clsql:roll now :minute 9000))) (clsql:time= add-time roll-time)) t) diff --git a/tests/utils.lisp b/tests/utils.lisp index 948d75a..ca7accb 100644 --- a/tests/utils.lisp +++ b/tests/utils.lisp @@ -20,8 +20,8 @@ (defvar *config-pathname* (make-pathname :defaults (user-homedir-pathname) - :name ".clsql-test" - :type "config")) + :name ".clsql-test" + :type "config")) (defvar +all-db-types+ '(:postgresql :postgresql-socket :mysql :sqlite :sqlite3 :odbc :oracle @@ -42,19 +42,19 @@ (defun read-specs (&optional (path *config-pathname*)) (if (probe-file path) (with-open-file (stream path :direction :input) - (let ((specs (make-instance 'conn-specs))) - (dolist (spec (read stream) specs) - (push (second spec) - (slot-value specs (intern (symbol-name (first spec)) - (find-package '#:clsql-tests))))))) + (let ((specs (make-instance 'conn-specs))) + (dolist (spec (read stream) specs) + (push (second spec) + (slot-value specs (intern (symbol-name (first spec)) + (find-package '#:clsql-tests))))))) (progn - (warn "CLSQL test config file ~S not found" path) - nil))) + (warn "CLSQL test config file ~S not found" path) + nil))) (defun spec-fn (db-type) (intern (concatenate 'string (symbol-name db-type) - (symbol-name '#:-spec)) - (find-package '#:clsql-tests))) + (symbol-name '#:-spec)) + (find-package '#:clsql-tests))) (defun db-type-spec (db-type specs) (funcall (spec-fn db-type) specs)) @@ -62,34 +62,34 @@ (defun summarize-test-report (sexp &optional (output *standard-output*)) (flet ((db-title (db-type underlying-db-type) - (format nil "~A~A" - db-type - (if (eq db-type underlying-db-type) - "" - (format nil "/~A" underlying-db-type))))) + (format nil "~A~A" + db-type + (if (eq db-type underlying-db-type) + "" + (format nil "/~A" underlying-db-type))))) (with-open-file (in sexp :direction :input) (let ((eof (cons nil nil))) - (do ((form (read in nil eof) (read in nil eof))) - ((eq form eof)) - (destructuring-bind (db-type - underlying-db-type - utime - total-tests - failed-tests - impl-type - impl-version - machine-type) - form - (declare (ignorable utime impl-version)) - (if failed-tests - (format output "~&~A: ~D of ~D tests failed (~A, ~A).~&" - (db-title db-type underlying-db-type) - (length failed-tests) - total-tests - machine-type - impl-type) - (format output "~&~A: All ~D tests passed (~A, ~A).~%" - (db-title db-type underlying-db-type) - total-tests - machine-type - impl-type)))))))) + (do ((form (read in nil eof) (read in nil eof))) + ((eq form eof)) + (destructuring-bind (db-type + underlying-db-type + utime + total-tests + failed-tests + impl-type + impl-version + machine-type) + form + (declare (ignorable utime impl-version)) + (if failed-tests + (format output "~&~A: ~D of ~D tests failed (~A, ~A).~&" + (db-title db-type underlying-db-type) + (length failed-tests) + total-tests + machine-type + impl-type) + (format output "~&~A: All ~D tests passed (~A, ~A).~%" + (db-title db-type underlying-db-type) + total-tests + machine-type + impl-type)))))))) diff --git a/uffi/clsql-uffi-loader.lisp b/uffi/clsql-uffi-loader.lisp index 2705f55..a2921f6 100644 --- a/uffi/clsql-uffi-loader.lisp +++ b/uffi/clsql-uffi-loader.lisp @@ -24,24 +24,24 @@ well as any of the filenames in any of the clsql:*foreign-library-search-paths*" (setq filenames (if (listp filenames) filenames (list filenames))) (flet ((try-load (testpath) - (handler-case - (uffi:load-foreign-library testpath - :module module - :supporting-libraries supporting-libraries) - (error nil)))) ;(c) (warn "~A" c) nil)))) + (handler-case + (uffi:load-foreign-library testpath + :module module + :supporting-libraries supporting-libraries) + (error nil)))) ;(c) (warn "~A" c) nil)))) (or (loop for type in (uffi:foreign-library-types) - thereis - (loop for name in filenames - for pn = (make-pathname :name name :type type) - thereis (or + thereis + (loop for name in filenames + for pn = (make-pathname :name name :type type) + thereis (or (try-load pn) - (loop for search-path in clsql:*foreign-library-search-paths* - thereis (try-load (merge-pathnames pn search-path)))))) + (loop for search-path in clsql:*foreign-library-search-paths* + thereis (try-load (merge-pathnames pn search-path)))))) (when errorp (error "Couldn't load foreign librar~@P ~{~S~^, ~}. (searched ~S)" - (length filenames) filenames - 'clsql:*foreign-library-search-paths*))))) + (length filenames) filenames + 'clsql:*foreign-library-search-paths*))))) ;; searches clsql_uffi64 to accomodate both 32-bit and 64-bit libraries on same system (defvar *clsql-uffi-library-filenames* diff --git a/uffi/clsql-uffi.lisp b/uffi/clsql-uffi.lisp index 76e63eb..4f9479d 100644 --- a/uffi/clsql-uffi.lisp +++ b/uffi/clsql-uffi.lisp @@ -30,38 +30,38 @@ (nreverse new-types)) (declare (fixnum length-types length-auto-list i)) (if (>= i length-types) - (push t new-types) ;; types is shorter than num-fields - (push - (case (nth i types) - (:int - (case (nth i auto-list) - (:int32 - :int32) - (:int64 - :int64) - (t - t))) - (:double - (case (nth i auto-list) - (:double - :double) - (t - t))) - (:int32 - (if (eq :int32 (nth i auto-list)) - :int32 - t)) - (:int64 - (if (eq :int64 (nth i auto-list)) - :int64 - t)) - (:blob - :blob) - (:uint - :uint) - (t - t)) - new-types)))) + (push t new-types) ;; types is shorter than num-fields + (push + (case (nth i types) + (:int + (case (nth i auto-list) + (:int32 + :int32) + (:int64 + :int64) + (t + t))) + (:double + (case (nth i auto-list) + (:double + :double) + (t + t))) + (:int32 + (if (eq :int32 (nth i auto-list)) + :int32 + t)) + (:int64 + (if (eq :int64 (nth i auto-list)) + :int64 + t)) + (:blob + :blob) + (:uint + :uint) + (t + t)) + new-types)))) (uffi:def-function "atoi" ((str (* :unsigned-char))) @@ -107,49 +107,49 @@ (defun strtoul (char-ptr) (declare (optimize (speed 3) (safety 0) (space 0)) - (type char-ptr-def char-ptr)) + (type char-ptr-def char-ptr)) (c-strtoul char-ptr uffi:+null-cstring-pointer+ 10)) (defun convert-raw-field (char-ptr types index &optional length) (declare (optimize (speed 3) (safety 0) (space 0)) - (type char-ptr-def char-ptr)) + (type char-ptr-def char-ptr)) (let ((type (if (consp types) - (nth index types) - types))) + (nth index types) + types))) (cond ((uffi:null-pointer-p char-ptr) nil) (t (case type - (:double - (atof char-ptr)) - (:int - (atol char-ptr)) - (:int32 - (atoi char-ptr)) - (:uint32 - (strtoul char-ptr)) - (:uint - (strtoul char-ptr)) - ((:int64 :uint64) - (uffi:with-foreign-object (high32-ptr :unsigned-int) - (let ((low32 (atol64 char-ptr high32-ptr)) - (high32 (uffi:deref-pointer high32-ptr :unsigned-int))) - (if (zerop high32) - low32 - (make-64-bit-integer high32 low32))))) - (:blob - (if length - (uffi:convert-from-foreign-usb8 char-ptr length) - (error "Can't return blob since length is not specified."))) - (t - ;; sb-unicode still broken with converting with length, assume - ;; that string is null terminated - #+sb-unicode - (uffi:convert-from-foreign-string char-ptr :locale :none) - #-sb-unicode + (:double + (atof char-ptr)) + (:int + (atol char-ptr)) + (:int32 + (atoi char-ptr)) + (:uint32 + (strtoul char-ptr)) + (:uint + (strtoul char-ptr)) + ((:int64 :uint64) + (uffi:with-foreign-object (high32-ptr :unsigned-int) + (let ((low32 (atol64 char-ptr high32-ptr)) + (high32 (uffi:deref-pointer high32-ptr :unsigned-int))) + (if (zerop high32) + low32 + (make-64-bit-integer high32 low32))))) + (:blob (if length - (uffi:convert-from-foreign-string char-ptr :locale :none + (uffi:convert-from-foreign-usb8 char-ptr length) + (error "Can't return blob since length is not specified."))) + (t + ;; sb-unicode still broken with converting with length, assume + ;; that string is null terminated + #+sb-unicode + (uffi:convert-from-foreign-string char-ptr :locale :none) + #-sb-unicode + (if length + (uffi:convert-from-foreign-string char-ptr :locale :none :null-terminated-p nil :length length) (uffi:convert-from-foreign-string char-ptr :locale :none)))))))) diff --git a/uffi/clsql_uffi.c b/uffi/clsql_uffi.c index 531abf0..0b84054 100644 --- a/uffi/clsql_uffi.c +++ b/uffi/clsql_uffi.c @@ -19,15 +19,15 @@ #include BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll, DWORD fdwReason, - LPVOID lpvReserved) + LPVOID lpvReserved) { return 1; } - + #define DLLEXPORT __declspec(dllexport) #else -#define DLLEXPORT +#define DLLEXPORT #endif @@ -69,7 +69,7 @@ atol64 (const unsigned char* str, unsigned int* pHigh32) return lower_32bits(result); } - - + +