[PATCH] Clisp portability patch
Matthew Stickney <[email protected]> Mon, 30 Jul 2012 23:37:01 -0400
| Newsgroups | gmane.lisp.clsql.general |
|---|---|
| Message-ID | <CAKH_Ld4VQcn+NForrwmQt7e_Yov4ZoP_aO-ihp-ZDNjPJLhr8g@mail.gmail.com> |
Hi all, There's a problem loading the current git version of clsql on clisp 2.49 (probably other versions as well). The loop in pool.lisp uses both an 'always' and 'thereis' clause, which have different default return values. Clisp believe this is ambiguous, and throws and error. I've rewritten the loop to avoid the conflicting clauses and provide what are equivalent semantics in most lisps (and hopefully what was intended), based on this discussion[1]. It loads on SBCL 1.0.57 and CLISP 2.49, but I've had some trouble running the tests (getting an error about the stream for .clsql-test.config having reached its end). Any help with testing or feedback would be appreciated. -Matt Stickney [1] http://comments.gmane.org/gmane.lisp.clisp.general/9079 _______________________________________________ CLSQL mailing list [email protected] http://lists.b9.com/cgi-bin/mailman/listinfo/clsql
0001-Use-more-portable-LOOP.patch
(application/octet-stream, 2.9 KB)
diff --git a/sql/pool.lisp b/sql/pool.lisp
index 8d73e67..ee7db15 100644
--- a/sql/pool.lisp
+++ b/sql/pool.lisp
@@ -34,6 +34,28 @@
+(defun pconn-is-valid (pconn pool)
+ ;; test if connection still valid.
+ ;; (e.g. db reboot -> invalid connection )
+ (handler-case
+ (progn (database-acquire-from-conn-pool pconn)
+ pconn)
+ (sql-database-error (e)
+ ;; we could check for a specific error,
+ ;; but, it's safer just to disconnect the pooled conn for any
+ ;; error ?
+ (warn "Database connection ~S had an error while acquiring from the pool:
+ ~S
+Disconnecting.~%"
+ pconn e)
+ ;;run database disconnect to give chance for cleanup
+ ;;there, then remove it from the lists of connected
+ ;;databases.
+ (%pool-force-disconnect pconn)
+ (with-process-lock ((conn-pool-lock pool) "remove dead conn")
+ (setf (all-connections pool)
+ (delete pconn (all-connections pool))))
+ nil)))
(defun acquire-from-pool (connection-spec database-type &optional pool encoding)
"Try to find a working database connection in the pool or create a new
@@ -43,30 +65,19 @@ command to put the connection back into its default state."
(unless (typep pool 'conn-pool)
(setf pool (find-or-create-connection-pool connection-spec database-type)))
(or
- (loop for pconn = (with-process-lock ((conn-pool-lock pool) "Acquire")
- (pop (free-connections pool)))
- always pconn
- thereis
- ;; test if connection still valid.
- ;; (e.g. db reboot -> invalid connection )
- (handler-case
- (progn (database-acquire-from-conn-pool pconn)
- pconn)
- (sql-database-error (e)
- ;; we could check for a specific error,
- ;; but, it's safer just to disconnect the pooled conn for any error ?
- (warn "Database connection ~S had an error while acquiring from the pool:
- ~S
-Disconnecting.~%"
- pconn e)
- ;;run database disconnect to give chance for cleanup
- ;;there, then remove it from the lists of connected
- ;;databases.
- (%pool-force-disconnect pconn)
- (with-process-lock ((conn-pool-lock pool) "remove dead conn")
- (setf (all-connections pool)
- (delete pconn (all-connections pool))))
- nil)))
+ (loop named pc-loop for pconn = (with-process-lock ((conn-pool-lock pool) "Acquire")
+ (pop (free-connections pool)))
+ with default-return
+ ;; Emulate "always pconn" and "thereis (pconn-is-valid
+ ;; pconn pool)" clauses
+ do (if (not pconn)
+ (return-from pc-loop nil)
+ (setf default-return t))
+ (let ((valid (pconn-is-valid pconn pool)))
+ (if valid
+ (return-from pc-loop valid)
+ (setf default-return nil)))
+ (return-from pc-loop default-return))
(let ((conn (connect (connection-spec pool)
:database-type (pool-database-type pool)
:if-exists :new
--
1.7.11.3