X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Futils.lisp;h=0196d04a95db8b39867aa1d4906d76b4b0859a6a;hp=fe5a24ce63aa930444708a10bbc233d929b49c67;hb=HEAD;hpb=3d6ed9e79589fd20effdd2b896a5bb2e9a6e8670 diff --git a/sql/utils.lisp b/sql/utils.lisp index fe5a24c..0196d04 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,48 @@ (in-package #:clsql-sys) +(defmacro defaulting (&rest place-value-plist) + "for places and values (as an &rest plist) + if place-n is null set it to value-n" + `(progn + ,@(loop for (place value . rest) on place-value-plist by #'cddr + collect `(unless ,place (setf ,place ,value))))) + +(defmacro pop-n (place &optional (n 1)) + "pops n items off of a list in place and returns their values in a new list + + if n > the length of the list in place, then we return the full list, + setting the place to nil" + `(loop repeat ,n + while ,place + collect (pop ,place))) + +(defun %get-int (v) + (etypecase v + (string (parse-integer v :junk-allowed t)) + (integer v) + (number (truncate v)))) + +(defun dequote (it) + (if (and (listp it) (eql (first it) 'quote)) + (second it) + it)) + +(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 +70,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)) @@ -59,8 +100,8 @@ #+lispworks (defvar +lw-has-without-preemption+ - #+lispworks6 nil - #-lispworks6 t) + #-(or lispworks5 lispworks4) nil + #+(or lispworks5 lispworks4) t) #+lispworks (defvar +lw-global-lock+ (unless +lw-has-without-preemption+ @@ -111,14 +152,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 +197,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)) @@ -330,7 +375,7 @@ list of characters and replacement strings." (cdr (assoc (string var) ext:*environment-list* :test #'equalp :key #'string)) #+lispworks (lw:environment-variable (string var)) - #+mcl (ccl::getenv var) + #+ccl (ccl::getenv var) #+sbcl (sb-ext:posix-getenv var)) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -353,7 +398,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 +407,105 @@ 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 read-decimal-value (string) + (let* ((comma 0) + (dot 0) + (last)) + (loop for c across string + do (case c + (#\. (incf dot) (setf last 'dot)) + (#\, (incf comma) (setf last 'comma)))) + (let* ((bag (if (and (eql last 'dot) (eql dot 1)) + ".0123456789+-" + ",0123456789+-")) + (clean (with-output-to-string (out) + (loop for c across string + do (when (find c bag :test #'char=) + (write-char c out)))))) + (if (and (eql last 'dot) (eql dot 1)) + (decimals:parse-decimal-number clean) + (decimals:parse-decimal-number + clean :decimal-separator #\,))))) + + +(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 ccl) + (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 + #+ccl :weak #+ccl :value + ,@args) + )) + +(defun to-slot-name (slot) + "try to turn what we got representing the slot into a slot name" + (etypecase slot + (symbol slot) + (slot-definition (slot-definition-name slot)))) + +(defun to-class (it) + (etypecase it + (class it) + (symbol (find-class it)) + (standard-object (class-of it)))) + +(defun to-class-name (o) + (etypecase o + (symbol o) + (standard-class (class-name o)) + (standard-object (class-name (class-of o))))) + +(defun easy-slot-value (obj slot) + "like slot-value except it accepts slot-names or defs + and returns nil when the slot is unbound" + (let ((n (to-slot-name slot))) + (when (and obj (slot-boundp obj n)) + (slot-value obj n)))) + +(defun (setf easy-slot-value) (new obj slot) + "like slot-value except it accepts slot-names or defs" + (setf (slot-value obj (to-slot-name slot)) new)) + +(defun delist-if-single (x) + "if this is a single item in a list return it" + (if (and (listp x) (= 1 (length x))) + (first x) + x))