about summary refs log blame commit diff
path: root/third_party/lisp/sclf/sysproc.lisp
blob: 1dd559ebe3a273ee6afc57c892f92be3c3243fcc (plain) (tree)


































































                                                                                
                                     























































































































                                                                                               




                                                         



                                                            



                                                         
                                              




                                                             






                                                                  





                                                                                       
                                    
                                   













                                                                         
                          





                                                                                                   









                                                                
                   
















                                                                 








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