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

95
retropikzel/scsh/portable.scm
View File

@ -354,14 +354,14 @@
(define home-file
(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"))
(when (and (= (length args) 2) (not (string? (list-ref args 0))))j
(error "home-file error: user must be string"))
(when (and (= (length args) 2) (not (string? (list-ref args 1))))
(error "home-file error: user must be string"))
(let ((dir (if (= (length args) 2)
(home-dir (list-ref args 0))
(home-dir (car args))
(home-dir)))
(fname (if (= (length args) 2)
(home-dir (list-ref args 1))
@ -384,10 +384,10 @@
(lambda ()
(letrec* ((buflen
(cond ((and (= (length args) 1)
(not (integer? (list-ref args 0))))
(not (integer? (car args))))
(error (string-append "make-string-port-filter error:"
" buflen must be integer" )))
((and (= (length args) 1)) (list-ref args 0))
((and (= (length args) 1)) (car args))
(else 1024)))
(looper (lambda (str)
(when (not (eof-object? str))
@ -415,15 +415,15 @@
(let ((path (string-join path-list "/")))
(cond ((null? path-list) "")
((and (not (null? args))
(string=? (list-ref args 0) ""))
(string=? (car args) ""))
(string-append "/" path))
((and (not (null? args))
(not (string? (list-ref args 0))))
(not (string? (car args))))
(error "path-list->file-name error: dir must be string"
(list-ref args 0)))
(car args)))
((and (not (null? args))
(string? (list-ref args 0)))
(string-append (file-name-as-directory (list-ref args 0)) path))
(string? (car args)))
(string-append (file-name-as-directory (car args)) path))
(else path))))
(define (port->list reader port)
@ -439,26 +439,87 @@
(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)
(when (and (not (string? char-set))
(not (char-set? char-set)))
(error (string-append "read-delimited error: read-delimited char-set must"
" be either string or char-set")))
(error (string-append "read-delimited error: char-set must be either"
" 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)
(string->char-set char-set)
char-set))
(port (if (>= (length args) 1)
(car args)
(current-input-port)))
(port (if (> (length args) 0) (car args) (current-input-port)))
(handle-delim (if (> (length args) 1) (list-ref args 1) 'trim))
(result '())
(in-char-set? (lambda (c) (char-set-contains? character-set c)))
(looper (lambda (c)
(cond ((char-set-contains? character-set c)
(list->string (reverse result)))
(cond ((in-char-set? c)
(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))
(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")))
(test-equal "foo" (read-delimited char-set:digit
(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-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")

14
retropikzel/scsh/unix.scm
View File

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