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