Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
14fc8fb4
Commit
14fc8fb4
authored
35 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Initial revision
parent
9ccf5947
No related branches found
No related tags found
No related merge requests found
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
code/run-program.lisp
+651
-0
651 additions, 0 deletions
code/run-program.lisp
code/serve-event.lisp
+365
-0
365 additions, 0 deletions
code/serve-event.lisp
with
1016 additions
and
0 deletions
code/run-program.lisp
0 → 100644
+
651
−
0
View file @
14fc8fb4
;;; -*- Package: Extensions; Log: code.log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; RUN-PROGRAM and friends. Factilty for running unix programs from inside
;;; a lisp.
;;;
;;; Written by Jim Healy and Bill Chiles, November 1987, using an earlier
;;; version written by David McDonald.
;;;
;;; Completely re-written by William Lott, July 1989 - January 1990.
;;;
(
in-package
"EXTENSIONS"
)
(
export
'
(
run-program
process-status
process-exit-code
process-core-dumped
process-wait
process-kill
process-input
process-output
process-plist
process-pty
process-error
process-status-hook
process-alive-p
process-close
process-pid
process-p
))
;;;; Import WAIT3 from unix.
(
ext:def-c-pointer
*wait
(
unsigned-byte
32
))
(
ext:def-c-routine
(
"wait3"
c-wait3
)
(
int
)
(
status
*wait
:out
)
(
options
int
)
(
rusage
int
))
(
eval-when
(
load
eval
compile
)
(
defconstant
wait-wstopped
#o177
)
(
defconstant
wait-wnohang
1
)
(
defconstant
wait-wuntraced
2
))
(
defun
wait3
(
&optional
do-not-hang
check-for-stopped
)
"Return any available status information on child processed. "
(
multiple-value-bind
(
pid
status
)
(
c-wait3
(
logior
(
if
do-not-hang
wait-wnohang
0
)
(
if
check-for-stopped
wait-wuntraced
0
))
0
)
(
cond
((
or
(
minusp
pid
)
(
zerop
pid
))
nil
)
((
eql
(
ldb
(
byte
8
0
)
status
)
wait-wstopped
)
(
values
pid
:stopped
(
ldb
(
byte
8
8
)
status
)))
((
zerop
(
ldb
(
byte
7
0
)
status
))
(
values
pid
:exited
(
ldb
(
byte
8
8
)
status
)))
(
t
(
let
((
signal
(
ldb
(
byte
7
0
)
status
)))
(
values
pid
(
if
(
or
(
eql
signal
mach:sigstop
)
(
eql
signal
mach:sigtstp
)
(
eql
signal
mach:sigttin
)
(
eql
signal
mach:sigttou
))
:stopped
:signaled
)
signal
(
not
(
zerop
(
ldb
(
byte
1
7
)
status
)))))))))
;;;; Process control stuff.
(
defvar
*active-processes*
nil
"List of process structures for all active processes."
)
(
defstruct
(
process
(
:print-function
%print-process
))
pid
; PID of child process.
%status
; Either :RUNNING, :STOPPED, :EXITED, or :SIGNALED.
exit-code
; Either exit code or signal
core-dumped
; T if a core image was dumped.
pty
; Stream to child's pty or nil.
input
; Stream to child's input or nil.
output
; Stream from child's output or nil.
error
; Stream from child's error output or nil.
status-hook
; Closure to call when PROC changes status.
plist
; Place for clients to stash tings.
)
(
defun
%print-process
(
proc
stream
depth
)
(
declare
(
ignore
depth
))
(
format
stream
"#<process ~D ~S>"
(
process-pid
proc
)
(
process-status
proc
)))
;;; PROCESS-STATUS -- Public.
;;;
(
defun
process-status
(
proc
)
"Return the current status of process. The result is one of :running,
:stopped, :exited, :signaled."
(
get-processes-status-changes
)
(
process-%status
proc
))
;;; PROCESS-WAIT -- Public.
;;;
(
defun
process-wait
(
proc
&optional
check-for-stopped
)
"Wait for PROC to quit running for some reason. Returns PROC."
(
loop
(
unless
(
or
(
eq
(
process-status
proc
)
:running
)
(
and
check-for-stopped
(
eq
(
process-status
proc
)
:stopped
)))
(
return
))
(
system:serve-all-events
1
))
proc
)
;;; FIND-CURRENT-FOREGROUND-PROCESS -- internal
;;;
;;; Finds the current foreground process group id.
;;;
(
defun
find-current-foreground-process
(
proc
)
(
mach:with-trap-arg-block
mach::int1
pgrp
(
multiple-value-bind
(
wonp
error
)
(
mach:unix-ioctl
(
system:fd-stream-fd
(
ext:process-pty
proc
))
mach:TIOCGPGRP
(
lisp::alien-value-sap
mach::int1
))
(
unless
wonp
(
error
"TIOCPGRP ioctl failed: ~S"
(
mach:get-unix-error-msg
error
)))
(
system:alien-access
(
mach::int1-int
(
system:alien-value
pgrp
))))))
;;; PROCESS-KILL -- public
;;;
;;; Hand a process a signal.
;;;
(
defun
process-kill
(
proc
signal
&optional
(
whom
:pid
))
"Hand SIGNAL to PROC. If whom is :pid, use the kill Unix system call. If
whom is :process-group, use the killpg Unix system call. If whom is
:pty-process-group deliver the signal to whichever process group is currently
in the foreground."
(
let
((
pid
(
ecase
whom
((
:pid
:process-group
)
(
process-pid
proc
))
(
:pty-process-group
(
find-current-foreground-process
proc
)))))
(
multiple-value-bind
(
okay
errno
)
(
if
(
eq
whom
:pty-process-group
)
(
mach:unix-killpg
pid
signal
)
(
mach:unix-kill
pid
signal
))
(
cond
((
not
okay
)
(
values
nil
errno
))
((
and
(
eql
pid
(
process-pid
proc
))
(
=
(
unix-signal-number
signal
)
mach:sigcont
))
(
setf
(
process-%status
proc
)
:running
)
(
setf
(
process-exit-code
proc
)
nil
)
(
when
(
process-status-hook
proc
)
(
funcall
(
process-status-hook
proc
)
proc
))
t
)
(
t
t
)))))
;;; PROCESS-ALIVE-P -- public
;;;
;;; Returns T if the process is still alive, NIL otherwise.
;;;
(
defun
process-alive-p
(
proc
)
"Returns T if the process is still alive, NIL otherwise."
(
let
((
status
(
process-status
proc
)))
(
if
(
or
(
eq
status
:running
)
(
eq
status
:stopped
))
t
nil
)))
;;; PROCESS-CLOSE -- public
;;;
;;; Close all the streams held open by PROC.
;;;
(
defun
process-close
(
proc
)
"Close all streams connected to PROC and stop maintaining the status slot."
(
macrolet
((
frob
(
stream
)
`
(
when
,
stream
(
close
,
stream
))))
(
frob
(
process-pty
proc
))
(
frob
(
process-input
proc
))
(
frob
(
process-output
proc
))
(
frob
(
process-error
proc
))
(
system:without-interrupts
(
setf
*active-processes*
(
delete
proc
*active-processes*
)))
proc
))
;;; SIGCHLD-HANDLER -- Internal.
;;;
;;; This should be the handler for sigchld signals that RUN-PROGRAM establishes.
;;;
;;; Since interrupts are so broken in the current RT system, we don't turn on
;;; sigchld signals for now. We call this by hand whenever we need to check
;;; the status of a process.
;;;
(
defun
sigchld-handler
(
ignore1
ignore2
ignore3
)
(
declare
(
ignore
ignore1
ignore2
ignore3
))
(
get-processes-status-changes
))
;;; GET-PROCESSES-STATUS-CHANGES -- Internal.
;;;
(
defun
get-processes-status-changes
()
(
loop
(
multiple-value-bind
(
pid
what
code
core
)
(
wait3
t
t
)
(
unless
pid
(
return
))
(
let
((
proc
(
find
pid
*active-processes*
:key
#'
process-pid
)))
(
when
proc
(
setf
(
process-%status
proc
)
what
)
(
setf
(
process-exit-code
proc
)
code
)
(
setf
(
process-core-dumped
proc
)
core
)
(
when
(
process-status-hook
proc
)
(
funcall
(
process-status-hook
proc
)
proc
))
(
when
(
or
(
eq
what
:exited
)
(
eq
what
:signaled
))
(
system:without-interrupts
(
setf
*active-processes*
(
delete
proc
*active-processes*
)))))))))
;;;; RUN-PROGRAM and close friends.
(
defvar
*close-on-error*
nil
"List of file descriptors to close when RUN-PROGRAM exits due to an error."
)
(
defvar
*close-in-parent*
nil
"List of file descriptors to close when RUN-PROGRAM returns in the parent."
)
(
defvar
*handlers-installed*
nil
"List of handlers installed by RUN-PROGRAM."
)
;;; FIND-A-PTY -- internal
;;;
;;; Finds a pty that is not in use. Returns three values: the file descriptor
;;; for the master side of the pty, the file descriptor for the slave side of
;;; the pty, and the name of the tty device for the slave side.
;;;
(
defun
find-a-pty
()
"Returns the master fd, the slave fd, and the name of the tty"
(
dolist
(
char
'
(
#\p
#\q
))
(
dotimes
(
digit
16
)
(
let*
((
master-name
(
format
nil
"/dev/pty~C~X"
char
digit
))
(
master-fd
(
mach:unix-open
master-name
mach:o_rdwr
#o666
)))
(
when
master-fd
(
let*
((
slave-name
(
format
nil
"/dev/tty~C~X"
char
digit
))
(
slave-fd
(
mach:unix-open
slave-name
mach:o_rdwr
#o666
)))
(
when
slave-fd
; Maybe put a vhangup here?
(
mach:unix-ioctl
slave-fd
mach:TIOCGETP
(
system:alien-sap
mach:sgtty
))
(
setf
(
system:alien-access
(
mach::sgtty-flags
mach:sgtty
))
#o6300
)
; XTABS|EVENP|ODDP
(
mach:unix-ioctl
slave-fd
mach:TIOCSETP
(
system:alien-sap
mach:sgtty
))
(
mach:unix-ioctl
master-fd
mach:TIOCGETP
(
system:alien-sap
mach:sgtty
))
(
setf
(
system:alien-access
(
mach::sgtty-flags
mach:sgtty
))
(
logand
(
system:alien-access
(
mach::sgtty-flags
mach:sgtty
))
(
lognot
8
)))
; ~ECHO
(
mach:unix-ioctl
master-fd
mach:TIOCSETP
(
system:alien-sap
mach:sgtty
))
(
return-from
find-a-pty
(
values
master-fd
slave-fd
slave-name
))))
(
mach:unix-close
master-fd
)))))
(
error
"Could not find a pty."
))
;;; OPEN-PTY -- internal
;;;
(
defun
open-pty
(
pty
)
(
when
pty
(
multiple-value-bind
(
master
slave
name
)
(
find-a-pty
)
(
push
master
*close-on-error*
)
(
push
slave
*close-in-parent*
)
(
when
(
streamp
pty
)
(
multiple-value-bind
(
won
new-fd
)
(
mach:unix-dup
master
)
(
unless
won
(
error
"Could not MACH:UNIX-DUP ~D: ~A"
master
(
mach:get-unix-error-msg
new-fd
)))
(
push
new-fd
*close-on-error*
)
(
copy-descriptor-to-stream
new-fd
pty
)))
(
values
name
(
system:make-fd-stream
master
:input
t
:output
t
)))))
;;; SETUP-CHILD -- internal
;;;
;;; Execs the program after setting up the environment correctly. This
;;; routine never returns under any condition.
;;;
(
defun
setup-child
(
pfile
args
env
stdin
stdout
stderr
pty-name
before-execve
)
(
unwind-protect
(
handler-bind
((
error
#'
(
lambda
(
condition
)
(
declare
(
ignore
condition
))
(
mach:unix-exit
2
))))
;; Put us in our own pgrp.
(
mach:unix-setpgrp
0
(
mach:unix-getpid
))
;; If we want a pty, set it up.
(
when
pty-name
(
let
((
old-tty
(
mach:unix-open
"/dev/tty"
mach:o_rdwr
0
)))
(
when
old-tty
(
mach:unix-ioctl
old-tty
mach:TIOCNOTTY
0
)
(
mach:unix-close
old-tty
)))
(
let
((
new-tty
(
mach:unix-open
pty-name
mach:o_rdwr
0
)))
(
when
new-tty
(
mach:unix-dup2
new-tty
0
)
(
mach:unix-dup2
new-tty
1
)
(
mach:unix-dup2
new-tty
2
))))
;; Setup the three standard descriptors.
(
when
stdin
(
mach:unix-dup2
stdin
0
))
(
when
stdout
(
mach:unix-dup2
stdout
1
))
(
when
stderr
(
mach:unix-dup2
stderr
2
))
;; Close all other descriptors.
(
do
((
fd
(
1-
(
mach:unix-getdtablesize
))
(
1-
fd
)))
((
=
fd
3
))
(
mach:unix-close
fd
))
;; Do the before-execve
(
when
before-execve
(
funcall
before-execve
))
;; Exec the program
(
mach:unix-execve
pfile
args
env
))
;; If exec returns, we lose.
(
mach:unix-exit
1
)))
;;; RUN-PROGRAM -- public
;;;
;;; RUN-PROGRAM uses fork and execve to run a different program. Strange stuff
;;; happens to keep the unix state of the world coherent.
;;;
;;; The child process needs to get it's input from somewhere, and send it's
;;; output (both standard and error) to somewhere. We have to do different
;;; things depending on where these somewheres really are.
;;;
;;; For input, there are five options:
;;; - T: Just leave fd 0 alone. Pretty simple.
;;; - "file": Read from the file. We need to open the file and pull the
;;; descriptor out of the stream. The parent should close this stream after
;;; the child is up and running to free any storage used in the parent.
;;; - NIL: Same as "file", but use "/dev/null" as the file.
;;; - :STREAM: Use unix-pipe to create two descriptors. Use system:make-fd-stream
;;; to create the output stream on the writeable descriptor, and pass the
;;; readable descriptor to the child. The parent must close the readable
;;; descriptor for EOF to be passed up correctly.
;;; - a stream: If it's a fd-stream, just pull the descriptor out of it.
;;; Otherwise make a pipe as in :STREAM, and copy everything across.
;;;
;;; For output, there are n options:
;;; - T: Leave descriptor 1 alone.
;;; - "file": dump output to the file.
;;; - NIL: dump output to /dev/null.
;;; - :STREAM: return a stream that can be read from.
;;; - a stream: if it's a fd-stream, use the descriptor in it. Otherwise, copy
;;; stuff from output to stream.
;;;
;;; For error, there are all the same options as output plus:
;;; - :OUTPUT: redirect to the same place as output.
;;;
;;; RUN-PROGRAM returns a process struct for the process if the fork worked,
;;; and NIL if it did not.
;;;
(
defun
run-program
(
program
args
&key
(
env
*environment-list*
)
(
wait
t
)
pty
input
if-input-does-not-exist
output
(
if-output-exists
:error
)
(
error
:output
)
(
if-error-exists
:error
)
status-hook
before-execve
)
"Run-program creates a new process and runs the unix progam in the
file specified by the simple-string program. Args are the standard
arguments that can be passed to a Unix program, for no arguments
use NIL (which means just the name of the program is passed as arg 0).
Run program will either return NIL or a PROCESS structure. See the CMU
Common Lisp Users Manual for details about the PROCESS structure.
The keyword arguments have the following meanings:
:env -
An A-LIST mapping keyword environment variables to simple-string
values.
:wait -
If non-NIL (default), wait until the created process finishes. If
NIL, continue running Lisp until the program finishes.
:pty -
Either T, NIL, or a stream. Unless NIL, the subprocess is established
under a PTY. If :pty is a stream, all output to this pty is sent to
this stream, otherwise the PROCESS-PTY slot is filled in with a stream
connected to pty that can read output and write input.
:input -
Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
input for the current process is inherited. If NIL, /dev/null
is used. If a pathname, the file so spesified is used. If a stream,
all the input is read from that stream and send to the subprocess. If
:STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
its output to the process. Defaults to NIL.
:if-input-does-not-exist (when :input is the name of a file) -
can be one of:
:error - generate an error.
:create - create an empty file.
nil (default) - return nil from run-program.
:output -
Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
input for the current process is inherited. If NIL, /dev/null
is used. If a pathname, the file so spesified is used. If a stream,
all the output from the process is written to this stream. If
:STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
be read to get the output. Defaults to NIL.
:if-output-exists (when :input is the name of a file) -
can be one of:
:error (default) - generates an error if the file already exists.
:supersede - output from the program supersedes the file.
:append - output from the program is appended to the file.
nil - run-program returns nil without doing anything.
:error and :if-error-exists -
Same as :output and :if-output-exists, except that :error can also be
spesified as :output in which case all error output is routed to the
same place as normal output.
:status-hook -
This is a function the system calls whenever the status of the
process changes. The function takes the process as an argument.
:before-execve -
This is a function, without arguments, RUN-PROGRAM runs in the child
process just before turning it into the specified program."
;; Make sure the interrupt handler is installed.
;(system:enable-interrupt mach:sigchld #'sigchld-handler)
;; Make sure all the args are okay.
(
unless
(
every
#'
simple-string-p
args
)
(
error
"All args to program must be simple strings -- ~S."
args
))
;; Pre-pend the program to the argument list.
(
push
(
namestring
program
)
args
)
;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup
;; info. Also, establish proc at this level so we can return it.
(
let
(
*close-on-error*
*close-in-parent*
*handlers-installed*
proc
)
(
unwind-protect
(
let
((
pfile
(
namestring
(
truename
(
merge-pathnames
program
"path:"
)))))
(
multiple-value-bind
(
stdin
input-stream
)
(
get-descriptor-for
input
:direction
:input
:if-does-not-exist
if-input-does-not-exist
)
(
multiple-value-bind
(
stdout
output-stream
)
(
get-descriptor-for
output
:direction
:output
:if-exists
if-output-exists
)
(
multiple-value-bind
(
stderr
error-stream
)
(
if
(
eq
error
:output
)
(
values
stdout
output-stream
)
(
get-descriptor-for
error
:direction
:output
:if-exists
if-error-exists
))
(
multiple-value-bind
(
pty-name
pty-stream
)
(
open-pty
pty
)
;; Make sure we are not notified about the child death before
;; we have installed the process struct in *active-processes*
(
system:without-interrupts
(
multiple-value-bind
(
child-pid
errno
)
(
mach:unix-fork
)
(
cond
((
zerop
child-pid
)
;; We are the child. Note: setup-child NEVER returns
(
setup-child
pfile
args
env
stdin
stdout
stderr
pty-name
before-execve
))
((
null
child-pid
)
;; This should only happen if the bozo has too
;; many running procs.
(
error
"Could not fork child process: ~A"
(
mach:get-unix-error-msg
errno
)))
(
t
;; We are the parent.
(
setf
proc
(
make-process
:pid
child-pid
:%status
:running
:pty
pty-stream
:input
input-stream
:output
output-stream
:error
error-stream
:status-hook
status-hook
))
(
push
proc
*active-processes*
))))))))))
(
dolist
(
fd
*close-in-parent*
)
(
mach:unix-close
fd
))
(
unless
proc
(
dolist
(
fd
*close-on-error*
)
(
mach:unix-close
fd
))
(
dolist
(
handler
*handlers-installed*
)
(
system:remove-fd-handler
handler
))))
(
when
(
and
wait
proc
)
(
process-wait
proc
))
proc
))
;;; COPY-DESCRIPTOR-TO-STREAM -- internal
;;;
;;; Installs a handler for any input that shows up on the file descriptor.
;;; The handler reads the data and writes it to the stream.
;;;
(
defun
copy-descriptor-to-stream
(
descriptor
stream
)
(
let
((
string
(
make-string
256
))
handler
)
(
setf
handler
(
system:add-fd-handler
descriptor
:input
#'
(
lambda
(
fd
)
(
declare
(
ignore
fd
))
(
loop
(
multiple-value-bind
(
result
readable/errno
)
(
mach:unix-select
(
1+
descriptor
)
(
ash
1
descriptor
)
0
0
0
)
(
cond
((
null
result
)
(
error
"Could not select on sub-process: ~A"
(
mach:get-unix-error-msg
readable/errno
)))
((
zerop
result
)
(
return
))))
(
multiple-value-bind
(
count
errno
)
(
mach:unix-read
descriptor
string
(
length
string
))
(
cond
((
or
(
and
(
null
count
)
(
eql
errno
mach:eio
))
(
eql
count
0
))
(
system:remove-fd-handler
handler
)
(
mach:unix-close
descriptor
)
(
return
))
((
null
count
)
(
system:remove-fd-handler
handler
)
(
error
"Could not read input from sub-process: ~A"
(
mach:get-unix-error-msg
errno
)))
(
t
(
write-string
string
stream
:end
count
))))))))))
;;; GET-DESCRIPTOR-FOR -- internal
;;;
;;; Find a file descriptor to use for object given the direction. Returns
;;; the descriptor. If object is :STREAM, returns the created stream as the
;;; second value.
;;;
(
defun
get-descriptor-for
(
object
&rest
keys
&key
direction
&allow-other-keys
)
(
cond
((
eq
object
t
)
;; No new descriptor is needed.
(
values
nil
nil
))
((
eq
object
nil
)
;; Use /dev/null.
(
multiple-value-bind
(
fd
errno
)
(
mach:unix-open
"/dev/null"
(
case
direction
(
:input
mach:o_rdonly
)
(
:output
mach:o_wronly
)
(
t
mach:o_rdwr
))
#o666
)
(
unless
fd
(
error
"Could not open \"/dev/null\": ~A"
(
mach:get-unix-error-msg
errno
)))
(
push
fd
*close-in-parent*
)
(
values
fd
nil
)))
((
eq
object
:stream
)
(
multiple-value-bind
(
read-fd
write-fd
)
(
mach:unix-pipe
)
(
unless
read-fd
(
error
"Could not create pipe: ~A"
(
mach:get-unix-error-msg
write-fd
)))
(
case
direction
(
:input
(
push
read-fd
*close-in-parent*
)
(
push
write-fd
*close-on-error*
)
(
let
((
stream
(
system:make-fd-stream
write-fd
:output
t
)))
(
values
read-fd
stream
)))
(
:output
(
push
read-fd
*close-on-error*
)
(
push
write-fd
*close-in-parent*
)
(
let
((
stream
(
system:make-fd-stream
read-fd
:input
t
)))
(
values
write-fd
stream
)))
(
t
(
mach:unix-close
read-fd
)
(
mach:unix-close
write-fd
)
(
error
"Direction must be either :INPUT or :OUTPUT, not ~S"
direction
)))))
((
stringp
object
)
(
with-open-stream
(
file
(
apply
#'
open
object
keys
))
(
multiple-value-bind
(
won
fd
)
(
mach:unix-dup
(
system:fd-stream-fd
file
))
(
cond
(
won
(
push
fd
*close-in-parent*
)
(
values
fd
nil
))
(
t
(
error
"Could not duplicate file descriptor: ~A"
(
mach:get-unix-error-msg
fd
)))))))
((
system:fd-stream-p
object
)
(
values
(
system:fd-stream-fd
object
)
nil
))
((
streamp
object
)
(
ecase
direction
(
:input
(
dotimes
(
count
256
(
error
"Could not open a temporary file in /tmp"
))
(
let*
((
name
(
format
nil
"/tmp/.run-program-~D"
count
))
(
fd
(
mach:unix-open
name
(
logior
mach:o_rdwr
mach:o_creat
mach:o_excl
)
#o666
)))
(
mach:unix-unlink
name
)
(
when
fd
(
let
((
newline
(
string
#\Newline
)))
(
loop
(
multiple-value-bind
(
line
no-cr
)
(
read-line
object
nil
nil
)
(
unless
line
(
return
))
(
mach:unix-write
fd
line
0
(
length
line
))
(
if
no-cr
(
return
)
(
mach:unix-write
fd
newline
0
1
)))))
(
mach:unix-lseek
fd
0
mach:l_set
)
(
push
fd
*close-in-parent*
)
(
return
(
values
fd
nil
))))))
(
:output
(
multiple-value-bind
(
read-fd
write-fd
)
(
mach:unix-pipe
)
(
unless
read-fd
(
error
"Cound not create pipe: ~A"
(
mach:get-unix-error-msg
write-fd
)))
(
copy-descriptor-to-stream
read-fd
object
)
(
push
read-fd
*close-on-error*
)
(
push
write-fd
*close-in-parent*
)
(
values
write-fd
nil
)))))
(
t
(
error
"Invalid option to run-program: ~S"
object
))))
This diff is collapsed.
Click to expand it.
code/serve-event.lisp
0 → 100644
+
365
−
0
View file @
14fc8fb4
;;; -*- Log: code.log; Package: LISP -*-
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; SYSTEM:SERVE-EVENT, now in it's own file.
;;;
;;; Re-written by William Lott, July 1989 - January 1990.
;;;
;;; **********************************************************************
(
in-package
"SYSTEM"
)
(
export
'
(
with-fd-handler
add-fd-handler
remove-fd-handler
invalidate-descriptor
serve-event
serve-all-events
wait-until-fd-usable
))
(
in-package
"LISP"
)
;;;; MACH Message receiving noise.
(
defvar
*in-server*
NIL
"*In-server* is set to T when the SIGMSG interrupt has been enabled
in Server."
)
(
defvar
server-unique-object
(
cons
1
2
)
"Object thrown by the message interrupt handler."
)
(
defconstant
server-message-size
4096
)
(
defalien
server-message
server-message
(
bytes
server-message-size
)
0
)
(
define-alien-stack
server-message
server-message
(
bytes
server-message-size
))
(
defrecord
server-message
(
msg
mach:msg
#.
(
record-size
'mach:msg
)))
;;; Grab-message-loop calls the appropiate handler for an IPC message.
(
defun
grab-message-loop
()
(
let
((
done-any
nil
))
(
loop
(
if
(
eql
(
server-grab-message
)
mach:rcv-timed-out
)
(
return
done-any
)
(
setf
done-any
t
)))))
(
defun
server-grab-message
()
(
with-stack-alien
(
sm
server-message
)
(
alien-bind
((
msg
(
server-message-msg
(
alien-value
sm
))))
(
setf
(
alien-access
(
mach:msg-msgsize
(
alien-value
msg
)))
server-message-size
)
(
setf
(
alien-access
(
mach:msg-localport
(
alien-value
msg
)))
mach::port-enabled
)
(
let
((
gr
(
mach:msg-receive
(
alien-value
sm
)
mach::rcv-timeout
0
)))
(
when
(
eql
gr
mach:rcv-timed-out
)
(
return-from
server-grab-message
gr
))
(
unless
(
eql
gr
mach:rcv-success
)
(
gr-error
'mach:msg-receive
gr
))
(
let*
((
server-message
(
alien-value
sm
))
(
port
(
alien-access
(
mach:msg-localport
(
alien-value
msg
))))
(
id
(
alien-access
(
mach:msg-id
(
alien-value
msg
))))
(
x
(
gethash
port
*port-table*
))
(
set
(
cdr
x
)))
(
unless
x
(
error
"~D is not known to server (operation: ~D)."
port
id
))
(
let
((
gr
(
funcall
(
gethash
id
(
object-set-table
set
)
(
object-set-default-handler
set
))
(
car
x
))))
(
unless
(
eql
gr
mach:kern-success
)
(
gr-error
'server
gr
)))))))
mach:kern-success
)
;;;; File descriptor IO noise.
(
defstruct
(
handler
(
:print-function
%print-handler
)
(
:constructor
make-handler
(
direction
descriptor
function
)))
direction
; Either :input or :output
descriptor
; File descriptor this handler is tied to.
active
; T iff this handler is running.
function
; Function to call.
bogus
; T if this descriptor is bogus.
)
(
defun
%print-handler
(
handler
stream
depth
)
(
declare
(
ignore
depth
))
(
format
stream
"#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"
(
handler-direction
handler
)
(
handler-bogus
handler
)
(
handler-descriptor
handler
)
(
handler-function
handler
)))
(
defvar
*descriptor-handlers*
nil
"List of all the currently active handlers for file descriptors"
)
;;; ADD-FD-HANDLER -- public
;;;
;;; Add a new handler to *descriptor-handlers*.
;;;
(
defun
add-fd-handler
(
fd
direction
function
)
"Arange to call FUNCTION whenever FD is usable. DIRECTION should be
either :INPUT or :OUTPUT. The value returned should be passed to
SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
(
assert
(
member
direction
'
(
:input
:output
))
(
direction
)
"Invalid direction ~S, must be either :INPUT or :OUTPUT"
direction
)
(
let
((
handler
(
make-handler
direction
fd
function
)))
(
push
handler
*descriptor-handlers*
)
handler
))
;;; REMOVE-FD-HANDLER -- public
;;;
;;; Remove an old handler from *descriptor-handlers*.
;;;
(
defun
remove-fd-handler
(
handler
)
"Removes HANDLER from the list of active handlers."
(
setf
*descriptor-handlers*
(
delete
handler
*descriptor-handlers*
:test
#'
eq
)))
;;; INVALIDATE-DESCRIPTOR -- public
;;;
;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
;;;
(
defun
invalidate-descriptor
(
fd
)
"Remove any handers refering to fd. This should only be used when attempting
to recover from a detected inconsistancy."
(
setf
*descriptor-handlers*
(
delete
fd
*descriptor-handlers*
:key
#'
handler-descriptor
)))
;;; WITH-FD-HANDLER -- Public.
;;;
;;; Add the handler to *descriptor-handlers* for the duration of BODY.
;;;
(
defmacro
with-fd-handler
((
fd
direction
function
)
&rest
body
)
"Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
use, and FUNCTION is the function to call whenever FD is usable."
(
let
((
handler
(
gensym
)))
`
(
let
(
,
handler
)
(
unwind-protect
(
progn
(
setf
,
handler
(
add-fd-handler
,
fd
,
direction
,
function
))
,@
body
)
(
when
,
handler
(
remove-fd-handler
,
handler
))))))
;;; WAIT-UNTIL-FD-USABLE -- Public.
;;;
;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
;;; timeout at the correct time irrespective of how many events are handled in
;;; the meantime.
;;;
(
defun
wait-until-fd-usable
(
fd
direction
&optional
timeout
)
"Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
:OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
up."
(
let
(
usable
(
stop-at
(
if
timeout
(
multiple-value-bind
(
okay
sec
usec
)
(
mach:unix-gettimeofday
)
(
declare
(
ignore
okay
))
(
+
(
*
1000000
timeout
sec
)
usec
)))))
(
with-fd-handler
(
fd
direction
#'
(
lambda
(
fd
)
(
declare
(
ignore
fd
))
(
setf
usable
t
)))
(
loop
(
serve-event
timeout
)
(
when
usable
(
return
t
))
(
when
timeout
(
multiple-value-bind
(
okay
sec
usec
)
(
mach:unix-gettimeofday
)
(
declare
(
ignore
okay
))
(
let
((
now
(
+
(
*
sec
1000000
)
usec
)))
(
if
(
>
now
stop-at
)
(
return
nil
)
(
setq
timeout
(
/
(
-
stop-at
now
)
1000000
))))))))))
;;; CALC-MASKS -- Internal.
;;;
;;; Return the correct masks to use for UNIX-SELECT. The four return values
;;; are: fd count, read mask, write mask, and exception mask. The exception
;;; mask is currently unused.
;;;
(
defun
calc-masks
()
(
let
((
count
0
)
(
read-mask
0
)
(
write-mask
0
)
(
except-mask
0
))
(
dolist
(
handler
*descriptor-handlers*
)
(
unless
(
or
(
handler-active
handler
)
(
handler-bogus
handler
))
(
let
((
fd
(
handler-descriptor
handler
)))
(
case
(
handler-direction
handler
)
(
:input
(
setf
read-mask
(
logior
read-mask
(
ash
1
fd
))))
(
:output
(
setf
write-mask
(
logior
write-mask
(
ash
1
fd
)))))
(
if
(
>
fd
count
)
(
setf
count
fd
)))))
(
values
(
1+
count
)
read-mask
write-mask
except-mask
)))
;;; HANDLER-DESCRIPTORS-ERROR -- Internal.
;;;
;;; First, get a list and mark bad file descriptors. Then signal an error
;;; offering a few restarts.
;;;
(
defun
handler-descriptors-error
()
(
let
((
bogus-handlers
nil
))
(
dolist
(
handler
*descriptor-handlers*
)
(
unless
(
or
(
handler-bogus
handler
)
(
mach:unix-fstat
(
handler-descriptor
handler
)))
(
setf
(
handler-bogus
handler
)
t
)
(
push
handler
bogus-handlers
)))
(
restart-case
(
error
"~S ~[have~;has a~:;have~] bad file descriptor~:P."
bogus-handlers
(
length
bogus-handlers
))
(
remove-them
()
:report
"Remove bogus handlers."
(
setf
*descriptor-handlers*
(
delete-if
#'
handler-bogus
*descriptor-handlers*
)))
(
retry-them
()
:report
"Retry bogus handlers."
(
dolist
(
handler
bogus-handlers
)
(
setf
(
handler-bogus
handler
)
nil
)))
(
continue
()
:report
"Go on, leaving handlers marked as bogus."
))))
;;;; Serve-all-events, serve-event, and friends.
;;; SERVE-ALL-EVENTS -- public
;;;
;;; Wait for up to timeout seconds for an event to happen. Make sure all
;;; pending events are processed before returning.
;;;
(
defun
serve-all-events
(
&optional
timeout
)
"SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
0 until all events have been served. SERVE-ALL-EVENTS returns T if
SERVE-EVENT did something and NIL if not."
(
do
((
res
nil
)
(
sval
(
serve-event
timeout
)
(
serve-event
0
)))
((
null
sval
)
res
)
(
setq
res
t
)))
;;; SERVE-EVENT -- public
;;;
;;; Serve a single event.
;;;
(
defun
serve-event
(
&optional
timeout
)
"Receive on all ports and Xevents and dispatch to the appropriate handler
function. If timeout is specified, server will wait the specified time (in
seconds) and then return, otherwise it will wait until something happens.
Server returns T if something happened and NIL otherwise."
;; First, check any X displays for any pending events.
(
dolist
(
d/h
ext::*display-event-handlers*
)
(
let
((
d
(
car
d/h
)))
(
when
(
xlib::event-listen
d
)
(
handler-bind
((
error
#'
(
lambda
(
condx
)
(
declare
(
ignore
condx
))
(
flush-display-events
d
))))
(
funcall
(
cdr
d/h
)
d
))
(
return-from
serve-event
t
))))
;; Next, wait for something to happen.
(
multiple-value-bind
(
value
readable
writeable
)
(
wait-for-event
timeout
)
;; Now see what it was (if anything)
(
cond
((
eq
value
server-unique-object
)
;; The interrupt handler fired.
(
grab-message-loop
)
t
)
((
numberp
value
)
(
unless
(
zerop
value
)
;; Check the descriptors.
(
let
((
result
nil
))
(
dolist
(
handler
*descriptor-handlers*
)
(
when
(
not
(
zerop
(
logand
(
ash
1
(
handler-descriptor
handler
))
(
case
(
handler-direction
handler
)
(
:input
readable
)
(
:output
writeable
)))))
(
unwind-protect
(
progn
;; Doesn't work -- ACK
;(setf (handler-active handler) t)
(
funcall
(
handler-function
handler
)
(
handler-descriptor
handler
)))
(
setf
(
handler-active
handler
)
nil
))
(
macrolet
((
frob
(
var
)
`
(
setf
,
var
(
logand
(
lognot
(
ash
1
(
handler-descriptor
handler
)))
,
var
))))
(
case
(
handler-direction
handler
)
(
:input
(
frob
readable
))
(
:output
(
frob
writeable
))))
(
setf
result
t
)))
result
)))
((
eql
readable
mach:eintr
)
;; We did an interrupt.
t
)
(
t
;; One of the file descriptors is bad.
(
handler-descriptors-error
)
nil
))))
;;; WAIT-FOR-EVENT -- internal
;;;
;;; Wait for something to happen.
;;;
(
defun
wait-for-event
(
&optional
timeout
)
"Wait for an something to show up on one of the file descriptors or a message
interupt to fire. Timeout is in seconds."
(
let
(
old-mask
)
(
multiple-value-bind
(
timeout-sec
timeout-usec
)
(
if
timeout
(
truncate
(
round
(
*
timeout
1000000
))
1000000
)
(
values
nil
0
))
(
multiple-value-bind
(
count
read-mask
write-mask
except-mask
)
(
calc-masks
)
(
catch
'server-catch
(
unwind-protect
(
progn
;; Block message interrupts.
(
multiple-value-bind
(
noise
mask
)
(
mach:unix-sigsetmask
(
mach:sigmask
:sigmsg
))
(
declare
(
ignore
noise
))
(
setf
old-mask
mask
))
;; Check for any pending messages, because we are only signaled
;; for newly arived messages. This must be done after the
;; unix-sigsetmask.
(
when
(
grab-message-loop
)
(
return-from
wait-for-event
t
))
;; Indicate that we are in the server.
(
let
((
*in-server*
t
))
;; Establish the interrupt handlers.
(
enable-interrupt
mach:sigmsg
#'
ih-sigmsg
)
;; Enable all interrupts.
(
mach:unix-sigsetmask
0
)
;; Do the select.
(
mach:unix-select
count
read-mask
write-mask
except-mask
timeout-sec
timeout-usec
)))
;; Restore interrupt handler state.
(
mach:unix-sigsetmask
(
mach:sigmask
:sigmsg
))
(
default-interrupt
mach:sigmsg
)
(
mach:unix-sigsetmask
old-mask
)))))))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment