;;; 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."))
