X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Futils.lisp;h=0196d04a95db8b39867aa1d4906d76b4b0859a6a;hp=b43e3180e64f6f8d392446229660c6eed1caaab1;hb=HEAD;hpb=dc107d34212597ed1272cfa21138d384e71b00d2 diff --git a/sql/utils.lisp b/sql/utils.lisp index b43e318..0196d04 100644 --- a/sql/utils.lisp +++ b/sql/utils.lisp @@ -16,6 +16,33 @@ (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 @@ -43,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)) @@ -72,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+ @@ -124,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) @@ -166,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)) @@ -343,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) @@ -376,7 +408,7 @@ list of characters and replacement strings." (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 + "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) @@ -392,3 +424,88 @@ is replaced with replacement. [FROM http://cl-cookbook.sourceforge.net/strings.h (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))