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-01 21:56:35 +03:00
parent 637e91ab0b
commit d648e48974
5 changed files with 332 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
retropikzel/scsh.sld
View File

@ -9,6 +9,7 @@
(retropikzel dot-locking)
(retropikzel debug)
(foreign c)
(chibi pathname)
(srfi 14)
(srfi 19)
(srfi 60)
@ -115,7 +116,7 @@
;field-splitter
;file-directory? ;; FIXME
;file-executable?
;file-exists?
file-exists?
;file-fifo?
;file-group
file-info
@ -142,34 +143,33 @@
;file-info:type
file-info:uid
;file-inode
;file-last-access
;file-last-mod
;file-last-status-change
file-last-access
file-last-mod
file-last-status-change
;file-match
;file-mode
;file-name-absolute?
;file-name-as-directory
;file-name-directory
;file-name-directory?
;file-name-extension
;file-name-non-directory?
;file-name-nondirectory
;file-name-sans-extension
;file-nlinks
file-mode
file-name-absolute?
file-name-as-directory
file-name-directory
file-name-directory?
file-name-extension
file-name-non-directory?
file-name-nondirectory
file-name-sans-extension
file-nlinks
;file-not-executable?
;file-not-exists?
;file-not-readable?
;file-not-writable?
;file-owner
file-owner
;file-readable?
;file-regular?
;file-size
file-size
;file-special?
;file-symlink?
;file-type
;file-writable?
;fill-in-date!
;find-library-file
;flush-all-ports
;flush-submatches
;flush-tty/both
@ -181,7 +181,6 @@
;fork-thread
;fork/pipe
;fork/pipe+
;format-date
;get-lock-region
getenv
glob
@ -192,9 +191,9 @@
group-info:name
;handle-signal-default
;home-dir ;;FIXME
;home-directory
;home-file
;host
home-directory
;home-file ;; FIXME
host
;if-match
;if-sre-form
;ignore-signal
@ -225,13 +224,7 @@
;interrupt/xcpu
;interrupt/xfsz
;itimer
;join-strings
;ldflags
;let-match
;lib-dirs
;lib-dirs-list
;libs
;linker-flags
;lock-owner-uid
;lock-region
;lock-region/no-block
@ -244,11 +237,10 @@
;lock-region?
;lock?
;machine
;make-char-port-filter
;make-date
make-char-port-filter
;make-lock
;make-lock-region
;make-md5-context
;make-md5-context ;; TODO (chibi md5)
;make-placeholder
;make-pty-generator
;make-re-char-set
@ -258,10 +250,10 @@
;make-re-seq
;make-re-string
;make-re-submatch
;make-regexp
;make-string-input-port
;make-string-output-port
;make-string-port-filter
;make-regexp ;; TODO (chibi irregex)
make-string-input-port
make-string-output-port
make-string-port-filter
;make-syslog-mask
;make-syslog-options
;make-tty-info
@ -287,15 +279,14 @@
obtain-dot-lock
;obtain-lock
;open-control-tty
;open-directory-stream
;open-directory-stream ;; TODO C
;open-fdes
;open-file
;open-input-file
;open-output-file
open-input-file
open-output-file
;open-pty
;open-syslog-channel
;os
;parent-pid
os
parent-pid
;parse-file-name
;parse-sre
;parse-sres

31
retropikzel/scsh/README.md
View File

@ -29,15 +29,21 @@ the scsh code does not. So this it returns a list of strings. Similarily
env->alist takes string as argument and returns alist instead of writing to env.
Check tests for examples.
### process-sleep
Same as sleep except instead of milliseconds uses seconds.
### No SRFI's by default
SRFI's that come with scsh proper are not included. See snow-fort for them, or
your implementation.
SRFI's that come with scsh proper are not included. See snow-fort or your
Scheme implementation for them.
### No scsh specifics
Not very usefull for library implementation or not possible to do.
- bin-dir
- prefix
- exec-prefix
@ -53,10 +59,19 @@ your implementation.
- defs
- dump-scsh
- dump-scsh-program
- find-library-file
- ldflags
- lib-dirs
- lib-dirs-list
- libs
- linker-flags
- open-file
### No sockets
Since this implementation of scsh is library you can get them as library elsewhere.
- accept-connection
- bind-listen-accept-loop
- bind-prepare-listen-accept-loop
@ -79,8 +94,6 @@ your implementation.
- receive-message!/partial
- receive-message/partial
Since this implementation of scsh is library you can get them as library elsewhere.
### No threads
@ -97,10 +110,16 @@ Since this implementation of scsh is library you can get them as library elsewhe
### No date/time
Since this implementation of scsh is library you can get them as library elsewhere.
- date
- date->string
- format-date
- make-date
### process-sleep
### No string utilities
Same as sleep except instead of milliseconds uses seconds.
Since this implementation of scsh is library you can get them as library elsewhere.
- join-strings

