+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.
#: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
(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"))
(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"
(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
(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."))
: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)))
(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)
(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."))
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
"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)))
projects / clsql.git / commitdiff