First version of shell library, bring named-pipes into this repo
This commit is contained in:
parent
d6db0eb5b3
commit
b1edf4cb1d
|
|
@ -17,4 +17,5 @@ test-r6rs.sps
|
||||||
test-r6rs
|
test-r6rs
|
||||||
test-r7rs.scm
|
test-r7rs.scm
|
||||||
test-r7rs
|
test-r7rs
|
||||||
|
*.html
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -36,8 +36,8 @@ RUN bash install.sh
|
||||||
ENV PATH=/root/.local/bin:${PATH}
|
ENV PATH=/root/.local/bin:${PATH}
|
||||||
RUN akku update
|
RUN akku update
|
||||||
WORKDIR /build/foreign-c
|
WORKDIR /build/foreign-c
|
||||||
RUN if [ ! "${SCHEME}" = "racket" ]; then timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(srfi 64)"; fi
|
RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(srfi 64)" || true
|
||||||
RUN if [ ! "${SCHEME}" = "larceny" ]; then timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(foreign c)"; fi
|
RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(foreign c)" || true
|
||||||
RUN make SCHEME=${SCHEME} build install
|
RUN make SCHEME=${SCHEME} build install
|
||||||
WORKDIR /workdir
|
WORKDIR /workdir
|
||||||
RUN cp -r /build/foreign-c/foreign .
|
RUN cp -r /build/foreign-c/foreign .
|
||||||
|
|
|
||||||
8
Makefile
8
Makefile
|
|
@ -1,4 +1,4 @@
|
||||||
.SILENT: build install test test-docker clean
|
.SILENT: build install test-r6rs test-r6rs-docker test-r7rs test-r7rs-docker clean
|
||||||
.PHONY: test-r6rs test-r7rs
|
.PHONY: test-r6rs test-r7rs
|
||||||
SCHEME=chibi
|
SCHEME=chibi
|
||||||
LIBRARY=system
|
LIBRARY=system
|
||||||
|
|
@ -36,7 +36,8 @@ test-r7rs:
|
||||||
printf "\n" | ./test-r7rs
|
printf "\n" | ./test-r7rs
|
||||||
|
|
||||||
test-r7rs-docker:
|
test-r7rs-docker:
|
||||||
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-library-test-${SCHEME} .
|
echo "Building docker image..."
|
||||||
|
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-library-test-${SCHEME} --quiet .
|
||||||
docker run -t foreign-c-library-test-${SCHEME} sh -c "make SCHEME=${SCHEME} LIBRARY=${LIBRARY} SNOW_CHIBI_ARGS=--always-yes build install test-r7rs"
|
docker run -t foreign-c-library-test-${SCHEME} sh -c "make SCHEME=${SCHEME} LIBRARY=${LIBRARY} SNOW_CHIBI_ARGS=--always-yes build install test-r7rs"
|
||||||
|
|
||||||
test-r6rs:
|
test-r6rs:
|
||||||
|
|
@ -47,7 +48,8 @@ test-r6rs:
|
||||||
./test-r6rs
|
./test-r6rs
|
||||||
|
|
||||||
test-r6rs-docker:
|
test-r6rs-docker:
|
||||||
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-library-test-${SCHEME} .
|
echo "Building docker image..."
|
||||||
|
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-library-test-${SCHEME} --quiet .
|
||||||
docker run -t foreign-c-library-test-${SCHEME} sh -c "make SCHEME=${SCHEME} LIBRARY=${LIBRARY} test-r6rs"
|
docker run -t foreign-c-library-test-${SCHEME} sh -c "make SCHEME=${SCHEME} LIBRARY=${LIBRARY} test-r6rs"
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,181 @@
|
||||||
|
;; TODO output-pipe and input-pipe types
|
||||||
|
;; TODO Check on writing that given pipe is output pipe
|
||||||
|
;; TODO Check on reading that given pipe is input pipe
|
||||||
|
(define-c-library libc-stdlib
|
||||||
|
'("stdlib.h" "errno.h" "fcntl.h")
|
||||||
|
libc-name
|
||||||
|
'((additional-versions ("0" "6"))))
|
||||||
|
|
||||||
|
;(define-c-procedure c-system libc-stdlib 'system 'int '(pointer))
|
||||||
|
(define-c-procedure c-mkfifo libc-stdlib 'mkfifo 'int '(pointer int))
|
||||||
|
(define-c-procedure c-open libc-stdlib 'open 'int '(pointer int))
|
||||||
|
(define-c-procedure c-read libc-stdlib 'read 'int '(int pointer int))
|
||||||
|
(define-c-procedure c-write libc-stdlib 'write 'int '(int pointer int))
|
||||||
|
(define-c-procedure c-close libc-stdlib 'close 'int '(int))
|
||||||
|
(define-c-procedure c-perror libc-stdlib 'perror 'void '(pointer))
|
||||||
|
;(define-c-procedure c-system libc-stdlib 'system 'int '(pointer))
|
||||||
|
;(define-c-procedure c-tempnam libc-stdlib 'tempnam 'pointer '(pointer pointer))
|
||||||
|
|
||||||
|
(define-record-type <input-pipe>
|
||||||
|
(make-input-pipe path file-descriptor)
|
||||||
|
input-pipe?
|
||||||
|
(path input-path)
|
||||||
|
(file-descriptor input-file-descriptor))
|
||||||
|
|
||||||
|
(define-record-type <output-pipe>
|
||||||
|
(make-output-pipe path file-descriptor)
|
||||||
|
output-pipe?
|
||||||
|
(path output-path)
|
||||||
|
(file-descriptor output-file-descriptor))
|
||||||
|
|
||||||
|
(define O_RDONLY+O_CREAT 64)
|
||||||
|
(define O_RDONLY+O_NONBLOCK+O_CREAT 2112)
|
||||||
|
(define O_WRONLY+O_CREAT 65)
|
||||||
|
(define O_WRONLY+O_NONBLOCK+O_CREAT 2113)
|
||||||
|
|
||||||
|
(define handle-c-errors
|
||||||
|
(lambda (msg return-code)
|
||||||
|
(when (and (number? return-code)
|
||||||
|
(< return-code 0))
|
||||||
|
(c-perror (string->c-utf8 msg))
|
||||||
|
(error msg return-code))
|
||||||
|
return-code))
|
||||||
|
|
||||||
|
(define create-pipe
|
||||||
|
(lambda (path mode)
|
||||||
|
(let* ((path* (string->c-utf8 path))
|
||||||
|
(octal-mode (string->number (string-append "#o"
|
||||||
|
(number->string mode)))))
|
||||||
|
(handle-c-errors (string-append "open-output-pipe mkfifo"
|
||||||
|
" "
|
||||||
|
path
|
||||||
|
" "
|
||||||
|
(number->string mode))
|
||||||
|
(c-mkfifo path* octal-mode)))))
|
||||||
|
|
||||||
|
(define open-input-pipe
|
||||||
|
(lambda (path . block?)
|
||||||
|
(make-input-pipe path
|
||||||
|
(handle-c-errors (string-append "open-input-pipe open"
|
||||||
|
"(Note that: A process can open a FIFO in nonblocking mode. In this case, opening for read-only succeeds even if no one has opened on the write side yet and opening for write-only fails with ENXIO (no such device or address) unless the other end has already been opened.)")
|
||||||
|
(c-open (string->c-utf8 path)
|
||||||
|
(if (null? block?)
|
||||||
|
O_RDONLY+O_NONBLOCK+O_CREAT
|
||||||
|
O_RDONLY+O_CREAT))))))
|
||||||
|
|
||||||
|
(define open-output-pipe
|
||||||
|
(lambda (path . block?)
|
||||||
|
(make-output-pipe path
|
||||||
|
(handle-c-errors (string-append "open-output-pipe open"
|
||||||
|
" "
|
||||||
|
"(Note that: A process can open a FIFO in nonblocking mode. In this case, opening for read-only succeeds even if no one has opened on the write side yet and opening for write-only fails with ENXIO (no such device or address) unless the other end has already been opened.)")
|
||||||
|
(c-open (string->c-utf8 path)
|
||||||
|
(if (null? block?)
|
||||||
|
O_WRONLY+O_NONBLOCK+O_CREAT
|
||||||
|
O_WRONLY+O_CREAT))))))
|
||||||
|
|
||||||
|
(define pipe-read-u8-buffer (make-c-bytevector (c-type-size 'uint8)))
|
||||||
|
(define pipe-read-u8
|
||||||
|
(lambda (pipe)
|
||||||
|
(when (not (input-pipe? pipe))
|
||||||
|
(error "Can only read from input-pipe" pipe))
|
||||||
|
(let* ((read-count (c-read (input-file-descriptor pipe)
|
||||||
|
pipe-read-u8-buffer
|
||||||
|
(c-type-size 'uint8)))
|
||||||
|
(byte (if (> read-count 0)
|
||||||
|
(c-bytevector-u8-ref pipe-read-u8-buffer 0)
|
||||||
|
(eof-object))))
|
||||||
|
byte)))
|
||||||
|
|
||||||
|
(define pipe-write-u8-buffer (make-c-bytevector (c-type-size 'uint8)))
|
||||||
|
(define pipe-write-u8
|
||||||
|
(lambda (byte pipe)
|
||||||
|
(when (not (output-pipe? pipe))
|
||||||
|
(error "Can only write to output-pipe" pipe))
|
||||||
|
(c-bytevector-u8-set! pipe-write-u8-buffer 0 byte)
|
||||||
|
(c-write (output-file-descriptor pipe) pipe-write-u8-buffer 1)))
|
||||||
|
|
||||||
|
(define pipe-read-char-buffer (make-c-bytevector (c-type-size 'char)))
|
||||||
|
(define pipe-read-char
|
||||||
|
(lambda (pipe)
|
||||||
|
(when (not (input-pipe? pipe))
|
||||||
|
(error "Can only read from input-pipe" pipe))
|
||||||
|
(let* ((read-count (c-read (input-file-descriptor pipe)
|
||||||
|
pipe-read-char-buffer
|
||||||
|
(c-type-size 'char)))
|
||||||
|
(char (if (> read-count 0)
|
||||||
|
(c-bytevector-char-ref pipe-read-char-buffer 0)
|
||||||
|
(eof-object))))
|
||||||
|
char)))
|
||||||
|
|
||||||
|
(define pipe-write-char-buffer (make-c-bytevector (c-type-size 'char)))
|
||||||
|
(define pipe-write-char
|
||||||
|
(lambda (char pipe)
|
||||||
|
(when (not (output-pipe? pipe))
|
||||||
|
(error "Can only write to output-pipe" pipe))
|
||||||
|
(c-bytevector-char-set! pipe-write-char-buffer 0 char)
|
||||||
|
(c-write (output-file-descriptor pipe)
|
||||||
|
pipe-write-char-buffer
|
||||||
|
(c-type-size 'char))))
|
||||||
|
|
||||||
|
(define pipe-read-string-old
|
||||||
|
(lambda (count pipe)
|
||||||
|
(when (not (input-pipe? pipe))
|
||||||
|
(error "Can only read from input-pipe" pipe))
|
||||||
|
(let* ((buffer (make-c-bytevector (* (c-type-size 'char) count)))
|
||||||
|
(read-count (c-read (input-file-descriptor pipe) buffer count))
|
||||||
|
(text (string-copy (c-utf8->string buffer))))
|
||||||
|
(display "text: ")
|
||||||
|
(display text)
|
||||||
|
(newline)
|
||||||
|
(c-free buffer)
|
||||||
|
(if (> read-count 0) text (eof-object)))))
|
||||||
|
|
||||||
|
(define pipe-read-string
|
||||||
|
(lambda (count pipe)
|
||||||
|
(when (not (input-pipe? pipe))
|
||||||
|
(error "Can only read from input-pipe" pipe))
|
||||||
|
(let* ((buffer (make-c-bytevector (* (c-type-size 'char) count)))
|
||||||
|
(read-count (c-read (input-file-descriptor pipe) buffer count))
|
||||||
|
(text (c-utf8->string buffer)))
|
||||||
|
(c-free buffer)
|
||||||
|
(if (> read-count 0) text (eof-object)))))
|
||||||
|
|
||||||
|
(define pipe-write-string
|
||||||
|
(lambda (text pipe)
|
||||||
|
(when (not (output-pipe? pipe))
|
||||||
|
(error "Can only write to output-pipe" pipe))
|
||||||
|
(let ((count (string-length text))
|
||||||
|
(text-pointer (string->c-utf8 text)))
|
||||||
|
(c-write (output-file-descriptor pipe) text-pointer count)
|
||||||
|
(c-free text-pointer))))
|
||||||
|
|
||||||
|
(define pipe-read-line
|
||||||
|
(lambda (pipe)
|
||||||
|
(letrec ((looper (lambda (c result result-length)
|
||||||
|
(cond ((eof-object? c) c)
|
||||||
|
((char=? c #\newline)
|
||||||
|
(list->string (reverse result)))
|
||||||
|
(else (looper (pipe-read-char pipe)
|
||||||
|
(cons c result)
|
||||||
|
(+ result-length 1)))))))
|
||||||
|
(looper (pipe-read-char pipe) (list) 0))))
|
||||||
|
|
||||||
|
(define pipe-read
|
||||||
|
(lambda (pipe)
|
||||||
|
(letrec ((looper (lambda (c result)
|
||||||
|
(cond ((eof-object? c)
|
||||||
|
(if (null? result)
|
||||||
|
(eof-object)
|
||||||
|
(list->string (reverse result))))
|
||||||
|
(else (looper (pipe-read-char pipe)
|
||||||
|
(cons c result)))))))
|
||||||
|
(looper (pipe-read-char pipe) (list)))))
|
||||||
|
|
||||||
|
(define close-pipe
|
||||||
|
(lambda (pipe)
|
||||||
|
(cond ((input-pipe? pipe)
|
||||||
|
(c-close (input-file-descriptor pipe)))
|
||||||
|
((output-pipe? pipe)
|
||||||
|
(c-close (output-file-descriptor pipe)))
|
||||||
|
(else (error "Can not close, not a pipe" pipe)))))
|
||||||
|
|
@ -0,0 +1,25 @@
|
||||||
|
(define-library
|
||||||
|
(retropikzel named-pipes)
|
||||||
|
(import (scheme base)
|
||||||
|
(scheme write)
|
||||||
|
(scheme char)
|
||||||
|
(scheme file)
|
||||||
|
(scheme process-context)
|
||||||
|
(foreign c))
|
||||||
|
(export create-pipe
|
||||||
|
open-input-pipe
|
||||||
|
input-pipe?
|
||||||
|
open-output-pipe
|
||||||
|
output-pipe?
|
||||||
|
pipe-read-u8
|
||||||
|
pipe-write-u8
|
||||||
|
pipe-read-char
|
||||||
|
pipe-write-char
|
||||||
|
pipe-read-string
|
||||||
|
pipe-write-string
|
||||||
|
pipe-read
|
||||||
|
pipe-read-line
|
||||||
|
close-pipe)
|
||||||
|
(include "named-pipes.scm"))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,165 @@
|
||||||
|
GNU LESSER GENERAL PUBLIC LICENSE
|
||||||
|
Version 3, 29 June 2007
|
||||||
|
|
||||||
|
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
|
||||||
|
Everyone is permitted to copy and distribute verbatim copies
|
||||||
|
of this license document, but changing it is not allowed.
|
||||||
|
|
||||||
|
|
||||||
|
This version of the GNU Lesser General Public License incorporates
|
||||||
|
the terms and conditions of version 3 of the GNU General Public
|
||||||
|
License, supplemented by the additional permissions listed below.
|
||||||
|
|
||||||
|
0. Additional Definitions.
|
||||||
|
|
||||||
|
As used herein, "this License" refers to version 3 of the GNU Lesser
|
||||||
|
General Public License, and the "GNU GPL" refers to version 3 of the GNU
|
||||||
|
General Public License.
|
||||||
|
|
||||||
|
"The Library" refers to a covered work governed by this License,
|
||||||
|
other than an Application or a Combined Work as defined below.
|
||||||
|
|
||||||
|
An "Application" is any work that makes use of an interface provided
|
||||||
|
by the Library, but which is not otherwise based on the Library.
|
||||||
|
Defining a subclass of a class defined by the Library is deemed a mode
|
||||||
|
of using an interface provided by the Library.
|
||||||
|
|
||||||
|
A "Combined Work" is a work produced by combining or linking an
|
||||||
|
Application with the Library. The particular version of the Library
|
||||||
|
with which the Combined Work was made is also called the "Linked
|
||||||
|
Version".
|
||||||
|
|
||||||
|
The "Minimal Corresponding Source" for a Combined Work means the
|
||||||
|
Corresponding Source for the Combined Work, excluding any source code
|
||||||
|
for portions of the Combined Work that, considered in isolation, are
|
||||||
|
based on the Application, and not on the Linked Version.
|
||||||
|
|
||||||
|
The "Corresponding Application Code" for a Combined Work means the
|
||||||
|
object code and/or source code for the Application, including any data
|
||||||
|
and utility programs needed for reproducing the Combined Work from the
|
||||||
|
Application, but excluding the System Libraries of the Combined Work.
|
||||||
|
|
||||||
|
1. Exception to Section 3 of the GNU GPL.
|
||||||
|
|
||||||
|
You may convey a covered work under sections 3 and 4 of this License
|
||||||
|
without being bound by section 3 of the GNU GPL.
|
||||||
|
|
||||||
|
2. Conveying Modified Versions.
|
||||||
|
|
||||||
|
If you modify a copy of the Library, and, in your modifications, a
|
||||||
|
facility refers to a function or data to be supplied by an Application
|
||||||
|
that uses the facility (other than as an argument passed when the
|
||||||
|
facility is invoked), then you may convey a copy of the modified
|
||||||
|
version:
|
||||||
|
|
||||||
|
a) under this License, provided that you make a good faith effort to
|
||||||
|
ensure that, in the event an Application does not supply the
|
||||||
|
function or data, the facility still operates, and performs
|
||||||
|
whatever part of its purpose remains meaningful, or
|
||||||
|
|
||||||
|
b) under the GNU GPL, with none of the additional permissions of
|
||||||
|
this License applicable to that copy.
|
||||||
|
|
||||||
|
3. Object Code Incorporating Material from Library Header Files.
|
||||||
|
|
||||||
|
The object code form of an Application may incorporate material from
|
||||||
|
a header file that is part of the Library. You may convey such object
|
||||||
|
code under terms of your choice, provided that, if the incorporated
|
||||||
|
material is not limited to numerical parameters, data structure
|
||||||
|
layouts and accessors, or small macros, inline functions and templates
|
||||||
|
(ten or fewer lines in length), you do both of the following:
|
||||||
|
|
||||||
|
a) Give prominent notice with each copy of the object code that the
|
||||||
|
Library is used in it and that the Library and its use are
|
||||||
|
covered by this License.
|
||||||
|
|
||||||
|
b) Accompany the object code with a copy of the GNU GPL and this license
|
||||||
|
document.
|
||||||
|
|
||||||
|
4. Combined Works.
|
||||||
|
|
||||||
|
You may convey a Combined Work under terms of your choice that,
|
||||||
|
taken together, effectively do not restrict modification of the
|
||||||
|
portions of the Library contained in the Combined Work and reverse
|
||||||
|
engineering for debugging such modifications, if you also do each of
|
||||||
|
the following:
|
||||||
|
|
||||||
|
a) Give prominent notice with each copy of the Combined Work that
|
||||||
|
the Library is used in it and that the Library and its use are
|
||||||
|
covered by this License.
|
||||||
|
|
||||||
|
b) Accompany the Combined Work with a copy of the GNU GPL and this license
|
||||||
|
document.
|
||||||
|
|
||||||
|
c) For a Combined Work that displays copyright notices during
|
||||||
|
execution, include the copyright notice for the Library among
|
||||||
|
these notices, as well as a reference directing the user to the
|
||||||
|
copies of the GNU GPL and this license document.
|
||||||
|
|
||||||
|
d) Do one of the following:
|
||||||
|
|
||||||
|
0) Convey the Minimal Corresponding Source under the terms of this
|
||||||
|
License, and the Corresponding Application Code in a form
|
||||||
|
suitable for, and under terms that permit, the user to
|
||||||
|
recombine or relink the Application with a modified version of
|
||||||
|
the Linked Version to produce a modified Combined Work, in the
|
||||||
|
manner specified by section 6 of the GNU GPL for conveying
|
||||||
|
Corresponding Source.
|
||||||
|
|
||||||
|
1) Use a suitable shared library mechanism for linking with the
|
||||||
|
Library. A suitable mechanism is one that (a) uses at run time
|
||||||
|
a copy of the Library already present on the user's computer
|
||||||
|
system, and (b) will operate properly with a modified version
|
||||||
|
of the Library that is interface-compatible with the Linked
|
||||||
|
Version.
|
||||||
|
|
||||||
|
e) Provide Installation Information, but only if you would otherwise
|
||||||
|
be required to provide such information under section 6 of the
|
||||||
|
GNU GPL, and only to the extent that such information is
|
||||||
|
necessary to install and execute a modified version of the
|
||||||
|
Combined Work produced by recombining or relinking the
|
||||||
|
Application with a modified version of the Linked Version. (If
|
||||||
|
you use option 4d0, the Installation Information must accompany
|
||||||
|
the Minimal Corresponding Source and Corresponding Application
|
||||||
|
Code. If you use option 4d1, you must provide the Installation
|
||||||
|
Information in the manner specified by section 6 of the GNU GPL
|
||||||
|
for conveying Corresponding Source.)
|
||||||
|
|
||||||
|
5. Combined Libraries.
|
||||||
|
|
||||||
|
You may place library facilities that are a work based on the
|
||||||
|
Library side by side in a single library together with other library
|
||||||
|
facilities that are not Applications and are not covered by this
|
||||||
|
License, and convey such a combined library under terms of your
|
||||||
|
choice, if you do both of the following:
|
||||||
|
|
||||||
|
a) Accompany the combined library with a copy of the same work based
|
||||||
|
on the Library, uncombined with any other library facilities,
|
||||||
|
conveyed under the terms of this License.
|
||||||
|
|
||||||
|
b) Give prominent notice with the combined library that part of it
|
||||||
|
is a work based on the Library, and explaining where to find the
|
||||||
|
accompanying uncombined form of the same work.
|
||||||
|
|
||||||
|
6. Revised Versions of the GNU Lesser General Public License.
|
||||||
|
|
||||||
|
The Free Software Foundation may publish revised and/or new versions
|
||||||
|
of the GNU Lesser General Public License from time to time. Such new
|
||||||
|
versions will be similar in spirit to the present version, but may
|
||||||
|
differ in detail to address new problems or concerns.
|
||||||
|
|
||||||
|
Each version is given a distinguishing version number. If the
|
||||||
|
Library as you received it specifies that a certain numbered version
|
||||||
|
of the GNU Lesser General Public License "or any later version"
|
||||||
|
applies to it, you have the option of following the terms and
|
||||||
|
conditions either of that published version or of any later version
|
||||||
|
published by the Free Software Foundation. If the Library as you
|
||||||
|
received it does not specify a version number of the GNU Lesser
|
||||||
|
General Public License, you may choose any version of the GNU Lesser
|
||||||
|
General Public License ever published by the Free Software Foundation.
|
||||||
|
|
||||||
|
If the Library as you received it specifies that a proxy can decide
|
||||||
|
whether future versions of the GNU Lesser General Public License shall
|
||||||
|
apply, that proxy's public statement of acceptance of any version is
|
||||||
|
permanent authorization for you to choose that version for the
|
||||||
|
Library.
|
||||||
|
|
@ -0,0 +1,94 @@
|
||||||
|
Named pipe library built upon (foreign c).
|
||||||
|
|
||||||
|
## Caveats
|
||||||
|
|
||||||
|
Does not yet work on Chibi.
|
||||||
|
|
||||||
|
## Documentation
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**create-pipe** path mode)
|
||||||
|
|
||||||
|
Path is the location you want the pipe to be. mode is filemode as number,
|
||||||
|
for example 0755.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**open-input-pipe** path)
|
||||||
|
|
||||||
|
Opens input pipe in path and returns it.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**input-pipe?** object)
|
||||||
|
|
||||||
|
Returns #t if given object is input pipe, #f otherwise.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**open-output-pipe** path)
|
||||||
|
|
||||||
|
Opens output pipe in path and returns it.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**output-pipe?** object)
|
||||||
|
|
||||||
|
Returns #t if given object is output pipe, #f otherwise.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**pipe-read-u8** pipe)
|
||||||
|
|
||||||
|
Read u8 byte from given pipe. Errors if pipe is not input pipe.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**pipe-write-u8** pipe)
|
||||||
|
|
||||||
|
Writes u8 byte into given pipe. Errros if pipe is not output pipe.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**pipe-read-char** pipe)
|
||||||
|
|
||||||
|
Read character from given pipe. Errors if pipe is not input pipe.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**pipe-write-char** pipe)
|
||||||
|
|
||||||
|
Write character into given pipe. Errors if pipe is not output pipe.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**pipe-read-string** count pipe)
|
||||||
|
|
||||||
|
Read string of length count or until enf of file from given pipe. Errors if
|
||||||
|
pipe is not input pipe.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**pipe-write-string** text pipe)
|
||||||
|
|
||||||
|
Write string text into given pipe. Errors if pipe is not output pipe.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**pipe-read** pipe)
|
||||||
|
|
||||||
|
Read from given pipe. Errors if pipe is not input pipe.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**pipe-read-line** pipe)
|
||||||
|
|
||||||
|
Read line or until end of file from given pipe. Does not block. Errors if
|
||||||
|
pipe is not input pipe.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(**close-pipe** pipe)
|
||||||
|
|
||||||
|
Closes given pipe.
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
0.1.3
|
||||||
|
|
@ -0,0 +1,101 @@
|
||||||
|
(import (scheme base)
|
||||||
|
(scheme file)
|
||||||
|
(scheme write)
|
||||||
|
(retropikzel named-pipes))
|
||||||
|
|
||||||
|
(define pipe-path "/tmp/named-pipes-test")
|
||||||
|
(when (file-exists? pipe-path) (delete-file pipe-path))
|
||||||
|
(create-pipe pipe-path 0777)
|
||||||
|
|
||||||
|
(define input (open-input-pipe pipe-path))
|
||||||
|
(define output (open-output-pipe pipe-path))
|
||||||
|
|
||||||
|
(display "Bytes: ")
|
||||||
|
(newline)
|
||||||
|
(define bytes '(1 2 3 4 5 6 7 8))
|
||||||
|
(for-each (lambda (item) (pipe-write-u8 item output)) bytes)
|
||||||
|
(for-each
|
||||||
|
(lambda (item)
|
||||||
|
(let ((output (pipe-read-u8 input)))
|
||||||
|
(if (= output item)
|
||||||
|
(begin
|
||||||
|
(display "Wrote: ")
|
||||||
|
(write item)
|
||||||
|
(newline)
|
||||||
|
(display "Read: ")
|
||||||
|
(write output)
|
||||||
|
(newline))
|
||||||
|
(error "Bytes do not match" (list item output)))))
|
||||||
|
bytes)
|
||||||
|
|
||||||
|
(display "Chars: ")
|
||||||
|
(newline)
|
||||||
|
(define chars (string->list "Hello world"))
|
||||||
|
(for-each (lambda (item) (pipe-write-char item output)) chars)
|
||||||
|
(for-each
|
||||||
|
(lambda (item)
|
||||||
|
(let ((output (pipe-read-char input)))
|
||||||
|
(if (char=? output item)
|
||||||
|
(begin
|
||||||
|
(display "Wrote: ")
|
||||||
|
(write item)
|
||||||
|
(newline)
|
||||||
|
(display "Read: ")
|
||||||
|
(write output)
|
||||||
|
(newline))
|
||||||
|
(error "Chars do not match" (list item output)))))
|
||||||
|
chars)
|
||||||
|
|
||||||
|
(display "String: ")
|
||||||
|
(newline)
|
||||||
|
(define text "Hello world")
|
||||||
|
(pipe-write-string text output)
|
||||||
|
(define output-string (pipe-read-string (string-length text) input))
|
||||||
|
(if (string=? output-string text)
|
||||||
|
(begin
|
||||||
|
(display "Wrote: ")
|
||||||
|
(write text)
|
||||||
|
(newline)
|
||||||
|
(display "Read: ")
|
||||||
|
(write output-string)
|
||||||
|
(newline))
|
||||||
|
(error "String does not match" (list text output-string)))
|
||||||
|
|
||||||
|
(display "Line: ")
|
||||||
|
(newline)
|
||||||
|
(define should-be-eof (pipe-read-line input))
|
||||||
|
(when (not (eof-object? should-be-eof))
|
||||||
|
(error "Reading line from empty buffer should eof"))
|
||||||
|
(define line (string-append "Hello world" (string #\newline)))
|
||||||
|
(define expected-output-line "Hello world")
|
||||||
|
(pipe-write-string line output)
|
||||||
|
(define output-line (pipe-read-line input))
|
||||||
|
(if (string=? output-line expected-output-line)
|
||||||
|
(begin
|
||||||
|
(display "Wrote: ")
|
||||||
|
(write line)
|
||||||
|
(newline)
|
||||||
|
(display "Read: ")
|
||||||
|
(write output-line)
|
||||||
|
(newline))
|
||||||
|
(error "String does not match" (list expected-output-line output-line)))
|
||||||
|
|
||||||
|
(display "Read: ")
|
||||||
|
(newline)
|
||||||
|
(set! should-be-eof (pipe-read input))
|
||||||
|
(when (not (eof-object? should-be-eof))
|
||||||
|
(error "Reading from empty buffer should eof"))
|
||||||
|
(define text1 (string-append "Hello world" (string #\newline)))
|
||||||
|
(pipe-write-string text1 output)
|
||||||
|
(define output-text1 (pipe-read input))
|
||||||
|
(if (string=? output-text1 text1)
|
||||||
|
(begin
|
||||||
|
(display "Wrote: ")
|
||||||
|
(write text1)
|
||||||
|
(newline)
|
||||||
|
(display "Read: ")
|
||||||
|
(write output-text1)
|
||||||
|
(newline))
|
||||||
|
(error "String does not match" (list text1 output-text1)))
|
||||||
|
|
||||||
|
(when (file-exists? pipe-path) (delete-file pipe-path))
|
||||||
|
|
@ -1,2 +1,35 @@
|
||||||
|
(define-c-library libc
|
||||||
|
'("stdlib.h" "stdio.h" "unistd.h")
|
||||||
|
libc-name
|
||||||
|
'((additional-versions ("0" "6"))))
|
||||||
|
|
||||||
|
(define-c-procedure c-tempnam libc 'tempnam 'pointer '(pointer pointer))
|
||||||
|
(define-c-procedure c-system libc 'system 'int '(pointer))
|
||||||
|
|
||||||
(define (shell cmd)
|
(define (shell cmd)
|
||||||
(display cmd))
|
(let* ((temp-prefix (string->c-utf8 "npcmd"))
|
||||||
|
(temp-name (lambda ()
|
||||||
|
(c-utf8->string (c-tempnam (make-c-null)
|
||||||
|
temp-prefix))))
|
||||||
|
(input-path (temp-name))
|
||||||
|
(shell-command (string-append cmd
|
||||||
|
" 1> "
|
||||||
|
input-path
|
||||||
|
" 2> "
|
||||||
|
input-path
|
||||||
|
" & ")))
|
||||||
|
(create-pipe input-path 0777)
|
||||||
|
(c-system (string->c-utf8 shell-command))
|
||||||
|
(pipe-read-string 64000 (open-input-pipe input-path #t))))
|
||||||
|
|
||||||
|
(define (lines->list port result)
|
||||||
|
(let ((line (read-line port)))
|
||||||
|
(if (eof-object? line)
|
||||||
|
(reverse result)
|
||||||
|
(lines->list port (cons line result)))))
|
||||||
|
|
||||||
|
(define (shell->list cmd)
|
||||||
|
(lines->list (open-input-string (shell cmd)) '()))
|
||||||
|
|
||||||
|
(define (shell->sexp cmd)
|
||||||
|
(read (open-input-string (shell cmd)) '()))
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,14 @@
|
||||||
(define-library
|
(define-library
|
||||||
(foreign c shell)
|
(retropikzel shell)
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
|
(scheme write)
|
||||||
|
(scheme read)
|
||||||
|
(scheme file)
|
||||||
|
(foreign c)
|
||||||
(retropikzel named-pipes))
|
(retropikzel named-pipes))
|
||||||
(export shell)
|
(export shell
|
||||||
|
shell->list
|
||||||
|
shell->sexp)
|
||||||
(include "shell.scm"))
|
(include "shell.scm"))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1 +1,17 @@
|
||||||
Library to run shell commands and get their output
|
Library to run shell commands and get their output
|
||||||
|
|
||||||
|
|
||||||
|
(**shell** cmd)
|
||||||
|
|
||||||
|
Run given cmd string and return output as string.
|
||||||
|
|
||||||
|
|
||||||
|
(**shell->list** cmd)
|
||||||
|
|
||||||
|
Run given cmd string and return output as list of lines.
|
||||||
|
|
||||||
|
|
||||||
|
(**shell->sexp** cmd)
|
||||||
|
|
||||||
|
Run given cmd string and return output as sexp using read.
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -2,11 +2,18 @@
|
||||||
(scheme write)
|
(scheme write)
|
||||||
(scheme file)
|
(scheme file)
|
||||||
(scheme process-context)
|
(scheme process-context)
|
||||||
(foreign c shell)
|
(retropikzel shell)
|
||||||
(srfi 64))
|
(srfi 64))
|
||||||
|
|
||||||
(test-begin "foreign-c-shell")
|
(test-begin "shell")
|
||||||
|
|
||||||
(display "Hello")
|
(write (shell "ls"))
|
||||||
|
(newline)
|
||||||
|
|
||||||
(test-end "foreign-c-shell")
|
(write (shell->list "ls"))
|
||||||
|
(newline)
|
||||||
|
|
||||||
|
(write (shell->sexp "echo '(1 2 3)'"))
|
||||||
|
(newline)
|
||||||
|
|
||||||
|
(test-end "shell")
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue