diff --git a/.gitignore b/.gitignore index 78f7b0f..44e0ba1 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,5 @@ foreign tmp *.json test-program +*.test +*.test1 diff --git a/Makefile b/Makefile index 12a8eb4..b8ae7d1 100644 --- a/Makefile +++ b/Makefile @@ -59,7 +59,7 @@ test-docker: DOCKER_TAG=${DOCKER_TAG} \ COMPILE_R7RS=${SCHEME} \ CSC_OPTIONS="${CSC_OPTIONS}" \ - SNOW_PACKAGES="srfi.64 foreign.c ${PKG}" \ + SNOW_PACKAGES="srfi.14 srfi.19 srfi.64 srfi.170 retropikzel.tap retropikzel.dot-locking retropikzel.debug foreign.c ${PKG}" \ AKKU_PACKAGES="akku-r7rs chez-srfi '(foreign c)' '(retropikzel ${LIBRARY})'" \ APT_PACKAGES="${APT_PACKAGES}" \ PASS_ENV_VARS="CSC_OPTIONS" \ diff --git a/retropikzel/scsh.sld b/retropikzel/scsh.sld index 7a60d32..d262ce6 100644 --- a/retropikzel/scsh.sld +++ b/retropikzel/scsh.sld @@ -1,15 +1,22 @@ (define-library (retropikzel scsh) (import (scheme base) + (scheme read) (scheme write) (scheme file) + (scheme char) (scheme process-context) + (retropikzel dot-locking) + (retropikzel debug) (foreign c) + (srfi 14) + (srfi 19) + (srfi 60) (srfi 170)) (export - ;*temp-file-template* - ;->uid - ;->username + *temp-file-template* + ->uid + ->username ;%exec ;%exit ;%fork @@ -19,104 +26,77 @@ ;& ;& ;&& - ;reduce-port - ;absolute-file-name - ;accept-connection - ;add-after - ;add-before - ;alist->env - ;alist-compress - ;alist-delete - ;alist-update - ;arg - ;arg* - ;argv - ;arithmetic-shift + reduce-port + absolute-file-name + add-after + add-before + alist->env + alist-compress + alist-delete + alist-update + arg + arg* + argv + arithmetic-shift ;ascii->char - ;autoreap-policy + autoreap-policy ;awk - ;become-session-leader - ;bin-dir - ;bind-listen-accept-loop - ;bind-prepare-listen-accept-loop - ;bind-socket - ;bitwise-and - ;bitwise-ior - ;bitwise-not - ;bitwise-xor - ;break-dot-lock - ;bufpol/block - ;bufpol/line - ;bufpol/none - ;call-terminally - ;call-with-string-output-port + become-session-leader + bitwise-and + bitwise-ior + bitwise-not + bitwise-xor + break-dot-lock + call-terminally + call-with-string-output-port ;call/fdes - ;cflags ;char->ascii - ;char-ascii? - ;char-blank? - ;char-digit? - ;char-graphic? - ;char-hex-digit? - ;char-iso-control? - ;char-letter+digit? - ;char-letter? - ;char-lower-case? - ;char-printing? - ;char-punctuation? - ;char-title-case? - ;char-upper-case? - ;char-whitespace? - ;chdir - ;clean-up-cres + char-ascii? + char-blank? + char-digit? + char-graphic? + char-hex-digit? + char-iso-control? + char-letter+digit? + char-letter? + char-lower-case? + char-printing? + char-punctuation? + char-title-case? + char-upper-case? + char-whitespace? + ;chdir ;; FIXME ;close ;close-after ;close-directory-stream - ;close-socket ;close-syslog-channel - ;command-line - ;command-line-arguments - ;compiler-flags - ;connect-socket - ;connect-socket-no-wait - ;connect-socket-successful? + command-line + command-line-arguments ;control-tty-file-name ;copy-tty-info - ;cppflags ;cpu-ticks/sec create-directory create-fifo create-hard-link - ;create-socket - ;create-socket-pair create-symlink create-temp-file ;crypt - ;current-thread - ;cwd - ;date, [2] - ;date, [2] - ;date->string - ;default-lib-dirs - ;define-record - ;defs + ;cwd ;; FIXME delete-directory delete-file - ;delete-filesys-object - ;directory-as-file-name + ;delete-filesys-object ;; FIXME + directory-as-file-name directory-files ;disable-tty-char ;drain-tty - ;dump-scsh - ;dump-scsh-program ;dup ;dup->fdes ;dup->inport ;dup->outport ;enabled-interrupts - ;env->alist + env->alist ;errno-error - ;error-output-port + error-output-port ;exec ;exec-epf ;exec-epf @@ -124,7 +104,6 @@ ;exec-path-list ;exec-path-search ;exec-path/env - ;exec-prefix ;exec/env exit ;expand-file-name @@ -134,7 +113,7 @@ ;fdes-status ;field-reader ;field-splitter - ;file-directory? + ;file-directory? ;; FIXME ;file-executable? ;file-exists? ;file-fifo? @@ -148,7 +127,6 @@ ;file-info-not-writable? ;file-info-readable? ;file-info-regular? - ;file-info-socket? ;file-info-special? ;file-info-symlink? ;file-info-writable? @@ -159,7 +137,7 @@ file-info:inode file-info:mode file-info:mtime - ile-info:nlinks + file-info:nlinks file-info:size ;file-info:type file-info:uid @@ -186,7 +164,6 @@ ;file-readable? ;file-regular? ;file-size - ;file-socket? ;file-special? ;file-symlink? ;file-type @@ -208,23 +185,20 @@ ;get-lock-region getenv glob - ;glob-quote + glob-quote group-info group-info:gid ;group-info:members group-info:name ;handle-signal-default - ;home-dir + ;home-dir ;;FIXME ;home-directory ;home-file ;host - ;host-info ;if-match ;if-sre-form ;ignore-signal - ;include-dir ;infix-splitter - ;internet-address->socket-address ;interrupt-handler ;interrupt-set ;interrupt/alarm @@ -254,12 +228,10 @@ ;join-strings ;ldflags ;let-match - ;lib-dir ;lib-dirs ;lib-dirs-list ;libs ;linker-flags - ;listen-socket ;lock-owner-uid ;lock-region ;lock-region/no-block @@ -293,7 +265,6 @@ ;make-syslog-mask ;make-syslog-options ;make-tty-info - ;man-dir ;match-cond ;match:end ;match:start @@ -307,14 +278,13 @@ ;md5-digest? ;most-recent-sigevent ;move->fdes - ;network-info ;next-sigevent ;next-sigevent-set ;next-sigevent-set/no-wait ;next-sigevent/no-wait nice ;number->md5-digest - ;obtain-dot-lock + obtain-dot-lock ;obtain-lock ;open-control-tty ;open-directory-stream @@ -338,19 +308,17 @@ ;port->fdes ;port->list ;port->sexp-list - ;port->socket ;port->string ;port->string-list - ;port-fold + port-fold ;port-revealed ;posix-string->regexp - ;prefix ;priority ;proc ;proc:pid ;proc? ;process-group - ;process-sleep + process-sleep ;process-sleep-until ;process-times ;protocol-info @@ -410,10 +378,6 @@ ;read-string/partial read-symlink ;reap-zombies - ;receive-message - ;receive-message! - ;receive-message!/partial - ;receive-message/partial ;record-reader ;regexp->posix-string ;regexp->scheme @@ -426,7 +390,7 @@ ;regexp-substitute ;regexp-substitute/global ;regexp?, [2] - ;release-dot-lock + release-dot-lock ;release-lock ;release-port-handle ;relinquish-timeslice @@ -521,10 +485,10 @@ ;signal/winch ;signal/xcpu ;signal/xfsz - ;simplify-file-name + simplify-file-name ;simplify-regexp ;skip-char-set - ;sleep + sleep ;sloppy-suffix-splitter ;socket-address->internet-address ;socket-address->unix-address @@ -720,8 +684,8 @@ ;with-current-output-port* ;with-cwd ;with-cwd* - ;with-dot-lock - ;with-dot-lock* + with-dot-lock + with-dot-lock* ;with-enabled-interrupts ;with-enabled-interrupts* ;with-env @@ -746,6 +710,8 @@ ;write-string ;write-string/partial ) + (include "scsh/util.scm") + (include "scsh/portable.scm") (cond-expand (windows (begin (error "Windows not supported"))) - (else (include "scsh.unix.scm")))) + (else (include "scsh/unix.scm")))) diff --git a/retropikzel/scsh.unix.scm b/retropikzel/scsh.unix.scm deleted file mode 100644 index 2124ed7..0000000 --- a/retropikzel/scsh.unix.scm +++ /dev/null @@ -1,28 +0,0 @@ -(define-c-library libc '("stdlib.h" "string.h" "stdio.h" "glob.h") #f ()) - -;(define-c-procedure c-setenv libc 'setenv 'int '(pointer pointer int)) - -(define (setenv var val) - (when (not (string? var)) (error "setenv error: var must be string")) - (when (not (string? val)) (error "setenv error: val must be string")) - (set-environment-variable! var val)) - -(define getenv get-environment-variable) - -(define-c-procedure c-glob libc 'glob 'int '(pointer int pointer pointer)) -(define-c-procedure c-globfree libc 'globfree 'int '(pointer)) -(define-c-struct-type glob-struct '((gl_pathc int) (gl_pathv pointer) (gl_offs int))) -(define glob - (lambda paths - (let ((result '())) - (for-each - (lambda (path) - (let ((glob-struct-cbv (make-c-bytevector (c-type-size glob-struct))) - (path-cbv (string->c-bytevector path))) - (c-glob path-cbv 0 glob-struct-cbv) - (display "HERE: path ") - (display path) - (newline) - (c-bytevector-free path-cbv) - )) - paths)))) diff --git a/retropikzel/scsh/README.md b/retropikzel/scsh/README.md index 8effb70..c361e48 100644 --- a/retropikzel/scsh/README.md +++ b/retropikzel/scsh/README.md @@ -1,7 +1,8 @@ -Scsh - The Scheme Shell +scsh - The Scheme Shell This is an implementation of [scsh](https://scsh.net/) on top of -[(foreign c)](https://codeberg.org/foreign-c/foreign-c). +[(foreign c)](https://codeberg.org/foreign-c/foreign-c). It is not a port but +remake, trying to conform to the scsh as much as is possible but sane. Not everything is implemented yet, see scsh.sld for commented out exports. @@ -12,3 +13,94 @@ Currently only supports Linux. ## Documentation See [https://scsh.net/docu/html/man-Z-H-13.html#node_index_start](https://scsh.net/docu/html/man-Z-H-13.html#node_index_start) + + +## Differences + +Since the scsh proper is a program that you give source file to run to, and +this is a library. This version does not include everything. You should be able +to use other libraries to replace most things from scsh proper that this +library does not implement. + +### alist->env, env->alist + +For some reason the manual says that alist->env modifies the environment, yet +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. + + +### No SRFI's by default + +SRFI's that come with scsh proper are not included. See snow-fort for them, or +your implementation. + + +### No scsh specifics + +- bin-dir +- prefix +- exec-prefix +- lib-dir +- include-dir +- man-dir +- cflags +- clean-up-cres +- compiler-flags +- cppflags +- default-lib-dirs +- define-record +- defs +- dump-scsh +- dump-scsh-program + + +### No sockets + +- accept-connection +- bind-listen-accept-loop +- bind-prepare-listen-accept-loop +- bind-socket +- close-socket +- connect-socket +- connect-socket-no-wait +- connect-socket-successful? +- create-socket +- create-socket-pair +- file-info-socket? +- file-socket? +- host-info +- internet-address->socket-address +- listen-socket +- network-info +- port->socket +- receive-message +- receive-message! +- receive-message!/partial +- receive-message/partial + +Since this implementation of scsh is library you can get them as library elsewhere. + + +### No threads + +Since this implementation of scsh is library you can get them as library elsewhere. + +- current-thread + +### No buffered io + +- bufpol/block +- bufpol/line +- bufpol/none + + +### No date/time + +- date +- date->string + + +### process-sleep + +Same as sleep except instead of milliseconds uses seconds. diff --git a/retropikzel/scsh/portable.scm b/retropikzel/scsh/portable.scm new file mode 100644 index 0000000..e149dcf --- /dev/null +++ b/retropikzel/scsh/portable.scm @@ -0,0 +1,266 @@ +(define (reduce-port port reader op . seeds) + (letrec* ((looper (lambda new-seeds + (let ((read-value (reader port))) + (if (eof-object? read-value) + (apply values new-seeds) + (call-with-values (lambda () + (apply op read-value new-seeds)) + looper)))))) + (apply looper seeds))) + +(define port-fold reduce-port) + +(define (simplify-file-name fname) ;; TODO + (cond + ((not (string? fname)) + (error "simplify-file-name error: fname must be string")) + (else fname))) + +(define set-umask set-umask!) + +(define (setenv var val) + (when (not (string? var)) (error "setenv error: var must be string")) + (when (not (string? val)) (error "setenv error: val must be string")) + (set-environment-variable! var val)) + +(define getenv get-environment-variable) + +(define (glob-quote str) + (list->string + (apply + append + (map + (lambda (c) + (if (member c (list #\*)) + (list #\\ c) + (list c))) + (string->list str))))) + +(define (add-after elt after lst) + (apply + append + (map + (lambda (item) + (if (equal? item after) + (list item elt) + (list item))) + lst))) + +(define (add-before elt after lst) + (apply + append + (map + (lambda (item) + (if (equal? item after) + (list elt item) + (list item))) + lst))) + +(define (alist->env alist) + (map (lambda (item) + (cond + ((not (pair? item)) + (error "alist->env error: alist items must be pairs" item)) + ((not (string? (car item))) + (error "alist->env error: alist item car must be string" item)) + ((and (not (string? (cdr item))) + (not (list? (cdr item)))) + (error (string-append "alist->env error: alist item cdr must be" + "string or list of strings") + item)) + ((string? (cdr item)) + (string-append (car item) "=" (cdr item))) + ((list? (cdr item)) + (for-each + (lambda (cdr-list-item) + (when (not (string? cdr-list-item)) + (error (string-append "alist->env errror: all cdr list" + " items must be strings" + item)))) + (cdr item)) + (string-append (car item) "=" (string-join (cdr item) ":"))) + (else (error "alist->env error: unexpected error" alist)))) + alist)) + +(define (alist-compress alist) + (let ((result '())) + (for-each + (lambda (item) + (when (not (member item result)) + (set! result (cons item result)))) + alist) + (reverse result))) + +(define (alist-delete key alist) + (let ((result '())) + (for-each + (lambda (item) + (when (not (equal? key (car item))) + (set! result (cons item result)))) + alist) + (reverse result))) + +(define (alist-update key val alist) + (cons (cons key val) (alist-delete key alist))) + +(define (arg arglist n . default) + (when (not (list? arglist)) (error "arg error: arglist must be list")) + (when (not (integer? n)) (error "arg error: n must be integer")) + (when (< n 1) (error "arg error: Index starts from 1")) + (if (and (< (length arglist) n) + (not (null? default))) + (car default) + (list-ref arglist (- n 1)))) + +(define (arg* arglist n . default-thunk) + (when (not (list? arglist)) (error "arg* error: arglist must be list")) + (when (not (integer? n)) (error "arg* error: n must be integer")) + (when (< n 1) (error "arg* error: Index starts from 1")) + (if (and (< (length arglist) n) + (not (null? default-thunk))) + (begin + (when (not (procedure? (car default-thunk))) + (error "arg* error: default-tunk must be procedure")) + (apply (car default-thunk) '())) + (list-ref arglist (- n 1)))) + +(define (argv n) + (when (not (integer? n)) (error "argv error: n must be integer")) + (arg (command-line) (+ n 1))) + +(define current-autoreap-policy 'wait) +(define autoreap-policy + (lambda args + (cond + ((null? args) current-autoreap-policy) + (else + (when (not (or (equal? (car args) 'early) + (equal? (car args) 'late) + (equal? (car args) #f))) + (error "autoreap-policy error: policy must be 'early, 'late or #f" + (car args))) + (set! current-autoreap-policy (car args)))))) + +(define (sleep time) + (when (not (integer? time)) (error "sleep error: time must be integer" time)) + (letrec* + ((end-time + (let ((end-time (current-time)) + (seconds (quotient time 1000)) + (nanoseconds (* (remainder time 1000) 1000000))) + (set-time-second! end-time (+ (time-second end-time) seconds)) + (set-time-nanosecond! end-time (+ (time-nanosecond end-time) nanoseconds)) + end-time)) + (looper (lambda () (when (timealist str) + (map (lambda (item) + (apply cons (string-split item #\=))) + (string-split str #\newline))) + +(define (error-output-port) (current-error-port)) + diff --git a/retropikzel/scsh/portable.sld b/retropikzel/scsh/portable.sld new file mode 100644 index 0000000..691c8a6 --- /dev/null +++ b/retropikzel/scsh/portable.sld @@ -0,0 +1,37 @@ +(define-library + (retropikzel scsh portable) + (import (scheme base) + (scheme read) + (scheme write) + (scheme file) + (scheme process-context) + (srfi 60) + (srfi 170)) + (export reduce-port + port-fold + simplify-file-name + set-umask + setenv + getenv + glob-quote + add-after + add-before + alist->env + alist-compress + alist-delete + alist-update + arg + arg* + argv + current-autoreap-policy + bin-dir + prefix + exec-prefix + lib-dir + include-dir + man-dir + obtain-dot-lock + ) + (begin (define set-umask set-umask!)) + (include "scsh/portable.scm")) + diff --git a/retropikzel/scsh/test.scm b/retropikzel/scsh/test.scm index c893e7c..a86d8a9 100644 --- a/retropikzel/scsh/test.scm +++ b/retropikzel/scsh/test.scm @@ -5,13 +5,16 @@ (scheme file) (scheme process-context) (retropikzel scsh) - (srfi 64) - (retropikzel tap)) + (retropikzel tap) + (retropikzel debug) + (srfi 19) + (srfi 64)) (test-runner-current (tap-runner)) (test-begin "scsh") + (test-begin "setenv") (setenv "SCSH_TEST1" "foobar") (test-equal "foobar" (get-environment-variable "SCSH_TEST1")) @@ -24,9 +27,281 @@ (test-begin "glob") -(test-equal '("test.hehe") (glob "*.hehe")) +(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") +(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") +(test-equal 0 (->uid 0)) +(test-equal 0 (->uid "root")) +(test-end "->uid") + + +(test-begin "->username") +(test-equal "root" (->username "root")) +(test-equal "root" (->username 0)) +(test-end "->username") + + +(test-begin "port-fold") +(let-values (((lst) (port-fold (open-input-string "1 2 3") read cons '()))) + (test-equal '(3 2 1) lst)) +(test-end "port-fold") + + +(test-begin "reduce-port") +(let-values (((lst) (reduce-port (open-input-string "1 2 3") read cons '()))) + (test-equal '(3 2 1) lst)) +(test-end "port-fold") + + +(test-begin "simplify-file-name") ;; TODO +(test-end "simplify-file-name") + + +(test-begin "absolute-file-name") +(test-equal "/tmp" (absolute-file-name "/tmp")) +(test-end "absolute-file-name") + + +(test-begin "add-after") +(test-equal '(foo baz bar) (add-after 'baz 'foo '(foo bar))) +(test-end "add-after") + + +(test-begin "add-before") +(test-equal '(baz foo bar) (add-before 'baz 'foo '(foo bar))) +(test-end "add-before") + + +(test-begin "alist->env") +(test-equal '("one=1" "two=2" "PATH=/tmp:/usr/local/bin") + (alist->env '(("one" . "1") + ("two" . "2") + ("PATH" "/tmp" "/usr/local/bin")))) +(test-end "alist->env") + + +(test-begin "alist-compress") +(test-equal '((one . 1) (two . 2) (three .3) (four . 4)) + (alist-compress '((one . 1) (two . 2) (three .3) (four . 4) (two . 2)))) +(test-end "alist-compress") + + +(test-begin "alist-delete") +(test-equal '((one . 1) (three .3) (four . 4)) + (alist-delete 'two '((one . 1) (two . 2) (three .3) (four . 4) (two . 2)))) +(test-end "alist-delete") + + +(test-begin "alist-update") +(test-equal '((two . 20) (one . 1) (three .3) (four . 4)) + (alist-update 'two 20 '((one . 1) (two . 2) (three .3) (four . 4)))) +(test-equal '((two . 20) (one . 1) (three .3) (four . 4)) + (alist-update 'two 20 '((one . 1) (two . 2) (three .3) (four . 4) (two . 2)))) +(test-end "alist-update") + + +(test-begin "arg") +(test-equal 2 (arg '(1 2 3) 2)) +(test-equal 200 (arg '(1 2 3) 4 200)) +(test-equal 3 (arg '(1 2 3) 3)) +(test-equal 3 (arg '(1 2 3) 3 200)) +(test-end "arg") + + +(test-begin "arg*") +(test-equal 2 (arg* '(1 2 3) 2)) +(test-equal 2 (arg* '(1 2 3) 2 (lambda () 2))) +(test-equal 2 (arg* '(1 2 3) 20 (lambda () 2))) +(test-end "arg*") + + +(test-begin "argv") +(test-assert (string? (argv 0))) +(test-end "argv") + + +(test-begin "autoreap-policy") +(autoreap-policy 'early) +(test-equal 'early (autoreap-policy)) +(autoreap-policy 'late) +(test-equal 'late (autoreap-policy)) +(autoreap-policy #f) +(test-equal #f (autoreap-policy)) +(test-end "autoreap-policy") + + +(test-begin "sleep") +(let ((start-time (current-time))) + (sleep 3000) + (display "Slept for seconds: ") + (write (time-second (time-difference (current-time) start-time))) + (newline)) +(test-end "sleep") + + +(test-begin "call-with-string-output-port") +(let* ((procedure (lambda (port) (display "Hello world" port))) + (out-str (call-with-string-output-port procedure))) + (test-equal "Hello world" out-str)) +(test-end "call-with-string-output-port") + + +(test-begin "char-ascii?") +(test-assert (char-ascii? #\a)) +(test-end "char-ascii?") + + +(test-begin "char-blank?") +(test-assert (char-blank? #\space)) +(test-assert (char-blank? #\tab)) +(test-assert (not (char-blank? #\a))) +(test-end "char-blank?") + + +(test-begin "char-digit?") +(test-assert (char-digit? #\1)) +(test-assert (char-digit? #\0)) +(test-assert (not (char-digit? #\a))) +(test-end "char-digit?") + + +(test-begin "char-graphic?") +(test-assert (char-graphic? #\a)) +(test-end "char-graphic?") + + +(test-begin "char-hex-digit?") +(test-assert (char-hex-digit? #\1)) +(test-assert (char-hex-digit? #\a)) +(test-assert (not (char-hex-digit? #\space))) +(test-end "char-hex-digit?") + + +(test-begin "char-iso-control?") +(test-assert (not (char-iso-control? #\space))) +(test-end "char-iso-control?") + + +(test-begin "char-letter+digit?") +(test-assert (char-letter+digit? #\1)) +(test-assert (char-letter+digit? #\a)) +(test-end "char-letter+digit?") + + +(test-begin "char-letter?") +(test-assert (not (char-letter? #\1))) +(test-assert (char-letter? #\a)) +(test-end "char-letter?") + + +(test-begin "char-punctuation?") +(test-assert (not (char-punctuation? #\a))) +(test-assert (char-punctuation? #\!)) +(test-end "char-punctuation?") + + +(test-begin "char-title-case?") +(test-assert (not (char-title-case? #\a))) +(test-end "char-title-case?") + + +#| FIXME +(test-begin "cwd") +(debug (cwd)) +(test-assert (string? (cwd))) +(test-assert (char=? (string-ref (cwd) 0) #\/)) +(test-end "cwd") +|# + + +#| FIXME +(test-begin "chdir") +(let ((test-dir (cwd))) + (debug 0) + (chdir "/tmp") + (debug (cwd)) + (test-assert (string=? (cwd) "/tmp")) + (debug 1) + (chdir test-dir) + (debug 2) + (test-assert (string=? (cwd) test-dir)) + (when (not (string=? (cwd) test-dir)) + (error "Test did not change back to test directory"))) +(test-end "chdir") +|# + + +(test-begin "command-line") +(test-assert (list? (command-line))) +(test-end "command-line") + + +(test-begin "command-line-arguments") +(test-assert (list? (command-line-arguments))) +(test-end "command-line-arguments") + + +#| FIXME +(test-begin "delete-filesys-object") +(let ((file "/tmp/scschtest1.txt")) + (when (file-exists? file) (delete-file file)) + (with-output-to-file file (lambda () (display 1))) + (test-assert (file-exists? file)) + (delete-filesys-object file) + (test-assert (not (file-exists? file))) + (when (file-exists? file) (delete-file file))) +(test-end "delete-filesys-object") +|# + + +#| FIXME +(test-begin "file-directory?") +(test-assert (file-directory? "/tmp" #f)) +(let ((file "/tmp/scsch-file-directory?.txt")) + (when (file-exists? file) (delete-file file)) + (with-output-to-file file (lambda () (display 1))) + (test-assert (not (file-directory? file #f))) + (when (file-exists? file) (delete-file file))) +(test-end "file-directory?") +|# + + +#| FIXME +(test-begin "home-dir") +(test-assert (string? (home-dir))) +(test-end "home-dir") +|# + + +(test-begin "directory-as-file-name") +(test-equal "/" (directory-as-file-name "/")) +(test-equal "." (directory-as-file-name "")) +(test-equal "/tmp" (directory-as-file-name "/tmp/")) +(test-end "directory-as-file-name") + + +(test-begin "env->alist") +(test-equal '(("one" . "1") ("two" . "2") ("PATH" . "/tmp:/tmp/bin")) + (env->alist "one=1\ntwo=2\nPATH=/tmp:/tmp/bin")) +(test-end "env->alist") + + +(test-begin "error-output-port") +(test-assert (port? (error-output-port))) +(test-end "error-output-port") + (test-end "scsh") diff --git a/retropikzel/scsh/unix.scm b/retropikzel/scsh/unix.scm new file mode 100644 index 0000000..5e58c08 --- /dev/null +++ b/retropikzel/scsh/unix.scm @@ -0,0 +1,188 @@ +(define-c-library libc + '("stdlib.h" "string.h" "stdio.h" "glob.h" "unistd.h") + #f + ()) +(define-c-procedure c-perror libc 'perror 'void '(pointer)) +(define (perror procedure-name msg . objs) + (let ((procedure-name* (string->c-bytevector + (string-append procedure-name " error")))) + (c-perror procedure-name*) + (c-bytevector-free procedure-name*)) + (apply error (cons (string-append procedure-name " error: ") objs))) + + +(define *temp-file-template* + (cond ((get-environment-variable "TMPDIR") + (string-append (get-environment-variable "TMPDIR") + "/" + (number->string (pid)) + ".~a")) + (else + (string-append "/var/tmp/" (number->string (pid)) ".~a")))) + +(define (->uid uid/username) + (cond + ((exact-integer? uid/username) uid/username) + ((string? uid/username) + (letrec* + ((username-length (string-length uid/username)) + (looper (lambda (line) + (if (eof-object? line) + #f + (let ((line-length (string-length line))) + (if (and (>= line-length username-length) + (string=? uid/username + (string-copy line + 0 + username-length))) + (string->number (list-ref (string-split line #\:) 2)) + (looper (read-line)))))))) + (with-input-from-file "/etc/passwd" (lambda () (looper (read-line)))))) + (else (error (string-append "->uid error: uid/username must be either" + " exact integer or string"))))) + +(define (->username uid/username) + (cond ((string? uid/username) uid/username) + ((exact-integer? uid/username) + (letrec* + ((looper (lambda (line) + (if (eof-object? line) + #f + (let* ((line-length (string-length line)) + (line-list (string-split line #\:)) + (line-list-length (length line-list))) + (if (and (>= line-list-length 3) + (= (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)))))) + (else (error (string-append "->username error: uid/username must be either" + " exact integer or string"))))) + +(define-c-procedure c-realpath libc 'realpath 'pointer '(pointer pointer)) +(define (absolute-file-name fname . dir) + (cond ((not (string? fname)) + (error "abosolute-file-name error: fname must bes string")) + ((= (string-length fname) 0) "/") + (else (let* ((fname* (string->c-bytevector fname)) + (path* (c-realpath fname* (c-bytevector-null)))) + (if (c-bytevector-null? path*) + (let ((error* (string->c-bytevector "absolute-file-name"))) + (c-perror error*) + (c-bytevector-free fname* path* error*) + (error "" fname)) + (let ((path (c-bytevector->string path*))) + (c-bytevector-free fname* path*) + path)))))) + +(define-c-procedure c-glob libc 'glob 'int '(pointer int pointer pointer)) +(define-c-procedure c-globfree libc 'globfree 'int '(pointer)) +(define-c-struct-type glob-struct '((gl_pathc int) (gl_pathv pointer) (gl_offs int))) +(define glob + (lambda paths + (let ((result '())) + (for-each + (lambda (path) + (let ((glob-struct* (make-c-bytevector (c-type-size glob-struct))) + (path* (string->c-bytevector path))) + (c-glob path* 0 (c-bytevector-null) glob-struct*) + (letrec + ((path-count (c-bytevector-ref glob-struct* glob-struct 'gl_pathc)) + (looper + (lambda (count) + (when (< count path-count) + (let* ((list-path* + (c-bytevector-ref + (c-bytevector-ref glob-struct* glob-struct 'gl_pathv) + 'pointer + (* (c-type-size 'pointer) count))) + (list-path-string (c-bytevector->string list-path*))) + (set! result (append result (list list-path-string))) + (c-bytevector-free list-path*) + (looper (+ count 1))))))) + (looper 0) + (c-bytevector-free path* glob-struct*)))) + paths) + result))) + +(define-c-procedure c-setsid libc 'setsid 'int '()) +(define (become-session-leader) + (let ((result (c-setsid))) + (when (< result 0) + (error "become-session-leader error: Most propably already session leader" + result)) + result)) + +(define-c-procedure c-chdir libc 'chdir 'int '(pointer)) +(define chdir + (lambda args + (let ((fname (if (null? args) (home-dir) (car args)))) + (when (not (string? fname)) (error "chdir error: fname must be string")) + (let* ((fname* (string->c-bytevector fname)) + (result (c-chdir fname*))) + (c-bytevector-free fname*) + (when (= result -1) + (perror "chdir" "could not change directory")))))) + +(define-c-procedure c-getcwd libc 'getcwd 'pointer '(pointer int)) +(define (cwd) + (letrec + ((start-size 128) + (looper + (lambda (size) + (let* ((buffer* (make-c-bytevector size)) + (cwd* (c-getcwd buffer* size))) + (if (c-bytevector-null? cwd*) + (looper (* size 2)) + (let ((result (c-bytevector->string buffer*))) + (c-bytevector-free cwd* buffer*) + result)))))) + (looper start-size))) + +(define (delete-filesys-object fname) + (when (not (string? fname)) + (error "delete-filesys-object error: fname must be string")) + (if (file-directory? fname #f) + (delete-directory fname) + (guard (condition (else #t)) + (delete-file fname)))) + +(define (file-directory? fname/port . chase?) + (when (not (or (string? fname/port) + (port? fname/port))) + (error "file-directory? error: fname/port must be string or port")) + (when (and (not (null? chase?)) + (not (equal? (car chase?) #t)) + (not (equal? (car chase?) #f))) + (error "file-directory? error: chase? must be boolean")) + (let ((f-info (file-info fname/port (if (null? chase?) #t (car chase?))))) + (file-info-directory? f-info))) + +(define home-dir + (lambda args + (let ((user (if (null? args) + (user-info:name (user-info (user-uid))) + (car args)))) + (when (not (string? user)) + (error "home-dir error: user must be string" user)) + (letrec + ((username-length (string-length user)) + (looper (lambda (line) + (if (eof-object? line) + #f + (let ((line-length (string-length line))) + (if (and (>= line-length username-length) + (string=? user + (string-copy line + 0 + username-length))) + (list-ref (string-split line #\:) 5) + (looper (read-line))))))) + (home-dir-path (with-input-from-file + "/etc/passwd" + (lambda () (looper (read-line)))))) + (when (not home-dir-path) + (error "home-dir error: home directory not found, user does not exist?" + user)) + home-dir-path)))) diff --git a/retropikzel/scsh/util.scm b/retropikzel/scsh/util.scm new file mode 100644 index 0000000..dde7d6a --- /dev/null +++ b/retropikzel/scsh/util.scm @@ -0,0 +1,19 @@ +(define (string-split str split-by) + (read (open-input-string + (list->string + (append + (list #\( #\") + (apply + append + (map + (lambda (c) + (if (char=? c split-by) + (list #\" #\space #\") + (list c))) + (string->list str))) + (list #\" #\))))))) + +(define (string-join lst join-by) + (apply string-append + (cdr (apply append (map (lambda (item) (list join-by item)) lst))))) +