X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=base%2Futils.lisp;h=8a96df6642846289ab4603f1449dda00cf95e9b7;hp=729109bd1ad98ed5ae21bcd24170414b738e5948;hb=09f07ac9d914a83f9426609f3264f4e66b5a6d97;hpb=afa1e8481ca62ee15952c695fd04c8601b65b218 diff --git a/base/utils.lisp b/base/utils.lisp index 729109b..8a96df6 100644 --- a/base/utils.lisp +++ b/base/utils.lisp @@ -16,7 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql-base-sys) +(in-package #:clsql-base) (defun number-to-sql-string (num) (etypecase num @@ -65,6 +65,39 @@ (char unescaped i))))) escaped)) +(defmacro without-interrupts (&body body) + #+lispworks `(mp:without-preemption ,@body) + #+allegro `(mp:without-scheduling ,@body) + #+cmu `(system:without-interrupts ,@body) + #+sbcl `(sb-sys::without-interrupts ,@body) + #+openmcl `(ccl:without-interrupts ,@body)) + +(defun make-process-lock (name) + #+allegro (mp:make-process-lock :name name) + #+cmu (mp:make-lock name) + #+lispworks (mp:make-lock :name name) + #+openmcl (ccl:make-lock name) + #+sb-thread (sb-thread:make-mutex :name name) + #+scl (thread:make-lock name) + #-(or allegro cmu lispworks openmcl sb-thread scl) (declare (ignore name)) + #-(or allegro cmu lispworks openmcl sb-thread scl) nil) + +(defmacro with-process-lock ((lock desc) &body body) + #+(or cmu allegro lispworks openmcl sb-thread) + (declare (ignore desc)) + #+(or allegro cmu lispworks openmcl sb-thread) + (let ((l (gensym))) + `(let ((,l ,lock)) + #+allegro (mp:with-process-lock (,l) ,@body) + #+cmu (mp:with-lock-held (,l) ,@body) + #+openmcl (ccl:with-lock-grabbed (,l) ,@body) + #+lispworks (mp:with-lock (,l) ,@body) + #+sb-thread (sb-thread:with-recursive-lock (,l) ,@body) + )) + #+scl `(thread:with-lock-held (,lock ,desc) ,@body) + #-(or cmu allegro lispworks openmcl sb-thread scl) (declare + (ignore lock desc)) + #-(or cmu allegro lispworks openmcl sb-thread scl) `(progn ,@body)) (defun sql-escape-quotes (s) "Escape quotes for SQL string writing" @@ -113,12 +146,198 @@ (setq pos (1+ end)))) (defun string-to-list-connection-spec (str) - (let ((at-pos (position-char #\@ str))) + (let ((at-pos (position-char #\@ str 0 (length str)))) (cond ((and at-pos (> (length str) at-pos)) ;; Connection spec is SQL*NET format - (append (delimited-string-to-list (subseq str 0 at-pos) #\/) - (list (subseq str (1+ at-pos))))) + (cons (subseq str (1+ at-pos)) + (delimited-string-to-list (subseq str 0 at-pos) #\/))) (t (delimited-string-to-list str #\/))))) +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package '#:excl.osi) + (require 'osi))) + +(defun command-output (control-string &rest args) + ;; Concatenates output and error since Lispworks combines + ;; these, thus CLSQL can't depend upon separate results + (multiple-value-bind (output error status) + (apply #'%command-output control-string args) + (values + (concatenate 'string (if output output "") + (if error error "")) + status))) + +(defun read-stream-to-string (in) + (with-output-to-string (out) + (let ((eof (gensym))) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) + (format out "~A~%" line))))) + +;; From KMRCL +(defun %command-output (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, +returns (VALUES string-output error-output exit-status)" + (let ((command (apply #'format nil control-string args))) + #+sbcl + (let* ((process (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream)) + (output (read-stream-to-string (sb-impl::process-output process))) + (error (read-stream-to-string (sb-impl::process-error process)))) + (close (sb-impl::process-output process)) + (close (sb-impl::process-error process)) + (values + output + error + (sb-impl::process-exit-code process))) + + + #+(or cmu scl) + (let* ((process (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream)) + (output (read-stream-to-string (ext::process-output process))) + (error (read-stream-to-string (ext::process-error process)))) + (close (ext::process-output process)) + (close (ext::process-error process)) + + (values + output + error + (ext::process-exit-code process))) + + #+allegro + (multiple-value-bind (output error status) + (excl.osi:command-output command :whole t) + (values output error status)) + + #+lispworks + ;; BUG: Lispworks combines output and error streams + (let ((output (make-string-output-stream))) + (unwind-protect + (let ((status + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :output-stream output))) + (values (get-output-stream-string output) nil status)) + (close output))) + + #+clisp + ;; BUG: CLisp doesn't allow output to user-specified stream + (values + nil + nil + (ext:run-shell-command command :output :terminal :wait t)) + + #+openmcl + (let* ((process (ccl:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream + :wait t)) + (output (read-stream-to-string (ccl::external-process-output-stream process))) + (error (read-stream-to-string (ccl::external-process-error-stream process)))) + (close (ccl::external-process-output-stream process)) + (close (ccl::external-process-error-stream process)) + (values output + error + (nth-value 1 (ccl::external-process-status process)))) + + #-(or openmcl clisp lispworks allegro scl cmu sbcl) + (error "COMMAND-OUTPUT not implemented for this Lisp") + + )) + + +;; From KMRCL +(defmacro in (obj &rest choices) + (let ((insym (gensym))) + `(let ((,insym ,obj)) + (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c)) + choices))))) + +;; From KMRCL +(defun substitute-char-string (procstr match-char subst-str) + "Substitutes a string for a single matching character of a string" + (substitute-chars-strings procstr (list (cons match-char subst-str)))) + +(defun replaced-string-length (str repl-alist) + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((i 0 (1+ i)) + (orig-len (length str)) + (new-len orig-len)) + ((= i orig-len) new-len) + (declare (fixnum i orig-len new-len)) + (let* ((c (char str i)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (when match + (incf new-len (1- (length + (the simple-string (cdr match))))))))) + + +(defun substitute-chars-strings (str repl-alist) + "Replace all instances of a chars with a string. repl-alist is an assoc +list of characters and replacement strings." + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((orig-len (length str)) + (new-string (make-string (replaced-string-length str repl-alist))) + (spos 0 (1+ spos)) + (dpos 0)) + ((>= spos orig-len) + new-string) + (declare (fixnum spos dpos) (simple-string new-string)) + (let* ((c (char str spos)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (if match + (let* ((subst (cdr match)) + (len (length subst))) + (declare (fixnum len) + (simple-string subst)) + (dotimes (j len) + (declare (fixnum j)) + (setf (char new-string dpos) (char subst j)) + (incf dpos))) + (progn + (setf (char new-string dpos) c) + (incf dpos)))))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (char= #\a (schar (symbol-name '#:a) 0)) + (pushnew :lowercase-reader *features*))) + +(defun symbol-name-default-case (str) + #-lowercase-reader + (string-upcase str) + #+lowercase-reader + (string-downcase str)) + +(defun convert-to-db-default-case (str database) + (if database + (case (db-type-default-case (database-underlying-type database)) + (:upper (string-upcase str)) + (:lower (string-downcase str)) + (t str)) + ;; Default CommonSQL behavior is to upcase strings + (string-upcase str))) + + +(defun ensure-keyword (name) + "Returns keyword for a name" + (etypecase name + (keyword name) + (string (nth-value 0 (intern (symbol-name-default-case name) :keyword))) + (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))