From e7d086e99ef7e3d9a5e0d8364c1bf72eee322dbb Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sun, 2 Aug 2026 19:23:41 +0300 Subject: [PATCH] scsh: Adding more features --- retropikzel/scsh.sld | 13 +++-- retropikzel/scsh/portable.scm | 95 ++++++++++++++++++++++++++++------- retropikzel/scsh/test.scm | 20 ++++++++ retropikzel/scsh/unix.scm | 14 +++--- 4 files changed, 113 insertions(+), 29 deletions(-) diff --git a/retropikzel/scsh.sld b/retropikzel/scsh.sld index e7808da..7752e49 100644 --- a/retropikzel/scsh.sld +++ b/retropikzel/scsh.sld @@ -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 diff --git a/retropikzel/scsh/portable.scm b/retropikzel/scsh/portable.scm index 89fd1a3..a9fa426 100644 --- a/retropikzel/scsh/portable.scm +++ b/retropikzel/scsh/portable.scm @@ -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))) + )) + +|# diff --git a/retropikzel/scsh/test.scm b/retropikzel/scsh/test.scm index 89dbb0c..bb2e314 100644 --- a/retropikzel/scsh/test.scm +++ b/retropikzel/scsh/test.scm @@ -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") diff --git a/retropikzel/scsh/unix.scm b/retropikzel/scsh/unix.scm index 43ed585..90d2a71 100644 --- a/retropikzel/scsh/unix.scm +++ b/retropikzel/scsh/unix.scm @@ -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))