Compare commits
2 Commits
0e39535c93
...
0cba23d93c
| Author | SHA1 | Date |
|---|---|---|
|
|
0cba23d93c | |
|
|
06fc8871a8 |
|
|
@ -1,3 +1,4 @@
|
|||
*.tgz
|
||||
venv
|
||||
*.html
|
||||
*.log
|
||||
|
|
|
|||
41
Makefile
41
Makefile
|
|
@ -1,6 +1,3 @@
|
|||
.SILENT: build install clean test-r6rs test-r6rs-docker test-r7rs \
|
||||
test-r7rs-docker
|
||||
.PHONY: test-r6rs test-r7rs
|
||||
SCHEME=chibi
|
||||
RNRS=r7rs
|
||||
SRFI=170
|
||||
|
|
@ -32,27 +29,25 @@ install:
|
|||
uninstall:
|
||||
-snow-chibi remove --impls=${SCHEME} ${PKG}
|
||||
|
||||
init-venv: build
|
||||
@rm -rf venv
|
||||
@scheme-venv ${SCHEME} ${RNRS} venv
|
||||
@echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (srfi ${SRFI}))" > venv/test.scm
|
||||
@printf "#!r6rs\n(import (rnrs) (srfi :64) (srfi :${SRFI}))" > venv/test.sps
|
||||
@cat ${TESTFILE} >> venv/test.scm
|
||||
@cat ${TESTFILE} >> venv/test.sps
|
||||
@if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign venv/lib/; fi; fi
|
||||
@if [ "${RNRS}" = "r6rs" ]; then cp -r retropikzel venv/lib/; fi
|
||||
@if [ "${SCHEME}" = "chezs" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
||||
@if [ "${SCHEME}" = "ikarus" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
||||
@if [ "${SCHEME}" = "ironscheme" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
||||
@if [ "${SCHEME}" = "racket" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
||||
@if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/akku install; fi
|
||||
@if [ "${SCHEME}" = "chicken" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi
|
||||
@if [ "${SCHEME}-${RNRS}" = "mosh-r7rs" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi
|
||||
@if [ "${RNRS}" = "r7rs" ]; then ./venv/bin/snow-chibi install ${PKG}; fi
|
||||
|
||||
run-test: init-venv
|
||||
run-test-venv: build
|
||||
rm -rf venv
|
||||
scheme-venv ${SCHEME} ${RNRS} venv
|
||||
echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (foreign c) (srfi ${SRFI}))" > venv/test.scm
|
||||
printf "#!r6rs\n(import (rnrs) (srfi :64) (foreign c) (srfi :${SRFI}))" > venv/test.sps
|
||||
cat ${TESTFILE} >> venv/test.scm
|
||||
cat ${TESTFILE} >> venv/test.sps
|
||||
if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign venv/lib/; fi; fi
|
||||
if [ "${RNRS}" = "r6rs" ]; then cp -r retropikzel venv/lib/; fi
|
||||
if [ "${SCHEME}" = "chezs" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
||||
if [ "${SCHEME}" = "ikarus" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
||||
if [ "${SCHEME}" = "ironscheme" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
||||
if [ "${SCHEME}" = "racket" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
|
||||
if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/akku install; fi
|
||||
if [ "${SCHEME}" = "chicken" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi
|
||||
if [ "${SCHEME}-${RNRS}" = "mosh-r7rs" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi
|
||||
if [ "${RNRS}" = "r7rs" ]; then ./venv/bin/snow-chibi install ${PKG}; fi
|
||||
if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/scheme-compile venv/test.sps; fi
|
||||
if [ "${RNRS}" = "r7rs" ]; then VENV_CSC_ARGS="-L -lcurl" ./venv/bin/scheme-compile venv/test.scm; fi
|
||||
if [ "${RNRS}" = "r7rs" ]; then CSC_OPTIONS="-L -lcurl" ./venv/bin/scheme-compile venv/test.scm; fi
|
||||
./venv/test
|
||||
|
||||
test-r7rs: tmpdir
|
||||
|
|
|
|||
50
srfi/106.scm
50
srfi/106.scm
|
|
@ -1,5 +1,5 @@
|
|||
(define-c-library libc
|
||||
`("sys/types.h"
|
||||
'("sys/types.h"
|
||||
"sys/socket.h"
|
||||
"sys/un.h"
|
||||
"netinet/in.h"
|
||||
|
|
@ -8,8 +8,8 @@
|
|||
"fcntl.h"
|
||||
"poll.h"
|
||||
"string.h")
|
||||
libc-name
|
||||
'((additional-versions ("0" "6"))))
|
||||
#f
|
||||
'())
|
||||
|
||||
(define-c-procedure c-socket libc 'socket 'int '(int int int))
|
||||
(define-c-procedure c-setsockopt libc 'setsockopt 'int '(int int int pointer int))
|
||||
|
|
@ -103,8 +103,8 @@
|
|||
(call-with-address-of
|
||||
addrinfo-hints
|
||||
(lambda (addrinfo-hints-address)
|
||||
(c-getaddrinfo (string->c-utf8 node)
|
||||
(string->c-utf8 service)
|
||||
(c-getaddrinfo (string->c-bytevector node)
|
||||
(string->c-bytevector service)
|
||||
addrinfo-hints
|
||||
addrinfo-address))))))
|
||||
(socket-file-descriptor
|
||||
|
|
@ -113,13 +113,13 @@
|
|||
(c-bytevector-ref addrinfo 'int ai-socktype-offset)
|
||||
(c-bytevector-ref addrinfo 'int ai-protocol-offset))))
|
||||
(when (< addrinfo-result 0)
|
||||
(c-perror (string->c-utf8 "make-client-socket (addrinfo) error"))
|
||||
(c-perror (string->c-bytevector "make-client-socket (addrinfo) error"))
|
||||
(raise-continuable "make-client-socket (addrinfo) error"))
|
||||
(when (< socket-file-descriptor 0)
|
||||
(c-perror (string->c-utf8 "make-client-socket (socket) error"))
|
||||
(c-perror (string->c-bytevector "make-client-socket (socket) error"))
|
||||
(raise-continuable "make-client-socket (socket) error"))
|
||||
(when (< (c-fcntl socket-file-descriptor F-SETFL O-NONBLOCK) 0)
|
||||
(c-perror (string->c-utf8 "make-client-socket (fcntl) error"))
|
||||
(c-perror (string->c-bytevector "make-client-socket (fcntl) error"))
|
||||
(raise-continuable "make-client-socket (fcntl) error"))
|
||||
(letrec* ((ai-addr-offset (* (c-type-size 'int) 6))
|
||||
(ai-addrlen-offset (* (c-type-size 'int) 4))
|
||||
|
|
@ -132,7 +132,7 @@
|
|||
(c-bytevector-set! pollfd 'int 0 0)
|
||||
;; FIXME No magic numbers, like 8 or 1 here. Put into variable with good name
|
||||
;; TODO Why 8 works but 1 does not?
|
||||
(when (= (c-poll pollfd 8 5000) 0)
|
||||
#;(when (= (c-poll pollfd 8 5000) 0)
|
||||
(error "make-client-socket (poll) error")))
|
||||
(make-socket socket-file-descriptor))))
|
||||
|
||||
|
|
@ -153,7 +153,7 @@
|
|||
(msg-len (bytevector-length bv))
|
||||
(sent-count (c-send (socket-file-descriptor socket) msg msg-len 0)))
|
||||
(when (= sent-count -1)
|
||||
(c-perror (string->c-utf8 "socket-send error"))
|
||||
(c-perror (string->c-bytevector "socket-send error"))
|
||||
(raise-continuable "socket-send error"))
|
||||
sent-count))
|
||||
|
||||
|
|
@ -194,26 +194,26 @@
|
|||
(c-type-size 'u16)
|
||||
(c-htons (string->number service)))
|
||||
(c-bytevector-set! pointer 'u16 (* (c-type-size 'u16) 2) INADDR-ANY)
|
||||
;(c-strcpy node-pointer (string->c-utf8 node))
|
||||
;(c-strcpy node-pointer (string->c-bytevector node))
|
||||
pointer))
|
||||
(option (let ((pointer (make-c-bytevector (c-type-size 'int))))
|
||||
(c-bytevector-set! pointer 'int 0 1)
|
||||
pointer))
|
||||
(sockaddr-size (+ *ai-family-size* (bytevector-length (string->utf8 node)))))
|
||||
(when (< socket-file-descriptor 0)
|
||||
(c-perror (string->c-utf8 "make-server-socket (socket) error"))
|
||||
(c-perror (string->c-bytevector "make-server-socket (socket) error"))
|
||||
(raise-continuable "make-server-socket (socket) error"))
|
||||
(when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEADDR option (c-type-size 'int)) 0)
|
||||
(c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEADDR) error"))
|
||||
(c-perror (string->c-bytevector "make-server-socket (setsockopt SO-REUSEADDR) error"))
|
||||
(raise-continuable "make-server-socket (setsockopt SO-REUSEADDR) error"))
|
||||
(when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEPORT option (c-type-size 'int)) 0)
|
||||
(c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEPORT) error"))
|
||||
(c-perror (string->c-bytevector "make-server-socket (setsockopt SO-REUSEPORT) error"))
|
||||
(raise-continuable "make-server-socket (setsockopt SO-REUSEPORT) error"))
|
||||
(when (< (c-bind socket-file-descriptor sockaddr *sockaddr-size*) 0)
|
||||
(c-perror (string->c-utf8 "socket-accept (bind) error"))
|
||||
(c-perror (string->c-bytevector "socket-accept (bind) error"))
|
||||
(raise-continuable "socket-accept (bind) error"))
|
||||
(when (< (c-listen socket-file-descriptor 0) 0)
|
||||
(c-perror (string->c-utf8 "make-server-socket (listen) error"))
|
||||
(c-perror (string->c-bytevector "make-server-socket (listen) error"))
|
||||
(raise-continuable "make-server-socket (listen) error"))
|
||||
(make-socket socket-file-descriptor)))
|
||||
|
||||
|
|
@ -240,8 +240,8 @@
|
|||
(call-with-address-of
|
||||
addrinfo-hints
|
||||
(lambda (addrinfo-hints-address)
|
||||
(c-getaddrinfo (string->c-utf8 "0.0.0.0")
|
||||
(string->c-utf8 service)
|
||||
(c-getaddrinfo (string->c-bytevector "0.0.0.0")
|
||||
(string->c-bytevector service)
|
||||
addrinfo-hints
|
||||
addrinfo-address))))))
|
||||
(socket-file-descriptor
|
||||
|
|
@ -257,22 +257,22 @@
|
|||
(ai-addrlen-offset (* (c-type-size 'int) 4))
|
||||
(ai-addr-len (c-bytevector-ref addrinfo 'int ai-addrlen-offset)))
|
||||
(when (< addrinfo-result 0)
|
||||
(c-perror (string->c-utf8 "make-server-socket (addrinfo) error"))
|
||||
(c-perror (string->c-bytevector "make-server-socket (addrinfo) error"))
|
||||
(raise-continuable "make-server-socket (addrinfo) error"))
|
||||
(when (< socket-file-descriptor 0)
|
||||
(c-perror (string->c-utf8 "make-server-socket (socket) error"))
|
||||
(c-perror (string->c-bytevector "make-server-socket (socket) error"))
|
||||
(raise-continuable "make-server-socket (socket) error"))
|
||||
(when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEADDR option (c-type-size 'int)) 0)
|
||||
(c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEADDR) error"))
|
||||
(c-perror (string->c-bytevector "make-server-socket (setsockopt SO-REUSEADDR) error"))
|
||||
(raise-continuable "make-server-socket (setsockopt SO-REUSEADDR) error"))
|
||||
(when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEPORT option (c-type-size 'int)) 0)
|
||||
(c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEPORT) error"))
|
||||
(c-perror (string->c-bytevector "make-server-socket (setsockopt SO-REUSEPORT) error"))
|
||||
(raise-continuable "make-server-socket (setsockopt SO-REUSEPORT) error"))
|
||||
(when (< (c-bind socket-file-descriptor ai-addr ai-addr-len) 0)
|
||||
(c-perror (string->c-utf8 "make-server-socket (bind) error"))
|
||||
(c-perror (string->c-bytevector "make-server-socket (bind) error"))
|
||||
(raise-continuable "make-server-socket (bind) error"))
|
||||
(when (< (c-listen socket-file-descriptor 5) 0)
|
||||
(c-perror (string->c-utf8 "make-server-socket (listen) error"))
|
||||
(c-perror (string->c-bytevector "make-server-socket (listen) error"))
|
||||
(raise-continuable "make-server-socket (listen) error"))
|
||||
(make-socket socket-file-descriptor))))
|
||||
|
||||
|
|
@ -285,7 +285,7 @@
|
|||
client-sockaddr
|
||||
addrlen)))
|
||||
(when (< accepted-socket 0)
|
||||
(c-perror (string->c-utf8 "socket-accept (accept) error"))
|
||||
(c-perror (string->c-bytevector "socket-accept (accept) error"))
|
||||
(raise-continuable "socket-accept (accept) error"))
|
||||
(make-socket accepted-socket)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
(test-begin "srfi-106")
|
||||
|
||||
(define sock1-port "3005")
|
||||
(define sock2-port "3006")
|
||||
|
||||
(define-c-library libc `("stdlib.h") libc-name '((additional-versions ("0" "6"))))
|
||||
(define-c-library libc `("stdlib.h") #f '())
|
||||
(define-c-procedure c-system libc 'system 'int '(pointer))
|
||||
|
||||
(display "Testing TCP socket")
|
||||
|
|
@ -13,7 +14,7 @@
|
|||
;(debug (socket-domain stream))
|
||||
;(debug (ip-protocol ip))
|
||||
|
||||
(c-system (string->c-utf8 (string-append "echo \"lol\" | nc -l " sock1-port "&")))
|
||||
(c-system (string->c-bytevector (string-append "echo \"lol\" | nc -l " sock1-port "&")))
|
||||
|
||||
(define sock1 (make-client-socket "127.0.0.1" sock1-port))
|
||||
|
||||
|
|
@ -40,3 +41,4 @@
|
|||
(write (utf8->string (socket-recv client-sock1 3)))
|
||||
(newline)
|
||||
|
||||
(test-end "srfi-106")
|
||||
|
|
|
|||
110
srfi/170.scm
110
srfi/170.scm
|
|
@ -9,8 +9,8 @@
|
|||
"pwd.h"
|
||||
"grp.h"
|
||||
"fcntl.h")
|
||||
libc-name
|
||||
'((additional-versions ("0" "6"))))
|
||||
#f
|
||||
'())
|
||||
|
||||
(define-c-procedure c-perror libc 'perror 'void '(pointer))
|
||||
(define-c-procedure c-mkdir libc 'mkdir 'int '(pointer int))
|
||||
|
|
@ -51,7 +51,7 @@
|
|||
|
||||
(define (random-to max)
|
||||
(when (not randomized?)
|
||||
(c-srand (c-time (make-c-null)))
|
||||
(c-srand (c-time (c-bytevector-null)))
|
||||
(set! randomized? #t))
|
||||
(modulo (c-rand) max))
|
||||
|
||||
|
|
@ -93,25 +93,25 @@
|
|||
(follow? file-info:follow?))
|
||||
|
||||
(define (file-info-directory? file-info)
|
||||
(let ((handle (c-open (string->c-utf8 (file-info:fname/port file-info)) 2)))
|
||||
(let ((handle (c-open (string->c-bytevector (file-info:fname/port file-info)) 2)))
|
||||
(cond ((> handle 0) (c-close handle) #f)
|
||||
(else #t))))
|
||||
|
||||
(define (file-info fname/port follow?)
|
||||
(when (port? fname/port)
|
||||
(error "file-info implementation does not support ports as arguments"))
|
||||
(let* ((fname-pointer (string->c-utf8 fname/port))
|
||||
(let* ((fname-pointer (string->c-bytevector fname/port))
|
||||
(stat-pointer (make-c-bytevector 256))
|
||||
(result (if follow?
|
||||
(c-stat fname-pointer stat-pointer)
|
||||
(c-lstat fname-pointer stat-pointer)))
|
||||
(error-message "file-info error")
|
||||
(error-pointer (string->c-utf8 error-message)))
|
||||
(error-pointer (string->c-bytevector error-message)))
|
||||
(when (< result 0)
|
||||
(c-perror error-pointer)
|
||||
(c-free fname-pointer)
|
||||
(c-free stat-pointer)
|
||||
(c-free error-pointer)
|
||||
(c-bytevector-free fname-pointer)
|
||||
(c-bytevector-free stat-pointer)
|
||||
(c-bytevector-free error-pointer)
|
||||
(error error-message fname/port))
|
||||
(make-file-info-record #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 0) (native-endianness))
|
||||
#f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 1) (native-endianness))
|
||||
|
|
@ -131,46 +131,46 @@
|
|||
|
||||
(define create-directory
|
||||
(lambda (fname . permission-bits)
|
||||
(let* ((fname-pointer (string->c-utf8 fname))
|
||||
(let* ((fname-pointer (string->c-bytevector fname))
|
||||
(mode (if (null? permission-bits)
|
||||
#o775
|
||||
(string->number (string-append "#o"
|
||||
(number->string (car permission-bits))))))
|
||||
(result (c-mkdir fname-pointer mode))
|
||||
(error-message "create-directory error")
|
||||
(error-pointer (string->c-utf8 error-message)))
|
||||
(c-free fname-pointer)
|
||||
(error-pointer (string->c-bytevector error-message)))
|
||||
(c-bytevector-free fname-pointer)
|
||||
(when (< result 0)
|
||||
(c-perror error-pointer)
|
||||
(c-free error-pointer)
|
||||
(c-bytevector-free error-pointer)
|
||||
(error error-message)))))
|
||||
|
||||
(define (create-hard-link old-fname new-fname)
|
||||
(c-link (string->c-utf8 old-fname)
|
||||
(string->c-utf8 new-fname)))
|
||||
(c-link (string->c-bytevector old-fname)
|
||||
(string->c-bytevector new-fname)))
|
||||
|
||||
(define (create-symlink old-fname new-fname)
|
||||
(c-slink (string->c-utf8 old-fname)
|
||||
(string->c-utf8 new-fname)))
|
||||
(c-slink (string->c-bytevector old-fname)
|
||||
(string->c-bytevector new-fname)))
|
||||
|
||||
(define (rename-file old-fname new-fname)
|
||||
(c-rename (string->c-utf8 old-fname) (string->c-utf8 new-fname)))
|
||||
(c-rename (string->c-bytevector old-fname) (string->c-bytevector new-fname)))
|
||||
|
||||
(define (delete-directory fname)
|
||||
(let* ((fname-pointer (string->c-utf8 fname))
|
||||
(let* ((fname-pointer (string->c-bytevector fname))
|
||||
(result (c-rmdir fname-pointer))
|
||||
(error-message "delete-directory error")
|
||||
(error-pointer (string->c-utf8 error-message)))
|
||||
(c-free fname-pointer)
|
||||
(error-pointer (string->c-bytevector error-message)))
|
||||
(c-bytevector-free fname-pointer)
|
||||
(when (< result 0)
|
||||
(c-perror error-pointer)
|
||||
(c-free error-pointer)
|
||||
(c-bytevector-free error-pointer)
|
||||
(error error-message))))
|
||||
|
||||
(define (set-file-owner fname uid gid)
|
||||
(let ((fname-pointer (string->c-utf8 fname)))
|
||||
(let ((fname-pointer (string->c-bytevector fname)))
|
||||
(c-chown fname-pointer uid gid)
|
||||
(c-free fname-pointer)))
|
||||
(c-bytevector-free fname-pointer)))
|
||||
|
||||
(define (pointer-string-read pointer offset)
|
||||
(letrec* ((looper (lambda (c index result)
|
||||
|
|
@ -189,13 +189,13 @@
|
|||
(define directory-files
|
||||
(lambda (dir . dotfiles?)
|
||||
(letrec* ((include-dotfiles? (if (null? dotfiles?) #f (car dotfiles?)))
|
||||
(path-pointer (string->c-utf8 dir))
|
||||
(path-pointer (string->c-bytevector dir))
|
||||
(directory-pointer (c-opendir path-pointer))
|
||||
(error-message "directory-files error")
|
||||
(error-pointer (string->c-utf8 error-message))
|
||||
(error-pointer (string->c-bytevector error-message))
|
||||
(dotfile? (lambda (name) (char=? (string-ref name 0) #\.)))
|
||||
(looper (lambda (directory-entity files)
|
||||
(if (c-null? directory-entity)
|
||||
(if (c-bytevector-null? directory-entity)
|
||||
files
|
||||
(let ((name (pointer-string-read directory-entity
|
||||
d-name-offset)))
|
||||
|
|
@ -208,30 +208,30 @@
|
|||
((not (dotfile? name))
|
||||
(cons name files))
|
||||
(else files))))))))
|
||||
(when (c-null? directory-pointer)
|
||||
(when (c-bytevector-null? directory-pointer)
|
||||
(c-perror error-pointer)
|
||||
;(c-free error-pointer)
|
||||
;(c-free directory)
|
||||
;(c-free path-pointer)
|
||||
;(c-bytevector-free error-pointer)
|
||||
;(c-bytevector-free directory)
|
||||
;(c-bytevector-free path-pointer)
|
||||
(error error-message))
|
||||
(let ((files (looper (c-readdir directory-pointer) (list))))
|
||||
;(c-free error-pointer)
|
||||
;(c-free directory-pointer)
|
||||
;(c-free path-pointer)
|
||||
;(c-bytevector-free error-pointer)
|
||||
;(c-bytevector-free directory-pointer)
|
||||
;(c-bytevector-free path-pointer)
|
||||
(c-closedir directory-pointer)
|
||||
files))))
|
||||
|
||||
(define real-path
|
||||
(lambda (path)
|
||||
(let* ((path-pointer (string->c-utf8 path))
|
||||
(real-path-pointer (c-realpath path-pointer (make-c-null)))
|
||||
(real-path (string-copy (c-utf8->string real-path-pointer))))
|
||||
(c-free path-pointer)
|
||||
(c-free real-path-pointer)
|
||||
(let* ((path-pointer (string->c-bytevector path))
|
||||
(real-path-pointer (c-realpath path-pointer (c-bytevector-null)))
|
||||
(real-path (string-copy (c-bytevector->string real-path-pointer))))
|
||||
(c-bytevector-free path-pointer)
|
||||
(c-bytevector-free real-path-pointer)
|
||||
real-path)))
|
||||
|
||||
(define (set-file-mode path mode)
|
||||
(c-chmod (string->c-utf8 path)
|
||||
(c-chmod (string->c-bytevector path)
|
||||
(string->number (string-append "#o" (number->string mode)))))
|
||||
|
||||
(define-record-type <directory>
|
||||
|
|
@ -241,14 +241,14 @@
|
|||
(dot-files? directory:dot-files?))
|
||||
|
||||
(define (open-directory path . dot-files?)
|
||||
(make-directory (c-opendir (string->c-utf8 path))
|
||||
(make-directory (c-opendir (string->c-bytevector path))
|
||||
(if (null? dot-files?)
|
||||
#f
|
||||
(car dot-files?))))
|
||||
|
||||
(define (read-directory directory-object)
|
||||
(let ((directory-entity (c-readdir (directory:handle directory-object))))
|
||||
(if (c-null? directory-entity)
|
||||
(if (c-bytevector-null? directory-entity)
|
||||
(eof-object)
|
||||
(let ((name (pointer-string-read directory-entity d-name-offset)))
|
||||
(cond ((or (string=? name ".")
|
||||
|
|
@ -304,12 +304,12 @@
|
|||
(let* ((path-pointer (make-c-bytevector 1024))
|
||||
(path (begin
|
||||
(c-getcwd path-pointer 1024)
|
||||
(string-copy (c-utf8->string path-pointer)))))
|
||||
(c-free path-pointer)
|
||||
(string-copy (c-bytevector->string path-pointer)))))
|
||||
(c-bytevector-free path-pointer)
|
||||
path))
|
||||
|
||||
(define (set-current-directory! path)
|
||||
(c-chdir (string->c-utf8 path)))
|
||||
(c-chdir (string->c-bytevector path)))
|
||||
|
||||
(define (pid)
|
||||
(c-getpid))
|
||||
|
|
@ -339,7 +339,7 @@
|
|||
))))))
|
||||
|
||||
(define (user-supplementary-gids)
|
||||
(let* ((group-count (c-getgroups 0 (make-c-null)))
|
||||
(let* ((group-count (c-getgroups 0 (c-bytevector-null)))
|
||||
(groups (make-c-bytevector (* (c-type-size 'int) group-count))))
|
||||
(c-getgroups group-count groups)
|
||||
(groups-loop group-count 0 groups (list))))
|
||||
|
|
@ -357,8 +357,8 @@
|
|||
(define (user-info uid/name)
|
||||
(let ((password-struct (if (number? uid/name)
|
||||
(c-getpwuid uid/name)
|
||||
(c-getpwnam (string->c-utf8 uid/name)))))
|
||||
(make-user-info (c-utf8->string (c-bytevector-ref password-struct
|
||||
(c-getpwnam (string->c-bytevector uid/name)))))
|
||||
(make-user-info (c-bytevector->string (c-bytevector-ref password-struct
|
||||
'pointer
|
||||
0))
|
||||
(c-bytevector-ref password-struct
|
||||
|
|
@ -368,15 +368,15 @@
|
|||
'int
|
||||
(+ (* (c-type-size 'pointer) 2)
|
||||
(c-type-size 'int)))
|
||||
(c-utf8->string (c-bytevector-ref password-struct
|
||||
(c-bytevector->string (c-bytevector-ref password-struct
|
||||
'pointer
|
||||
(+ (* (c-type-size 'pointer) 3)
|
||||
(* (c-type-size 'int) 2))))
|
||||
(c-utf8->string (c-bytevector-ref password-struct
|
||||
(c-bytevector->string (c-bytevector-ref password-struct
|
||||
'pointer
|
||||
(+ (* (c-type-size 'pointer) 4)
|
||||
(* (c-type-size 'int) 2))))
|
||||
(c-utf8->string (c-bytevector-ref password-struct
|
||||
(c-bytevector->string (c-bytevector-ref password-struct
|
||||
'pointer
|
||||
(+ (* (c-type-size 'pointer) 2)
|
||||
(* (c-type-size 'int) 2)))))))
|
||||
|
|
@ -391,15 +391,15 @@
|
|||
(define (group-info gid/name)
|
||||
(let ((group-struct (if (number? gid/name)
|
||||
(c-getgrgid gid/name)
|
||||
(c-getgrnam (string->c-utf8 gid/name)))))
|
||||
(c-getgrnam (string->c-bytevector gid/name)))))
|
||||
(make-group-info
|
||||
(c-utf8->string (c-bytevector-ref group-struct 'pointer 0))
|
||||
(c-bytevector->string (c-bytevector-ref group-struct 'pointer 0))
|
||||
(c-bytevector-ref group-struct
|
||||
'int
|
||||
(* (c-type-size 'pointer) 2)))))
|
||||
|
||||
(define (set-environment-variable! name value)
|
||||
(c-setenv (string->c-utf8 name) (string->c-utf8 value) 1))
|
||||
(c-setenv (string->c-bytevector name) (string->c-bytevector value) 1))
|
||||
|
||||
(define (delete-environment-variable! name)
|
||||
(c-unsetenv (string->c-utf8 name)))
|
||||
(c-unsetenv (string->c-bytevector name)))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
(test-begin "srfi-170")
|
||||
|
||||
(display (real-path "Makefile"))
|
||||
(newline)
|
||||
|
|
@ -144,3 +145,5 @@
|
|||
(display "file-info-directory? on file: ")
|
||||
(write (file-info-directory? tmp-file-info))
|
||||
(newline)
|
||||
|
||||
(test-begin "srfi-170")
|
||||
|
|
|
|||
Loading…
Reference in New Issue