From 528f5d6b8e61af69d00ad84b87c5237d1a7fe8c6 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 29 Aug 2026 14:07:18 +0200 Subject: [PATCH] srfi-170 (#1) Reviewed-on: https://codeberg.org/retropikzel/foreign-c-srfis/pulls/1 --- .gitignore | 4 +- .snow-repo.scm | 36 ++++ Dockerfile.jenkins | 7 +- Jenkinsfile | 65 +++--- Makefile | 83 ++++---- README.md | 26 ++- srfi/106.scm | 17 +- srfi/106/DESCRIPTION | 1 + srfi/106/LICENSE | 166 +-------------- srfi/106/test.scm | 34 ++- srfi/170.scm | 479 ++++++++++++++++++++++++++++++++----------- srfi/170.sld | 47 ++--- srfi/170/DESCRIPTION | 1 + srfi/170/LICENSE | 166 +-------------- srfi/170/README.md | 84 +------- srfi/170/VERSION | 2 +- srfi/170/test.scm | 41 +++- test-headers.sps | 2 +- test.scm | 180 ++++++++++++++++ 19 files changed, 795 insertions(+), 646 deletions(-) create mode 100644 .snow-repo.scm create mode 100644 srfi/106/DESCRIPTION create mode 100644 srfi/170/DESCRIPTION create mode 100644 test.scm diff --git a/.gitignore b/.gitignore index 7a80de4..9f4f8f0 100644 --- a/.gitignore +++ b/.gitignore @@ -5,4 +5,6 @@ venv foreign run-test* .* - +test-program +*.link +!.snow-repo.scm diff --git a/.snow-repo.scm b/.snow-repo.scm new file mode 100644 index 0000000..73eabac --- /dev/null +++ b/.snow-repo.scm @@ -0,0 +1,36 @@ +(repository + (package + (git + (hash "02c5fa06cab2ea15fe25fbd6433a8a549ee5d18f") + (url "https://codeberg.org/retropikzel/foreign-c-srfis.git")) + (authors "Retropikzel") + (version "0.2.5") + (license LGPL-3.0-or-later) + (library + (name + (srfi 170)) + (path "srfi/170.sld") + (foreign-depends) + (depends + (scheme base) + (scheme char) + (scheme write) + (scheme file) + (scheme process-context) + (foreign c) + (srfi 19))) + (manual "srfi/170/index.html") + (description "(foreign c) SRFI 170: POSIX API") + (test "srfi/170/test.scm") + (test-depends + (scheme base) + (scheme write) + (scheme read) + (scheme char) + (scheme file) + (scheme process-context) + (retropikzel tap) + (foreign c) + (srfi 64) + (srfi 170)) + (updated "2026-08-29T15:04:01+00:00"))) diff --git a/Dockerfile.jenkins b/Dockerfile.jenkins index 91b0707..6a2a454 100644 --- a/Dockerfile.jenkins +++ b/Dockerfile.jenkins @@ -1,2 +1,5 @@ -FROM debian:trixie -RUN apt-get update && apt-get -y install make docker.io git +FROM schemers/chibi:head +RUN apt-get update && apt-get install -y \ + gcc ca-certificates libffi-dev docker.io make +ARG timestamp=0 +RUN snow-chibi install --impls=chibi retropikzel.test-r7rs && echo "$timestamp" diff --git a/Jenkinsfile b/Jenkinsfile index fc09848..5f36019 100644 --- a/Jenkinsfile +++ b/Jenkinsfile @@ -3,46 +3,65 @@ pipeline { dockerfile { filename 'Dockerfile.jenkins' label 'docker-x86_64' - args '--user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock' + args '-t --user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock' } } + triggers { + GenericTrigger( + genericVariables: [[key: 'ref', value: '$.ref']], + causeString: 'Triggered on $ref', + printContributedVariables: true, + printPostContent: true, + silentResponse: false, + shouldNotFlatten: false, + regexpFilterText: '$ref', + regexpFilterExpression: 'refs/heads/' + BRANCH_NAME + ) + } + options { disableConcurrentBuilds() buildDiscarder(logRotator(numToKeepStr: '10', artifactNumToKeepStr: '10')) } - parameters { - string(name: 'R7RS_SCHEMES', defaultValue: 'chibi chicken gauche guile kawa mosh racket sagittarius stklos ypsilon', description: '') - string(name: 'R6RS_SCHEMES', defaultValue: 'chezscheme guile ikarus ironscheme mosh racket sagittarius ypsilon', description: '') - string(name: 'SRFIS', defaultValue: '106 170', description: '') + environment { + R7RS_SCHEMES="capyscheme chibi chicken gauche kawa mosh racket sagittarius stklos ypsilon" + R6RS_SCHEMES="chezscheme guile ikarus ironscheme mosh racket sagittarius ypsilon" + SRFIS="170" } stages { - stage('Tests') { - stage('R6RS x86_64 Debian') { - steps { - script { - params.SRFIS.split().each { SRFI -> - params.R6RS_SCHEMES.split().each { SCHEME -> - stage("${SCHEME} - ${SRFI}") { - catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') { - sh "timeout 600 make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r6rs run-test-docker" + stage('Parallel') { + parallel { + stage('R6RS Debian') { + steps { + script { + env.SRFIS.split().each { SRFI -> + stage("${SRFI}") { + env.R6RS_SCHEMES.split().each { SCHEME -> + stage("${SCHEME} ${SRFI}") { + catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') { + sh "make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r6rs test-docker" + } + } } } } } } } - } - stage('R7RS x86_64 Debian') { - steps { - script { - params.SRFIS.split().each { SRFI -> - params.R7RS_SCHEMES.split().each { SCHEME -> - stage("${SCHEME} - ${SRFI}") { - catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') { - sh "timeout 600 make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r6rs run-test-docker" + stage('R7RS Debian') { + steps { + script { + env.SRFIS.split().each { SRFI -> + stage("${SRFI}") { + env.R7RS_SCHEMES.split().each { SCHEME -> + stage("${SCHEME} ${SRFI}") { + catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') { + sh "make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r7rs test-docker" + } + } } } } diff --git a/Makefile b/Makefile index e380a5b..3f7cf8e 100644 --- a/Makefile +++ b/Makefile @@ -1,60 +1,49 @@ +.POSIX: +.DEFAULT: all SCHEME=chibi -RNRS=r7rs SRFI=170 -AUTHOR=Retropikzel - -SRFI_FILE=srfi/${SRFI}.sld -VERSION=$(shell cat srfi/${SRFI}/VERSION) -DESCRIPTION=$(shell head -n1 srfi/${SRFI}/README.md) -README=srfi/${SRFI}/README.html -TESTFILE=srfi/${SRFI}/test.scm -TMPDIR=.tmp/${SCHEME} - PKG=srfi-${SRFI}-${VERSION}.tgz - -SFX=scm -ifeq "${RNRS}" "r6rs" -SFX=sps -endif - -DOCKER_TAG=head -ifeq "${SCHEME}" "chicken" -DOCKER_TAG=5 -endif +VERSION=$$(cat srfi/${SRFI}/VERSION) +TESTFILE=srfi/${SRFI}/test.scm +DOCFILE=srfi/${SRFI}/index.html all: package package: srfi/${SRFI}/LICENSE srfi/${SRFI}/VERSION - echo "
$$(cat srfi/${SRFI}/README.md)
" > ${README} + cp srfi/${SRFI}/test.scm test.scm snow-chibi package \ - --version=${VERSION} \ - --authors=${AUTHOR} \ - --doc=${README} \ - --description="${DESCRIPTION}" \ - ${SRFI_FILE} + --license="$$(cat srfi/${SRFI}/LICENSE)" \ + --version="${VERSION}" \ + --authors="$$(cat srfi/${SRFI}/AUTHORS 2>/dev/null || echo 'Retropikzel')" \ + --doc=${DOCFILE} \ + --test=${TESTFILE} \ + --description="$$(cat srfi/${SRFI}/DESCRIPTION)" \ + srfi/${SRFI}.sld + +git-index: package + snow-chibi git-index ${PKG} install: - snow-chibi install --impls=${SCHEME} ${PKG} + snow-chibi install --impls=${SCHEME} --skip-tests?=1 ${PKG} -testfiles: - rm -rf .tmp - mkdir -p .tmp - cp ${PKG} .tmp - cp -r srfi .tmp/ - cat test-headers.${SFX} ${TESTFILE} | sed 's/SRFI/${SRFI}/' > .tmp/test.${SFX} - cat ${TESTFILE} >> run-test.${SFX} - if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign .tmp/; fi; fi +test: + cp srfi/${SRFI}/test.scm test.scm + COMPILE_R7RS=${SCHEME} compile-r7rs -o test-program test.scm + ./test-program -test: testfiles package - cd .tmp && COMPILE_R7RS=${SCHEME} compile-r7rs -o test-program test.${SFX} - cd .tmp && ./test-program +test-docker: testfiles + DOCKER_TAG=${DOCKER_TAG} \ + SNOW_PACKAGES="srfi.64 ${PKG}" \ + AKKU_PACKAGES=${AKKU_PACKAGES} \ + APT_PACKAGES="libcurl4-openssl-dev" \ + COMPILE_R7RS=${SCHEME} \ + TEST_R7RS_DEBUG=1 \ + CSC_OPIONS="-L -lcurl" \ + test-r7rs -o test-program test.scm -test-docker: testfiles package - cd .tmp && \ - DOCKER_TAG=${DOCKER_TAG} \ - SNOW_PACKAGES="srfi.64 srfi.60 srfi.145 srfi.180 retropikzel.mouth foreign.c ${PKG}" \ - APT_PACKAGES="libcurl4-openssl-dev" \ - COMPILE_R7RS=${SCHEME} \ - TEST_R7RS_DEBUG=1 \ - CSC_OPIONS="-L -lcurl" \ - test-r7rs -o test-program test.${SFX} +update-info: + curl -L -o srfi/${SRFI}/index.html https://srfi.schemers.org/srfi-${SRFI}/srfi-${SRFI}.html + printf "(foreign c) $$(cat srfi/${SRFI}/index.html | grep '' | sed 's/<title>//' | sed 's/<\/title>//' | sed 's/^[ \t]*//' | tr -d '\n')" > srfi/${SRFI}/DESCRIPTION + +clean: + git clean -X -f diff --git a/README.md b/README.md index 276b247..e4f7680 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,27 @@ -To install SRFI library run +# (foreign c) SRFis + +SRFIs made using [(foreign c)](https://codeberg.org/foreign-c/foreign-c) library. + + +## SRFI-106: Basic socket interface + +Prioritazing TCP client sockets. + +## SRFI-170: POSIX API + + +## Installation + +To install published SRFI run: + + snow-fort install --impls=chibi srfi.N + + +To install SRFI from this repository run: make SCHEME=chibi SRFI=106 build install -Change chibi to any other implementation supported by snow-chibi, and 106 -to any filename without suffix in srfi/*.sld +## Usage + +Import and use. diff --git a/srfi/106.scm b/srfi/106.scm index 6a08391..f855779 100644 --- a/srfi/106.scm +++ b/srfi/106.scm @@ -83,10 +83,7 @@ (ai-flags (if (>= (length args) 3) (list-ref args 2) (socket-merge-flags *ai-v4mapped* *ai-addrconfig*))) - (ai-protocol - (if (>= (length args) 4) - (list-ref args 3) - *ipproto-ip*))) + (ai-protocol (if (>= (length args) 4) (list-ref args 3) *ipproto-ip*))) (let* ((ai-family-offset (c-type-size 'int)) (ai-socktype-offset (* (c-type-size 'int) 2)) (ai-protocol-offset (* (c-type-size 'int) 3)) @@ -149,9 +146,21 @@ names)))) (define (socket-send socket bv . flags) + (display "HERE :") + (write socket) + (newline) + (write bv) + (newline) + (display "HERE :") + (write socket) + (newline) + (write bv) + (newline) (let* ((msg (bytevector->c-bytevector bv)) (msg-len (bytevector-length bv)) (sent-count (c-send (socket-file-descriptor socket) msg msg-len 0))) + (display sent-count) + (newline) (when (= sent-count -1) (c-perror (string->c-bytevector "socket-send error")) (raise-continuable "socket-send error")) diff --git a/srfi/106/DESCRIPTION b/srfi/106/DESCRIPTION new file mode 100644 index 0000000..5ff20d7 --- /dev/null +++ b/srfi/106/DESCRIPTION @@ -0,0 +1 @@ +(foreign c) SRFI 106: Basic socket interface \ No newline at end of file diff --git a/srfi/106/LICENSE b/srfi/106/LICENSE index 0a04128..447ad67 100644 --- a/srfi/106/LICENSE +++ b/srfi/106/LICENSE @@ -1,165 +1 @@ - GNU LESSER GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/> - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - - This version of the GNU Lesser General Public License incorporates -the terms and conditions of version 3 of the GNU General Public -License, supplemented by the additional permissions listed below. - - 0. Additional Definitions. - - As used herein, "this License" refers to version 3 of the GNU Lesser -General Public License, and the "GNU GPL" refers to version 3 of the GNU -General Public License. - - "The Library" refers to a covered work governed by this License, -other than an Application or a Combined Work as defined below. - - An "Application" is any work that makes use of an interface provided -by the Library, but which is not otherwise based on the Library. -Defining a subclass of a class defined by the Library is deemed a mode -of using an interface provided by the Library. - - A "Combined Work" is a work produced by combining or linking an -Application with the Library. The particular version of the Library -with which the Combined Work was made is also called the "Linked -Version". - - The "Minimal Corresponding Source" for a Combined Work means the -Corresponding Source for the Combined Work, excluding any source code -for portions of the Combined Work that, considered in isolation, are -based on the Application, and not on the Linked Version. - - The "Corresponding Application Code" for a Combined Work means the -object code and/or source code for the Application, including any data -and utility programs needed for reproducing the Combined Work from the -Application, but excluding the System Libraries of the Combined Work. - - 1. Exception to Section 3 of the GNU GPL. - - You may convey a covered work under sections 3 and 4 of this License -without being bound by section 3 of the GNU GPL. - - 2. Conveying Modified Versions. - - If you modify a copy of the Library, and, in your modifications, a -facility refers to a function or data to be supplied by an Application -that uses the facility (other than as an argument passed when the -facility is invoked), then you may convey a copy of the modified -version: - - a) under this License, provided that you make a good faith effort to - ensure that, in the event an Application does not supply the - function or data, the facility still operates, and performs - whatever part of its purpose remains meaningful, or - - b) under the GNU GPL, with none of the additional permissions of - this License applicable to that copy. - - 3. Object Code Incorporating Material from Library Header Files. - - The object code form of an Application may incorporate material from -a header file that is part of the Library. You may convey such object -code under terms of your choice, provided that, if the incorporated -material is not limited to numerical parameters, data structure -layouts and accessors, or small macros, inline functions and templates -(ten or fewer lines in length), you do both of the following: - - a) Give prominent notice with each copy of the object code that the - Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the object code with a copy of the GNU GPL and this license - document. - - 4. Combined Works. - - You may convey a Combined Work under terms of your choice that, -taken together, effectively do not restrict modification of the -portions of the Library contained in the Combined Work and reverse -engineering for debugging such modifications, if you also do each of -the following: - - a) Give prominent notice with each copy of the Combined Work that - the Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the Combined Work with a copy of the GNU GPL and this license - document. - - c) For a Combined Work that displays copyright notices during - execution, include the copyright notice for the Library among - these notices, as well as a reference directing the user to the - copies of the GNU GPL and this license document. - - d) Do one of the following: - - 0) Convey the Minimal Corresponding Source under the terms of this - License, and the Corresponding Application Code in a form - suitable for, and under terms that permit, the user to - recombine or relink the Application with a modified version of - the Linked Version to produce a modified Combined Work, in the - manner specified by section 6 of the GNU GPL for conveying - Corresponding Source. - - 1) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (a) uses at run time - a copy of the Library already present on the user's computer - system, and (b) will operate properly with a modified version - of the Library that is interface-compatible with the Linked - Version. - - e) Provide Installation Information, but only if you would otherwise - be required to provide such information under section 6 of the - GNU GPL, and only to the extent that such information is - necessary to install and execute a modified version of the - Combined Work produced by recombining or relinking the - Application with a modified version of the Linked Version. (If - you use option 4d0, the Installation Information must accompany - the Minimal Corresponding Source and Corresponding Application - Code. If you use option 4d1, you must provide the Installation - Information in the manner specified by section 6 of the GNU GPL - for conveying Corresponding Source.) - - 5. Combined Libraries. - - You may place library facilities that are a work based on the -Library side by side in a single library together with other library -facilities that are not Applications and are not covered by this -License, and convey such a combined library under terms of your -choice, if you do both of the following: - - a) Accompany the combined library with a copy of the same work based - on the Library, uncombined with any other library facilities, - conveyed under the terms of this License. - - b) Give prominent notice with the combined library that part of it - is a work based on the Library, and explaining where to find the - accompanying uncombined form of the same work. - - 6. Revised Versions of the GNU Lesser General Public License. - - The Free Software Foundation may publish revised and/or new versions -of the GNU Lesser General Public License from time to time. Such new -versions will be similar in spirit to the present version, but may -differ in detail to address new problems or concerns. - - Each version is given a distinguishing version number. If the -Library as you received it specifies that a certain numbered version -of the GNU Lesser General Public License "or any later version" -applies to it, you have the option of following the terms and -conditions either of that published version or of any later version -published by the Free Software Foundation. If the Library as you -received it does not specify a version number of the GNU Lesser -General Public License, you may choose any version of the GNU Lesser -General Public License ever published by the Free Software Foundation. - - If the Library as you received it specifies that a proxy can decide -whether future versions of the GNU Lesser General Public License shall -apply, that proxy's public statement of acceptance of any version is -permanent authorization for you to choose that version for the -Library. +LGPL-3.0-or-later diff --git a/srfi/106/test.scm b/srfi/106/test.scm index 54ccc51..23c658d 100644 --- a/srfi/106/test.scm +++ b/srfi/106/test.scm @@ -1,5 +1,33 @@ -(test-begin "srfi-106") +(import (scheme base) + (scheme write) + (scheme read) + (scheme char) + (scheme file) + (scheme process-context) + (retropikzel tap) + (foreign c) + (srfi 64) + (srfi 106)) +(test-runner-current (tap-runner)) + +(test-begin "106") + + +(test-begin "TCP Client") + +(test-begin "URL") +(let ((sock (make-client-socket "tcpbin.com" "4242")) + (msg "Hello world!")) + (socket-send sock (string->utf8 msg)) + (test-equal msg (utf8->string (socket-recv sock (string-length msg)))) + (socket-close)) +(test-begin "URL") + +(test-end "TCP Client") + + +#| (define sock1-port "3005") (define sock2-port "3006") @@ -41,4 +69,6 @@ (write (utf8->string (socket-recv client-sock1 3))) (newline) -(test-end "srfi-106") +|# + +(test-end "106") diff --git a/srfi/170.scm b/srfi/170.scm index ffaa50f..a48e309 100644 --- a/srfi/170.scm +++ b/srfi/170.scm @@ -4,6 +4,7 @@ "string.h" "dirent.h" "sys/stat.h" + "sys/statvfs.h" "sys/types.h" "unistd.h" "pwd.h" @@ -21,6 +22,7 @@ (define-c-procedure c-lstat libc 'stat 'int '(pointer pointer)) (define-c-procedure c-open libc 'open 'int '(pointer int)) (define-c-procedure c-opendir libc 'opendir 'pointer '(pointer)) +(define-c-procedure c-dirfd libc 'dirfd 'int '(pointer)) (define-c-procedure c-readdir libc 'readdir 'pointer '(pointer)) (define-c-procedure c-close libc 'close 'int '(int)) (define-c-procedure c-closedir libc 'closedir 'int '(pointer)) @@ -47,10 +49,51 @@ (define-c-procedure c-link libc 'link 'int '(pointer pointer)) (define-c-procedure c-slink libc 'link 'int '(pointer pointer)) (define-c-procedure c-chown libc 'chown 'int '(pointer int int)) +(define-c-procedure c-clock-gettime libc 'clock_gettime 'int '(int pointer)) +(define-c-procedure c-nice libc 'nice 'int '(int)) +(define-c-procedure c-umask libc 'umask 'uint '(int)) +(define-c-procedure + c-utimensat libc 'utimensat 'int '(int pointer pointer int)) +(define-c-procedure c-truncate libc 'truncate 'int '(pointer int)) +(define-c-procedure c-statvfs libc 'statvfs 'int '(pointer pointer)) (define slash (cond-expand (windows "\\") (else "/"))) (define randomized? #f) +(define (string-split str mark) + (let* ((str-l (string->list str)) + (res (list)) + (last-index 0) + (index 0) + (splitter + (lambda (c) + (cond ((char=? c mark) + (begin + (set! res + (append res + (list (string-copy str last-index index)))) + (set! last-index (+ index 1)))) + ((equal? (length str-l) (+ index 1)) + (set! res + (append res + (list (string-copy str + last-index + (+ index 1))))))) + (set! index (+ index 1))))) + (for-each splitter str-l) + res)) + +(define (string-char-replace replace-in replace-this replace-with) + (let ((result "")) + (list->string + (for-each + (lambda (c) + (if (char=? c replace-this) + (set! result (string-append result replace-with)) + (set! result (string-append result (string c))))) + (string->list replace-in))) + result)) + (define (random-to max) (when (not randomized?) (c-srand (c-time (c-bytevector-null))) @@ -75,8 +118,22 @@ (random-to 128))))))))) (looper "" (random-to 128)))) -(define-record-type file-info-record - (make-file-info-record device inode mode nlinks uid gid rdev size blksize blocks atime mtime ctime fname/port follow?) +(define-record-type <file-info> + (make-file-info device + inode + mode + nlinks + uid + gid + rdev + size + blksize + blocks + atime + mtime + ctime + fname/port + follow?) file-info? (device file-info:device) (inode file-info:inode) @@ -95,129 +152,215 @@ (follow? file-info:follow?)) (define (file-info-directory? file-info) - (let ((handle (c-open (string->c-bytevector (file-info:fname/port file-info)) 2))) - (cond ((> handle 0) (c-close handle) #f) - (else #t)))) + (when (not (file-info? file-info)) + (error "file-info-directory? error: file-info must be <file-info> record" + file-info)) + (let* ((file-info:fname/port* + (string->c-bytevector (file-info:fname/port file-info))) + (handle (c-open file-info:fname/port* 2)) + (result + (cond ((> handle 0) (c-close handle) #f) + (else #t)))) + (c-bytevector-free file-info:fname/port*) + result)) +(define-c-struct-type stat-struct + `((st_dev int) + (st_ino uint) + (st_mode uint) + (st_nlink int) + (st_uid uint) + (st_gid uint) + (st_rdev int) + (st_size int) + (st_blksize int) + (st_blocks int) + (st_atim.tv_sec long) + (st_atim.tv_nsec long) + (st_mtim.tv_sec long) + (st_mtim.tv_nsec long) + (st_ctim.tv_sec long) + (st_ctim.tv_nsec long))) (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-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-bytevector error-message))) + (let* ((fname* (string->c-bytevector fname/port)) + (stat* (make-c-bytevector (c-type-size stat-struct))) + (result (if follow? (c-stat fname* stat*) (c-lstat fname* stat*)))) (when (< result 0) - (c-perror 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)) - #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 2) (native-endianness)) - #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 3) (native-endianness)) - #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 4) (native-endianness)) - #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 5) (native-endianness)) - #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 6) (native-endianness)) - #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 7) (native-endianness)) - #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 8) (native-endianness)) - #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 9) (native-endianness)) - #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 10) (native-endianness)) - #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 11) (native-endianness)) - #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 12) (native-endianness)) - fname/port - follow?))) + (let* ((error-message "file-info error") + (error-msg* (string->c-bytevector error-message))) + (c-perror error-msg*) + (c-bytevector-free fname* stat* error-msg*) + (error error-message fname/port))) + (let ((file-info (make-file-info + (c-bytevector-ref stat* stat-struct 'st_dev) + (c-bytevector-ref stat* stat-struct 'st_ino) + (c-bytevector-ref stat* stat-struct 'st_mode) + (c-bytevector-ref stat* stat-struct 'st_nlink) + (c-bytevector-ref stat* stat-struct 'st_uid) + (c-bytevector-ref stat* stat-struct 'st_gid) + (c-bytevector-ref stat* stat-struct 'st_rdev) + (c-bytevector-ref stat* stat-struct 'st_size) + (c-bytevector-ref stat* stat-struct 'st_blksize) + (c-bytevector-ref stat* stat-struct 'st_blocks) + (make-time time-utc + (c-bytevector-ref stat* stat-struct 'st_atim.tv_sec) + (c-bytevector-ref stat* stat-struct 'st_atim.tv_nsec)) + (make-time time-utc + (c-bytevector-ref stat* stat-struct 'st_mtim.tv_sec) + (c-bytevector-ref stat* stat-struct 'st_mtim.tv_nsec)) + (make-time time-utc + (c-bytevector-ref stat* stat-struct 'st_ctim.tv_sec) + (c-bytevector-ref stat* stat-struct 'st_ctim.tv_nsec)) + fname/port + follow?))) + (c-bytevector-free fname* stat*) + file-info))) (define create-directory (lambda (fname . permission-bits) - (let* ((fname-pointer (string->c-bytevector fname)) + (let* ((fname* (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)) + (result (c-mkdir fname* mode)) (error-message "create-directory error") - (error-pointer (string->c-bytevector error-message))) - (c-bytevector-free fname-pointer) + (error-msg* (string->c-bytevector error-message))) + (c-bytevector-free fname*) (when (< result 0) - (c-perror error-pointer) - (c-bytevector-free error-pointer) + (c-perror error-msg*) + (c-bytevector-free error-msg*) (error error-message)) - (c-bytevector-free error-pointer)))) + (c-bytevector-free error-msg*)))) (define (create-fifo fname . permission-bits) - (let* ((fname-pointer (string->c-bytevector fname)) + (let* ((fname* (string->c-bytevector fname)) (mode (if (null? permission-bits) #o664 (string->number (string-append "#o" (number->string (car permission-bits)))))) - (result (c-mkfifo fname-pointer mode)) + (result (c-mkfifo fname* mode)) (error-message "create-fifo error") - (error-pointer (string->c-bytevector error-message))) - (c-bytevector-free fname-pointer) + (error-msg* (string->c-bytevector error-message))) + (c-bytevector-free fname*) (when (< result 0) - (c-perror error-pointer) - (c-bytevector-free error-pointer) + (c-perror error-msg*) + (c-bytevector-free error-msg*) (error error-message)) - (c-bytevector-free error-pointer))) + (c-bytevector-free error-msg*))) (define (create-hard-link old-fname new-fname) - (c-link (string->c-bytevector old-fname) - (string->c-bytevector new-fname))) + (let ((old-fname* (string->c-bytevector old-fname)) + (new-fname* (string->c-bytevector new-fname))) + (c-link old-fname* new-fname*) + (c-bytevector-free old-fname* new-fname*))) (define (create-symlink old-fname new-fname) (c-slink (string->c-bytevector old-fname) (string->c-bytevector new-fname))) (define (internal-read-symlink fname buffer-length) - (let* ((path-pointer (string->c-bytevector fname)) + (let* ((path* (string->c-bytevector fname)) (buffer (make-c-bytevector buffer-length)) - (result (c-readlink path-pointer buffer (- buffer-length 1))) + (result (c-readlink path* buffer (- buffer-length 1))) (error-message "read-symlink error") - (error-pointer (string->c-bytevector error-message))) + (error-msg* (string->c-bytevector error-message))) (cond ((< result 0) - (c-perror error-pointer) - (c-bytevector-free error-pointer) + (c-perror error-msg*) + (c-bytevector-free error-msg*) (error error-message)) ((> result buffer-length) - (c-bytevector-free path-pointer) + (c-bytevector-free path*) (c-bytevector-free buffer) (internal-read-symlink fname (+ buffer-length buffer-length))) (else (c-bytevector-set! buffer 'u8 result null-byte) (let ((name (c-bytevector->string buffer))) - (c-bytevector-free path-pointer) + (c-bytevector-free path*) (c-bytevector-free buffer) name))))) (define (read-symlink fname) (internal-read-symlink fname 128)) (define (rename-file old-fname new-fname) - (c-rename (string->c-bytevector old-fname) - (string->c-bytevector new-fname))) + (let* ((old-fname* (string->c-bytevector old-fname)) + (new-fname* (string->c-bytevector new-fname))) + (c-rename old-fname* new-fname*) + (c-bytevector-free old-fname* new-fname*))) (define (delete-directory fname) - (let* ((fname-pointer (string->c-bytevector fname)) - (result (c-rmdir fname-pointer)) - (error-message "delete-directory error") - (error-pointer (string->c-bytevector error-message))) - (c-bytevector-free fname-pointer) + (let* ((fname* (string->c-bytevector fname)) + (result (c-rmdir fname*))) + (c-bytevector-free fname*) (when (< result 0) - (c-perror error-pointer) - (c-bytevector-free error-pointer) - (error error-message)))) + (let* ((error-message "delete-directory error") + (error-msg* (string->c-bytevector error-message))) + (c-perror error-msg*) + (c-bytevector-free error-msg*) + (error error-message))))) (define (set-file-owner fname uid gid) - (let ((fname-pointer (string->c-bytevector fname))) - (c-chown fname-pointer uid gid) - (c-bytevector-free fname-pointer))) + (let ((fname* (string->c-bytevector fname))) + (c-chown fname* uid gid) + (c-bytevector-free fname*))) + +(define-c-array-type timespec-array 'long) +(define (set-file-times fname . args) + (when (and (not (= (length args) 0)) + (not (= (length args) 2))) + (error + (string-append "set-file-times error: " + "It is an error if exactly one time is provided"))) + (let* ((current-time (posix-time)) + (access-time-object (if (null? args) + current-time + (car args))) + (modify-time-object (if (or (null? args) + (< (length args) 2)) + current-time + (cadr args))) + (fname-cbv (string->c-bytevector fname)) + (timespecs-cbv (make-c-bytevector (c-type-size* 'long 4))) + (current-dir-cbv (string->c-bytevector (current-directory))) + (current-dir-stream (c-opendir current-dir-cbv)) + (current-dir-fd (c-dirfd current-dir-stream))) + (c-bytevector-set! + timespecs-cbv timespec-array 0 (time-second access-time-object)) + (c-bytevector-set! + timespecs-cbv timespec-array 1 (time-nanosecond access-time-object)) + (c-bytevector-set! + timespecs-cbv timespec-array 2 (time-second modify-time-object)) + (c-bytevector-set! + timespecs-cbv timespec-array 3 (time-nanosecond modify-time-object)) + (let ((result (c-utimensat current-dir-fd fname-cbv timespecs-cbv 0))) + (c-bytevector-free fname-cbv timespecs-cbv current-dir-cbv current-dir-stream) + (when (< result 0) + (let* ((error-message "set-file-times error") + (error-msg*(string->c-bytevector error-message))) + (c-perror error-msg*) + (c-bytevector-free error-msg*) + (error error-message)))))) + +(define (truncate-file fname/port len) + (when (not (exact-integer? len)) + (error "truncate-file error: len must be exact-integer")) + (when (not (string? fname/port)) + (error "truncate-file error: ports not supported yet")) + (let* ((fname/port-cbv (string->c-bytevector fname/port)) + (result (c-truncate fname/port-cbv len))) + (c-bytevector-free fname/port-cbv) + (when (< result 0) + (let* ((error-message "truncate-file error") + (error-msg* (string->c-bytevector error-message))) + (c-perror error-msg*) + (c-bytevector-free error-msg*) + (error error-message))))) (define (pointer-string-read pointer offset) (letrec* ((looper (lambda (c index result) @@ -236,17 +379,17 @@ (define directory-files (lambda (dir . dotfiles?) (letrec* ((include-dotfiles? (if (null? dotfiles?) #f (car dotfiles?))) - (path-pointer (string->c-bytevector dir)) - (directory-pointer (c-opendir path-pointer)) + (path* (string->c-bytevector dir)) + (directory* (c-opendir path*)) (error-message "directory-files error") - (error-pointer (string->c-bytevector error-message)) + (error-msg* (string->c-bytevector error-message)) (dotfile? (lambda (name) (char=? (string-ref name 0) #\.))) (looper (lambda (directory-entity files) (if (c-bytevector-null? directory-entity) files (let ((name (pointer-string-read directory-entity d-name-offset))) - (looper (c-readdir directory-pointer) + (looper (c-readdir directory*) (cond ((string=? name ".") files) ((string=? name "..") files) ((and include-dotfiles? @@ -255,28 +398,19 @@ ((not (dotfile? name)) (cons name files)) (else files)))))))) - (when (c-bytevector-null? directory-pointer) - (c-perror error-pointer) - ;(c-bytevector-free error-pointer) - ;(c-bytevector-free directory) - ;(c-bytevector-free path-pointer) + (when (c-bytevector-null? directory*) + (c-perror error-msg*) + ;(c-bytevector-free error-msg*) + ;(c-bytevector-free directory*) + ;(c-bytevector-free path*) (error error-message)) - (let ((files (looper (c-readdir directory-pointer) (list)))) - ;(c-bytevector-free error-pointer) - ;(c-bytevector-free directory-pointer) - ;(c-bytevector-free path-pointer) - (c-closedir directory-pointer) + (let ((files (looper (c-readdir directory*) (list)))) + ;(c-bytevector-free error-msg*) + ;(c-bytevector-free directory*) + ;(c-bytevector-free path*) + (c-closedir directory*) files)))) -(define real-path - (lambda (path) - (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-bytevector path) (string->number (string-append "#o" (number->string mode))))) @@ -311,6 +445,15 @@ (define (close-directory directory-object) (c-closedir (directory:handle directory-object))) +(define real-path + (lambda (path) + (let* ((path* (string->c-bytevector path)) + (real-path* (c-realpath path* (c-bytevector-null))) + (real-path (string-copy (c-bytevector->string real-path*)))) + (c-bytevector-free path*) + (c-bytevector-free real-path*) + real-path))) + (define temp-file-prefix (make-parameter (if (get-environment-variable "TMPDIR") @@ -327,9 +470,10 @@ (let* ((tmpdir (cond-expand (windows (get-environment-variable "TMP")) (else "/tmp"))) - (real-prefix (if (null? prefix) - (string-append tmpdir slash (number->string (c-getpid))) - (car prefix))) + (real-prefix + (if (null? prefix) + (string-append tmpdir slash (number->string (c-getpid))) + (car prefix))) (path (string-append real-prefix "-" (random-string 6)))) (if (file-exists? path) (create-temp-file real-prefix) @@ -342,48 +486,60 @@ (let* ((tmpdir (cond-expand (windows (get-environment-variable "TMP")) (else "/tmp"))) (real-prefix (if (null? prefix) - (string-append tmpdir slash (number->string (c-getpid))) + (string-append tmpdir + slash + (number->string (c-getpid))) (car prefix))) (path (string-append real-prefix "-" (random-string 6)))) (apply maker (list path)))) +(define (umask) + (let ((mask (c-umask 0))) + (c-umask mask) + mask)) + +(define (set-umask! umask) + (c-umask umask)) + (define (current-directory) - (let* ((path-pointer (make-c-bytevector 1024)) + (let* ((path* (make-c-bytevector 1024)) (path (begin - (c-getcwd path-pointer 1024) - (string-copy (c-bytevector->string path-pointer))))) - (c-bytevector-free path-pointer) + (c-getcwd path* 1024) + (string-copy (c-bytevector->string path*))))) + (c-bytevector-free path*) path)) (define (set-current-directory! path) (c-chdir (string->c-bytevector path))) -(define (pid) - (c-getpid)) +(define (pid) (c-getpid)) -(define (user-uid) - (c-getuid)) +(define nice + (lambda args + (let ((result (if (null? args) (c-nice 1) (c-nice (car args))))) + (when (< result 0) + (let* ((error-message "nice error") + (error-msg* (string->c-bytevector error-message))) + (c-perror error-msg*) + (c-bytevector-free timespec) + (c-bytevector-free error-msg*) + (error error-message))) + result))) +(define (user-uid) (c-getuid)) +(define (user-gid) (c-getgid)) +(define (user-effective-uid) (c-geteuid)) +(define (user-effective-gid) (c-getegid)) -(define (user-gid) - (c-getgid)) - -(define (user-effective-uid) - (c-geteuid)) - -(define (user-effective-gid) - (c-getegid)) - -(define (groups-loop max-count count groups-pointer result) +(define (groups-loop max-count count groups* result) (if (>= count max-count) result (groups-loop max-count (+ count 1) - groups-pointer + groups* (append result - (list (c-bytevector-ref groups-pointer + (list (c-bytevector-ref groups* 'int - (* (c-type-size 'int) count) - )))))) + (* (c-type-size 'int) count))))))) (define (user-supplementary-gids) (let* ((group-count (c-getgroups 0 (c-bytevector-null))) @@ -394,17 +550,40 @@ (define-record-type <user-info> (make-user-info name uid gid home-dir shell full-name) user-info? - (name user-info:name) - (uid user-info:uid) - (gid user-info:gid) - (home-dir user-info:home-dir) - (shell user-info:shell) - (full-name user-info:full-name)) + (name internal-user-info:name) + (uid internal-user-info:uid) + (gid internal-user-info:gid) + (home-dir internal-user-info:home-dir) + (shell internal-user-info:shell) + (full-name internal-user-info:full-name)) + +(define (user-info:name user-info) (internal-user-info:name user-info)) +(define (user-info:uid user-info) (internal-user-info:uid user-info)) +(define (user-info:gid user-info) (internal-user-info:gid user-info)) +(define (user-info:home-dir user-info) (internal-user-info:home-dir user-info)) +(define (user-info:shell user-info) (internal-user-info:shell user-info)) + +(define (user-info:full-name user-info) + (internal-user-info:full-name user-info)) + +(define (user-info:parsed-full-name user-info) + (let* ((parsed-list + (string-split (internal-user-info:full-name user-info) #\,)) + (first + (string-append + (string (char-upcase (string-ref (car parsed-list) 0))) + (string-copy (car parsed-list) 1)))) + (cons (string-char-replace first #\& (user-info:name user-info)) + (cdr parsed-list)))) (define (user-info uid/name) (let ((password-struct (if (number? uid/name) (c-getpwuid uid/name) - (c-getpwnam (string->c-bytevector uid/name))))) + (let* + ((uid/name* (string->c-bytevector uid/name)) + (result (c-getpwnam uid/name*))) + (c-bytevector-free uid/name*) + result)))) (make-user-info (c-bytevector->string (c-bytevector-ref password-struct 'pointer 0)) @@ -446,7 +625,57 @@ (* (c-type-size 'pointer) 2))))) (define (set-environment-variable! name value) - (c-setenv (string->c-bytevector name) (string->c-bytevector value) 1)) + (when (not (string? name)) + (error "set-environment-variable! error: name must be string")) + (when (not (string? value)) + (error "set-environment-variable! error: value must be string")) + (let ((name* (string->c-bytevector name)) + (value* (string->c-bytevector value))) + (c-setenv name* value* 1) + (c-bytevector-free name* value*))) (define (delete-environment-variable! name) + (when (not (string? name)) + (error "delete-environment-variable! error: Name must be string")) (c-unsetenv (string->c-bytevector name))) + +(define CLOCK_REALTIME 0) +(define CLOCK_MONOTONIC 1) +(define tv_sec-type 'long) +(define tv_nsec-type 'long) +(define timespec (make-c-bytevector (c-type-size+ tv_sec-type tv_nsec-type))) + +(define (posix-time) + (let* ((result (c-clock-gettime CLOCK_REALTIME timespec))) + (cond + ((< result 0) + (let* ((error-message "posix-time error") + (error-msg* (string->c-bytevector error-message))) + (c-perror error-msg*) + (c-bytevector-free timespec) + (c-bytevector-free error-msg*) + (error error-message))) + (else + (make-time time-utc + (c-bytevector-ref timespec + tv_nsec-type + (c-type-size tv_sec-type)) + (c-bytevector-ref timespec tv_sec-type 0)))))) + +(define (monotonic-time) + (let* ((result (c-clock-gettime CLOCK_MONOTONIC timespec))) + (cond + ((< result 0) + (let* ((error-message "posix-time error") + (error-msg* (string->c-bytevector error-message))) + (c-perror error-msg*) + (c-bytevector-free timespec) + (c-bytevector-free error-msg*) + (error error-message))) + (else + (make-time time-utc + (c-bytevector-ref timespec + tv_nsec-type + (c-type-size tv_sec-type)) + (c-bytevector-ref timespec tv_sec-type 0)))))) + diff --git a/srfi/170.sld b/srfi/170.sld index 898cead..6b5920a 100644 --- a/srfi/170.sld +++ b/srfi/170.sld @@ -5,7 +5,8 @@ (scheme write) (scheme file) (scheme process-context) - (foreign c)) + (foreign c) + (srfi 19)) (export ;posix-error? ;posix-error-name ;posix-error-message @@ -19,23 +20,23 @@ rename-file delete-directory set-file-owner - ;set-file-times - ;truncate-file + set-file-times + truncate-file file-info file-info? - ;file-info:device - ;file-info:inode - ;file-info:mode - ;file-info:nlinks - ;file-info:uid - ;file-info:gid - ;file-info:rdev - ;file-info:size - ;file-info:blksize - ;file-info:blocks - ;file-info:atime - ;file-info:mtime - ;file-info:ctime + file-info:device + file-info:inode + file-info:mode + file-info:nlinks + file-info:uid + file-info:gid + file-info:rdev + file-info:size + file-info:blksize + file-info:blocks + file-info:atime + file-info:mtime + file-info:ctime file-info-directory? ;file-info-fifo? ;file-info-symlink? @@ -48,17 +49,17 @@ open-directory read-directory close-directory - ;real-path + real-path ;file-space temp-file-prefix create-temp-file call-with-temporary-filename - ;umask - ;set-umask! + umask + set-umask! current-directory set-current-directory! pid - ;nice + nice user-uid user-gid user-effective-uid @@ -72,13 +73,13 @@ user-info:home-dir user-info:shell user-info:full-name - ;user-info:parsed-full-name + user-info:parsed-full-name group-info group-info? group-info:name group-info:gid - ;posix-time - ;monotonic-time + posix-time + monotonic-time set-environment-variable! delete-environment-variable! ;terminal? diff --git a/srfi/170/DESCRIPTION b/srfi/170/DESCRIPTION new file mode 100644 index 0000000..911aefd --- /dev/null +++ b/srfi/170/DESCRIPTION @@ -0,0 +1 @@ +(foreign c) SRFI 170: POSIX API \ No newline at end of file diff --git a/srfi/170/LICENSE b/srfi/170/LICENSE index 0a04128..447ad67 100644 --- a/srfi/170/LICENSE +++ b/srfi/170/LICENSE @@ -1,165 +1 @@ - GNU LESSER GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/> - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - - This version of the GNU Lesser General Public License incorporates -the terms and conditions of version 3 of the GNU General Public -License, supplemented by the additional permissions listed below. - - 0. Additional Definitions. - - As used herein, "this License" refers to version 3 of the GNU Lesser -General Public License, and the "GNU GPL" refers to version 3 of the GNU -General Public License. - - "The Library" refers to a covered work governed by this License, -other than an Application or a Combined Work as defined below. - - An "Application" is any work that makes use of an interface provided -by the Library, but which is not otherwise based on the Library. -Defining a subclass of a class defined by the Library is deemed a mode -of using an interface provided by the Library. - - A "Combined Work" is a work produced by combining or linking an -Application with the Library. The particular version of the Library -with which the Combined Work was made is also called the "Linked -Version". - - The "Minimal Corresponding Source" for a Combined Work means the -Corresponding Source for the Combined Work, excluding any source code -for portions of the Combined Work that, considered in isolation, are -based on the Application, and not on the Linked Version. - - The "Corresponding Application Code" for a Combined Work means the -object code and/or source code for the Application, including any data -and utility programs needed for reproducing the Combined Work from the -Application, but excluding the System Libraries of the Combined Work. - - 1. Exception to Section 3 of the GNU GPL. - - You may convey a covered work under sections 3 and 4 of this License -without being bound by section 3 of the GNU GPL. - - 2. Conveying Modified Versions. - - If you modify a copy of the Library, and, in your modifications, a -facility refers to a function or data to be supplied by an Application -that uses the facility (other than as an argument passed when the -facility is invoked), then you may convey a copy of the modified -version: - - a) under this License, provided that you make a good faith effort to - ensure that, in the event an Application does not supply the - function or data, the facility still operates, and performs - whatever part of its purpose remains meaningful, or - - b) under the GNU GPL, with none of the additional permissions of - this License applicable to that copy. - - 3. Object Code Incorporating Material from Library Header Files. - - The object code form of an Application may incorporate material from -a header file that is part of the Library. You may convey such object -code under terms of your choice, provided that, if the incorporated -material is not limited to numerical parameters, data structure -layouts and accessors, or small macros, inline functions and templates -(ten or fewer lines in length), you do both of the following: - - a) Give prominent notice with each copy of the object code that the - Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the object code with a copy of the GNU GPL and this license - document. - - 4. Combined Works. - - You may convey a Combined Work under terms of your choice that, -taken together, effectively do not restrict modification of the -portions of the Library contained in the Combined Work and reverse -engineering for debugging such modifications, if you also do each of -the following: - - a) Give prominent notice with each copy of the Combined Work that - the Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the Combined Work with a copy of the GNU GPL and this license - document. - - c) For a Combined Work that displays copyright notices during - execution, include the copyright notice for the Library among - these notices, as well as a reference directing the user to the - copies of the GNU GPL and this license document. - - d) Do one of the following: - - 0) Convey the Minimal Corresponding Source under the terms of this - License, and the Corresponding Application Code in a form - suitable for, and under terms that permit, the user to - recombine or relink the Application with a modified version of - the Linked Version to produce a modified Combined Work, in the - manner specified by section 6 of the GNU GPL for conveying - Corresponding Source. - - 1) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (a) uses at run time - a copy of the Library already present on the user's computer - system, and (b) will operate properly with a modified version - of the Library that is interface-compatible with the Linked - Version. - - e) Provide Installation Information, but only if you would otherwise - be required to provide such information under section 6 of the - GNU GPL, and only to the extent that such information is - necessary to install and execute a modified version of the - Combined Work produced by recombining or relinking the - Application with a modified version of the Linked Version. (If - you use option 4d0, the Installation Information must accompany - the Minimal Corresponding Source and Corresponding Application - Code. If you use option 4d1, you must provide the Installation - Information in the manner specified by section 6 of the GNU GPL - for conveying Corresponding Source.) - - 5. Combined Libraries. - - You may place library facilities that are a work based on the -Library side by side in a single library together with other library -facilities that are not Applications and are not covered by this -License, and convey such a combined library under terms of your -choice, if you do both of the following: - - a) Accompany the combined library with a copy of the same work based - on the Library, uncombined with any other library facilities, - conveyed under the terms of this License. - - b) Give prominent notice with the combined library that part of it - is a work based on the Library, and explaining where to find the - accompanying uncombined form of the same work. - - 6. Revised Versions of the GNU Lesser General Public License. - - The Free Software Foundation may publish revised and/or new versions -of the GNU Lesser General Public License from time to time. Such new -versions will be similar in spirit to the present version, but may -differ in detail to address new problems or concerns. - - Each version is given a distinguishing version number. If the -Library as you received it specifies that a certain numbered version -of the GNU Lesser General Public License "or any later version" -applies to it, you have the option of following the terms and -conditions either of that published version or of any later version -published by the Free Software Foundation. If the Library as you -received it does not specify a version number of the GNU Lesser -General Public License, you may choose any version of the GNU Lesser -General Public License ever published by the Free Software Foundation. - - If the Library as you received it specifies that a proxy can decide -whether future versions of the GNU Lesser General Public License shall -apply, that proxy's public statement of acceptance of any version is -permanent authorization for you to choose that version for the -Library. +LGPL-3.0-or-later diff --git a/srfi/170/README.md b/srfi/170/README.md index 9d09ba4..e062fd9 100644 --- a/srfi/170/README.md +++ b/srfi/170/README.md @@ -1,83 +1,9 @@ -Implementation of [SRFI 170](https://srfi.schemers.org/srfi-170/srfi-170.html) -POSIX API using (foreign c)]. +Implementation of SRFI 170 - POSIX API using (foreign c) + +Not everything is implemented yet, see 170.sld for commented out parts Currently only supports Linux. -Uncommented things here are implemented. +## Documentation - ;;;;posix-error? - ;;;;posix-error-name - ;;;;posix-error-message - ;;;;open-file - ;;;;fd->port - create-directory - ;;;;create-fifo - create-hard-link - create-symlink - ;;;;read-symlink - ;;;;rename-file - delete-directory - ;;;;set-file-owner - ;;;;set-file-times - ;;;;truncate-file - file-info - file-info? - ;;;;file-info:device - ;;;;file-info:inode - ;;;;file-info:mode - ;;;;file-info:nlinks - ;;;;file-info:uid - ;;;;file-info:gid - ;;;;file-info:rdev - ;;;;file-info:size - ;;;;file-info:blksize - ;;;;file-info:blocks - ;;;;file-info:atime - ;;;;file-info:mtime - ;;;;file-info:ctime - file-info-directory? - ;;;;file-info-fifo? - ;;;;file-info-symlink? - ;;;;file-info-regular? - ;;;;file-info-socket? - ;;;;file-info-device? - set-file-mode - directory-files - ;;;;make-directory-files-generator - open-directory - read-directory - close-directory - real-path - ;;;;file-space - temp-file-prefix - create-temp-file - call-with-temporary-filename - ;;;;umask - ;;;;set-umask! - current-directory - set-current-directory! - pid - ;;;;nice - user-uid - user-gid - user-effective-uid - user-effective-gid - user-supplementary-gids - user-info - user-info? - user-info:name - user-info:uid - user-info:gid - user-info:home-dir - user-info:shell - user-info:full-name - ;;;;user-info:parsed-full-name - group-info - group-info? - group-info:name - group-info:gid - ;;;;posix-time - ;;;;monotonic-time - set-environment-variable! - delete-environment-variable! - ;;;;terminal? +See [https://srfi.schemers.org/srfi-170/srfi-170.html](https://srfi.schemers.org/srfi-170/srfi-170.html) diff --git a/srfi/170/VERSION b/srfi/170/VERSION index 845639e..3a4036f 100644 --- a/srfi/170/VERSION +++ b/srfi/170/VERSION @@ -1 +1 @@ -0.1.4 +0.2.5 diff --git a/srfi/170/test.scm b/srfi/170/test.scm index 5228fe7..d479c4a 100644 --- a/srfi/170/test.scm +++ b/srfi/170/test.scm @@ -1,12 +1,41 @@ +(import (scheme base) + (scheme write) + (scheme read) + (scheme char) + (scheme file) + (scheme process-context) + (retropikzel tap) + (foreign c) + (srfi 64) + (srfi 170)) + (test-begin "srfi-170") -;(display (real-path "Makefile")) -;(newline) +(write (posix-time)) +(newline) -;(exit 0) +(write (monotonic-time)) +(newline) +(define niceness (nice 1)) +(test-assert (number? niceness)) +(test-assert (> niceness 0)) + +(define fi (file-info "/tmp" #f)) +(write fi) +(newline) +(write (file-info:mode fi)) +(newline) + + +#| (define tmp-dir "/tmp/foreign-c-srfi-170") -(when (file-exists? tmp-dir) (delete-directory tmp-dir)) +(for-each + (lambda (file) + (delete-file (string-append tmp-dir "/" file))) + (directory-files tmp-dir #t)) +(when (file-exists? tmp-dir) + (delete-directory tmp-dir)) (create-directory tmp-dir) (define tmp-file (string-append tmp-dir "/test.txt")) @@ -145,5 +174,7 @@ (display "file-info-directory? on file: ") (write (file-info-directory? tmp-file-info)) (newline) +|# -(test-begin "srfi-170") + +(test-end "srfi-170") diff --git a/test-headers.sps b/test-headers.sps index 788aba2..c0fcc90 100644 --- a/test-headers.sps +++ b/test-headers.sps @@ -1,4 +1,4 @@ (import (rnrs) (srfi :64) (foreign c) - (srfi SRFI)) + (srfi :SRFI)) diff --git a/test.scm b/test.scm new file mode 100644 index 0000000..d479c4a --- /dev/null +++ b/test.scm @@ -0,0 +1,180 @@ +(import (scheme base) + (scheme write) + (scheme read) + (scheme char) + (scheme file) + (scheme process-context) + (retropikzel tap) + (foreign c) + (srfi 64) + (srfi 170)) + +(test-begin "srfi-170") + +(write (posix-time)) +(newline) + +(write (monotonic-time)) +(newline) + +(define niceness (nice 1)) +(test-assert (number? niceness)) +(test-assert (> niceness 0)) + +(define fi (file-info "/tmp" #f)) +(write fi) +(newline) +(write (file-info:mode fi)) +(newline) + + +#| +(define tmp-dir "/tmp/foreign-c-srfi-170") +(for-each + (lambda (file) + (delete-file (string-append tmp-dir "/" file))) + (directory-files tmp-dir #t)) +(when (file-exists? tmp-dir) + (delete-directory tmp-dir)) +(create-directory tmp-dir) + +(define tmp-file (string-append tmp-dir "/test.txt")) +(when (file-exists? tmp-file) (delete-file tmp-file)) + +(with-output-to-file + tmp-file + (lambda () + (display "Hello") + (newline))) + +(define tmp-dotfile (string-append tmp-dir "/.dot.txt")) +(when (file-exists? tmp-dotfile) (delete-file tmp-dotfile)) + +(with-output-to-file + tmp-dotfile + (lambda () + (display "Dot") + (newline))) + +(define tmp-dir-info (file-info tmp-dir #f)) +(define tmp-file-info (file-info tmp-file #f)) +(define tmp-dotfile-info (file-info tmp-dotfile #f)) + +(set-file-mode tmp-file 0755) + + +(define dir1 (open-directory tmp-dir)) +(write (read-directory dir1)) +(newline) +(write (read-directory dir1)) +(newline) +(write (read-directory dir1)) +(newline) +(close-directory dir1) + +(define dir2 (open-directory tmp-dir #t)) +(write (read-directory dir2)) +(newline) +(write (read-directory dir2)) +(newline) +(write (read-directory dir2)) +(newline) +(close-directory dir2) + +(display "temp-file-prefix: ") +(display (temp-file-prefix)) +(newline) + +(display "create-temp-file: ") +(define tf1 (create-temp-file)) +(display tf1) +(newline) + +(display "create-temp-file, with prefix lol: ") +(define tf2 (create-temp-file "/tmp/lol")) +(display tf2) +(newline) + +(call-with-temporary-filename + (lambda (path) + (display "call-with-temporary-filename, path: ") + (display path) + (newline))) + +(display "Current directory: ") +(display (current-directory)) +(newline) + +(set-current-directory! "/tmp") +(display "Current directory: ") +(display (current-directory)) +(newline) + +(display "pid: ") +(display (pid)) +(newline) + +(display "uid: ") +(display (user-uid)) +(newline) + +(display "gid: ") +(display (user-gid)) +(newline) + +(display "euid: ") +(display (user-effective-uid)) +(newline) + +(display "egid: ") +(display (user-effective-gid)) +(newline) + +(display "user-supplementary-gids: ") +(display (user-supplementary-gids)) +(newline) + +(display "user-info, uid 0: ") +(display (user-info 0)) +(newline) + +(display "user-info, name root: ") +(display (user-info "root")) +(newline) + +(display "group-info: ") +(display (group-info "root")) +(newline) + +(display "set-environment-variable! lol=lel ") +(newline) +(set-environment-variable! "lol" "lel") + +;(display "get-environment-variable lol: ") +;(display (get-environment-variable "lol")) +;(newline) + +(define movefile "/tmp/test1.txt") +(with-output-to-file + movefile + (lambda () + (display "Hello") + (newline))) + +(rename-file movefile "/tmp/test2.txt") + +(display "File /tmp/test2.txt exists? ") +(display (file-exists? "/tmp/test2.txt")) +(newline) + +(display "file-info-directory? on dir: ") +(write (file-info-directory? tmp-dir-info)) +(newline) + +(display "file-info-directory? on file: ") +(write (file-info-directory? tmp-file-info)) +(newline) +|# + + +(test-end "srfi-170")