Retropikzel
/
foreign-c-libraries
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

scsh: Adding more features

This commit is contained in:
retropikzel 2026-08-02 19:23:41 +03:00
parent d096879892
commit e7d086e99e
4 changed files with 113 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
retropikzel/scsh.sld
View File

@ -1,6 +1,7 @@
(define-library (define-library
(retropikzel scsh) (retropikzel scsh)
(import (scheme base) (import (rename (scheme base)
(read-line r7rs-read-line))
(scheme read) (scheme read)
(scheme write) (scheme write)
(scheme file) (scheme file)
@ -262,12 +263,14 @@
;match:start ;match:start
;match:substring ;match:substring
;maybe-obtain-lock ;maybe-obtain-lock
;; TODO (chibi md5) begin
;md5-context->md5-digest ;md5-context->md5-digest
;md5-context? ;md5-context?
;md5-digest->number ;md5-digest->number
;md5-digest-for-port ;md5-digest-for-port
;md5-digest-for-string ;md5-digest-for-string
;md5-digest? ;md5-digest?
;; TODO (chibi md5) end
;most-recent-sigevent ;most-recent-sigevent
;move->fdes ;move->fdes
;next-sigevent ;next-sigevent
@ -281,8 +284,8 @@
;open-control-tty ;open-control-tty
;open-directory-stream ;; TODO C ;open-directory-stream ;; TODO C
;open-fdes ;open-fdes
open-input-file ;open-input-file ;; TODO Different from R7RS
open-output-file ;open-output-file ;; TODO Different from R7RS
;open-pty ;open-pty
;open-syslog-channel ;open-syslog-channel
os os
@ -361,8 +364,8 @@
read-delimited read-delimited
;read-delimited! ;read-delimited!
;read-directory-stream ;read-directory-stream
;read-line read-line
;read-paragraph ;read-paragraph ;; IN PROGRESS
;read-string ;read-string
;read-string! ;read-string!
;read-string!/partial ;read-string!/partial

95
retropikzel/scsh/portable.scm
View File

@ -354,14 +354,14 @@
(define home-file (define home-file
(lambda args (lambda args
(when (and (= (length args) 1) (not (string? (list-ref args 0)))) (when (and (= (length args) 1) (not (string? (car args))))
(error "home-file error: fname must be string")) (error "home-file error: fname must be string"))
(when (and (= (length args) 2) (not (string? (list-ref args 0))))j (when (and (= (length args) 2) (not (string? (list-ref args 0))))j
(error "home-file error: user must be string")) (error "home-file error: user must be string"))
(when (and (= (length args) 2) (not (string? (list-ref args 1)))) (when (and (= (length args) 2) (not (string? (list-ref args 1))))
(error "home-file error: user must be string")) (error "home-file error: user must be string"))
(let ((dir (if (= (length args) 2) (let ((dir (if (= (length args) 2)
(home-dir (list-ref args 0)) (home-dir (car args))
(home-dir))) (home-dir)))
(fname (if (= (length args) 2) (fname (if (= (length args) 2)
(home-dir (list-ref args 1)) (home-dir (list-ref args 1))
@ -384,10 +384,10 @@
(lambda () (lambda ()
(letrec* ((buflen (letrec* ((buflen
(cond ((and (= (length args) 1) (cond ((and (= (length args) 1)
(not (integer? (list-ref args 0)))) (not (integer? (car args))))
(error (string-append "make-string-port-filter error:" (error (string-append "make-string-port-filter error:"
" buflen must be integer" ))) " buflen must be integer" )))
((and (= (length args) 1)) (list-ref args 0)) ((and (= (length args) 1)) (car args))
(else 1024))) (else 1024)))
(looper (lambda (str) (looper (lambda (str)
(when (not (eof-object? str)) (when (not (eof-object? str))
@ -415,15 +415,15 @@
(let ((path (string-join path-list "/"))) (let ((path (string-join path-list "/")))
(cond ((null? path-list) "") (cond ((null? path-list) "")
((and (not (null? args)) ((and (not (null? args))
(string=? (list-ref args 0) "")) (string=? (car args) ""))
(string-append "/" path)) (string-append "/" path))
((and (not (null? args)) ((and (not (null? args))
(not (string? (list-ref args 0)))) (not (string? (car args))))
(error "path-list->file-name error: dir must be string" (error "path-list->file-name error: dir must be string"
(list-ref args 0))) (car args)))
((and (not (null? args)) ((and (not (null? args))
(string? (list-ref args 0))) (string? (car args)))
(string-append (file-name-as-directory (list-ref args 0)) path)) (string-append (file-name-as-directory (car args)) path))
(else path)))) (else path))))
(define (port->list reader port) (define (port->list reader port)
@ -439,26 +439,87 @@
(looper (read-string 1024 port))))))) (looper (read-string 1024 port)))))))
(looper (read-string 1024 port)))) (looper (read-string 1024 port))))
(define (port->string-list port) (reverse (port-fold port read-line cons '()))) (define (port->string-list port) (reverse (port-fold port r7rs-read-line cons '())))
(define (read-delimited char-set . args) (define (read-delimited char-set . args)
(when (and (not (string? char-set)) (when (and (not (string? char-set))
(not (char-set? char-set))) (not (char-set? char-set)))
(error (string-append "read-delimited error: read-delimited char-set must" (error (string-append "read-delimited error: char-set must be either"
" be either string or char-set"))) " string or char-set")))
(when (and (> (length args) 0)
(not (port? (car args))))
(error (string-append "read-delimited error: port must of type port")))
(when (and (> (length args) 1)
(not (member (list-ref args 1) '(trim peek concat split))))
(error (string-append "read-delimited error: handle-delim must be either"
" 'trim, 'peek, 'concat or 'split")
(list-ref args 1)))
(letrec* ((character-set (if (string? char-set) (letrec* ((character-set (if (string? char-set)
(string->char-set char-set) (string->char-set char-set)
char-set)) char-set))
(port (if (>= (length args) 1) (port (if (> (length args) 0) (car args) (current-input-port)))
(car args) (handle-delim (if (> (length args) 1) (list-ref args 1) 'trim))
(current-input-port)))
(result '()) (result '())
(in-char-set? (lambda (c) (char-set-contains? character-set c)))
(looper (lambda (c) (looper (lambda (c)
(cond ((char-set-contains? character-set c) (cond ((in-char-set? c)
(list->string (reverse result))) (cond ((equal? handle-delim 'trim)
(list->string (reverse result)))
((equal? handle-delim 'concat)
(list->string (reverse (cons c result))))
((equal? handle-delim 'split)
(values (list->string (reverse result)) c))))
((and (equal? handle-delim 'peek)
(in-char-set? (peek-char port)))
(list->string (reverse (cons c result))))
(else (set! result (cons c result)) (else (set! result (cons c result))
(looper (read-char port))))))) (looper (read-char port)))))))
(looper (read-char port)))) (looper (read-char port))))
(define read-line
(lambda args
(when (and (> (length args) 0)
(not (port? (car args))))
(error (string-append "read-delimited error: port must of type port")))
(when (and (> (length args) 1)
(not (member (list-ref args 1) '(trim peek concat split))))
(error (string-append "read-line error: handle-delim must be either"
" 'trim, 'peek, 'concat or 'split")
(list-ref args 1)))
(apply read-delimited (cons (string #\newline) args))))
#| TODO
(define read-paragraph
(lambda args
(when (and (> (length args) 0)
(not (port? (car args))))
(error (string-append "read-delimited error: port must of type port")))
(when (and (> (length args) 1)
(not (member (list-ref args 1) '(trim concat split))))
(error (string-append "read-paragraph error: handle-delim must be either"
" 'trim, 'concat or 'split (peek not supported)")
(list-ref args 1)))
(letrec*
((port (if (> (length args) 0) (car args) (current-input-port)))
(handle-delim (if (> (length args) 1) (list-ref args 1) 'trim))
(result '())
(skipped-blank-lines? #f)
(looper (lambda (line)
(cond ((and (eof-object? line) (null? result)) line)
((and (not skipped-blank-lines?) (string=? line ""))
(looper (read-line port handle-delim)))
))
|#

20
retropikzel/scsh/test.scm
View File

@ -500,7 +500,27 @@
(open-input-string "foo1bar2baz3"))) (open-input-string "foo1bar2baz3")))
(test-equal "foo" (read-delimited char-set:digit (test-equal "foo" (read-delimited char-set:digit
(open-input-string "foo1bar2baz3"))) (open-input-string "foo1bar2baz3")))
(test-equal "foo" (read-delimited char-set:digit
(open-input-string "foo1bar2baz3")
'trim))
(let ((port (open-input-string "foo1bar2baz3")))
(test-equal "foo" (read-delimited char-set:digit port 'peek))
(test-equal #\1 (read-char port)))
(test-equal "foo1" (read-delimited char-set:digit
(open-input-string "foo1bar2baz3")
'concat))
(test-end "read-delimited") (test-end "read-delimited")
(test-begin "read-line")
(test-equal "foo" (read-line (open-input-string "foo\nbar\nbaz\n")))
(test-equal "foo" (read-line (open-input-string "foo\nbar\nbaz\n")))
(test-equal "foo" (read-line (open-input-string "foo\nbar\nbaz\n") 'trim))
(let ((port (open-input-string "foo\nbar\nbaz\n")))
(test-equal "foo" (read-line port 'peek))
(test-equal #\newline (read-char port)))
(test-equal "foo\n" (read-line (open-input-string "foo\nbar\nbaz\n") 'concat))
(test-end "read-line")
(test-end "scsh") (test-end "scsh")

14
retropikzel/scsh/unix.scm
View File

@ -36,8 +36,8 @@
0 0
username-length))) username-length)))
(string->number (list-ref (string-split line #\:) 2)) (string->number (list-ref (string-split line #\:) 2))
(looper (read-line)))))))) (looper (r7rs-read-line))))))))
(with-input-from-file "/etc/passwd" (lambda () (looper (read-line)))))) (with-input-from-file "/etc/passwd" (lambda () (looper (r7rs-read-line))))))
(else (error (string-append "->uid error: uid/username must be either" (else (error (string-append "->uid error: uid/username must be either"
" exact integer or string"))))) " exact integer or string")))))
@ -55,8 +55,8 @@
(= (string->number (list-ref line-list 2)) (= (string->number (list-ref line-list 2))
uid/username)) uid/username))
(car line-list) (car line-list)
(looper (read-line)))))))) (looper (r7rs-read-line))))))))
(with-input-from-file "/etc/passwd" (lambda () (looper (read-line)))))) (with-input-from-file "/etc/passwd" (lambda () (looper (r7rs-read-line))))))
(else (error (string-append "->username error: uid/username must be either" (else (error (string-append "->username error: uid/username must be either"
" exact integer or string"))))) " exact integer or string")))))
@ -178,16 +178,16 @@
0 0
username-length))) username-length)))
(list-ref (string-split line #\:) 5) (list-ref (string-split line #\:) 5)
(looper (read-line))))))) (looper (r7rs-read-line)))))))
(home-dir-path (with-input-from-file (home-dir-path (with-input-from-file
"/etc/passwd" "/etc/passwd"
(lambda () (looper (read-line)))))) (lambda () (looper (r7rs-read-line))))))
(when (not home-dir-path) (when (not home-dir-path)
(error "home-dir error: home directory not found, user does not exist?" (error "home-dir error: home directory not found, user does not exist?"
user)) user))
home-dir-path)))) home-dir-path))))
(define (host) (with-input-from-file "/etc/hostname" (lambda () (read-line)))) (define (host) (with-input-from-file "/etc/hostname" (lambda () (r7rs-read-line))))
(define-c-procedure c-getppid libc 'getppid 'int '()) (define-c-procedure c-getppid libc 'getppid 'int '())
(define (parent-pid) (c-getppid)) (define (parent-pid) (c-getppid))