scsh: More progress
This commit is contained in:
parent
2d27e6687d
commit
637e91ab0b
|
|
@ -27,3 +27,5 @@ foreign
|
|||
tmp
|
||||
*.json
|
||||
test-program
|
||||
*.test
|
||||
*.test1
|
||||
|
|
|
|||
2
Makefile
2
Makefile
|
|
@ -59,7 +59,7 @@ test-docker:
|
|||
DOCKER_TAG=${DOCKER_TAG} \
|
||||
COMPILE_R7RS=${SCHEME} \
|
||||
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})'" \
|
||||
APT_PACKAGES="${APT_PACKAGES}" \
|
||||
PASS_ENV_VARS="CSC_OPTIONS" \
|
||||
|
|
|
|||
|
|
@ -1,15 +1,22 @@
|
|||
(define-library
|
||||
(retropikzel scsh)
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme char)
|
||||
(scheme process-context)
|
||||
(retropikzel dot-locking)
|
||||
(retropikzel debug)
|
||||
(foreign c)
|
||||
(srfi 14)
|
||||
(srfi 19)
|
||||
(srfi 60)
|
||||
(srfi 170))
|
||||
(export
|
||||
;*temp-file-template*
|
||||
;->uid
|
||||
;->username
|
||||
*temp-file-template*
|
||||
->uid
|
||||
->username
|
||||
;%exec
|
||||
;%exit
|
||||
;%fork
|
||||
|
|
@ -19,104 +26,77 @@
|
|||
;&
|
||||
;&
|
||||
;&&
|
||||
;reduce-port
|
||||
;absolute-file-name
|
||||
;accept-connection
|
||||
;add-after
|
||||
;add-before
|
||||
;alist->env
|
||||
;alist-compress
|
||||
;alist-delete
|
||||
;alist-update
|
||||
;arg
|
||||
;arg*
|
||||
;argv
|
||||
;arithmetic-shift
|
||||
reduce-port
|
||||
absolute-file-name
|
||||
add-after
|
||||
add-before
|
||||
alist->env
|
||||
alist-compress
|
||||
alist-delete
|
||||
alist-update
|
||||
arg
|
||||
arg*
|
||||
argv
|
||||
arithmetic-shift
|
||||
;ascii->char
|
||||
;autoreap-policy
|
||||
autoreap-policy
|
||||
;awk
|
||||
;become-session-leader
|
||||
;bin-dir
|
||||
;bind-listen-accept-loop
|
||||
;bind-prepare-listen-accept-loop
|
||||
;bind-socket
|
||||
;bitwise-and
|
||||
;bitwise-ior
|
||||
;bitwise-not
|
||||
;bitwise-xor
|
||||
;break-dot-lock
|
||||
;bufpol/block
|
||||
;bufpol/line
|
||||
;bufpol/none
|
||||
;call-terminally
|
||||
;call-with-string-output-port
|
||||
become-session-leader
|
||||
bitwise-and
|
||||
bitwise-ior
|
||||
bitwise-not
|
||||
bitwise-xor
|
||||
break-dot-lock
|
||||
call-terminally
|
||||
call-with-string-output-port
|
||||
;call/fdes
|
||||
;cflags
|
||||
;char->ascii
|
||||
;char-ascii?
|
||||
;char-blank?
|
||||
;char-digit?
|
||||
;char-graphic?
|
||||
;char-hex-digit?
|
||||
;char-iso-control?
|
||||
;char-letter+digit?
|
||||
;char-letter?
|
||||
;char-lower-case?
|
||||
;char-printing?
|
||||
;char-punctuation?
|
||||
;char-title-case?
|
||||
;char-upper-case?
|
||||
;char-whitespace?
|
||||
;chdir
|
||||
;clean-up-cres
|
||||
char-ascii?
|
||||
char-blank?
|
||||
char-digit?
|
||||
char-graphic?
|
||||
char-hex-digit?
|
||||
char-iso-control?
|
||||
char-letter+digit?
|
||||
char-letter?
|
||||
char-lower-case?
|
||||
char-printing?
|
||||
char-punctuation?
|
||||
char-title-case?
|
||||
char-upper-case?
|
||||
char-whitespace?
|
||||
;chdir ;; FIXME
|
||||
;close
|
||||
;close-after
|
||||
;close-directory-stream
|
||||
;close-socket
|
||||
;close-syslog-channel
|
||||
;command-line
|
||||
;command-line-arguments
|
||||
;compiler-flags
|
||||
;connect-socket
|
||||
;connect-socket-no-wait
|
||||
;connect-socket-successful?
|
||||
command-line
|
||||
command-line-arguments
|
||||
;control-tty-file-name
|
||||
;copy-tty-info
|
||||
;cppflags
|
||||
;cpu-ticks/sec
|
||||
create-directory
|
||||
create-fifo
|
||||
create-hard-link
|
||||
;create-socket
|
||||
;create-socket-pair
|
||||
create-symlink
|
||||
create-temp-file
|
||||
;crypt
|
||||
;current-thread
|
||||
;cwd
|
||||
;date, [2]
|
||||
;date, [2]
|
||||
;date->string
|
||||
;default-lib-dirs
|
||||
;define-record
|
||||
;defs
|
||||
;cwd ;; FIXME
|
||||
delete-directory
|
||||
delete-file
|
||||
;delete-filesys-object
|
||||
;directory-as-file-name
|
||||
;delete-filesys-object ;; FIXME
|
||||
directory-as-file-name
|
||||
directory-files
|
||||
;disable-tty-char
|
||||
;drain-tty
|
||||
;dump-scsh
|
||||
;dump-scsh-program
|
||||
;dup
|
||||
;dup->fdes
|
||||
;dup->inport
|
||||
;dup->outport
|
||||
;enabled-interrupts
|
||||
;env->alist
|
||||
env->alist
|
||||
;errno-error
|
||||
;error-output-port
|
||||
error-output-port
|
||||
;exec
|
||||
;exec-epf
|
||||
;exec-epf
|
||||
|
|
@ -124,7 +104,6 @@
|
|||
;exec-path-list
|
||||
;exec-path-search
|
||||
;exec-path/env
|
||||
;exec-prefix
|
||||
;exec/env
|
||||
exit
|
||||
;expand-file-name
|
||||
|
|
@ -134,7 +113,7 @@
|
|||
;fdes-status
|
||||
;field-reader
|
||||
;field-splitter
|
||||
;file-directory?
|
||||
;file-directory? ;; FIXME
|
||||
;file-executable?
|
||||
;file-exists?
|
||||
;file-fifo?
|
||||
|
|
@ -148,7 +127,6 @@
|
|||
;file-info-not-writable?
|
||||
;file-info-readable?
|
||||
;file-info-regular?
|
||||
;file-info-socket?
|
||||
;file-info-special?
|
||||
;file-info-symlink?
|
||||
;file-info-writable?
|
||||
|
|
@ -159,7 +137,7 @@
|
|||
file-info:inode
|
||||
file-info:mode
|
||||
file-info:mtime
|
||||
ile-info:nlinks
|
||||
file-info:nlinks
|
||||
file-info:size
|
||||
;file-info:type
|
||||
file-info:uid
|
||||
|
|
@ -186,7 +164,6 @@
|
|||
;file-readable?
|
||||
;file-regular?
|
||||
;file-size
|
||||
;file-socket?
|
||||
;file-special?
|
||||
;file-symlink?
|
||||
;file-type
|
||||
|
|
@ -208,23 +185,20 @@
|
|||
;get-lock-region
|
||||
getenv
|
||||
glob
|
||||
;glob-quote
|
||||
glob-quote
|
||||
group-info
|
||||
group-info:gid
|
||||
;group-info:members
|
||||
group-info:name
|
||||
;handle-signal-default
|
||||
;home-dir
|
||||
;home-dir ;;FIXME
|
||||
;home-directory
|
||||
;home-file
|
||||
;host
|
||||
;host-info
|
||||
;if-match
|
||||
;if-sre-form
|
||||
;ignore-signal
|
||||
;include-dir
|
||||
;infix-splitter
|
||||
;internet-address->socket-address
|
||||
;interrupt-handler
|
||||
;interrupt-set
|
||||
;interrupt/alarm
|
||||
|
|
@ -254,12 +228,10 @@
|
|||
;join-strings
|
||||
;ldflags
|
||||
;let-match
|
||||
;lib-dir
|
||||
;lib-dirs
|
||||
;lib-dirs-list
|
||||
;libs
|
||||
;linker-flags
|
||||
;listen-socket
|
||||
;lock-owner-uid
|
||||
;lock-region
|
||||
;lock-region/no-block
|
||||
|
|
@ -293,7 +265,6 @@
|
|||
;make-syslog-mask
|
||||
;make-syslog-options
|
||||
;make-tty-info
|
||||
;man-dir
|
||||
;match-cond
|
||||
;match:end
|
||||
;match:start
|
||||
|
|
@ -307,14 +278,13 @@
|
|||
;md5-digest?
|
||||
;most-recent-sigevent
|
||||
;move->fdes
|
||||
;network-info
|
||||
;next-sigevent
|
||||
;next-sigevent-set
|
||||
;next-sigevent-set/no-wait
|
||||
;next-sigevent/no-wait
|
||||
nice
|
||||
;number->md5-digest
|
||||
;obtain-dot-lock
|
||||
obtain-dot-lock
|
||||
;obtain-lock
|
||||
;open-control-tty
|
||||
;open-directory-stream
|
||||
|
|
@ -338,19 +308,17 @@
|
|||
;port->fdes
|
||||
;port->list
|
||||
;port->sexp-list
|
||||
;port->socket
|
||||
;port->string
|
||||
;port->string-list
|
||||
;port-fold
|
||||
port-fold
|
||||
;port-revealed
|
||||
;posix-string->regexp
|
||||
;prefix
|
||||
;priority
|
||||
;proc
|
||||
;proc:pid
|
||||
;proc?
|
||||
;process-group
|
||||
;process-sleep
|
||||
process-sleep
|
||||
;process-sleep-until
|
||||
;process-times
|
||||
;protocol-info
|
||||
|
|
@ -410,10 +378,6 @@
|
|||
;read-string/partial
|
||||
read-symlink
|
||||
;reap-zombies
|
||||
;receive-message
|
||||
;receive-message!
|
||||
;receive-message!/partial
|
||||
;receive-message/partial
|
||||
;record-reader
|
||||
;regexp->posix-string
|
||||
;regexp->scheme
|
||||
|
|
@ -426,7 +390,7 @@
|
|||
;regexp-substitute
|
||||
;regexp-substitute/global
|
||||
;regexp?, [2]
|
||||
;release-dot-lock
|
||||
release-dot-lock
|
||||
;release-lock
|
||||
;release-port-handle
|
||||
;relinquish-timeslice
|
||||
|
|
@ -521,10 +485,10 @@
|
|||
;signal/winch
|
||||
;signal/xcpu
|
||||
;signal/xfsz
|
||||
;simplify-file-name
|
||||
simplify-file-name
|
||||
;simplify-regexp
|
||||
;skip-char-set
|
||||
;sleep
|
||||
sleep
|
||||
;sloppy-suffix-splitter
|
||||
;socket-address->internet-address
|
||||
;socket-address->unix-address
|
||||
|
|
@ -720,8 +684,8 @@
|
|||
;with-current-output-port*
|
||||
;with-cwd
|
||||
;with-cwd*
|
||||
;with-dot-lock
|
||||
;with-dot-lock*
|
||||
with-dot-lock
|
||||
with-dot-lock*
|
||||
;with-enabled-interrupts
|
||||
;with-enabled-interrupts*
|
||||
;with-env
|
||||
|
|
@ -746,6 +710,8 @@
|
|||
;write-string
|
||||
;write-string/partial
|
||||
)
|
||||
(include "scsh/util.scm")
|
||||
(include "scsh/portable.scm")
|
||||
(cond-expand
|
||||
(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
|
||||
[(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.
|
||||
|
|
@ -12,3 +13,94 @@ Currently only supports Linux.
|
|||
## 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)
|
||||
|
||||
|
||||
## 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 process-context)
|
||||
(retropikzel scsh)
|
||||
(srfi 64)
|
||||
(retropikzel tap))
|
||||
(retropikzel tap)
|
||||
(retropikzel debug)
|
||||
(srfi 19)
|
||||
(srfi 64))
|
||||
|
||||
(test-runner-current (tap-runner))
|
||||
|
||||
(test-begin "scsh")
|
||||
|
||||
|
||||
(test-begin "setenv")
|
||||
(setenv "SCSH_TEST1" "foobar")
|
||||
(test-equal "foobar" (get-environment-variable "SCSH_TEST1"))
|
||||
|
|
@ -24,9 +27,281 @@
|
|||
|
||||
|
||||
(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-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")
|
||||
|
|
|
|||
|
|
@ -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