Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
A
asdf
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
Container Registry
Model registry
Operate
Environments
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
Didier Verna
asdf
Commits
b2b86603
Commit
b2b86603
authored
8 years ago
by
Elias Pipping
Browse files
Options
Downloads
Patches
Plain Diff
Add and use process-info class
Allows for type checking and in-place changes via setf
parent
1c195eda
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
uiop/run-program.lisp
+61
-48
61 additions, 48 deletions
uiop/run-program.lisp
with
61 additions
and
48 deletions
uiop/run-program.lisp
+
61
−
48
View file @
b2b86603
...
...
@@ -408,6 +408,14 @@ argument to pass to the internal RUN-PROGRAM"
(
integer
raw-exit-code
)
; negative: signal
(
t
-1
)))
(
defclass
process-info
()
((
process
:initform
nil
)
(
input-stream
:initform
nil
)
(
output-stream
:initform
nil
)
(
bidir-stream
:initform
nil
)
(
error-output-stream
:initform
nil
)
(
exit-code
:initform
nil
)))
(
defun
%run-program
(
command
&rest
keys
&key
input
(
if-input-does-not-exist
:error
)
...
...
@@ -420,8 +428,7 @@ argument to pass to the internal RUN-PROGRAM"
It spawns a subprocess that runs the specified COMMAND (a list of program and arguments).
INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer,
to be normalized by %NORMALIZE-IO-SPECIFIER.
It returns a process-info plist with possible keys:
PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM."
It returns a process-info object."
;; NB: these implementations have Unix vs Windows set at compile-time.
(
declare
(
ignorable
directory
if-input-does-not-exist
if-output-exists
if-error-output-exists
))
#-
(
or
cmucl
ecl
mkcl
sbcl
)
...
...
@@ -478,53 +485,54 @@ It returns a process-info plist with possible keys:
#+
sbcl
`
(
:search
t
)
#-
sbcl
keys
#+
sbcl
(
if
directory
keys
(
remove-plist-key
:directory
keys
))))))
(
process-info-r
()))
(
flet
((
prop
(
key
value
)
(
push
key
process-info-r
)
(
push
value
process-info-r
)))
(
process-info
(
make-instance
'process-info
)))
(
flet
((
prop
(
key
value
)
(
setf
(
slot-value
process-info
key
)
value
)))
#+
allegro
(
cond
(
wait
(
prop
:
exit-code
(
first
process*
)))
(
wait
(
prop
'
exit-code
(
first
process*
)))
(
separate-streams
(
destructuring-bind
(
in
out
err
pid
)
process*
(
prop
:
process
pid
)
(
when
(
eq
input
:stream
)
(
prop
:
input-stream
in
))
(
when
(
eq
output
:stream
)
(
prop
:
output-stream
out
))
(
when
(
eq
error-output
:stream
)
(
prop
:
error-stream
err
))))
(
prop
'
process
pid
)
(
when
(
eq
input
:stream
)
(
prop
'
input-stream
in
))
(
when
(
eq
output
:stream
)
(
prop
'
output-stream
out
))
(
when
(
eq
error-output
:stream
)
(
prop
'
error-stream
err
))))
(
t
(
prop
:
process
(
third
process*
))
(
prop
'
process
(
third
process*
))
(
let
((
x
(
first
process*
)))
(
ecase
(
+
(
if
(
eq
input
:stream
)
1
0
)
(
if
(
eq
output
:stream
)
2
0
))
(
0
)
(
1
(
prop
:
input-stream
x
))
(
2
(
prop
:
output-stream
x
))
(
3
(
prop
:
bidir-stream
x
))))
(
1
(
prop
'
input-stream
x
))
(
2
(
prop
'
output-stream
x
))
(
3
(
prop
'
bidir-stream
x
))))
(
when
(
eq
error-output
:stream
)
(
prop
:
error-stream
(
second
process*
)))))
(
prop
'
error-stream
(
second
process*
)))))
#+
clisp
(
cond
(
wait
(
prop
:
exit-code
(
clisp-exit-code
(
first
process*
))))
(
wait
(
prop
'
exit-code
(
clisp-exit-code
(
first
process*
))))
(
t
(
ecase
(
+
(
if
(
eq
input
:stream
)
1
0
)
(
if
(
eq
output
:stream
)
2
0
))
(
0
)
(
1
(
prop
:
input-stream
(
first
process*
)))
(
2
(
prop
:
output-stream
(
first
process*
)))
(
3
(
prop
:
bidir-stream
(
pop
process*
))
(
prop
:
input-stream
(
pop
process*
))
(
prop
:
output-stream
(
pop
process*
))))))
(
1
(
prop
'
input-stream
(
first
process*
)))
(
2
(
prop
'
output-stream
(
first
process*
)))
(
3
(
prop
'
bidir-stream
(
pop
process*
))
(
prop
'
input-stream
(
pop
process*
))
(
prop
'
output-stream
(
pop
process*
))))))
#+
(
or
clozure
cmucl
sbcl
scl
)
(
progn
(
prop
:
process
process*
)
(
prop
'
process
process*
)
(
when
(
eq
input
:stream
)
(
prop
:
input-stream
(
prop
'
input-stream
#+
clozure
(
ccl:external-process-input-stream
process*
)
#+
(
or
cmucl
scl
)
(
ext:process-input
process*
)
#+
sbcl
(
sb-ext:process-input
process*
)))
(
when
(
eq
output
:stream
)
(
prop
:
output-stream
(
prop
'
output-stream
#+
clozure
(
ccl:external-process-output-stream
process*
)
#+
(
or
cmucl
scl
)
(
ext:process-output
process*
)
#+
sbcl
(
sb-ext:process-output
process*
)))
(
when
(
eq
error-output
:stream
)
(
prop
:
error-output-stream
(
prop
'
error-output-stream
#+
clozure
(
ccl:external-process-error-stream
process*
)
#+
(
or
cmucl
scl
)
(
ext:process-error
process*
)
#+
sbcl
(
sb-ext:process-error
process*
))))
...
...
@@ -533,24 +541,24 @@ It returns a process-info plist with possible keys:
(
let
((
mode
(
+
(
if
(
eq
input
:stream
)
1
0
)
(
if
(
eq
output
:stream
)
2
0
))))
(
cond
((
zerop
mode
))
((
null
process*
)
(
prop
:
exit-code
-1
))
(
t
(
prop
(
case
mode
(
1
:
input-stream
)
(
2
:
output-stream
)
(
3
:
bidir-stream
))
stream
))))
(
when
code
(
prop
:
exit-code
code
))
(
when
process
(
prop
:
process
process
)))
((
null
process*
)
(
prop
'
exit-code
-1
))
(
t
(
prop
(
case
mode
(
1
'
input-stream
)
(
2
'
output-stream
)
(
3
'
bidir-stream
))
stream
))))
(
when
code
(
prop
'
exit-code
code
))
(
when
process
(
prop
'
process
process
)))
#+
lispworks
(
if
wait
(
prop
:
exit-code
(
first
process*
))
(
prop
'
exit-code
(
first
process*
))
(
let
((
mode
(
+
(
if
(
eq
input
:stream
)
1
0
)
(
if
(
eq
output
:stream
)
2
0
))))
(
if
(
zerop
mode
)
(
prop
:
process
(
first
process*
))
(
prop
'
process
(
first
process*
))
(
destructuring-bind
(
x
err
pid
)
process*
(
prop
:
process
pid
)
(
prop
(
ecase
mode
(
1
:
input-stream
)
(
2
:
output-stream
)
(
3
:
bidir-stream
))
x
)
(
when
(
eq
error-output
:stream
)
(
prop
:
error-stream
err
))))))
(
nreverse
process-info
-r
)
)))
(
prop
'
process
pid
)
(
prop
(
ecase
mode
(
1
'
input-stream
)
(
2
'
output-stream
)
(
3
'
bidir-stream
))
x
)
(
when
(
eq
error-output
:stream
)
(
prop
'
error-stream
err
))))))
process-info
)))
(
defun
%process-info-pid
(
process-info
)
(
let
((
process
(
getf
process-info
:
process
)))
(
let
((
process
(
slot-value
process-info
'
process
)))
(
declare
(
ignorable
process
))
#+
(
or
allegro
lispworks
)
process
#+
clasp
(
si:external-process-pid
process
)
...
...
@@ -563,8 +571,8 @@ It returns a process-info plist with possible keys:
(
error
"~S not implemented"
'%process-info-pid
)))
(
defun
%wait-process-result
(
process-info
)
(
or
(
getf
process-info
:
exit-code
)
(
let
((
process
(
getf
process-info
:
process
)))
(
or
(
slot-value
process-info
'
exit-code
)
(
let
((
process
(
slot-value
process-info
'
process
)))
(
when
process
;; 1- wait
#+
clozure
(
ccl::external-process-wait
process
)
...
...
@@ -579,10 +587,10 @@ It returns a process-info plist with possible keys:
#+
(
or
cmucl
scl
)
(
ext:process-exit-code
process
)
#+
(
or
clasp
ecl
)
(
nth-value
1
(
ext:external-process-wait
process
t
))
#+
lispworks
(
if-let
((
stream
(
or
(
getf
process-info
:
input-stream
)
(
getf
process-info
:
output-stream
)
(
getf
process-info
:
bidir-stream
)
(
getf
process-info
:
error-stream
))))
(
if-let
((
stream
(
or
(
slot-value
process-info
'
input-stream
)
(
slot-value
process-info
'
output-stream
)
(
slot-value
process-info
'
bidir-stream
)
(
slot-value
process-info
'
error-stream
))))
(
system:pipe-exit-status
stream
:wait
t
)
(
if-let
((
f
(
find-symbol*
:pid-exit-status
:system
nil
)))
(
funcall
f
process
:wait
t
)))
...
...
@@ -720,9 +728,9 @@ It returns a process-info plist with possible keys:
:error-output
(
if
(
eq
error-output
:output
)
:output
reduced-error-output
)
keys
)))
(
labels
((
get-stream
(
stream-name
&optional
fallbackp
)
(
or
(
getf
process-info
stream-name
)
(
or
(
slot-value
process-info
stream-name
)
(
when
fallbackp
(
getf
process-info
:
bidir-stream
))))
(
slot-value
process-info
'
bidir-stream
))))
(
run-activity
(
activity
stream-name
&optional
fallbackp
)
(
if-let
(
stream
(
get-stream
stream-name
fallbackp
))
(
funcall
activity
stream
)
...
...
@@ -732,11 +740,16 @@ It returns a process-info plist with possible keys:
(
unwind-protect
(
ecase
activity
((
nil
))
(
:input
(
run-activity
input-activity
:input-stream
t
))
(
:output
(
run-activity
output-activity
:output-stream
t
))
(
:error-output
(
run-activity
error-output-activity
:error-output-stream
)))
(
loop
:for
(()
val
)
:on
process-info
:by
#'
cddr
:when
(
streamp
val
)
:do
(
ignore-errors
(
close
val
)))
(
:input
(
run-activity
input-activity
'input-stream
t
))
(
:output
(
run-activity
output-activity
'output-stream
t
))
(
:error-output
(
run-activity
error-output-activity
'error-output-stream
)))
(
dolist
(
stream
(
cons
(
slot-value
process-info
'error-output-stream
)
(
if-let
(
bidir-stream
(
slot-value
process-info
'bidir-stream
))
(
list
bidir-stream
)
(
list
(
slot-value
process-info
'input-stream
)
(
slot-value
process-info
'output-stream
)))))
(
when
stream
(
close
stream
)))
(
setf
exit-code
(
%check-result
(
%wait-process-result
process-info
)
:command
command
:process
process-info
...
...
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