about summary refs log tree commit diff
path: root/third_party/lisp/sclf/sysproc.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'third_party/lisp/sclf/sysproc.lisp')
-rw-r--r--third_party/lisp/sclf/sysproc.lisp295
1 files changed, 295 insertions, 0 deletions
diff --git a/third_party/lisp/sclf/sysproc.lisp b/third_party/lisp/sclf/sysproc.lisp
new file mode 100644
index 000000000000..1dd559ebe3a2
--- /dev/null
+++ b/third_party/lisp/sclf/sysproc.lisp
@@ -0,0 +1,295 @@
+;;;  sysproc.lisp --- system processes
+
+;;;  Copyright (C) 2008, 2009, 2010 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: sclf
+
+#+cmu (ext:file-comment "$Module: sysproc.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :sclf)
+
+(defvar *bourne-shell* "/bin/sh")
+
+(defvar *run-verbose* nil
+  "If true system commands are displayed before execution and standard
+error is not discarded.")
+
+;;
+;; SIGINFO is missing in both CMUCL and SBCL
+;;
+
+#+cmu
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defconstant unix::siginfo 29)
+  (defvar siginfo (unix::make-unix-signal :siginfo unix::siginfo "Information"))
+  (export '(unix::siginfo) "UNIX")
+  (pushnew siginfo unix::*unix-signals*))
+
+#+sbcl (in-package :sb-posix)
+#+sbcl
+(eval-when (:execute :compile-toplevel :load-toplevel)
+  (unless (find-symbol "SIGINFO" :sb-posix)
+    (sb-ext:with-unlocked-packages (:sb-posix)
+      (defvar siginfo 29)
+      (export '(SIGINFO)))))
+#+sbcl (in-package :sclf)
+
+(defun signal-number (signal-name)
+  (ecase signal-name
+    ((:abrt :abort)
+     #+cmu unix:sigabrt
+     #+sbcl sb-posix:sigabrt)
+    ((:alrm :alarm)
+     #+cmu unix:sigalrm
+     #+sbcl sb-posix:sigalrm)
+    ((:bus :bus-error)
+     #+cmu unix:sigbus
+     #+sbcl sb-posix:sigbus)
+    ((:chld :child)
+     #+cmu unix:sigchld
+     #+sbcl sb-posix:sigchld)
+    ((:cont :continue)
+     #+cmu unix:sigcont
+     #+sbcl sb-posix:sigcont)
+    #+freebsd((:emt :emulate-instruction)
+              #+cmu unix:sigemt
+              #+sbcl sb-posix:sigemt)
+    ((:fpe :floating-point-exception)
+     #+cmu unix:sigfpe
+     #+sbcl sb-posix:sigfpe)
+    ((:hup :hangup)
+     #+cmu unix:sighup
+     #+sbcl sb-posix:sighup)
+    ((:ill :illegal :illegal-instruction)
+     #+cmu unix:sigill
+     #+sbcl sb-posix:sigill)
+    ((:int :interrupt)
+     #+cmu unix:sigint
+     #+sbcl sb-posix:sigint)
+    ((:io :input-output)
+     #+cmu unix:sigio
+     #+sbcl sb-posix:sigio)
+    (:kill
+     #+cmu unix:sigkill
+     #+sbcl sb-posix:sigkill)
+    ((:pipe :broke-pipe)
+     #+cmu unix:sigpipe
+     #+sbcl sb-posix:sigpipe)
+    ((:prof :profiler)
+     #+cmu unix:sigprof
+     #+sbcl sb-posix:sigprof)
+    (:quit
+     #+cmu unix:sigquit
+     #+sbcl sb-posix:sigquit)
+    ((:segv :segmentation-violation)
+     #+cmu unix:sigsegv
+     #+sbcl sb-posix:sigsegv)
+    (:stop
+     #+cmu unix:sigstop
+     #+sbcl sb-posix:sigstop)
+    ((:sys :system-call)
+     #+cmu unix:sigsys
+     #+sbcl sb-posix:sigsys)
+    ((:term :terminate)
+     #+cmu unix:sigterm
+     #+sbcl sb-posix:sigterm)
+    ((:trap)
+     #+cmu unix:sigtrap
+     #+sbcl sb-posix:sigtrap)
+    ((:tstp :terminal-stop)
+     #+cmu unix:sigtstp
+     #+sbcl sb-posix:sigtstp)
+    ((:ttin :tty-input)
+     #+cmu unix:sigttin
+     #+sbcl sb-posix:sigttin)
+    ((:ttou :tty-output)
+     #+cmu unix:sigttou
+     #+sbcl sb-posix:sigttou)
+    ((:urg :urgent)
+     #+cmu unix:sigurg
+     #+sbcl sb-posix:sigurg)
+    ((:usr1 :user1)
+     #+cmu unix:sigusr1
+     #+sbcl sb-posix:sigusr1)
+    ((:usr2 :user2)
+     #+cmu unix:sigusr2
+     #+sbcl sb-posix:sigusr2)
+    ((:vtalrm :virtual-timer-alarm)
+     #+cmu unix:sigvtalrm
+     #+sbcl sb-posix:sigvtalrm)
+    ((:winch :window-change :window-size-change)
+     #+cmu unix:sigwinch
+     #+sbcl sb-posix:sigwinch)
+    ((:xcpu :exceeded-cpu)
+     #+cmu unix:sigxcpu
+     #+sbcl sb-posix:sigxcpu)
+    ((:xfsz :exceeded-file-size)
+     #+cmu unix:sigxfsz
+     #+sbcl sb-posix:sigxfsz)
+    ;; oddly this is not defined by neither CMUCL nor SBCL
+    (:info 29)))
+
+(defun sysproc-kill (process signal)
+  (when (keywordp signal)
+    (setf signal (signal-number signal)))
+  #+cmu (ext:process-kill process signal)
+  #+sbcl (sb-ext:process-kill process signal)
+  #-(or sbcl cmu) (error "Don't know how to kill a process"))
+
+(defun sysproc-exit-code (process)
+  #+cmu (ext:process-exit-code process)
+  #+sbcl (sb-ext:process-exit-code process)
+  #-(or sbcl cmu) (error "Don't know how to get a process exit code"))
+
+(defun sysproc-wait (process)
+  #+cmu (ext:process-wait process)
+  #+sbcl (sb-ext:process-wait process)
+  #-(or sbcl cmu) (error "Don't know how to wait a process"))
+
+(defun sysproc-input (process)
+  #+cmu (ext:process-input process)
+  #+sbcl (sb-ext:process-input process)
+  #-(or sbcl cmu) (error "Don't know how to get the process input"))
+
+(defun sysproc-output (process)
+  #+cmu (ext:process-output process)
+  #+sbcl (sb-ext:process-output process)
+  #-(or sbcl cmu) (error "Don't know how to get the process output"))
+
+(defun sysproc-alive-p (process)
+  #+cmu (ext:process-alive-p process)
+  #+sbcl (sb-ext:process-alive-p process)
+  #-(or sbcl cmu) (error "Don't know how to test wether a process might be running"))
+
+(defun sysproc-pid (process)
+  #+cmu (ext:process-pid process)
+  #+sbcl (sb-ext:process-pid process)
+  #-(or sbcl cmu) (error "Don't know how to get the id of a process"))
+
+(defun sysproc-p (thing)
+  #+sbcl (sb-ext:process-p thing)
+  #+cmu (ext:process-p thing)
+  #-(or sbcl cmu) (error "Don't know how to figure out whether something is a system process"))
+
+(defun run-program (program arguments &key (wait t) pty input output error)
+  "Run PROGRAM with ARGUMENTS (a list) and return a process object."
+  ;; convert arguments to strings
+  (setf arguments
+        (mapcar #'(lambda (item)
+                    (typecase item
+                      (string item)
+                      (pathname (native-namestring item))
+                      (t (format nil "~A" item))))
+                arguments))
+  (when *run-verbose*
+    (unless error
+      (setf error t))
+    (format t "~&; run-pipe ~A~{ ~S~}~%" program arguments))
+  #+cmu (ext:run-program program arguments
+                         :wait wait
+                         :pty pty
+                         :input input
+                         :output output
+                         :error (or error *run-verbose*))
+  #+sbcl (sb-ext:run-program program arguments
+                             :search t
+                             :wait wait
+                             :pty pty
+                             :input input
+                             :output output
+                             :error (or error *run-verbose*))
+  #-(or sbcl cmu)
+  (error "Unsupported Lisp system."))
+
+(defun run-pipe (direction program arguments &key error)
+  "Run PROGRAM with a list of ARGUMENTS and according to DIRECTION
+return the input and output streams and process object of that
+process."
+  (be process (run-program program arguments
+                           :wait nil
+                           :pty nil
+                           :input (when (member direction '(:output :input-output :io))
+                                    :stream)
+                           :output (when (member direction '(:input :input-output :io))
+                                     :stream)
+                           :error error)
+    (values (sysproc-output process)
+            (sysproc-input process)
+            process))
+  #-(or sbcl cmu)
+  (error "Unsupported Lisp system."))
+
+(defun exit-code (process)
+  (sysproc-wait process)
+  (sysproc-exit-code process))
+
+(defun run-shell-command (fmt &rest args)
+  "Run a Bourne Shell command.  Return the exit status of the command."
+  (run-program *bourne-shell* (list "-c" (apply #'format nil fmt args))))
+
+(defun run-async-shell-command (fmt &rest args)
+  "Run a Bourne Shell command asynchronously. Return a process
+object if provided by your Lisp implementation."
+  (run-program *bourne-shell* (list "-c" (apply #'format nil fmt args))
+               :wait nil))
+
+(defmacro with-open-pipe ((in out program arguments &key (process (gensym)) error pty) &body forms)
+  "Run BODY with IN and OUT bound respectively to an input and an
+output stream connected to a system process created by running PROGRAM
+with ARGUMENTS.  If IN or OUT are NIL, then don't create that stream."
+  (with-gensyms (prg args)
+    `(be* ,prg ,program
+          ,args ,arguments
+          ,process (run-program ,prg ,args
+                                :output ,(case in
+                                               ((t nil) in)
+                                               (t :stream))
+                                :input ,(case out
+                                              ((t nil) out)
+                                              (t :stream))
+                                :wait nil
+                                :pty ,pty
+                                ,@(when error `(:error ,error)))
+       (if ,process
+           (let (,@(case in
+                         ((t nil))
+                         (t `((,in (sysproc-output ,process)))))
+                 ,@(case out
+                         ((t nil))
+                         (t `((,out (sysproc-input ,process))))))
+             (unwind-protect
+                  (progn
+                    ,@forms)
+               ,@(case in
+                       ((t nil))
+                       (t `((close ,in))))
+               ,@(case out
+                       ((t nil))
+                       (t `((close ,out))))
+               (when (sysproc-alive-p ,process)
+                 (sysproc-kill ,process :term))))
+           (error "unable to run ~A~{ ~A~}." ,prg ,args)))))
+
+
+(defun sysproc-set-signal-callback (signal handler)
+  "Arrange HANDLER function to be called when receiving the system
+signal SIGNAL."
+  (when (keywordp signal)
+    (setf signal (signal-number signal)))
+  #+cmu (system:enable-interrupt signal handler)
+  #+sbcl (sb-sys:enable-interrupt signal handler)
+  #-(or cmu sbcl) (error "Don't know how to set a system signal callback."))