X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=os.lisp;h=7b7da44e5fa23adac19e668e0010fff7f192dfea;hp=589eac4b74e89a2ef798ce01030315a3770a87b9;hb=1142016daa209cb657b035c651641a94ef49892a;hpb=2f65fd6d93691f3943182138efd2013c3fdb67c7 diff --git a/os.lisp b/os.lisp index 589eac4..7b7da44 100644 --- a/os.lisp +++ b/os.lisp @@ -15,91 +15,165 @@ (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 - (sb-impl::process-exit-code - (sb-ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output nil)) - + (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) - (ext:process-exit-code - (ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output nil)) - + (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) + (excl.osi:command-output command :whole t) (values output error status)) - + #+lispworks - (system:call-system-showing-output - command - :shell-type "/bin/sh" - :output-stream output) - - #+clisp ;XXX not exactly *verbose-out*, I know - (ext:run-shell-command command :output :terminal :wait t) - + ;; BUG: Lispworks combines output and error streams + (let ((output (make-string-output-stream))) + (unwind-protect + (let ((status + (system:call-system-showing-output + command + :prefix "" + :show-cmd nil + :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 - (nth-value 1 - (ccl:external-process-status - (ccl:run-program "/bin/sh" (list "-c" command) - :input nil :output nil - :wait t))) - + (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 "RUN-SHELL-PROGRAM not implemented for this Lisp") + (error "COMMAND-OUTPUT not implemented for this Lisp") )) (defun run-shell-command (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 output-string pid)" (let ((command (apply #'format nil control-string args))) #+sbcl (sb-impl::process-exit-code - (sb-ext:run-program + (sb-ext:run-program "/bin/sh" (list "-c" command) :input nil :output nil)) - + #+(or cmu scl) (ext:process-exit-code - (ext:run-program + (ext:run-program "/bin/sh" (list "-c" command) :input nil :output nil)) - - + + #+allegro (excl:run-shell-command command :input nil :output nil - :wait t) + :wait t) #+lispworks (system:call-system-showing-output command :shell-type "/bin/sh" - :output-stream output) - - #+clisp ;XXX not exactly *verbose-out*, I know + :show-cmd nil + :prefix "" + :output-stream nil) + + #+clisp ;XXX not exactly *verbose-out*, I know (ext:run-shell-command command :output :terminal :wait t) - + #+openmcl (nth-value 1 - (ccl:external-process-status - (ccl:run-program "/bin/sh" (list "-c" command) - :input nil :output nil - :wait t))) - + (ccl:external-process-status + (ccl:run-program "/bin/sh" (list "-c" command) + :input nil :output nil + :wait t))) + #-(or openmcl clisp lispworks allegro scl cmu sbcl) (error "RUN-SHELL-PROGRAM not implemented for this Lisp") )) + +(defun delete-directory-and-files (dir &key (if-does-not-exist :error) (quiet t) force) + #+allegro (excl:delete-directory-and-files dir :if-does-not-exist if-does-not-exist + :quiet quiet :force force) + #-(or allegro) (declare (ignore force)) + #-(or allegro) (cond + ((probe-directory dir) + (let ((cmd (format nil "rm -rf ~A" (namestring dir)))) + (unless quiet + (format *trace-output* ";; ~A" cmd)) + (command-output cmd))) + ((eq if-does-not-exist :error) + (error "Directory ~A does not exist [delete-directory-and-files]." dir)))) + +(defun file-size (file) + (when (probe-file file) + #+allegro (let ((stat (excl.osi:stat (namestring file)))) + (excl.osi:stat-size stat)) + #-allegro + (with-open-file (in file :direction :input) + (file-length in)))) + +(defun getpid () + "Return the PID of the lisp process." + #+allegro (excl::getpid) + #+(and lispworks win32) (win32:get-current-process-id) + #+(and lispworks (not win32)) (system::getpid) + #+sbcl (sb-posix:getpid) + #+cmu (unix:unix-getpid) + #+openmcl (ccl::getpid) + #+(and clisp unix) (system::process-id) + #+(and clisp win32) (cond ((find-package :win32) + (funcall (find-symbol "GetCurrentProcessId" + :win32))) + (t + (system::getenv "PID"))) + ) + +