scsh: More progress
This commit is contained in:
parent
2d27e6687d
commit
637e91ab0b
|
|
@ -27,3 +27,5 @@ foreign
|
||||||
tmp
|
tmp
|
||||||
*.json
|
*.json
|
||||||
test-program
|
test-program
|
||||||
|
*.test
|
||||||
|
*.test1
|
||||||
|
|
|
||||||
2
Makefile
2
Makefile
|
|
@ -59,7 +59,7 @@ test-docker:
|
||||||
DOCKER_TAG=${DOCKER_TAG} \
|
DOCKER_TAG=${DOCKER_TAG} \
|
||||||
COMPILE_R7RS=${SCHEME} \
|
COMPILE_R7RS=${SCHEME} \
|
||||||
CSC_OPTIONS="${CSC_OPTIONS}" \
|
CSC_OPTIONS="${CSC_OPTIONS}" \
|
||||||
SNOW_PACKAGES="srfi.64 foreign.c ${PKG}" \
|
SNOW_PACKAGES="srfi.14 srfi.19 srfi.64 srfi.170 retropikzel.tap retropikzel.dot-locking retropikzel.debug foreign.c ${PKG}" \
|
||||||
AKKU_PACKAGES="akku-r7rs chez-srfi '(foreign c)' '(retropikzel ${LIBRARY})'" \
|
AKKU_PACKAGES="akku-r7rs chez-srfi '(foreign c)' '(retropikzel ${LIBRARY})'" \
|
||||||
APT_PACKAGES="${APT_PACKAGES}" \
|
APT_PACKAGES="${APT_PACKAGES}" \
|
||||||
PASS_ENV_VARS="CSC_OPTIONS" \
|
PASS_ENV_VARS="CSC_OPTIONS" \
|
||||||
|
|
|
||||||
|
|
@ -1,15 +1,22 @@
|
||||||
(define-library
|
(define-library
|
||||||
(retropikzel scsh)
|
(retropikzel scsh)
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
|
(scheme read)
|
||||||
(scheme write)
|
(scheme write)
|
||||||
(scheme file)
|
(scheme file)
|
||||||
|
(scheme char)
|
||||||
(scheme process-context)
|
(scheme process-context)
|
||||||
|
(retropikzel dot-locking)
|
||||||
|
(retropikzel debug)
|
||||||
(foreign c)
|
(foreign c)
|
||||||
|
(srfi 14)
|
||||||
|
(srfi 19)
|
||||||
|
(srfi 60)
|
||||||
(srfi 170))
|
(srfi 170))
|
||||||
(export
|
(export
|
||||||
;*temp-file-template*
|
*temp-file-template*
|
||||||
;->uid
|
->uid
|
||||||
;->username
|
->username
|
||||||
;%exec
|
;%exec
|
||||||
;%exit
|
;%exit
|
||||||
;%fork
|
;%fork
|
||||||
|
|
@ -19,104 +26,77 @@
|
||||||
;&
|
;&
|
||||||
;&
|
;&
|
||||||
;&&
|
;&&
|
||||||
;reduce-port
|
reduce-port
|
||||||
;absolute-file-name
|
absolute-file-name
|
||||||
;accept-connection
|
add-after
|
||||||
;add-after
|
add-before
|
||||||
;add-before
|
alist->env
|
||||||
;alist->env
|
alist-compress
|
||||||
;alist-compress
|
alist-delete
|
||||||
;alist-delete
|
alist-update
|
||||||
;alist-update
|
arg
|
||||||
;arg
|
arg*
|
||||||
;arg*
|
argv
|
||||||
;argv
|
arithmetic-shift
|
||||||
;arithmetic-shift
|
|
||||||
;ascii->char
|
;ascii->char
|
||||||
;autoreap-policy
|
autoreap-policy
|
||||||
;awk
|
;awk
|
||||||
;become-session-leader
|
become-session-leader
|
||||||
;bin-dir
|
bitwise-and
|
||||||
;bind-listen-accept-loop
|
bitwise-ior
|
||||||
;bind-prepare-listen-accept-loop
|
bitwise-not
|
||||||
;bind-socket
|
bitwise-xor
|
||||||
;bitwise-and
|
break-dot-lock
|
||||||
;bitwise-ior
|
call-terminally
|
||||||
;bitwise-not
|
call-with-string-output-port
|
||||||
;bitwise-xor
|
|
||||||
;break-dot-lock
|
|
||||||
;bufpol/block
|
|
||||||
;bufpol/line
|
|
||||||
;bufpol/none
|
|
||||||
;call-terminally
|
|
||||||
;call-with-string-output-port
|
|
||||||
;call/fdes
|
;call/fdes
|
||||||
;cflags
|
|
||||||
;char->ascii
|
;char->ascii
|
||||||
;char-ascii?
|
char-ascii?
|
||||||
;char-blank?
|
char-blank?
|
||||||
;char-digit?
|
char-digit?
|
||||||
;char-graphic?
|
char-graphic?
|
||||||
;char-hex-digit?
|
char-hex-digit?
|
||||||
;char-iso-control?
|
char-iso-control?
|
||||||
;char-letter+digit?
|
char-letter+digit?
|
||||||
;char-letter?
|
char-letter?
|
||||||
;char-lower-case?
|
char-lower-case?
|
||||||
;char-printing?
|
char-printing?
|
||||||
;char-punctuation?
|
char-punctuation?
|
||||||
;char-title-case?
|
char-title-case?
|
||||||
;char-upper-case?
|
char-upper-case?
|
||||||
;char-whitespace?
|
char-whitespace?
|
||||||
;chdir
|
;chdir ;; FIXME
|
||||||
;clean-up-cres
|
|
||||||
;close
|
;close
|
||||||
;close-after
|
;close-after
|
||||||
;close-directory-stream
|
;close-directory-stream
|
||||||
;close-socket
|
|
||||||
;close-syslog-channel
|
;close-syslog-channel
|
||||||
;command-line
|
command-line
|
||||||
;command-line-arguments
|
command-line-arguments
|
||||||
;compiler-flags
|
|
||||||
;connect-socket
|
|
||||||
;connect-socket-no-wait
|
|
||||||
;connect-socket-successful?
|
|
||||||
;control-tty-file-name
|
;control-tty-file-name
|
||||||
;copy-tty-info
|
;copy-tty-info
|
||||||
;cppflags
|
|
||||||
;cpu-ticks/sec
|
;cpu-ticks/sec
|
||||||
create-directory
|
create-directory
|
||||||
create-fifo
|
create-fifo
|
||||||
create-hard-link
|
create-hard-link
|
||||||
;create-socket
|
|
||||||
;create-socket-pair
|
|
||||||
create-symlink
|
create-symlink
|
||||||
create-temp-file
|
create-temp-file
|
||||||
;crypt
|
;crypt
|
||||||
;current-thread
|
;cwd ;; FIXME
|
||||||
;cwd
|
|
||||||
;date, [2]
|
|
||||||
;date, [2]
|
|
||||||
;date->string
|
|
||||||
;default-lib-dirs
|
|
||||||
;define-record
|
|
||||||
;defs
|
|
||||||
delete-directory
|
delete-directory
|
||||||
delete-file
|
delete-file
|
||||||
;delete-filesys-object
|
;delete-filesys-object ;; FIXME
|
||||||
;directory-as-file-name
|
directory-as-file-name
|
||||||
directory-files
|
directory-files
|
||||||
;disable-tty-char
|
;disable-tty-char
|
||||||
;drain-tty
|
;drain-tty
|
||||||
;dump-scsh
|
|
||||||
;dump-scsh-program
|
|
||||||
;dup
|
;dup
|
||||||
;dup->fdes
|
;dup->fdes
|
||||||
;dup->inport
|
;dup->inport
|
||||||
;dup->outport
|
;dup->outport
|
||||||
;enabled-interrupts
|
;enabled-interrupts
|
||||||
;env->alist
|
env->alist
|
||||||
;errno-error
|
;errno-error
|
||||||
;error-output-port
|
error-output-port
|
||||||
;exec
|
;exec
|
||||||
;exec-epf
|
;exec-epf
|
||||||
;exec-epf
|
;exec-epf
|
||||||
|
|
@ -124,7 +104,6 @@
|
||||||
;exec-path-list
|
;exec-path-list
|
||||||
;exec-path-search
|
;exec-path-search
|
||||||
;exec-path/env
|
;exec-path/env
|
||||||
;exec-prefix
|
|
||||||
;exec/env
|
;exec/env
|
||||||
exit
|
exit
|
||||||
;expand-file-name
|
;expand-file-name
|
||||||
|
|
@ -134,7 +113,7 @@
|
||||||
;fdes-status
|
;fdes-status
|
||||||
;field-reader
|
;field-reader
|
||||||
;field-splitter
|
;field-splitter
|
||||||
;file-directory?
|
;file-directory? ;; FIXME
|
||||||
;file-executable?
|
;file-executable?
|
||||||
;file-exists?
|
;file-exists?
|
||||||
;file-fifo?
|
;file-fifo?
|
||||||
|
|
@ -148,7 +127,6 @@
|
||||||
;file-info-not-writable?
|
;file-info-not-writable?
|
||||||
;file-info-readable?
|
;file-info-readable?
|
||||||
;file-info-regular?
|
;file-info-regular?
|
||||||
;file-info-socket?
|
|
||||||
;file-info-special?
|
;file-info-special?
|
||||||
;file-info-symlink?
|
;file-info-symlink?
|
||||||
;file-info-writable?
|
;file-info-writable?
|
||||||
|
|
@ -159,7 +137,7 @@
|
||||||
file-info:inode
|
file-info:inode
|
||||||
file-info:mode
|
file-info:mode
|
||||||
file-info:mtime
|
file-info:mtime
|
||||||
ile-info:nlinks
|
file-info:nlinks
|
||||||
file-info:size
|
file-info:size
|
||||||
;file-info:type
|
;file-info:type
|
||||||
file-info:uid
|
file-info:uid
|
||||||
|
|
@ -186,7 +164,6 @@
|
||||||
;file-readable?
|
;file-readable?
|
||||||
;file-regular?
|
;file-regular?
|
||||||
;file-size
|
;file-size
|
||||||
;file-socket?
|
|
||||||
;file-special?
|
;file-special?
|
||||||
;file-symlink?
|
;file-symlink?
|
||||||
;file-type
|
;file-type
|
||||||
|
|
@ -208,23 +185,20 @@
|
||||||
;get-lock-region
|
;get-lock-region
|
||||||
getenv
|
getenv
|
||||||
glob
|
glob
|
||||||
;glob-quote
|
glob-quote
|
||||||
group-info
|
group-info
|
||||||
group-info:gid
|
group-info:gid
|
||||||
;group-info:members
|
;group-info:members
|
||||||
group-info:name
|
group-info:name
|
||||||
;handle-signal-default
|
;handle-signal-default
|
||||||
;home-dir
|
;home-dir ;;FIXME
|
||||||
;home-directory
|
;home-directory
|
||||||
;home-file
|
;home-file
|
||||||
;host
|
;host
|
||||||
;host-info
|
|
||||||
;if-match
|
;if-match
|
||||||
;if-sre-form
|
;if-sre-form
|
||||||
;ignore-signal
|
;ignore-signal
|
||||||
;include-dir
|
|
||||||
;infix-splitter
|
;infix-splitter
|
||||||
;internet-address->socket-address
|
|
||||||
;interrupt-handler
|
;interrupt-handler
|
||||||
;interrupt-set
|
;interrupt-set
|
||||||
;interrupt/alarm
|
;interrupt/alarm
|
||||||
|
|
@ -254,12 +228,10 @@
|
||||||
;join-strings
|
;join-strings
|
||||||
;ldflags
|
;ldflags
|
||||||
;let-match
|
;let-match
|
||||||
;lib-dir
|
|
||||||
;lib-dirs
|
;lib-dirs
|
||||||
;lib-dirs-list
|
;lib-dirs-list
|
||||||
;libs
|
;libs
|
||||||
;linker-flags
|
;linker-flags
|
||||||
;listen-socket
|
|
||||||
;lock-owner-uid
|
;lock-owner-uid
|
||||||
;lock-region
|
;lock-region
|
||||||
;lock-region/no-block
|
;lock-region/no-block
|
||||||
|
|
@ -293,7 +265,6 @@
|
||||||
;make-syslog-mask
|
;make-syslog-mask
|
||||||
;make-syslog-options
|
;make-syslog-options
|
||||||
;make-tty-info
|
;make-tty-info
|
||||||
;man-dir
|
|
||||||
;match-cond
|
;match-cond
|
||||||
;match:end
|
;match:end
|
||||||
;match:start
|
;match:start
|
||||||
|
|
@ -307,14 +278,13 @@
|
||||||
;md5-digest?
|
;md5-digest?
|
||||||
;most-recent-sigevent
|
;most-recent-sigevent
|
||||||
;move->fdes
|
;move->fdes
|
||||||
;network-info
|
|
||||||
;next-sigevent
|
;next-sigevent
|
||||||
;next-sigevent-set
|
;next-sigevent-set
|
||||||
;next-sigevent-set/no-wait
|
;next-sigevent-set/no-wait
|
||||||
;next-sigevent/no-wait
|
;next-sigevent/no-wait
|
||||||
nice
|
nice
|
||||||
;number->md5-digest
|
;number->md5-digest
|
||||||
;obtain-dot-lock
|
obtain-dot-lock
|
||||||
;obtain-lock
|
;obtain-lock
|
||||||
;open-control-tty
|
;open-control-tty
|
||||||
;open-directory-stream
|
;open-directory-stream
|
||||||
|
|
@ -338,19 +308,17 @@
|
||||||
;port->fdes
|
;port->fdes
|
||||||
;port->list
|
;port->list
|
||||||
;port->sexp-list
|
;port->sexp-list
|
||||||
;port->socket
|
|
||||||
;port->string
|
;port->string
|
||||||
;port->string-list
|
;port->string-list
|
||||||
;port-fold
|
port-fold
|
||||||
;port-revealed
|
;port-revealed
|
||||||
;posix-string->regexp
|
;posix-string->regexp
|
||||||
;prefix
|
|
||||||
;priority
|
;priority
|
||||||
;proc
|
;proc
|
||||||
;proc:pid
|
;proc:pid
|
||||||
;proc?
|
;proc?
|
||||||
;process-group
|
;process-group
|
||||||
;process-sleep
|
process-sleep
|
||||||
;process-sleep-until
|
;process-sleep-until
|
||||||
;process-times
|
;process-times
|
||||||
;protocol-info
|
;protocol-info
|
||||||
|
|
@ -410,10 +378,6 @@
|
||||||
;read-string/partial
|
;read-string/partial
|
||||||
read-symlink
|
read-symlink
|
||||||
;reap-zombies
|
;reap-zombies
|
||||||
;receive-message
|
|
||||||
;receive-message!
|
|
||||||
;receive-message!/partial
|
|
||||||
;receive-message/partial
|
|
||||||
;record-reader
|
;record-reader
|
||||||
;regexp->posix-string
|
;regexp->posix-string
|
||||||
;regexp->scheme
|
;regexp->scheme
|
||||||
|
|
@ -426,7 +390,7 @@
|
||||||
;regexp-substitute
|
;regexp-substitute
|
||||||
;regexp-substitute/global
|
;regexp-substitute/global
|
||||||
;regexp?, [2]
|
;regexp?, [2]
|
||||||
;release-dot-lock
|
release-dot-lock
|
||||||
;release-lock
|
;release-lock
|
||||||
;release-port-handle
|
;release-port-handle
|
||||||
;relinquish-timeslice
|
;relinquish-timeslice
|
||||||
|
|
@ -521,10 +485,10 @@
|
||||||
;signal/winch
|
;signal/winch
|
||||||
;signal/xcpu
|
;signal/xcpu
|
||||||
;signal/xfsz
|
;signal/xfsz
|
||||||
;simplify-file-name
|
simplify-file-name
|
||||||
;simplify-regexp
|
;simplify-regexp
|
||||||
;skip-char-set
|
;skip-char-set
|
||||||
;sleep
|
sleep
|
||||||
;sloppy-suffix-splitter
|
;sloppy-suffix-splitter
|
||||||
;socket-address->internet-address
|
;socket-address->internet-address
|
||||||
;socket-address->unix-address
|
;socket-address->unix-address
|
||||||
|
|
@ -720,8 +684,8 @@
|
||||||
;with-current-output-port*
|
;with-current-output-port*
|
||||||
;with-cwd
|
;with-cwd
|
||||||
;with-cwd*
|
;with-cwd*
|
||||||
;with-dot-lock
|
with-dot-lock
|
||||||
;with-dot-lock*
|
with-dot-lock*
|
||||||
;with-enabled-interrupts
|
;with-enabled-interrupts
|
||||||
;with-enabled-interrupts*
|
;with-enabled-interrupts*
|
||||||
;with-env
|
;with-env
|
||||||
|
|
@ -746,6 +710,8 @@
|
||||||
;write-string
|
;write-string
|
||||||
;write-string/partial
|
;write-string/partial
|
||||||
)
|
)
|
||||||
|
(include "scsh/util.scm")
|
||||||
|
(include "scsh/portable.scm")
|
||||||
(cond-expand
|
(cond-expand
|
||||||
(windows (begin (error "Windows not supported")))
|
(windows (begin (error "Windows not supported")))
|
||||||
(else (include "scsh.unix.scm"))))
|
(else (include "scsh/unix.scm"))))
|
||||||
|
|
|
||||||
|
|
@ -1,28 +0,0 @@
|
||||||
(define-c-library libc '("stdlib.h" "string.h" "stdio.h" "glob.h") #f ())
|
|
||||||
|
|
||||||
;(define-c-procedure c-setenv libc 'setenv 'int '(pointer pointer int))
|
|
||||||
|
|
||||||
(define (setenv var val)
|
|
||||||
(when (not (string? var)) (error "setenv error: var must be string"))
|
|
||||||
(when (not (string? val)) (error "setenv error: val must be string"))
|
|
||||||
(set-environment-variable! var val))
|
|
||||||
|
|
||||||
(define getenv get-environment-variable)
|
|
||||||
|
|
||||||
(define-c-procedure c-glob libc 'glob 'int '(pointer int pointer pointer))
|
|
||||||
(define-c-procedure c-globfree libc 'globfree 'int '(pointer))
|
|
||||||
(define-c-struct-type glob-struct '((gl_pathc int) (gl_pathv pointer) (gl_offs int)))
|
|
||||||
(define glob
|
|
||||||
(lambda paths
|
|
||||||
(let ((result '()))
|
|
||||||
(for-each
|
|
||||||
(lambda (path)
|
|
||||||
(let ((glob-struct-cbv (make-c-bytevector (c-type-size glob-struct)))
|
|
||||||
(path-cbv (string->c-bytevector path)))
|
|
||||||
(c-glob path-cbv 0 glob-struct-cbv)
|
|
||||||
(display "HERE: path ")
|
|
||||||
(display path)
|
|
||||||
(newline)
|
|
||||||
(c-bytevector-free path-cbv)
|
|
||||||
))
|
|
||||||
paths))))
|
|
||||||
|
|
@ -1,7 +1,8 @@
|
||||||
Scsh - The Scheme Shell
|
scsh - The Scheme Shell
|
||||||
|
|
||||||
This is an implementation of [scsh](https://scsh.net/) on top of
|
This is an implementation of [scsh](https://scsh.net/) on top of
|
||||||
[(foreign c)](https://codeberg.org/foreign-c/foreign-c).
|
[(foreign c)](https://codeberg.org/foreign-c/foreign-c). It is not a port but
|
||||||
|
remake, trying to conform to the scsh as much as is possible but sane.
|
||||||
|
|
||||||
|
|
||||||
Not everything is implemented yet, see scsh.sld for commented out exports.
|
Not everything is implemented yet, see scsh.sld for commented out exports.
|
||||||
|
|
@ -12,3 +13,94 @@ Currently only supports Linux.
|
||||||
## Documentation
|
## Documentation
|
||||||
|
|
||||||
See [https://scsh.net/docu/html/man-Z-H-13.html#node_index_start](https://scsh.net/docu/html/man-Z-H-13.html#node_index_start)
|
See [https://scsh.net/docu/html/man-Z-H-13.html#node_index_start](https://scsh.net/docu/html/man-Z-H-13.html#node_index_start)
|
||||||
|
|
||||||
|
|
||||||
|
## Differences
|
||||||
|
|
||||||
|
Since the scsh proper is a program that you give source file to run to, and
|
||||||
|
this is a library. This version does not include everything. You should be able
|
||||||
|
to use other libraries to replace most things from scsh proper that this
|
||||||
|
library does not implement.
|
||||||
|
|
||||||
|
### alist->env, env->alist
|
||||||
|
|
||||||
|
For some reason the manual says that alist->env modifies the environment, yet
|
||||||
|
the scsh code does not. So this it returns a list of strings. Similarily
|
||||||
|
env->alist takes string as argument and returns alist instead of writing to env.
|
||||||
|
Check tests for examples.
|
||||||
|
|
||||||
|
|
||||||
|
### No SRFI's by default
|
||||||
|
|
||||||
|
SRFI's that come with scsh proper are not included. See snow-fort for them, or
|
||||||
|
your implementation.
|
||||||
|
|
||||||
|
|
||||||
|
### No scsh specifics
|
||||||
|
|
||||||
|
- bin-dir
|
||||||
|
- prefix
|
||||||
|
- exec-prefix
|
||||||
|
- lib-dir
|
||||||
|
- include-dir
|
||||||
|
- man-dir
|
||||||
|
- cflags
|
||||||
|
- clean-up-cres
|
||||||
|
- compiler-flags
|
||||||
|
- cppflags
|
||||||
|
- default-lib-dirs
|
||||||
|
- define-record
|
||||||
|
- defs
|
||||||
|
- dump-scsh
|
||||||
|
- dump-scsh-program
|
||||||
|
|
||||||
|
|
||||||
|
### No sockets
|
||||||
|
|
||||||
|
- accept-connection
|
||||||
|
- bind-listen-accept-loop
|
||||||
|
- bind-prepare-listen-accept-loop
|
||||||
|
- bind-socket
|
||||||
|
- close-socket
|
||||||
|
- connect-socket
|
||||||
|
- connect-socket-no-wait
|
||||||
|
- connect-socket-successful?
|
||||||
|
- create-socket
|
||||||
|
- create-socket-pair
|
||||||
|
- file-info-socket?
|
||||||
|
- file-socket?
|
||||||
|
- host-info
|
||||||
|
- internet-address->socket-address
|
||||||
|
- listen-socket
|
||||||
|
- network-info
|
||||||
|
- port->socket
|
||||||
|
- receive-message
|
||||||
|
- receive-message!
|
||||||
|
- receive-message!/partial
|
||||||
|
- receive-message/partial
|
||||||
|
|
||||||
|
Since this implementation of scsh is library you can get them as library elsewhere.
|
||||||
|
|
||||||
|
|
||||||
|
### No threads
|
||||||
|
|
||||||
|
Since this implementation of scsh is library you can get them as library elsewhere.
|
||||||
|
|
||||||
|
- current-thread
|
||||||
|
|
||||||
|
### No buffered io
|
||||||
|
|
||||||
|
- bufpol/block
|
||||||
|
- bufpol/line
|
||||||
|
- bufpol/none
|
||||||
|
|
||||||
|
|
||||||
|
### No date/time
|
||||||
|
|
||||||
|
- date
|
||||||
|
- date->string
|
||||||
|
|
||||||
|
|
||||||
|
### process-sleep
|
||||||
|
|
||||||
|
Same as sleep except instead of milliseconds uses seconds.
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,266 @@
|
||||||
|
(define (reduce-port port reader op . seeds)
|
||||||
|
(letrec* ((looper (lambda new-seeds
|
||||||
|
(let ((read-value (reader port)))
|
||||||
|
(if (eof-object? read-value)
|
||||||
|
(apply values new-seeds)
|
||||||
|
(call-with-values (lambda ()
|
||||||
|
(apply op read-value new-seeds))
|
||||||
|
looper))))))
|
||||||
|
(apply looper seeds)))
|
||||||
|
|
||||||
|
(define port-fold reduce-port)
|
||||||
|
|
||||||
|
(define (simplify-file-name fname) ;; TODO
|
||||||
|
(cond
|
||||||
|
((not (string? fname))
|
||||||
|
(error "simplify-file-name error: fname must be string"))
|
||||||
|
(else fname)))
|
||||||
|
|
||||||
|
(define set-umask set-umask!)
|
||||||
|
|
||||||
|
(define (setenv var val)
|
||||||
|
(when (not (string? var)) (error "setenv error: var must be string"))
|
||||||
|
(when (not (string? val)) (error "setenv error: val must be string"))
|
||||||
|
(set-environment-variable! var val))
|
||||||
|
|
||||||
|
(define getenv get-environment-variable)
|
||||||
|
|
||||||
|
(define (glob-quote str)
|
||||||
|
(list->string
|
||||||
|
(apply
|
||||||
|
append
|
||||||
|
(map
|
||||||
|
(lambda (c)
|
||||||
|
(if (member c (list #\*))
|
||||||
|
(list #\\ c)
|
||||||
|
(list c)))
|
||||||
|
(string->list str)))))
|
||||||
|
|
||||||
|
(define (add-after elt after lst)
|
||||||
|
(apply
|
||||||
|
append
|
||||||
|
(map
|
||||||
|
(lambda (item)
|
||||||
|
(if (equal? item after)
|
||||||
|
(list item elt)
|
||||||
|
(list item)))
|
||||||
|
lst)))
|
||||||
|
|
||||||
|
(define (add-before elt after lst)
|
||||||
|
(apply
|
||||||
|
append
|
||||||
|
(map
|
||||||
|
(lambda (item)
|
||||||
|
(if (equal? item after)
|
||||||
|
(list elt item)
|
||||||
|
(list item)))
|
||||||
|
lst)))
|
||||||
|
|
||||||
|
(define (alist->env alist)
|
||||||
|
(map (lambda (item)
|
||||||
|
(cond
|
||||||
|
((not (pair? item))
|
||||||
|
(error "alist->env error: alist items must be pairs" item))
|
||||||
|
((not (string? (car item)))
|
||||||
|
(error "alist->env error: alist item car must be string" item))
|
||||||
|
((and (not (string? (cdr item)))
|
||||||
|
(not (list? (cdr item))))
|
||||||
|
(error (string-append "alist->env error: alist item cdr must be"
|
||||||
|
"string or list of strings")
|
||||||
|
item))
|
||||||
|
((string? (cdr item))
|
||||||
|
(string-append (car item) "=" (cdr item)))
|
||||||
|
((list? (cdr item))
|
||||||
|
(for-each
|
||||||
|
(lambda (cdr-list-item)
|
||||||
|
(when (not (string? cdr-list-item))
|
||||||
|
(error (string-append "alist->env errror: all cdr list"
|
||||||
|
" items must be strings"
|
||||||
|
item))))
|
||||||
|
(cdr item))
|
||||||
|
(string-append (car item) "=" (string-join (cdr item) ":")))
|
||||||
|
(else (error "alist->env error: unexpected error" alist))))
|
||||||
|
alist))
|
||||||
|
|
||||||
|
(define (alist-compress alist)
|
||||||
|
(let ((result '()))
|
||||||
|
(for-each
|
||||||
|
(lambda (item)
|
||||||
|
(when (not (member item result))
|
||||||
|
(set! result (cons item result))))
|
||||||
|
alist)
|
||||||
|
(reverse result)))
|
||||||
|
|
||||||
|
(define (alist-delete key alist)
|
||||||
|
(let ((result '()))
|
||||||
|
(for-each
|
||||||
|
(lambda (item)
|
||||||
|
(when (not (equal? key (car item)))
|
||||||
|
(set! result (cons item result))))
|
||||||
|
alist)
|
||||||
|
(reverse result)))
|
||||||
|
|
||||||
|
(define (alist-update key val alist)
|
||||||
|
(cons (cons key val) (alist-delete key alist)))
|
||||||
|
|
||||||
|
(define (arg arglist n . default)
|
||||||
|
(when (not (list? arglist)) (error "arg error: arglist must be list"))
|
||||||
|
(when (not (integer? n)) (error "arg error: n must be integer"))
|
||||||
|
(when (< n 1) (error "arg error: Index starts from 1"))
|
||||||
|
(if (and (< (length arglist) n)
|
||||||
|
(not (null? default)))
|
||||||
|
(car default)
|
||||||
|
(list-ref arglist (- n 1))))
|
||||||
|
|
||||||
|
(define (arg* arglist n . default-thunk)
|
||||||
|
(when (not (list? arglist)) (error "arg* error: arglist must be list"))
|
||||||
|
(when (not (integer? n)) (error "arg* error: n must be integer"))
|
||||||
|
(when (< n 1) (error "arg* error: Index starts from 1"))
|
||||||
|
(if (and (< (length arglist) n)
|
||||||
|
(not (null? default-thunk)))
|
||||||
|
(begin
|
||||||
|
(when (not (procedure? (car default-thunk)))
|
||||||
|
(error "arg* error: default-tunk must be procedure"))
|
||||||
|
(apply (car default-thunk) '()))
|
||||||
|
(list-ref arglist (- n 1))))
|
||||||
|
|
||||||
|
(define (argv n)
|
||||||
|
(when (not (integer? n)) (error "argv error: n must be integer"))
|
||||||
|
(arg (command-line) (+ n 1)))
|
||||||
|
|
||||||
|
(define current-autoreap-policy 'wait)
|
||||||
|
(define autoreap-policy
|
||||||
|
(lambda args
|
||||||
|
(cond
|
||||||
|
((null? args) current-autoreap-policy)
|
||||||
|
(else
|
||||||
|
(when (not (or (equal? (car args) 'early)
|
||||||
|
(equal? (car args) 'late)
|
||||||
|
(equal? (car args) #f)))
|
||||||
|
(error "autoreap-policy error: policy must be 'early, 'late or #f"
|
||||||
|
(car args)))
|
||||||
|
(set! current-autoreap-policy (car args))))))
|
||||||
|
|
||||||
|
(define (sleep time)
|
||||||
|
(when (not (integer? time)) (error "sleep error: time must be integer" time))
|
||||||
|
(letrec*
|
||||||
|
((end-time
|
||||||
|
(let ((end-time (current-time))
|
||||||
|
(seconds (quotient time 1000))
|
||||||
|
(nanoseconds (* (remainder time 1000) 1000000)))
|
||||||
|
(set-time-second! end-time (+ (time-second end-time) seconds))
|
||||||
|
(set-time-nanosecond! end-time (+ (time-nanosecond end-time) nanoseconds))
|
||||||
|
end-time))
|
||||||
|
(looper (lambda () (when (time<? (current-time) end-time) (looper)))))
|
||||||
|
(looper)))
|
||||||
|
|
||||||
|
(define (process-sleep secs)
|
||||||
|
(when (not (integer? secs))
|
||||||
|
(error "process-sleep error: secs must be integer" secs))
|
||||||
|
(sleep (* secs 1000)))
|
||||||
|
|
||||||
|
(define (call-terminally thunk)
|
||||||
|
(when (not (procedure? thunk))
|
||||||
|
(error "call-terminally error: thunk must be procedure" thunk))
|
||||||
|
(thunk)
|
||||||
|
(exit 0))
|
||||||
|
|
||||||
|
(define (call-with-string-output-port procedure)
|
||||||
|
(when (not (procedure? procedure))
|
||||||
|
(error (string-append "call-with-string-output-port error: procedure"
|
||||||
|
" argument must be type of procedure")
|
||||||
|
procedure))
|
||||||
|
(let ((port (open-output-string)))
|
||||||
|
(procedure port)
|
||||||
|
(get-output-string port)))
|
||||||
|
|
||||||
|
(define (char-ascii? character)
|
||||||
|
(when (not (char? character))
|
||||||
|
(error "char-ascii? error: character argument must be of type character"
|
||||||
|
character))
|
||||||
|
(char-set-contains? char-set:ascii character))
|
||||||
|
|
||||||
|
(define (char-blank? character)
|
||||||
|
(when (not (char? character))
|
||||||
|
(error "char-blank? error: character argument must be of type character"
|
||||||
|
character))
|
||||||
|
(char-set-contains? char-set:blank character))
|
||||||
|
|
||||||
|
(define (char-digit? character)
|
||||||
|
(when (not (char? character))
|
||||||
|
(error "char-digit? error: character argument must be of type character"
|
||||||
|
character))
|
||||||
|
(char-set-contains? char-set:digit character))
|
||||||
|
|
||||||
|
(define (char-graphic? character)
|
||||||
|
(when (not (char? character))
|
||||||
|
(error "char-graphic? error: character argument must be of type character"
|
||||||
|
character))
|
||||||
|
(char-set-contains? char-set:graphic character))
|
||||||
|
|
||||||
|
(define (char-hex-digit? character)
|
||||||
|
(when (not (char? character))
|
||||||
|
(error "char-hex-digit? error: character argument must be of type character"
|
||||||
|
character))
|
||||||
|
(char-set-contains? char-set:hex-digit character))
|
||||||
|
|
||||||
|
(define (char-iso-control? character)
|
||||||
|
(when (not (char? character))
|
||||||
|
(error "char-iso-control? error: character argument must be of type character"
|
||||||
|
character))
|
||||||
|
(char-set-contains? char-set:iso-control character))
|
||||||
|
|
||||||
|
(define (char-letter+digit? character)
|
||||||
|
(when (not (char? character))
|
||||||
|
(error "char-letter+digit? error: character argument must be of type character"
|
||||||
|
character))
|
||||||
|
(char-set-contains? char-set:letter+digit character))
|
||||||
|
|
||||||
|
(define (char-letter? character)
|
||||||
|
(when (not (char? character))
|
||||||
|
(error "char-letter? error: character argument must be of type character"
|
||||||
|
character))
|
||||||
|
(char-set-contains? char-set:letter character))
|
||||||
|
|
||||||
|
(define (char-printing? character)
|
||||||
|
(when (not (char? character))
|
||||||
|
(error "char-printing? error: character argument must be of type character"
|
||||||
|
character))
|
||||||
|
(char-set-contains? char-set:printing character))
|
||||||
|
|
||||||
|
(define (char-punctuation? character)
|
||||||
|
(when (not (char? character))
|
||||||
|
(error "char-punctuation? error: character argument must be of type character"
|
||||||
|
character))
|
||||||
|
(char-set-contains? char-set:punctuation character))
|
||||||
|
|
||||||
|
(define (char-title-case? character)
|
||||||
|
(when (not (char? character))
|
||||||
|
(error "char-title-case? error: character argument must be of type character"
|
||||||
|
character))
|
||||||
|
(char-set-contains? char-set:title-case character))
|
||||||
|
|
||||||
|
(define (command-line-arguments)
|
||||||
|
(cdr (command-line)))
|
||||||
|
|
||||||
|
(define (directory-as-file-name fname)
|
||||||
|
(cond
|
||||||
|
((not (string? fname))
|
||||||
|
(error "directory-as-file-name error: fname must be string" fname))
|
||||||
|
((string=? fname "/")
|
||||||
|
"/")
|
||||||
|
((string=? fname "")
|
||||||
|
".")
|
||||||
|
(else
|
||||||
|
(let ((fname-length (string-length fname)))
|
||||||
|
(if (char=? (string-ref fname (- fname-length 1)) #\/)
|
||||||
|
(string-copy fname 0 (- fname-length 1))
|
||||||
|
fname)))))
|
||||||
|
|
||||||
|
(define (env->alist str)
|
||||||
|
(map (lambda (item)
|
||||||
|
(apply cons (string-split item #\=)))
|
||||||
|
(string-split str #\newline)))
|
||||||
|
|
||||||
|
(define (error-output-port) (current-error-port))
|
||||||
|
|
||||||
|
|
@ -0,0 +1,37 @@
|
||||||
|
(define-library
|
||||||
|
(retropikzel scsh portable)
|
||||||
|
(import (scheme base)
|
||||||
|
(scheme read)
|
||||||
|
(scheme write)
|
||||||
|
(scheme file)
|
||||||
|
(scheme process-context)
|
||||||
|
(srfi 60)
|
||||||
|
(srfi 170))
|
||||||
|
(export reduce-port
|
||||||
|
port-fold
|
||||||
|
simplify-file-name
|
||||||
|
set-umask
|
||||||
|
setenv
|
||||||
|
getenv
|
||||||
|
glob-quote
|
||||||
|
add-after
|
||||||
|
add-before
|
||||||
|
alist->env
|
||||||
|
alist-compress
|
||||||
|
alist-delete
|
||||||
|
alist-update
|
||||||
|
arg
|
||||||
|
arg*
|
||||||
|
argv
|
||||||
|
current-autoreap-policy
|
||||||
|
bin-dir
|
||||||
|
prefix
|
||||||
|
exec-prefix
|
||||||
|
lib-dir
|
||||||
|
include-dir
|
||||||
|
man-dir
|
||||||
|
obtain-dot-lock
|
||||||
|
)
|
||||||
|
(begin (define set-umask set-umask!))
|
||||||
|
(include "scsh/portable.scm"))
|
||||||
|
|
||||||
|
|
@ -5,13 +5,16 @@
|
||||||
(scheme file)
|
(scheme file)
|
||||||
(scheme process-context)
|
(scheme process-context)
|
||||||
(retropikzel scsh)
|
(retropikzel scsh)
|
||||||
(srfi 64)
|
(retropikzel tap)
|
||||||
(retropikzel tap))
|
(retropikzel debug)
|
||||||
|
(srfi 19)
|
||||||
|
(srfi 64))
|
||||||
|
|
||||||
(test-runner-current (tap-runner))
|
(test-runner-current (tap-runner))
|
||||||
|
|
||||||
(test-begin "scsh")
|
(test-begin "scsh")
|
||||||
|
|
||||||
|
|
||||||
(test-begin "setenv")
|
(test-begin "setenv")
|
||||||
(setenv "SCSH_TEST1" "foobar")
|
(setenv "SCSH_TEST1" "foobar")
|
||||||
(test-equal "foobar" (get-environment-variable "SCSH_TEST1"))
|
(test-equal "foobar" (get-environment-variable "SCSH_TEST1"))
|
||||||
|
|
@ -24,9 +27,281 @@
|
||||||
|
|
||||||
|
|
||||||
(test-begin "glob")
|
(test-begin "glob")
|
||||||
(test-equal '("test.hehe") (glob "*.hehe"))
|
(when (file-exists? "test.test") (delete-file "test.test"))
|
||||||
|
(with-output-to-file "test.test" (lambda () (display 1)))
|
||||||
|
(test-equal '("test.test") (glob "*.test"))
|
||||||
|
(test-equal "." (car (glob ".*")))
|
||||||
(test-end "glob")
|
(test-end "glob")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "glob-quote")
|
||||||
|
(test-equal "\\*.scm" (glob-quote "*.scm"))
|
||||||
|
(when (file-exists? "*.test1") (delete-file "*.test1"))
|
||||||
|
(with-output-to-file "*.test1" (lambda () (display 1)))
|
||||||
|
(test-equal '("*.test1") (glob (glob-quote "*.test1")))
|
||||||
|
(test-end "glob-quote")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "->uid")
|
||||||
|
(test-equal 0 (->uid 0))
|
||||||
|
(test-equal 0 (->uid "root"))
|
||||||
|
(test-end "->uid")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "->username")
|
||||||
|
(test-equal "root" (->username "root"))
|
||||||
|
(test-equal "root" (->username 0))
|
||||||
|
(test-end "->username")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "port-fold")
|
||||||
|
(let-values (((lst) (port-fold (open-input-string "1 2 3") read cons '())))
|
||||||
|
(test-equal '(3 2 1) lst))
|
||||||
|
(test-end "port-fold")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "reduce-port")
|
||||||
|
(let-values (((lst) (reduce-port (open-input-string "1 2 3") read cons '())))
|
||||||
|
(test-equal '(3 2 1) lst))
|
||||||
|
(test-end "port-fold")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "simplify-file-name") ;; TODO
|
||||||
|
(test-end "simplify-file-name")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "absolute-file-name")
|
||||||
|
(test-equal "/tmp" (absolute-file-name "/tmp"))
|
||||||
|
(test-end "absolute-file-name")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "add-after")
|
||||||
|
(test-equal '(foo baz bar) (add-after 'baz 'foo '(foo bar)))
|
||||||
|
(test-end "add-after")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "add-before")
|
||||||
|
(test-equal '(baz foo bar) (add-before 'baz 'foo '(foo bar)))
|
||||||
|
(test-end "add-before")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "alist->env")
|
||||||
|
(test-equal '("one=1" "two=2" "PATH=/tmp:/usr/local/bin")
|
||||||
|
(alist->env '(("one" . "1")
|
||||||
|
("two" . "2")
|
||||||
|
("PATH" "/tmp" "/usr/local/bin"))))
|
||||||
|
(test-end "alist->env")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "alist-compress")
|
||||||
|
(test-equal '((one . 1) (two . 2) (three .3) (four . 4))
|
||||||
|
(alist-compress '((one . 1) (two . 2) (three .3) (four . 4) (two . 2))))
|
||||||
|
(test-end "alist-compress")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "alist-delete")
|
||||||
|
(test-equal '((one . 1) (three .3) (four . 4))
|
||||||
|
(alist-delete 'two '((one . 1) (two . 2) (three .3) (four . 4) (two . 2))))
|
||||||
|
(test-end "alist-delete")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "alist-update")
|
||||||
|
(test-equal '((two . 20) (one . 1) (three .3) (four . 4))
|
||||||
|
(alist-update 'two 20 '((one . 1) (two . 2) (three .3) (four . 4))))
|
||||||
|
(test-equal '((two . 20) (one . 1) (three .3) (four . 4))
|
||||||
|
(alist-update 'two 20 '((one . 1) (two . 2) (three .3) (four . 4) (two . 2))))
|
||||||
|
(test-end "alist-update")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "arg")
|
||||||
|
(test-equal 2 (arg '(1 2 3) 2))
|
||||||
|
(test-equal 200 (arg '(1 2 3) 4 200))
|
||||||
|
(test-equal 3 (arg '(1 2 3) 3))
|
||||||
|
(test-equal 3 (arg '(1 2 3) 3 200))
|
||||||
|
(test-end "arg")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "arg*")
|
||||||
|
(test-equal 2 (arg* '(1 2 3) 2))
|
||||||
|
(test-equal 2 (arg* '(1 2 3) 2 (lambda () 2)))
|
||||||
|
(test-equal 2 (arg* '(1 2 3) 20 (lambda () 2)))
|
||||||
|
(test-end "arg*")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "argv")
|
||||||
|
(test-assert (string? (argv 0)))
|
||||||
|
(test-end "argv")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "autoreap-policy")
|
||||||
|
(autoreap-policy 'early)
|
||||||
|
(test-equal 'early (autoreap-policy))
|
||||||
|
(autoreap-policy 'late)
|
||||||
|
(test-equal 'late (autoreap-policy))
|
||||||
|
(autoreap-policy #f)
|
||||||
|
(test-equal #f (autoreap-policy))
|
||||||
|
(test-end "autoreap-policy")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "sleep")
|
||||||
|
(let ((start-time (current-time)))
|
||||||
|
(sleep 3000)
|
||||||
|
(display "Slept for seconds: ")
|
||||||
|
(write (time-second (time-difference (current-time) start-time)))
|
||||||
|
(newline))
|
||||||
|
(test-end "sleep")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "call-with-string-output-port")
|
||||||
|
(let* ((procedure (lambda (port) (display "Hello world" port)))
|
||||||
|
(out-str (call-with-string-output-port procedure)))
|
||||||
|
(test-equal "Hello world" out-str))
|
||||||
|
(test-end "call-with-string-output-port")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "char-ascii?")
|
||||||
|
(test-assert (char-ascii? #\a))
|
||||||
|
(test-end "char-ascii?")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "char-blank?")
|
||||||
|
(test-assert (char-blank? #\space))
|
||||||
|
(test-assert (char-blank? #\tab))
|
||||||
|
(test-assert (not (char-blank? #\a)))
|
||||||
|
(test-end "char-blank?")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "char-digit?")
|
||||||
|
(test-assert (char-digit? #\1))
|
||||||
|
(test-assert (char-digit? #\0))
|
||||||
|
(test-assert (not (char-digit? #\a)))
|
||||||
|
(test-end "char-digit?")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "char-graphic?")
|
||||||
|
(test-assert (char-graphic? #\a))
|
||||||
|
(test-end "char-graphic?")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "char-hex-digit?")
|
||||||
|
(test-assert (char-hex-digit? #\1))
|
||||||
|
(test-assert (char-hex-digit? #\a))
|
||||||
|
(test-assert (not (char-hex-digit? #\space)))
|
||||||
|
(test-end "char-hex-digit?")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "char-iso-control?")
|
||||||
|
(test-assert (not (char-iso-control? #\space)))
|
||||||
|
(test-end "char-iso-control?")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "char-letter+digit?")
|
||||||
|
(test-assert (char-letter+digit? #\1))
|
||||||
|
(test-assert (char-letter+digit? #\a))
|
||||||
|
(test-end "char-letter+digit?")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "char-letter?")
|
||||||
|
(test-assert (not (char-letter? #\1)))
|
||||||
|
(test-assert (char-letter? #\a))
|
||||||
|
(test-end "char-letter?")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "char-punctuation?")
|
||||||
|
(test-assert (not (char-punctuation? #\a)))
|
||||||
|
(test-assert (char-punctuation? #\!))
|
||||||
|
(test-end "char-punctuation?")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "char-title-case?")
|
||||||
|
(test-assert (not (char-title-case? #\a)))
|
||||||
|
(test-end "char-title-case?")
|
||||||
|
|
||||||
|
|
||||||
|
#| FIXME
|
||||||
|
(test-begin "cwd")
|
||||||
|
(debug (cwd))
|
||||||
|
(test-assert (string? (cwd)))
|
||||||
|
(test-assert (char=? (string-ref (cwd) 0) #\/))
|
||||||
|
(test-end "cwd")
|
||||||
|
|#
|
||||||
|
|
||||||
|
|
||||||
|
#| FIXME
|
||||||
|
(test-begin "chdir")
|
||||||
|
(let ((test-dir (cwd)))
|
||||||
|
(debug 0)
|
||||||
|
(chdir "/tmp")
|
||||||
|
(debug (cwd))
|
||||||
|
(test-assert (string=? (cwd) "/tmp"))
|
||||||
|
(debug 1)
|
||||||
|
(chdir test-dir)
|
||||||
|
(debug 2)
|
||||||
|
(test-assert (string=? (cwd) test-dir))
|
||||||
|
(when (not (string=? (cwd) test-dir))
|
||||||
|
(error "Test did not change back to test directory")))
|
||||||
|
(test-end "chdir")
|
||||||
|
|#
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "command-line")
|
||||||
|
(test-assert (list? (command-line)))
|
||||||
|
(test-end "command-line")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "command-line-arguments")
|
||||||
|
(test-assert (list? (command-line-arguments)))
|
||||||
|
(test-end "command-line-arguments")
|
||||||
|
|
||||||
|
|
||||||
|
#| FIXME
|
||||||
|
(test-begin "delete-filesys-object")
|
||||||
|
(let ((file "/tmp/scschtest1.txt"))
|
||||||
|
(when (file-exists? file) (delete-file file))
|
||||||
|
(with-output-to-file file (lambda () (display 1)))
|
||||||
|
(test-assert (file-exists? file))
|
||||||
|
(delete-filesys-object file)
|
||||||
|
(test-assert (not (file-exists? file)))
|
||||||
|
(when (file-exists? file) (delete-file file)))
|
||||||
|
(test-end "delete-filesys-object")
|
||||||
|
|#
|
||||||
|
|
||||||
|
|
||||||
|
#| FIXME
|
||||||
|
(test-begin "file-directory?")
|
||||||
|
(test-assert (file-directory? "/tmp" #f))
|
||||||
|
(let ((file "/tmp/scsch-file-directory?.txt"))
|
||||||
|
(when (file-exists? file) (delete-file file))
|
||||||
|
(with-output-to-file file (lambda () (display 1)))
|
||||||
|
(test-assert (not (file-directory? file #f)))
|
||||||
|
(when (file-exists? file) (delete-file file)))
|
||||||
|
(test-end "file-directory?")
|
||||||
|
|#
|
||||||
|
|
||||||
|
|
||||||
|
#| FIXME
|
||||||
|
(test-begin "home-dir")
|
||||||
|
(test-assert (string? (home-dir)))
|
||||||
|
(test-end "home-dir")
|
||||||
|
|#
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "directory-as-file-name")
|
||||||
|
(test-equal "/" (directory-as-file-name "/"))
|
||||||
|
(test-equal "." (directory-as-file-name ""))
|
||||||
|
(test-equal "/tmp" (directory-as-file-name "/tmp/"))
|
||||||
|
(test-end "directory-as-file-name")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "env->alist")
|
||||||
|
(test-equal '(("one" . "1") ("two" . "2") ("PATH" . "/tmp:/tmp/bin"))
|
||||||
|
(env->alist "one=1\ntwo=2\nPATH=/tmp:/tmp/bin"))
|
||||||
|
(test-end "env->alist")
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "error-output-port")
|
||||||
|
(test-assert (port? (error-output-port)))
|
||||||
|
(test-end "error-output-port")
|
||||||
|
|
||||||
|
|
||||||
(test-end "scsh")
|
(test-end "scsh")
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,188 @@
|
||||||
|
(define-c-library libc
|
||||||
|
'("stdlib.h" "string.h" "stdio.h" "glob.h" "unistd.h")
|
||||||
|
#f
|
||||||
|
())
|
||||||
|
(define-c-procedure c-perror libc 'perror 'void '(pointer))
|
||||||
|
(define (perror procedure-name msg . objs)
|
||||||
|
(let ((procedure-name* (string->c-bytevector
|
||||||
|
(string-append procedure-name " error"))))
|
||||||
|
(c-perror procedure-name*)
|
||||||
|
(c-bytevector-free procedure-name*))
|
||||||
|
(apply error (cons (string-append procedure-name " error: ") objs)))
|
||||||
|
|
||||||
|
|
||||||
|
(define *temp-file-template*
|
||||||
|
(cond ((get-environment-variable "TMPDIR")
|
||||||
|
(string-append (get-environment-variable "TMPDIR")
|
||||||
|
"/"
|
||||||
|
(number->string (pid))
|
||||||
|
".~a"))
|
||||||
|
(else
|
||||||
|
(string-append "/var/tmp/" (number->string (pid)) ".~a"))))
|
||||||
|
|
||||||
|
(define (->uid uid/username)
|
||||||
|
(cond
|
||||||
|
((exact-integer? uid/username) uid/username)
|
||||||
|
((string? uid/username)
|
||||||
|
(letrec*
|
||||||
|
((username-length (string-length uid/username))
|
||||||
|
(looper (lambda (line)
|
||||||
|
(if (eof-object? line)
|
||||||
|
#f
|
||||||
|
(let ((line-length (string-length line)))
|
||||||
|
(if (and (>= line-length username-length)
|
||||||
|
(string=? uid/username
|
||||||
|
(string-copy line
|
||||||
|
0
|
||||||
|
username-length)))
|
||||||
|
(string->number (list-ref (string-split line #\:) 2))
|
||||||
|
(looper (read-line))))))))
|
||||||
|
(with-input-from-file "/etc/passwd" (lambda () (looper (read-line))))))
|
||||||
|
(else (error (string-append "->uid error: uid/username must be either"
|
||||||
|
" exact integer or string")))))
|
||||||
|
|
||||||
|
(define (->username uid/username)
|
||||||
|
(cond ((string? uid/username) uid/username)
|
||||||
|
((exact-integer? uid/username)
|
||||||
|
(letrec*
|
||||||
|
((looper (lambda (line)
|
||||||
|
(if (eof-object? line)
|
||||||
|
#f
|
||||||
|
(let* ((line-length (string-length line))
|
||||||
|
(line-list (string-split line #\:))
|
||||||
|
(line-list-length (length line-list)))
|
||||||
|
(if (and (>= line-list-length 3)
|
||||||
|
(= (string->number (list-ref line-list 2))
|
||||||
|
uid/username))
|
||||||
|
(car line-list)
|
||||||
|
(looper (read-line))))))))
|
||||||
|
(with-input-from-file "/etc/passwd" (lambda () (looper (read-line))))))
|
||||||
|
(else (error (string-append "->username error: uid/username must be either"
|
||||||
|
" exact integer or string")))))
|
||||||
|
|
||||||
|
(define-c-procedure c-realpath libc 'realpath 'pointer '(pointer pointer))
|
||||||
|
(define (absolute-file-name fname . dir)
|
||||||
|
(cond ((not (string? fname))
|
||||||
|
(error "abosolute-file-name error: fname must bes string"))
|
||||||
|
((= (string-length fname) 0) "/")
|
||||||
|
(else (let* ((fname* (string->c-bytevector fname))
|
||||||
|
(path* (c-realpath fname* (c-bytevector-null))))
|
||||||
|
(if (c-bytevector-null? path*)
|
||||||
|
(let ((error* (string->c-bytevector "absolute-file-name")))
|
||||||
|
(c-perror error*)
|
||||||
|
(c-bytevector-free fname* path* error*)
|
||||||
|
(error "" fname))
|
||||||
|
(let ((path (c-bytevector->string path*)))
|
||||||
|
(c-bytevector-free fname* path*)
|
||||||
|
path))))))
|
||||||
|
|
||||||
|
(define-c-procedure c-glob libc 'glob 'int '(pointer int pointer pointer))
|
||||||
|
(define-c-procedure c-globfree libc 'globfree 'int '(pointer))
|
||||||
|
(define-c-struct-type glob-struct '((gl_pathc int) (gl_pathv pointer) (gl_offs int)))
|
||||||
|
(define glob
|
||||||
|
(lambda paths
|
||||||
|
(let ((result '()))
|
||||||
|
(for-each
|
||||||
|
(lambda (path)
|
||||||
|
(let ((glob-struct* (make-c-bytevector (c-type-size glob-struct)))
|
||||||
|
(path* (string->c-bytevector path)))
|
||||||
|
(c-glob path* 0 (c-bytevector-null) glob-struct*)
|
||||||
|
(letrec
|
||||||
|
((path-count (c-bytevector-ref glob-struct* glob-struct 'gl_pathc))
|
||||||
|
(looper
|
||||||
|
(lambda (count)
|
||||||
|
(when (< count path-count)
|
||||||
|
(let* ((list-path*
|
||||||
|
(c-bytevector-ref
|
||||||
|
(c-bytevector-ref glob-struct* glob-struct 'gl_pathv)
|
||||||
|
'pointer
|
||||||
|
(* (c-type-size 'pointer) count)))
|
||||||
|
(list-path-string (c-bytevector->string list-path*)))
|
||||||
|
(set! result (append result (list list-path-string)))
|
||||||
|
(c-bytevector-free list-path*)
|
||||||
|
(looper (+ count 1)))))))
|
||||||
|
(looper 0)
|
||||||
|
(c-bytevector-free path* glob-struct*))))
|
||||||
|
paths)
|
||||||
|
result)))
|
||||||
|
|
||||||
|
(define-c-procedure c-setsid libc 'setsid 'int '())
|
||||||
|
(define (become-session-leader)
|
||||||
|
(let ((result (c-setsid)))
|
||||||
|
(when (< result 0)
|
||||||
|
(error "become-session-leader error: Most propably already session leader"
|
||||||
|
result))
|
||||||
|
result))
|
||||||
|
|
||||||
|
(define-c-procedure c-chdir libc 'chdir 'int '(pointer))
|
||||||
|
(define chdir
|
||||||
|
(lambda args
|
||||||
|
(let ((fname (if (null? args) (home-dir) (car args))))
|
||||||
|
(when (not (string? fname)) (error "chdir error: fname must be string"))
|
||||||
|
(let* ((fname* (string->c-bytevector fname))
|
||||||
|
(result (c-chdir fname*)))
|
||||||
|
(c-bytevector-free fname*)
|
||||||
|
(when (= result -1)
|
||||||
|
(perror "chdir" "could not change directory"))))))
|
||||||
|
|
||||||
|
(define-c-procedure c-getcwd libc 'getcwd 'pointer '(pointer int))
|
||||||
|
(define (cwd)
|
||||||
|
(letrec
|
||||||
|
((start-size 128)
|
||||||
|
(looper
|
||||||
|
(lambda (size)
|
||||||
|
(let* ((buffer* (make-c-bytevector size))
|
||||||
|
(cwd* (c-getcwd buffer* size)))
|
||||||
|
(if (c-bytevector-null? cwd*)
|
||||||
|
(looper (* size 2))
|
||||||
|
(let ((result (c-bytevector->string buffer*)))
|
||||||
|
(c-bytevector-free cwd* buffer*)
|
||||||
|
result))))))
|
||||||
|
(looper start-size)))
|
||||||
|
|
||||||
|
(define (delete-filesys-object fname)
|
||||||
|
(when (not (string? fname))
|
||||||
|
(error "delete-filesys-object error: fname must be string"))
|
||||||
|
(if (file-directory? fname #f)
|
||||||
|
(delete-directory fname)
|
||||||
|
(guard (condition (else #t))
|
||||||
|
(delete-file fname))))
|
||||||
|
|
||||||
|
(define (file-directory? fname/port . chase?)
|
||||||
|
(when (not (or (string? fname/port)
|
||||||
|
(port? fname/port)))
|
||||||
|
(error "file-directory? error: fname/port must be string or port"))
|
||||||
|
(when (and (not (null? chase?))
|
||||||
|
(not (equal? (car chase?) #t))
|
||||||
|
(not (equal? (car chase?) #f)))
|
||||||
|
(error "file-directory? error: chase? must be boolean"))
|
||||||
|
(let ((f-info (file-info fname/port (if (null? chase?) #t (car chase?)))))
|
||||||
|
(file-info-directory? f-info)))
|
||||||
|
|
||||||
|
(define home-dir
|
||||||
|
(lambda args
|
||||||
|
(let ((user (if (null? args)
|
||||||
|
(user-info:name (user-info (user-uid)))
|
||||||
|
(car args))))
|
||||||
|
(when (not (string? user))
|
||||||
|
(error "home-dir error: user must be string" user))
|
||||||
|
(letrec
|
||||||
|
((username-length (string-length user))
|
||||||
|
(looper (lambda (line)
|
||||||
|
(if (eof-object? line)
|
||||||
|
#f
|
||||||
|
(let ((line-length (string-length line)))
|
||||||
|
(if (and (>= line-length username-length)
|
||||||
|
(string=? user
|
||||||
|
(string-copy line
|
||||||
|
0
|
||||||
|
username-length)))
|
||||||
|
(list-ref (string-split line #\:) 5)
|
||||||
|
(looper (read-line)))))))
|
||||||
|
(home-dir-path (with-input-from-file
|
||||||
|
"/etc/passwd"
|
||||||
|
(lambda () (looper (read-line))))))
|
||||||
|
(when (not home-dir-path)
|
||||||
|
(error "home-dir error: home directory not found, user does not exist?"
|
||||||
|
user))
|
||||||
|
home-dir-path))))
|
||||||
|
|
@ -0,0 +1,19 @@
|
||||||
|
(define (string-split str split-by)
|
||||||
|
(read (open-input-string
|
||||||
|
(list->string
|
||||||
|
(append
|
||||||
|
(list #\( #\")
|
||||||
|
(apply
|
||||||
|
append
|
||||||
|
(map
|
||||||
|
(lambda (c)
|
||||||
|
(if (char=? c split-by)
|
||||||
|
(list #\" #\space #\")
|
||||||
|
(list c)))
|
||||||
|
(string->list str)))
|
||||||
|
(list #\" #\)))))))
|
||||||
|
|
||||||
|
(define (string-join lst join-by)
|
||||||
|
(apply string-append
|
||||||
|
(cdr (apply append (map (lambda (item) (list join-by item)) lst)))))
|
||||||
|
|
||||||
Loading…
Reference in New Issue