X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=base%2Futils.lisp;h=ae1a4b06b14dd119288bc99589bb019225478fe6;hb=f68abc76e0e01f4633141a0c17a4d8f1976229b8;hp=0221ac4eb7b1837d4e51b526ffe17ce68792ee21;hpb=e5744a78271044484b3399d4fc1d55b3e8808784;p=clsql.git diff --git a/base/utils.lisp b/base/utils.lisp index 0221ac4..ae1a4b0 100644 --- a/base/utils.lisp +++ b/base/utils.lisp @@ -65,6 +65,39 @@ (char unescaped i))))) escaped)) +(defmacro without-interrupts (&body body) + #+lispworks `(mp:without-preemption ,@body) + #+allegro `(mp:without-scheduling ,@body) + #+cmu `(pcl::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 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" @@ -137,6 +170,14 @@ (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 @@ -170,14 +211,14 @@ returns (VALUES string-output error-output exit-status)" #+lispworks ;; BUG: Lispworks combines output and error streams - (let ((output (make-output-string-stream))) + (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-string output) nil status)) + (values (get-output-stream-string output) nil status)) (close output))) #+clisp @@ -188,17 +229,95 @@ returns (VALUES string-output error-output exit-status)" (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))) - (values - (get-output-stream-string (ccl::external-process-output-stream process)) - (get-output-stream-string (ccl::external-process-error-stream process)) - (nth-value 1 (ccl::external-process-status process)))) - + (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") )) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (char= #\a (schar (symbol-name '#:a) 0)) + (pushnew :lowercase-reader *features*))) + +(defun string-default-case (str) + #-lowercase-reader + (string-upcase str) + #+lowercase-reader + (string-downcase str)) + +;; From KMRCL +(defun ensure-keyword (name) + "Returns keyword for a name" + (etypecase name + (keyword name) + (string (nth-value 0 (intern (string-default-case name) :keyword))) + (symbol (nth-value 0 (intern (symbol-name name) :keyword))))) + +;; 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)))))) +