X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Futils.lisp;h=e6176cbb0a18f110620931938172e74b91472d3b;hp=d0402e8954a7fb7b85a96f77887a5f0ad62cdd08;hb=e567409d9fff3f7231c2a0bb69b345e19de2b246;hpb=215ec41559dda52d46539d48a0aa390811c2423c diff --git a/sql/utils.lisp b/sql/utils.lisp index d0402e8..e6176cb 100644 --- a/sql/utils.lisp +++ b/sql/utils.lisp @@ -53,8 +53,8 @@ (defun sql-escape (identifier) "Change hyphens to underscores, ensure string" (let ((unescaped (etypecase identifier - (symbol (symbol-name identifier)) - (string identifier)))) + (symbol (symbol-name identifier)) + (string identifier)))) (substitute #\_ #\- unescaped))) (defmacro without-interrupts (&body body) @@ -65,7 +65,7 @@ #+openmcl `(ccl:without-interrupts ,@body) #+sbcl `(sb-sys::without-interrupts ,@body)) -(defun make-process-lock (name) +(defun make-process-lock (name) #+allegro (mp:make-process-lock :name name) #+cmu (mp:make-lock name) #+lispworks (mp:make-lock :name name) @@ -88,53 +88,53 @@ #+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) (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" (substitute-string-for-char s #\' "''")) -(defun substitute-string-for-char (procstr match-char subst-str) +(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)) + (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) "From KMRCL." (declare (optimize (speed 3) (safety 0) (space 0)) - (fixnum start max) (simple-string string)) + (fixnum start max) (simple-string string)) (do* ((i start (1+ i))) ((= i max) nil) (declare (fixnum i)) (when (char= char (schar string i)) (return i)))) -(defun delimited-string-to-list (string &optional (separator #\space) - skip-terminal) +(defun delimited-string-to-list (string &optional (separator #\space) + skip-terminal) "Split a string with delimiter, from KMRCL." (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)) - (type string string) - (type character separator)) + (type string string) + (type character separator)) (do* ((len (length string)) - (output '()) - (pos 0) - (end (position-char separator string pos len) - (position-char separator string pos len))) + (output '()) + (pos 0) + (end (position-char separator string pos len) + (position-char separator string pos len))) ((null end) - (if (< pos len) - (push (subseq string pos) output) - (when (or (not skip-terminal) (zerop len)) - (push "" output))) - (nreverse output)) + (if (< pos len) + (push (subseq string pos) output) + (when (or (not skip-terminal) (zerop len)) + (push "" output))) + (nreverse output)) (declare (type fixnum pos len) - (type (or null fixnum) end)) + (type (or null fixnum) end)) (push (subseq string pos end) output) (setq pos (1+ end)))) @@ -144,7 +144,7 @@ ((and at-pos (> (length str) at-pos)) ;; Connection spec is SQL*NET format (cons (subseq str (1+ at-pos)) - (delimited-string-to-list (subseq str 0 at-pos) #\/))) + (delimited-string-to-list (subseq str 0 at-pos) #\/))) (t (delimited-string-to-list str #\/))))) @@ -159,92 +159,92 @@ (multiple-value-bind (output error status) (apply #'%command-output control-string args) (values - (concatenate 'string (if output output "") - (if error error "")) + (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))))) - + (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, +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)))) + (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))) + (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)))) + (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))) + (ext::process-exit-code process))) #+allegro (multiple-value-bind (output error status) - (excl.osi:command-output command :whole t) + (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 + (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)))) + (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)))) - + 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") @@ -259,53 +259,53 @@ returns (VALUES string-output error-output exit-status)" choices))))) ;; From KMRCL -(defun substitute-char-string (procstr match-char subst-str) +(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))) + (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) + (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))))))))) + (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))) + (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)) + (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=))) + (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)))))) + (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)))))) (defun getenv (var) @@ -332,12 +332,12 @@ list of characters and replacement strings." (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)) + (: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