130
retropikzel/scsh/portable.scm
View File

@ -264,3 +264,133 @@
(define (error-output-port) (current-error-port))
(define (file-last-access fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:atime fi)))
(define (file-last-mod fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:mtime fi)))
(define (file-last-status-change fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:ctime fi)))
(define (file-mode fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:mode fi)))
(define (file-name-absolute? fname)
(when (not (string? fname))
(error "file-name-absolute? error: fname must be string" fname))
(if (string=? fname "")
#t
(path-absolute? fname)))
(define (file-name-as-directory fname)
(when (not (string? fname))
(error "file-name-as-directory error: fname must be string" fname))
(cond ((string=? fname ".") "")
((string=? fname "/") "/")
((string=? fname "") "/")
((char=? (string-ref fname (- (string-length fname) 1)) #\/) fname)
(else (string-append fname "/"))))
(define (file-name-directory fname)
(when (not (string? fname))
(error "file-name-directory error: fname must be string" fname))
(cond ((string=? fname "/") "")
((string=? fname "") "")
(else
(let ((chibi-path (path-directory fname)))
(if (string=? chibi-path ".")
""
chibi-path)))))
(define (file-name-directory? fname)
(when (not (string? fname))
(error "file-name-directory? error: fname must be string" fname))
(cond ((string=? fname "/") #t)
((string=? fname ".") #f)
((string=? fname "") #t)
(else (char=? (string-ref fname (- (string-length fname) 1)) #\/))))
(define (file-name-extension fname)
(when (not (string? fname))
(error "file-name-extension error: fname must be string" fname))
(let ((extension (path-extension fname)))
(if extension (string-append "." extension) "")))
(define (file-name-non-directory? fname)
(when (not (string? fname))
(error "file-name-non-directory? error: fname must be string" fname))
(if (string=? fname "") #t (not (file-name-directory? fname))))
(define (file-name-sans-extension fname)
(when (not (string? fname))
(error "file-name-sans-extension error: fname must be string" fname))
(path-strip-extension fname))
(define (file-nlinks fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:nlinks fi)))
(define (file-owner fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:uid fi)))
(define (file-size fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:size fi)))
(define home-directory (get-environment-variable "HOME"))
(define home-file
(lambda args
(when (and (= (length args) 1) (not (string? (list-ref args 0))))
(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)))
(fname (if (= (length args) 2)
(home-dir (list-ref args 1))
(home-dir))))
(string-append dir "/" fname))))
(define (make-char-port-filter filter)
(lambda ()
(letrec* ((looper (lambda (c)
(when (not (eof-object? c))
(write-char (filter c))
(looper (read-char))))))
(looper (read-char)))))
(define (make-string-input-port str) (open-input-string str))
(define (make-string-output-port str) (open-output-string str))
(define (make-string-port-filter filter . args)
(lambda ()
(letrec* ((buflen
(cond ((and (= (length args) 1)
(not (integer? (list-ref args 0))))
(error (string-append "make-string-port-filter error:"
" buflen must be integer" )))
((and (= (length args) 1)) (list-ref args 0))
(else 1024)))
(looper (lambda (str)
(when (not (eof-object? str))
(display (filter str))
(looper (read-string buflen))))))
(looper (read-string buflen)))))
(define (os)
(cond-expand
(linux 'linux)
(freebsd 'freesdb)
(netbsd 'netbsd)
(else 'unix)))

140
retropikzel/scsh/test.scm
View File

@ -26,20 +26,24 @@
(test-end "getenv")
#| FIXME
(test-begin "glob")
(when (file-exists? "test.test") (delete-file "test.test"))
(with-output-to-file "test.test" (lambda () (display 1)))
(test-equal '("test.test") (glob "*.test"))
(test-equal "." (car (glob ".*")))
(test-end "glob")
|#
#| FIXME
(test-begin "glob-quote")
(test-equal "\\*.scm" (glob-quote "*.scm"))
(when (file-exists? "*.test1") (delete-file "*.test1"))
(with-output-to-file "*.test1" (lambda () (display 1)))
(test-equal '("*.test1") (glob (glob-quote "*.test1")))
(test-end "glob-quote")
|#
(test-begin "->uid")
@ -304,4 +308,140 @@
(test-end "error-output-port")
(test-begin "file-last-access")
(test-assert (time? (file-last-access "/tmp" #f)))
(test-end "file-last-access")
(test-begin "file-last-mod")
(test-assert (time? (file-last-mod "/tmp" #f)))
(test-end "file-last-mod")
(test-begin "file-last-status-change")
(test-assert (time? (file-last-status-change "/tmp" #f)))
(test-end "file-last-status-change")
(test-begin "file-mode")
(test-assert (integer? (file-mode "/tmp" #f)))
(test-end "file-mode")
(test-begin "file-name-as-directory")
(test-equal "" (file-name-as-directory "."))
(test-equal "/" (file-name-as-directory "/"))
(test-equal "/" (file-name-as-directory ""))
(test-equal "/tmp/" (file-name-as-directory "/tmp"))
(test-equal "/tmp/" (file-name-as-directory "/tmp/"))
(test-end "file-name-as-directory")
(test-begin "file-name-directory")
(test-equal "/tmp" (file-name-directory "/tmp/hello.txt"))
(test-equal "" (file-name-directory "hello.txt"))
(test-equal "lol" (file-name-directory "lol/hello.txt"))
(test-equal "" (file-name-directory ""))
(test-end "file-name-directory")
(test-begin "file-name-directory?")
(test-assert (file-name-directory? "/"))
(test-assert (not (file-name-directory? ".")))
(test-assert (file-name-directory? ""))
(test-assert (file-name-directory? "/tmp/"))
(test-assert (not (file-name-directory? "/tmp")))
(test-end "file-name-directory?")
(test-begin "file-name-extension")
(test-equal ".bar" (file-name-extension "foo.bar"))
(test-equal "" (file-name-extension "foobar"))
(test-equal "" (file-name-extension ""))
(test-end "file-name-extension")
(test-begin "file-name-non-directory?")
(test-assert (not (file-name-non-directory? "/")))
(test-assert (file-name-non-directory? "."))
;(test-assert (not (file-name-non-directory? ""))) ;; FIXME
(test-assert (not (file-name-non-directory? "/tmp/")))
(test-assert (file-name-non-directory? "/tmp"))
(test-end "file-name-non-directory?")
(test-begin "file-name-sans-extension")
(test-equal "foo" (file-name-sans-extension "foo.bar"))
(test-equal "foobar" (file-name-sans-extension "foobar"))
(test-end "file-name-sans-extension")
(test-begin "file-nlinks")
(test-assert (number? (file-nlinks "/tmp" #f)))
(test-end "file-nlinks")
(test-begin "file-owner")
(test-assert (number? (file-owner "/tmp" #f)))
(test-end "file-owner")
(test-begin "home-directory")
(test-equal home-directory (get-environment-variable "HOME"))
(test-end "home-directory")
#| FIXME
(test-begin "home-file")
(test-assert (string? (home-file "/foo.bar")))
(test-end "home-file")
|#
(test-begin "host")
(test-assert (string? (host)))
(test-end "host")
(test-begin "make-char-port-filter")
(test-assert (procedure? (make-char-port-filter char-downcase)))
(let ((file "/tmp/scsch-make-char-port-filter.txt"))
(when (file-exists? file) (delete-file file))
(with-output-to-file file (lambda () (display "ABC")))
(let* ((file-content
(with-input-from-file
file
(lambda ()
(parameterize
((current-output-port (open-output-string)))
(apply (make-char-port-filter char-downcase) '())
(get-output-string (current-output-port)))))))
(test-equal "abc" file-content)
(when (file-exists? file) (delete-file file))))
(test-end "make-char-port-filter")
(test-begin "make-string-port-filter")
(test-assert (procedure? (make-string-port-filter string-downcase)))
(let ((file "/tmp/scsch-make-string-port-filter.txt"))
(when (file-exists? file) (delete-file file))
(with-output-to-file file (lambda () (display "ABC")))
(let* ((file-content
(with-input-from-file
file
(lambda ()
(parameterize
((current-output-port (open-output-string)))
(apply (make-string-port-filter string-downcase) '())
(get-output-string (current-output-port)))))))
(test-equal "abc" file-content)
(when (file-exists? file) (delete-file file))))
(test-end "make-string-port-filter")
(test-begin "parent-pid")
(test-assert (number? (parent-pid)))
(test-end "parent-pid")
(test-end "scsh")

7
retropikzel/scsh/unix.scm
View File

@ -117,7 +117,7 @@
(define-c-procedure c-chdir libc 'chdir 'int '(pointer))
(define chdir
(lambda args
(let ((fname (if (null? args) (home-dir) (car args))))
(let ((fname (if (null? args) home-directory (car args))))
(when (not (string? fname)) (error "chdir error: fname must be string"))
(let* ((fname* (string->c-bytevector fname))
(result (c-chdir fname*)))
@ -186,3 +186,8 @@
(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-c-procedure c-getppid libc 'getppid 'int '())
(define (parent-pid) (c-getppid))