Major rewrite of table/column name output escaping system wide.

[clsql.git] / sql / utils.lisp

diff --git a/sql/utils.lisp b/sql/utils.lisp
index e6176cbb0a18f110620931938172e74b91472d3b..b43e3180e64f6f8d392446229660c6eed1caaab1 100644 (file)
--- a/sql/utils.lisp
+++ b/sql/utils.lisp
@@ -7,9 +7,7 @@
 ;;;; Programmer:   Kevin M. Rosenberg
 ;;;; Date Started: Mar 2002
 ;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
 ;;;;
 ;;;; CLSQL users are granted the rights to distribute and use this software
 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
@@ -18,6 +16,21 @@
 
 (in-package #:clsql-sys)
 
+(defvar +whitespace-chars+
+  '(#\space #\tab #\newline #\return
+    ;; Tested: sbcl unicode, allegrocl, openmcl,clisp use #\no-break_space
+    ;; lispworks uses #\no-break-space
+    ;; sbcl non-unicode doesn't support no break space
+    ;; AllegroCL 8-bit strings don't fail on reading #\no-break_space,
+    ;; but can't represent such a character
+    ;; CMUCL errors when trying to read #\no-break_space
+    #+(and lispworks unicode) #\no-break-space
+    #+(or (and sbcl sb-unicode) (and allegro ics) (and clisp i18n)
+       (and openmcl openmcl-unicode-strings))
+    #\no-break_space
+    )
+  "List of whitespace characters for this lisp implementation.")
+
 (defun number-to-sql-string (num)
   (etypecase num
     (integer
@@ -57,11 +70,25 @@
                      (string identifier))))
     (substitute #\_ #\- unescaped)))
 
+#+lispworks
+(defvar +lw-has-without-preemption+
+  #+lispworks6 nil
+  #-lispworks6 t)
+#+lispworks
+(defvar +lw-global-lock+
+  (unless +lw-has-without-preemption+
+    (mp:make-lock :name "CLSQL" :important-p nil :safep t :recursivep nil
+                  :sharing t)))
+
 (defmacro without-interrupts (&body body)
   #+allegro `(mp:without-scheduling ,@body)
   #+clisp `(progn ,@body)
   #+cmu `(system:without-interrupts ,@body)
-  #+lispworks `(mp:without-preemption ,@body)
+  #+lispworks
+  (if +lw-has-without-preemption+
+      `(mp:without-preemption ,@body)
+      `(mp:with-exclusive-lock (+lw-global-lock+)
+         ,@body))
   #+openmcl `(ccl:without-interrupts ,@body)
   #+sbcl `(sb-sys::without-interrupts ,@body))
 
@@ -339,7 +366,7 @@ list of characters and replacement strings."
     (string-upcase str)))
 
 (defun ensure-keyword (name)
-  "Returns keyword for a name"
+  "Returns keyword for a name."
   (etypecase name
     (keyword name)
     (string (nth-value 0 (intern (symbol-name-default-case name) :keyword)))
@@ -348,3 +375,20 @@ list of characters and replacement strings."
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (setq cl:*features* (delete :clsql-lowercase-reader cl:*features*)))
 
+(defun replace-all (string part replacement &key (test #'char=) stream)
+  "Returns a new string in which all the occurences of the part 
+is replaced with replacement. [FROM http://cl-cookbook.sourceforge.net/strings.html#manip]"
+  (let ((out (or stream (make-string-output-stream))))
+    (loop with part-length = (length part)
+         for old-pos = 0 then (+ pos part-length)
+         for pos = (search part string
+                           :start2 old-pos
+                           :test test)
+         do (write-string string out
+                  :start old-pos
+                  :end (or pos (length string)))
+         when pos do (write-string replacement out)
+           while pos)
+    (unless stream
+      (get-output-stream-string out))))
+