Making the infrastructure
This commit is contained in:
commit
85007b2d38
|
|
@ -0,0 +1,46 @@
|
||||||
|
ARG SCHEME=chibi
|
||||||
|
ARG IMAGE=${SCHEME}:head
|
||||||
|
FROM debian:trixie AS build
|
||||||
|
RUN apt-get update && apt-get install -y \
|
||||||
|
git ca-certificates make gcc libffi-dev libffi-dev wget xz-utils libcurl4
|
||||||
|
RUN mkdir ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
|
||||||
|
WORKDIR /build
|
||||||
|
RUN wget https://gitlab.com/-/project/6808260/uploads/094ce726ce3c6cf8c14560f1e31aaea0/akku-1.1.0.amd64-linux.tar.xz \
|
||||||
|
&& tar -xf akku-1.1.0.amd64-linux.tar.xz \
|
||||||
|
&& mv akku-1.1.0.amd64-linux akku
|
||||||
|
RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1
|
||||||
|
RUN git clone https://codeberg.org/retropikzel/compile-scheme.git --depth=1
|
||||||
|
WORKDIR /build/chibi-scheme
|
||||||
|
RUN make
|
||||||
|
RUN make install
|
||||||
|
WORKDIR /build/compile-scheme
|
||||||
|
RUN make build-gauche
|
||||||
|
WORKDIR /build
|
||||||
|
RUN git clone https://codeberg.org/foreign-c/foreign-c.git --depth=2
|
||||||
|
|
||||||
|
ARG SCHEME=chibi
|
||||||
|
ARG IMAGE=${SCHEME}:head
|
||||||
|
FROM schemers/${IMAGE}
|
||||||
|
RUN apt-get update && apt-get install -y make gcc libffi-dev libcurl4 gauche
|
||||||
|
RUN mkdir ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
|
||||||
|
COPY --from=build /build /build
|
||||||
|
ARG SCHEME=chibi
|
||||||
|
WORKDIR /build/compile-scheme
|
||||||
|
RUN make install
|
||||||
|
WORKDIR /build/chibi-scheme
|
||||||
|
RUN make install
|
||||||
|
WORKDIR /build/chibi-scheme
|
||||||
|
RUN make install
|
||||||
|
WORKDIR /build/akku
|
||||||
|
RUN bash install.sh
|
||||||
|
ENV PATH=/root/.local/bin:${PATH}
|
||||||
|
RUN akku update
|
||||||
|
WORKDIR /build/foreign-c
|
||||||
|
RUN if [ ! "${SCHEME}" = "racket" ]; then timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(srfi 64)"; fi
|
||||||
|
RUN if [ ! "${SCHEME}" = "larceny" ]; then timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(foreign c)"; fi
|
||||||
|
RUN make SCHEME=${SCHEME} build install
|
||||||
|
WORKDIR /workdir
|
||||||
|
RUN cp -r /build/foreign-c/foreign .
|
||||||
|
COPY Makefile .
|
||||||
|
COPY srfi srfi/
|
||||||
|
|
||||||
|
|
@ -0,0 +1,70 @@
|
||||||
|
pipeline {
|
||||||
|
agent {
|
||||||
|
docker {
|
||||||
|
label 'docker-x86_64'
|
||||||
|
image 'debian'
|
||||||
|
args '--user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock'
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
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: '170', description: '')
|
||||||
|
}
|
||||||
|
|
||||||
|
stages {
|
||||||
|
stage('Init') {
|
||||||
|
steps {
|
||||||
|
sh "apt-get update && apt-get install -y make docker.io git"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
stage('Tests') {
|
||||||
|
parallel {
|
||||||
|
stage('R6RS x86_64 Debian') {
|
||||||
|
steps {
|
||||||
|
script {
|
||||||
|
params.SRFIS.split().each { SRFI ->
|
||||||
|
params.R6RS_SCHEMES.split().each { SCHEME ->
|
||||||
|
def IMG="${SCHEME}:head"
|
||||||
|
stage("${SCHEME} - ${SRFI}") {
|
||||||
|
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
|
||||||
|
sh "timeout 600 make SCHEME=${SCHEME} SRFI=${SRFI} test-r6rs-docker"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
stage('R7RS x86_64 Debian') {
|
||||||
|
steps {
|
||||||
|
script {
|
||||||
|
params.SRFIS.split().each { SRFI ->
|
||||||
|
params.R7RS_SCHEMES.split().each { SCHEME ->
|
||||||
|
def IMG="${SCHEME}:head"
|
||||||
|
if("${SCHEME}" == "chicken") {
|
||||||
|
IMG="${SCHEME}:5"
|
||||||
|
}
|
||||||
|
stage("${SCHEME} - ${SRFI}") {
|
||||||
|
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
|
||||||
|
sh "timeout 600 make SCHEME=${SCHEME} SRFI=${SRFI} test-r7rs-docker"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,54 @@
|
||||||
|
.SILENT: build install test test-docker clean
|
||||||
|
.PHONY: test-r6rs test-r7rs
|
||||||
|
SCHEME=chibi
|
||||||
|
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
|
||||||
|
|
||||||
|
PKG=srfi-${SRFI}-${VERSION}.tgz
|
||||||
|
|
||||||
|
DOCKERIMG=${SCHEME}:head
|
||||||
|
ifeq "${SCHEME}" "chicken"
|
||||||
|
DOCKERIMG="chicken:5"
|
||||||
|
endif
|
||||||
|
|
||||||
|
all: build
|
||||||
|
|
||||||
|
build: srfi/${SRFI}/LICENSE srfi/${SRFI}/VERSION
|
||||||
|
echo "<pre>$$(cat srfi/${SRFI}/README.md)</pre>" > ${README}
|
||||||
|
snow-chibi package --version=${VERSION} --authors=${AUTHOR} --doc=${README} --description="${DESCRIPTION}" ${SRFI_FILE}
|
||||||
|
|
||||||
|
install:
|
||||||
|
snow-chibi install --impls=${SCHEME} ${SNOW_CHIBI_ARGS} ${PKG}
|
||||||
|
|
||||||
|
uninstall:
|
||||||
|
-snow-chibi remove --impls=${SCHEME} ${PKG}
|
||||||
|
|
||||||
|
test-r7rs:
|
||||||
|
echo "(import (scheme base) (scheme write) (scheme file) (scheme process-context) (srfi ${SRFI}) (srfi 64))" > test-r7rs.scm
|
||||||
|
cat srfi/${SRFI}/test.scm >> test-r7rs.scm
|
||||||
|
COMPILE_R7RS=${SCHEME} compile-scheme -I . -o test-r7rs test-r7rs.scm
|
||||||
|
printf "\n" | ./test-r7rs
|
||||||
|
|
||||||
|
test-r7rs-docker:
|
||||||
|
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-srfi-test-${SCHEME} .
|
||||||
|
docker run -t foreign-c-srfi-test-${SCHEME} sh -c "make SCHEME=${SCHEME} SRFI=${SRFI} SNOW_CHIBI_ARGS=--always-yes build install test-r7rs"
|
||||||
|
|
||||||
|
test-r6rs:
|
||||||
|
echo "(import (rnrs) (srfi ${SRFI}) (srfi :64))" > test-r6rs.sps
|
||||||
|
cat srfi/${SRFI}/test.scm >> test-r6rs.sps
|
||||||
|
akku install chez-srfi akku-r7rs "(foreign c)"
|
||||||
|
COMPILE_R7RS=${SCHEME} compile-scheme -I .akku/lib -o test-r6rs test-r6rs.sps
|
||||||
|
./test-r6rs
|
||||||
|
|
||||||
|
test-r6rs-docker:
|
||||||
|
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-srfi-test-${SCHEME} .
|
||||||
|
docker run -t foreign-c-srfi-test-${SCHEME} sh -c "make SCHEME=${SCHEME} SRFI=${SRFI} test-r6rs"
|
||||||
|
|
||||||
|
clean:
|
||||||
|
git clean -X -f
|
||||||
|
|
@ -0,0 +1,403 @@
|
||||||
|
(define-c-library libc
|
||||||
|
'("stdlib.h"
|
||||||
|
"stdio.h"
|
||||||
|
"string.h"
|
||||||
|
"dirent.h"
|
||||||
|
"sys/stat.h"
|
||||||
|
"sys/types.h"
|
||||||
|
"unistd.h"
|
||||||
|
"pwd.h"
|
||||||
|
"grp.h"
|
||||||
|
"fcntl.h")
|
||||||
|
libc-name
|
||||||
|
'((additional-versions ("0" "6"))))
|
||||||
|
|
||||||
|
(define-c-procedure c-perror libc 'perror 'void '(pointer))
|
||||||
|
(define-c-procedure c-mkdir libc 'mkdir 'int '(pointer int))
|
||||||
|
(define-c-procedure c-rmdir libc 'rmdir 'int '(pointer))
|
||||||
|
(define-c-procedure c-stat libc 'stat 'int '(pointer pointer))
|
||||||
|
(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-readdir libc 'readdir 'pointer '(pointer))
|
||||||
|
(define-c-procedure c-close libc 'close 'int '(int))
|
||||||
|
(define-c-procedure c-closedir libc 'closedir 'int '(pointer))
|
||||||
|
(define-c-procedure c-realpath libc 'realpath 'pointer '(pointer pointer))
|
||||||
|
(define-c-procedure c-chmod libc 'chmod 'int '(pointer int))
|
||||||
|
(define-c-procedure c-getpid libc 'getpid 'int '())
|
||||||
|
(define-c-procedure c-time libc 'time 'int '(pointer))
|
||||||
|
(define-c-procedure c-srand libc 'srand 'void '(int))
|
||||||
|
(define-c-procedure c-rand libc 'rand 'int '())
|
||||||
|
(define-c-procedure c-getcwd libc 'getcwd 'pointer '(pointer int))
|
||||||
|
(define-c-procedure c-chdir libc 'chdir 'int '(pointer))
|
||||||
|
(define-c-procedure c-getuid libc 'getuid 'int '())
|
||||||
|
(define-c-procedure c-getgid libc 'getgid 'int '())
|
||||||
|
(define-c-procedure c-geteuid libc 'geteuid 'int '())
|
||||||
|
(define-c-procedure c-getegid libc 'getegid 'int '())
|
||||||
|
(define-c-procedure c-getgroups libc 'getgroups 'int '(int pointer))
|
||||||
|
(define-c-procedure c-getpwuid libc 'getpwuid 'pointer '(int))
|
||||||
|
(define-c-procedure c-getpwnam libc 'getpwnam 'pointer '(pointer))
|
||||||
|
(define-c-procedure c-getgrgid libc 'getgrgid 'pointer '(int))
|
||||||
|
(define-c-procedure c-getgrnam libc 'getgrnam 'pointer '(pointer))
|
||||||
|
(define-c-procedure c-setenv libc 'setenv 'int '(pointer pointer int))
|
||||||
|
(define-c-procedure c-unsetenv libc 'unsetenv 'int '(pointer))
|
||||||
|
(define-c-procedure c-rename libc 'rename 'int '(pointer pointer))
|
||||||
|
(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 slash (cond-expand (windows "\\") (else "/")))
|
||||||
|
(define randomized? #f)
|
||||||
|
|
||||||
|
(define (random-to max)
|
||||||
|
(when (not randomized?)
|
||||||
|
(c-srand (c-time (make-c-null)))
|
||||||
|
(set! randomized? #t))
|
||||||
|
(modulo (c-rand) max))
|
||||||
|
|
||||||
|
(define (random-string size)
|
||||||
|
(letrec
|
||||||
|
((looper
|
||||||
|
(lambda (result integer)
|
||||||
|
(cond ((= (string-length result) size) result)
|
||||||
|
((or (< integer 0)
|
||||||
|
(> integer 128))
|
||||||
|
(looper result (random-to 128)))
|
||||||
|
(else
|
||||||
|
(let ((char (integer->char integer)))
|
||||||
|
(if (not (or (char-alphabetic? char)
|
||||||
|
(char-numeric? char)))
|
||||||
|
(looper result (c-rand))
|
||||||
|
(looper (string-append result
|
||||||
|
(string (integer->char integer)))
|
||||||
|
(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?)
|
||||||
|
file-info?
|
||||||
|
(device file-info:device)
|
||||||
|
(inode file-info:inode)
|
||||||
|
(mode file-info:mode)
|
||||||
|
(nlinks file-info:nlinks)
|
||||||
|
(uid file-info:uid)
|
||||||
|
(gid file-info:gid)
|
||||||
|
(rdev file-info:rdev)
|
||||||
|
(size file-info:size)
|
||||||
|
(blksize file-info:blksize)
|
||||||
|
(blocks file-info:blocks)
|
||||||
|
(atime file-info:atime)
|
||||||
|
(mtime file-info:mtime)
|
||||||
|
(ctime file-info:ctime)
|
||||||
|
(fname/port file-info:fname/port)
|
||||||
|
(follow? file-info:follow?))
|
||||||
|
|
||||||
|
(define (file-info-directory? file-info)
|
||||||
|
(let ((handle (c-open (string->c-utf8 (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))
|
||||||
|
(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)))
|
||||||
|
(when (< result 0)
|
||||||
|
(c-perror error-pointer)
|
||||||
|
(c-free fname-pointer)
|
||||||
|
(c-free stat-pointer)
|
||||||
|
(c-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?)))
|
||||||
|
|
||||||
|
(define create-directory
|
||||||
|
(lambda (fname . permission-bits)
|
||||||
|
(let* ((fname-pointer (string->c-utf8 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)
|
||||||
|
(when (< result 0)
|
||||||
|
(c-perror error-pointer)
|
||||||
|
(c-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)))
|
||||||
|
|
||||||
|
(define (create-symlink old-fname new-fname)
|
||||||
|
(c-slink (string->c-utf8 old-fname)
|
||||||
|
(string->c-utf8 new-fname)))
|
||||||
|
|
||||||
|
(define (rename-file old-fname new-fname)
|
||||||
|
(c-rename (string->c-utf8 old-fname) (string->c-utf8 new-fname)))
|
||||||
|
|
||||||
|
(define (delete-directory fname)
|
||||||
|
(let* ((fname-pointer (string->c-utf8 fname))
|
||||||
|
(result (c-rmdir fname-pointer))
|
||||||
|
(error-message "delete-directory error")
|
||||||
|
(error-pointer (string->c-utf8 error-message)))
|
||||||
|
(c-free fname-pointer)
|
||||||
|
(when (< result 0)
|
||||||
|
(c-perror error-pointer)
|
||||||
|
(c-free error-pointer)
|
||||||
|
(error error-message))))
|
||||||
|
|
||||||
|
(define (set-file-owner fname uid gid)
|
||||||
|
(let ((fname-pointer (string->c-utf8 fname)))
|
||||||
|
(c-chown fname-pointer uid gid)
|
||||||
|
(c-free fname-pointer)))
|
||||||
|
|
||||||
|
(define (pointer-string-read pointer offset)
|
||||||
|
(letrec* ((looper (lambda (c index result)
|
||||||
|
(if (char=? c #\null)
|
||||||
|
(list->string (reverse result))
|
||||||
|
(looper (c-bytevector-char-ref pointer
|
||||||
|
(+ offset index))
|
||||||
|
(+ index 1)
|
||||||
|
(cons c result))))))
|
||||||
|
(looper (c-bytevector-char-ref pointer offset) 1 (list))))
|
||||||
|
|
||||||
|
; struct dirent d_name offset on linux
|
||||||
|
(define d-name-offset 19)
|
||||||
|
|
||||||
|
(define directory-files
|
||||||
|
(lambda (dir . dotfiles?)
|
||||||
|
(letrec* ((include-dotfiles? (if (null? dotfiles?) #f (car dotfiles?)))
|
||||||
|
(path-pointer (string->c-utf8 dir))
|
||||||
|
(directory-pointer (c-opendir path-pointer))
|
||||||
|
(error-message "directory-files error")
|
||||||
|
(error-pointer (string->c-utf8 error-message))
|
||||||
|
(dotfile? (lambda (name) (char=? (string-ref name 0) #\.)))
|
||||||
|
(looper (lambda (directory-entity files)
|
||||||
|
(if (c-null? directory-entity)
|
||||||
|
files
|
||||||
|
(let ((name (pointer-string-read directory-entity
|
||||||
|
d-name-offset)))
|
||||||
|
(looper (c-readdir directory-pointer)
|
||||||
|
(cond ((string=? name ".") files)
|
||||||
|
((string=? name "..") files)
|
||||||
|
((and include-dotfiles?
|
||||||
|
(dotfile? name))
|
||||||
|
(cons name files))
|
||||||
|
((not (dotfile? name))
|
||||||
|
(cons name files))
|
||||||
|
(else files))))))))
|
||||||
|
(when (c-null? directory-pointer)
|
||||||
|
(c-perror error-pointer)
|
||||||
|
;(c-free error-pointer)
|
||||||
|
;(c-free directory)
|
||||||
|
;(c-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-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)
|
||||||
|
real-path)))
|
||||||
|
|
||||||
|
(define (set-file-mode path mode)
|
||||||
|
(c-chmod (string->c-utf8 path)
|
||||||
|
(string->number (string-append "#o" (number->string mode)))))
|
||||||
|
|
||||||
|
(define-record-type <directory>
|
||||||
|
(make-directory handle dot-files?)
|
||||||
|
directory?
|
||||||
|
(handle directory:handle)
|
||||||
|
(dot-files? directory:dot-files?))
|
||||||
|
|
||||||
|
(define (open-directory path . dot-files?)
|
||||||
|
(make-directory (c-opendir (string->c-utf8 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)
|
||||||
|
(eof-object)
|
||||||
|
(let ((name (pointer-string-read directory-entity d-name-offset)))
|
||||||
|
(cond ((or (string=? name ".")
|
||||||
|
(string=? name ".."))
|
||||||
|
(read-directory directory-object))
|
||||||
|
((and (directory:dot-files? directory-object)
|
||||||
|
(char=? (string-ref name 0) #\.))
|
||||||
|
name)
|
||||||
|
((char=? (string-ref name 0) #\.)
|
||||||
|
(read-directory directory-object))
|
||||||
|
(else name))))))
|
||||||
|
|
||||||
|
(define (close-directory directory-object)
|
||||||
|
(c-closedir (directory:handle directory-object)))
|
||||||
|
|
||||||
|
(define temp-file-prefix
|
||||||
|
(make-parameter
|
||||||
|
(if (get-environment-variable "TMPDIR")
|
||||||
|
(string-append (get-environment-variable "TMPDIR")
|
||||||
|
slash
|
||||||
|
(number->string (c-getpid)))
|
||||||
|
(string-append
|
||||||
|
(cond-expand (windows (get-environment-variable "TMP")) (else "/tmp"))
|
||||||
|
slash
|
||||||
|
(number->string (c-getpid))))))
|
||||||
|
|
||||||
|
(define create-temp-file
|
||||||
|
(lambda prefix
|
||||||
|
(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)))
|
||||||
|
(path (string-append real-prefix "-" (random-string 6))))
|
||||||
|
(if (file-exists? path)
|
||||||
|
(create-temp-file real-prefix)
|
||||||
|
(begin
|
||||||
|
(with-output-to-file path (lambda () (display "")))
|
||||||
|
(set-file-mode path 600)
|
||||||
|
path)))))
|
||||||
|
|
||||||
|
(define (call-with-temporary-filename maker . prefix)
|
||||||
|
(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)))
|
||||||
|
(path (string-append real-prefix "-" (random-string 6))))
|
||||||
|
(apply maker (list path))))
|
||||||
|
|
||||||
|
(define (current-directory)
|
||||||
|
(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)
|
||||||
|
path))
|
||||||
|
|
||||||
|
(define (set-current-directory! path)
|
||||||
|
(c-chdir (string->c-utf8 path)))
|
||||||
|
|
||||||
|
(define (pid)
|
||||||
|
(c-getpid))
|
||||||
|
|
||||||
|
(define (user-uid)
|
||||||
|
(c-getuid))
|
||||||
|
|
||||||
|
(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)
|
||||||
|
(if (>= count max-count)
|
||||||
|
result
|
||||||
|
(groups-loop max-count
|
||||||
|
(+ count 1)
|
||||||
|
groups-pointer
|
||||||
|
(append result
|
||||||
|
(list (c-bytevector-sint-ref groups-pointer
|
||||||
|
(* (c-type-size 'int) count)
|
||||||
|
(native-endianness)
|
||||||
|
(c-type-size 'int)))))))
|
||||||
|
|
||||||
|
(define (user-supplementary-gids)
|
||||||
|
(let* ((group-count (c-getgroups 0 (make-c-null)))
|
||||||
|
(groups (make-c-bytevector (* (c-type-size 'int) group-count))))
|
||||||
|
(c-getgroups group-count groups)
|
||||||
|
(groups-loop group-count 0 groups (list))))
|
||||||
|
|
||||||
|
(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))
|
||||||
|
|
||||||
|
(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-pointer-ref password-struct
|
||||||
|
0))
|
||||||
|
(c-bytevector-sint-ref password-struct
|
||||||
|
(* (c-type-size 'pointer) 2)
|
||||||
|
(native-endianness)
|
||||||
|
(c-type-size 'int))
|
||||||
|
(c-bytevector-sint-ref password-struct
|
||||||
|
(+ (* (c-type-size 'pointer) 2)
|
||||||
|
(c-type-size 'int))
|
||||||
|
(native-endianness)
|
||||||
|
(c-type-size 'int))
|
||||||
|
(c-utf8->string (c-bytevector-pointer-ref password-struct
|
||||||
|
(+ (* (c-type-size 'pointer) 3)
|
||||||
|
(* (c-type-size 'int) 2))))
|
||||||
|
(c-utf8->string (c-bytevector-pointer-ref password-struct
|
||||||
|
(+ (* (c-type-size 'pointer) 4)
|
||||||
|
(* (c-type-size 'int) 2))))
|
||||||
|
(c-utf8->string (c-bytevector-pointer-ref password-struct
|
||||||
|
(+ (* (c-type-size 'pointer) 2)
|
||||||
|
(* (c-type-size 'int) 2)))))))
|
||||||
|
|
||||||
|
|
||||||
|
(define-record-type <group-info>
|
||||||
|
(make-group-info name gid)
|
||||||
|
group-info?
|
||||||
|
(name group-info:name)
|
||||||
|
(gid group-info:gid))
|
||||||
|
|
||||||
|
(define (group-info gid/name)
|
||||||
|
(let ((group-struct (if (number? gid/name)
|
||||||
|
(c-getgrgid gid/name)
|
||||||
|
(c-getgrnam (string->c-utf8 gid/name)))))
|
||||||
|
(make-group-info
|
||||||
|
(c-utf8->string (c-bytevector-pointer-ref group-struct 0))
|
||||||
|
(c-bytevector-sint-ref group-struct
|
||||||
|
(* (c-type-size 'pointer) 2)
|
||||||
|
(native-endianness)
|
||||||
|
(c-type-size 'int)))))
|
||||||
|
|
||||||
|
(define (set-environment-variable! name value)
|
||||||
|
(c-setenv (string->c-utf8 name) (string->c-utf8 value) 1))
|
||||||
|
|
||||||
|
(define (delete-environment-variable! name)
|
||||||
|
(c-unsetenv (string->c-utf8 name)))
|
||||||
|
|
@ -0,0 +1,86 @@
|
||||||
|
(define-library
|
||||||
|
(srfi 170)
|
||||||
|
(import (scheme base)
|
||||||
|
(scheme char)
|
||||||
|
(scheme write)
|
||||||
|
(scheme file)
|
||||||
|
(scheme process-context)
|
||||||
|
(foreign c))
|
||||||
|
(export ;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?
|
||||||
|
)
|
||||||
|
(include "170.scm"))
|
||||||
|
|
@ -0,0 +1,165 @@
|
||||||
|
GNU LESSER GENERAL PUBLIC LICENSE
|
||||||
|
Version 3, 29 June 2007
|
||||||
|
|
||||||
|
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
|
||||||
|
Everyone is permitted to copy and distribute verbatim copies
|
||||||
|
of this license document, but changing it is not allowed.
|
||||||
|
|
||||||
|
|
||||||
|
This version of the GNU Lesser General Public License incorporates
|
||||||
|
the terms and conditions of version 3 of the GNU General Public
|
||||||
|
License, supplemented by the additional permissions listed below.
|
||||||
|
|
||||||
|
0. Additional Definitions.
|
||||||
|
|
||||||
|
As used herein, "this License" refers to version 3 of the GNU Lesser
|
||||||
|
General Public License, and the "GNU GPL" refers to version 3 of the GNU
|
||||||
|
General Public License.
|
||||||
|
|
||||||
|
"The Library" refers to a covered work governed by this License,
|
||||||
|
other than an Application or a Combined Work as defined below.
|
||||||
|
|
||||||
|
An "Application" is any work that makes use of an interface provided
|
||||||
|
by the Library, but which is not otherwise based on the Library.
|
||||||
|
Defining a subclass of a class defined by the Library is deemed a mode
|
||||||
|
of using an interface provided by the Library.
|
||||||
|
|
||||||
|
A "Combined Work" is a work produced by combining or linking an
|
||||||
|
Application with the Library. The particular version of the Library
|
||||||
|
with which the Combined Work was made is also called the "Linked
|
||||||
|
Version".
|
||||||
|
|
||||||
|
The "Minimal Corresponding Source" for a Combined Work means the
|
||||||
|
Corresponding Source for the Combined Work, excluding any source code
|
||||||
|
for portions of the Combined Work that, considered in isolation, are
|
||||||
|
based on the Application, and not on the Linked Version.
|
||||||
|
|
||||||
|
The "Corresponding Application Code" for a Combined Work means the
|
||||||
|
object code and/or source code for the Application, including any data
|
||||||
|
and utility programs needed for reproducing the Combined Work from the
|
||||||
|
Application, but excluding the System Libraries of the Combined Work.
|
||||||
|
|
||||||
|
1. Exception to Section 3 of the GNU GPL.
|
||||||
|
|
||||||
|
You may convey a covered work under sections 3 and 4 of this License
|
||||||
|
without being bound by section 3 of the GNU GPL.
|
||||||
|
|
||||||
|
2. Conveying Modified Versions.
|
||||||
|
|
||||||
|
If you modify a copy of the Library, and, in your modifications, a
|
||||||
|
facility refers to a function or data to be supplied by an Application
|
||||||
|
that uses the facility (other than as an argument passed when the
|
||||||
|
facility is invoked), then you may convey a copy of the modified
|
||||||
|
version:
|
||||||
|
|
||||||
|
a) under this License, provided that you make a good faith effort to
|
||||||
|
ensure that, in the event an Application does not supply the
|
||||||
|
function or data, the facility still operates, and performs
|
||||||
|
whatever part of its purpose remains meaningful, or
|
||||||
|
|
||||||
|
b) under the GNU GPL, with none of the additional permissions of
|
||||||
|
this License applicable to that copy.
|
||||||
|
|
||||||
|
3. Object Code Incorporating Material from Library Header Files.
|
||||||
|
|
||||||
|
The object code form of an Application may incorporate material from
|
||||||
|
a header file that is part of the Library. You may convey such object
|
||||||
|
code under terms of your choice, provided that, if the incorporated
|
||||||
|
material is not limited to numerical parameters, data structure
|
||||||
|
layouts and accessors, or small macros, inline functions and templates
|
||||||
|
(ten or fewer lines in length), you do both of the following:
|
||||||
|
|
||||||
|
a) Give prominent notice with each copy of the object code that the
|
||||||
|
Library is used in it and that the Library and its use are
|
||||||
|
covered by this License.
|
||||||
|
|
||||||
|
b) Accompany the object code with a copy of the GNU GPL and this license
|
||||||
|
document.
|
||||||
|
|
||||||
|
4. Combined Works.
|
||||||
|
|
||||||
|
You may convey a Combined Work under terms of your choice that,
|
||||||
|
taken together, effectively do not restrict modification of the
|
||||||
|
portions of the Library contained in the Combined Work and reverse
|
||||||
|
engineering for debugging such modifications, if you also do each of
|
||||||
|
the following:
|
||||||
|
|
||||||
|
a) Give prominent notice with each copy of the Combined Work that
|
||||||
|
the Library is used in it and that the Library and its use are
|
||||||
|
covered by this License.
|
||||||
|
|
||||||
|
b) Accompany the Combined Work with a copy of the GNU GPL and this license
|
||||||
|
document.
|
||||||
|
|
||||||
|
c) For a Combined Work that displays copyright notices during
|
||||||
|
execution, include the copyright notice for the Library among
|
||||||
|
these notices, as well as a reference directing the user to the
|
||||||
|
copies of the GNU GPL and this license document.
|
||||||
|
|
||||||
|
d) Do one of the following:
|
||||||
|
|
||||||
|
0) Convey the Minimal Corresponding Source under the terms of this
|
||||||
|
License, and the Corresponding Application Code in a form
|
||||||
|
suitable for, and under terms that permit, the user to
|
||||||
|
recombine or relink the Application with a modified version of
|
||||||
|
the Linked Version to produce a modified Combined Work, in the
|
||||||
|
manner specified by section 6 of the GNU GPL for conveying
|
||||||
|
Corresponding Source.
|
||||||
|
|
||||||
|
1) Use a suitable shared library mechanism for linking with the
|
||||||
|
Library. A suitable mechanism is one that (a) uses at run time
|
||||||
|
a copy of the Library already present on the user's computer
|
||||||
|
system, and (b) will operate properly with a modified version
|
||||||
|
of the Library that is interface-compatible with the Linked
|
||||||
|
Version.
|
||||||
|
|
||||||
|
e) Provide Installation Information, but only if you would otherwise
|
||||||
|
be required to provide such information under section 6 of the
|
||||||
|
GNU GPL, and only to the extent that such information is
|
||||||
|
necessary to install and execute a modified version of the
|
||||||
|
Combined Work produced by recombining or relinking the
|
||||||
|
Application with a modified version of the Linked Version. (If
|
||||||
|
you use option 4d0, the Installation Information must accompany
|
||||||
|
the Minimal Corresponding Source and Corresponding Application
|
||||||
|
Code. If you use option 4d1, you must provide the Installation
|
||||||
|
Information in the manner specified by section 6 of the GNU GPL
|
||||||
|
for conveying Corresponding Source.)
|
||||||
|
|
||||||
|
5. Combined Libraries.
|
||||||
|
|
||||||
|
You may place library facilities that are a work based on the
|
||||||
|
Library side by side in a single library together with other library
|
||||||
|
facilities that are not Applications and are not covered by this
|
||||||
|
License, and convey such a combined library under terms of your
|
||||||
|
choice, if you do both of the following:
|
||||||
|
|
||||||
|
a) Accompany the combined library with a copy of the same work based
|
||||||
|
on the Library, uncombined with any other library facilities,
|
||||||
|
conveyed under the terms of this License.
|
||||||
|
|
||||||
|
b) Give prominent notice with the combined library that part of it
|
||||||
|
is a work based on the Library, and explaining where to find the
|
||||||
|
accompanying uncombined form of the same work.
|
||||||
|
|
||||||
|
6. Revised Versions of the GNU Lesser General Public License.
|
||||||
|
|
||||||
|
The Free Software Foundation may publish revised and/or new versions
|
||||||
|
of the GNU Lesser General Public License from time to time. Such new
|
||||||
|
versions will be similar in spirit to the present version, but may
|
||||||
|
differ in detail to address new problems or concerns.
|
||||||
|
|
||||||
|
Each version is given a distinguishing version number. If the
|
||||||
|
Library as you received it specifies that a certain numbered version
|
||||||
|
of the GNU Lesser General Public License "or any later version"
|
||||||
|
applies to it, you have the option of following the terms and
|
||||||
|
conditions either of that published version or of any later version
|
||||||
|
published by the Free Software Foundation. If the Library as you
|
||||||
|
received it does not specify a version number of the GNU Lesser
|
||||||
|
General Public License, you may choose any version of the GNU Lesser
|
||||||
|
General Public License ever published by the Free Software Foundation.
|
||||||
|
|
||||||
|
If the Library as you received it specifies that a proxy can decide
|
||||||
|
whether future versions of the GNU Lesser General Public License shall
|
||||||
|
apply, that proxy's public statement of acceptance of any version is
|
||||||
|
permanent authorization for you to choose that version for the
|
||||||
|
Library.
|
||||||
|
|
@ -0,0 +1,83 @@
|
||||||
|
Implementation of [SRFI 170](https://srfi.schemers.org/srfi-170/srfi-170.html)
|
||||||
|
POSIX API using [(foreign c)](https://git.sr.ht/~retropikzel/foreign-c).
|
||||||
|
|
||||||
|
Currently only supports Linux.
|
||||||
|
|
||||||
|
Uncommented things here are implemented.
|
||||||
|
|
||||||
|
;;;;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?
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
0.1.1
|
||||||
|
|
@ -0,0 +1,146 @@
|
||||||
|
|
||||||
|
(display (real-path "Makefile"))
|
||||||
|
(newline)
|
||||||
|
|
||||||
|
(exit 0)
|
||||||
|
|
||||||
|
(define tmp-dir "/tmp/foreign-c-srfi-170")
|
||||||
|
(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)
|
||||||
|
|
@ -0,0 +1,87 @@
|
||||||
|
;; This file exists for guile compability
|
||||||
|
(define-library
|
||||||
|
(srfi 170)
|
||||||
|
(import (scheme base)
|
||||||
|
(scheme char)
|
||||||
|
(scheme write)
|
||||||
|
(scheme file)
|
||||||
|
(foreign c)
|
||||||
|
(scheme process-context))
|
||||||
|
(export ;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?
|
||||||
|
)
|
||||||
|
(include "170.scm"))
|
||||||
Loading…
Reference in New Issue