From f68abc76e0e01f4633141a0c17a4d8f1976229b8 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 14 Apr 2004 06:54:07 +0000 Subject: [PATCH] r9009: add sequence fns --- ChangeLog | 8 +++++++ base/package.lisp | 8 ++++++- base/pool.lisp | 28 ----------------------- base/utils.lisp | 33 +++++++++++++++++++++++++++ db-aodbc/aodbc-sql.lisp | 37 +++++++++++++++++++++++++----- db-mysql/mysql-sql.lisp | 50 +++++------------------------------------ db-odbc/odbc-dbi.lisp | 12 +++------- 7 files changed, 88 insertions(+), 88 deletions(-) diff --git a/ChangeLog b/ChangeLog index 983ea58..8e958a3 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +14 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.14. + * base/utils.lisp: Add process functions + * base/package.lisp: Export utils to CLSQL-BASE-SYS + * db-aodbc: implement sequence functions + * db-mysql/mysql-sql.lisp: Use WITHOUT-INTERRUPTS + for SEQUENCE-NEXT + 13 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.6.13. Requires UFFI version 1.4.9 * db-odbc/*.lisp: Further porting. diff --git a/base/package.lisp b/base/package.lisp index 45a2615..42789b3 100644 --- a/base/package.lisp +++ b/base/package.lisp @@ -71,7 +71,13 @@ #:with-process-lock #:connection-spec #:ensure-keyword - + + ;; utils.lisp + #:without-interrupts + #:make-process-lock + #:with-process-lock + #:command-output + ;; Shared exports for re-export by CLSQL-BASE . #1=(#:clsql-condition diff --git a/base/pool.lisp b/base/pool.lisp index e051423..bebe1b6 100644 --- a/base/pool.lisp +++ b/base/pool.lisp @@ -18,34 +18,6 @@ (in-package #:clsql-base-sys) -(defun make-process-lock (name) - #+allegro (mp:make-process-lock :name name) - #+cmu (mp:make-lock name) - #+lispworks (mp:make-lock :name name) - #+openmcl (ccl:make-lock :name name) - #+sb-thread (sb-thread:make-mutex :name name) - #+scl (thread:make-lock name) - #-(or allegro cmu lispworks openmcl sb-thread scl) (declare (ignore name)) - #-(or allegro cmu lispworks openmcl sb-thread scl) nil) - -(defmacro with-process-lock ((lock desc) &body body) - #+(or cmu allegro lispworks openmcl sb-thread) - (declare (ignore desc)) - #+(or allegro cmu lispworks openmcl sb-thread) - (let ((l (gensym))) - `(let ((,l ,lock)) - #+allegro (mp:with-process-lock (,l) ,@body) - #+cmu (mp:with-lock-held (,l) ,@body) - #+openmcl (ccl:with-lock-grabbed (,l) ,@body) - #+lispworks (mp:with-lock (,l) ,@body) - #+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) `(progn ,@body)) - (defvar *db-pool* (make-hash-table :test #'equal)) (defvar *db-pool-lock* (make-process-lock "DB Pool lock")) diff --git a/base/utils.lisp b/base/utils.lisp index 1584104..ae1a4b0 100644 --- a/base/utils.lisp +++ b/base/utils.lisp @@ -65,6 +65,39 @@ (char unescaped i))))) escaped)) +(defmacro without-interrupts (&body body) + #+lispworks `(mp:without-preemption ,@body) + #+allegro `(mp:without-scheduling ,@body) + #+cmu `(pcl::without-interrupts ,@body) + #+sbcl `(sb-sys::without-interrupts ,@body) + #+openmcl `(ccl:without-interrupts ,@body)) + +(defun make-process-lock (name) + #+allegro (mp:make-process-lock :name name) + #+cmu (mp:make-lock name) + #+lispworks (mp:make-lock :name name) + #+openmcl (ccl:make-lock :name name) + #+sb-thread (sb-thread:make-mutex :name name) + #+scl (thread:make-lock name) + #-(or allegro cmu lispworks openmcl sb-thread scl) (declare (ignore name)) + #-(or allegro cmu lispworks openmcl sb-thread scl) nil) + +(defmacro with-process-lock ((lock desc) &body body) + #+(or cmu allegro lispworks openmcl sb-thread) + (declare (ignore desc)) + #+(or allegro cmu lispworks openmcl sb-thread) + (let ((l (gensym))) + `(let ((,l ,lock)) + #+allegro (mp:with-process-lock (,l) ,@body) + #+cmu (mp:with-lock-held (,l) ,@body) + #+openmcl (ccl:with-lock-grabbed (,l) ,@body) + #+lispworks (mp:with-lock (,l) ,@body) + #+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) `(progn ,@body)) (defun sql-escape-quotes (s) "Escape quotes for SQL string writing" diff --git a/db-aodbc/aodbc-sql.lisp b/db-aodbc/aodbc-sql.lisp index 181c3ed..4cd8a6e 100644 --- a/db-aodbc/aodbc-sql.lisp +++ b/db-aodbc/aodbc-sql.lisp @@ -159,11 +159,11 @@ (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)") + " (last_value int NOT NULL PRIMARY KEY, increment_by int, min_value int, is_called char(1))") database) (database-execute-command (concatenate 'string "INSERT INTO " table-name - " VALUES (0)") + " VALUES (1,1,1,'f')") database))) (defmethod database-drop-sequence (sequence-name @@ -183,16 +183,41 @@ (position integer) (database aodbc-database)) (database-execute-command - (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name) + (format nil "UPDATE ~A SET last-value=~A" + (%sequence-name-to-table sequence-name) position) database) position) (defmethod database-sequence-next (sequence-name (database aodbc-database)) - (warn "Not implemented.")) - + (without-interrupts + (let* ((table-name (%sequence-name-to-table sequence-name)) + (tuple + (car (database-query + (concatenate 'string "SELECT last_value,is_called FROM " + table-name) + database + :auto)))) + (cond + ((char-equal (schar (second tuple) 0) #\f) + (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)))))) + (defmethod database-sequence-last (sequence-name (database aodbc-database)) - (declare (ignore sequence-name))) + (without-interrupts + (caar (database-query + (concatenate 'string "SELECT last_value FROM " + (%sequence-name-to-table sequence-name)) + database + :auto)))) (defmethod database-create (connection-spec (type (eql :aodbc))) (warn "Not implemented.")) diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index 2a0ba82..d04f671 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -170,43 +170,6 @@ :errno (mysql-errno mysql-ptr) :error (mysql-error-string mysql-ptr)))))) -#+ignore -(defmethod database-query (query-expression (database mysql-database) - result-types) - (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-query mysql-ptr query-native)) - (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)) - (loop for row = (mysql-fetch-row res-ptr) - until (uffi:null-pointer-p row) - collect - (loop for i fixnum from 0 below num-fields - collect - (convert-raw-field - (uffi:deref-array row '(:array - (* :unsigned-char)) - i) - result-types i)))) - (mysql-free-result res-ptr)) - (error 'clsql-sql-error - :database database - :expression query-expression - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr)))) - (error 'clsql-sql-error - :database database - :expression query-expression - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr)))))) - (defmethod database-execute-command (sql-expression (database mysql-database)) (uffi:with-cstring (sql-native sql-expression) (let ((mysql-ptr (database-mysql-ptr database))) @@ -385,17 +348,16 @@ (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) (defmethod database-sequence-next (sequence-name (database mysql-database)) - (database-execute-command - (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name) - " SET id=LAST_INSERT_ID(id+1)") - database) - (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) + (without-interrupts + (database-execute-command + (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name) + " 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)) (declare (ignore sequence-name))) - - (defmethod database-create (connection-spec (type (eql :mysql))) (destructuring-bind (host name user password) connection-spec (multiple-value-bind (output status) diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp index 7656a65..6e299d1 100644 --- a/db-odbc/odbc-dbi.lisp +++ b/db-odbc/odbc-dbi.lisp @@ -125,7 +125,8 @@ the query against." )) (defun sql (expr &key db result-types row-count column-names query) (if query (db-query db expr) - (db-execute db expr))) + ;; fixme: don't return all query results. + (db-query db expr))) (defun close-query (result-set) (warn "Not implemented.")) @@ -243,13 +244,6 @@ the query against." )) out-len-ptr nil))))) query))))) -(defmacro without-interrupts (&body body) - #+lispworks `(mp:without-preemption ,@body) - #+allegro `(mp:without-scheduling ,@body) - #+cmu `(pcl::without-interrupts ,@body) - #+sbcl `(sb-sys::without-interrupts ,@body) - #+openmcl `(ccl:without-interrupts ,@body)) - (defmethod db-query ((database odbc-db) query-expression) (let ((free-query ;; make it thread safe @@ -285,7 +279,7 @@ the query against." )) "get-free-query finds or makes a nonactive query object, and then sets it to active. This makes the functions db-execute-command and db-query thread safe." (with-slots (queries) database - (or (without-interrupts ;; not context switch allowed here + (or (clsql-base-sys:without-interrupts ;; not context switch allowed here (let ((inactive-query (find-if (lambda (query) (not (query-active-p query))) queries))) -- 2.34.1