X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Futils.lisp;h=52ee019943c3250946d6d465bbb3ca94210aaf43;hb=30186614582039bdc3d3f86bc5165ef300c5d3e0;hp=fe5a24ce63aa930444708a10bbc233d929b49c67;hpb=90ce2284fab5f1daedb8aa6aba3008a5c3651e30;p=clsql.git

diff --git a/sql/utils.lisp b/sql/utils.lisp
index fe5a24c..52ee019 100644
--- 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,27 @@
 
 (in-package #:clsql-sys)
 
+(defun %get-int (v)
+  (etypecase v
+    (string (parse-integer v :junk-allowed t))
+    (integer v)
+    (number (truncate v))))
+
+(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
@@ -30,6 +49,7 @@
 (defun float-to-sql-string (num)
   "Convert exponent character for SQL"
   (let ((str (write-to-string num :readably t)))
+    (declare (type string str))
     (cond
      ((find #\f str)
       (substitute #\e #\f str))
@@ -111,14 +131,17 @@
   (substitute-string-for-char s #\' "''"))
 
 (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))
-      procstr)))
+  "Substitutes a string for a single matching character of a string"
+  (when procstr
+    (locally
+        (declare (type string procstr))
+      (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))
+            procstr)))))
 
 
 (defun position-char (char string start max)
@@ -153,6 +176,7 @@
     (setq pos (1+ end))))
 
 (defun string-to-list-connection-spec (str)
+  (declare (type string str))
   (let ((at-pos (position-char #\@ str 0 (length str))))
     (cond
       ((and at-pos (> (length str) at-pos))
@@ -353,7 +377,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)))
@@ -362,3 +386,49 @@ 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))))
+
+
+(defun filter-plist (plist &rest keys-to-remove)
+  "Returns a copy of the given plist with indicated key-value pairs
+removed. keys are searched with #'MEMBER"
+  (declare (dynamic-extent keys-to-remove))
+  (when plist
+    (loop for (k v . rest) = plist then rest
+          unless (member k keys-to-remove)
+            collect k and collect v
+          while rest)))
+
+(defmacro make-weak-hash-table (&rest args)
+  "Creates a weak hash table for use in a cache."
+  `(progn
+
+    ;;NB: These are generally used for caches that may not have an alternate
+    ;;clearing mechanism. If you are on an implementation that doesn't support
+    ;;weak hash tables then you're memory may accumulate.
+
+    #-(or sbcl allegro clisp lispworks)
+    (warn "UNSAFE! use of weak hash on implementation without support. (see clsql/sql/utils.lisp to add)")
+
+    (make-hash-table
+      #+allegro   :values    #+allegro :weak
+      #+clisp     :weak      #+clisp :value
+      #+lispworks :weak-kind #+lispworks :value
+      #+sbcl :weakness #+sbcl :value
+      ,@args)
+    ))