diff --git a/retropikzel/scsh.sld b/retropikzel/scsh.sld index b87c929..e7808da 100644 --- a/retropikzel/scsh.sld +++ b/retropikzel/scsh.sld @@ -287,20 +287,20 @@ ;open-syslog-channel os parent-pid - ;parse-file-name + parse-file-name ;parse-sre ;parse-sres - ;path-list->file-name + path-list->file-name pid ;pid->proc ;pipe ;placeholder-value ;placeholder? ;port->fdes - ;port->list - ;port->sexp-list - ;port->string - ;port->string-list + port->list + port->sexp-list + port->string + port->string-list port-fold ;port-revealed ;posix-string->regexp @@ -358,7 +358,7 @@ ;re-trivial ;re-trivial? ;re-tsm - ;read-delimited + read-delimited ;read-delimited! ;read-directory-stream ;read-line diff --git a/retropikzel/scsh/portable.scm b/retropikzel/scsh/portable.scm index 47fd1ab..89fd1a3 100644 --- a/retropikzel/scsh/portable.scm +++ b/retropikzel/scsh/portable.scm @@ -1,4 +1,4 @@ -(define (reduce-port port reader op . seeds) +(define (port-fold port reader op . seeds) (letrec* ((looper (lambda new-seeds (let ((read-value (reader port))) (if (eof-object? read-value) @@ -8,7 +8,7 @@ looper)))))) (apply looper seeds))) -(define port-fold reduce-port) +(define reduce-port port-fold) (define (simplify-file-name fname) ;; TODO (cond @@ -301,11 +301,12 @@ (error "file-name-directory error: fname must be string" fname)) (cond ((string=? fname "/") "") ((string=? fname "") "") + ((char=? (string-ref fname (- (string-length fname) 1)) #\/) fname) (else (let ((chibi-path (path-directory fname))) (if (string=? chibi-path ".") "" - chibi-path))))) + (string-append chibi-path "/")))))) (define (file-name-directory? fname) (when (not (string? fname)) @@ -326,6 +327,12 @@ (error "file-name-non-directory? error: fname must be string" fname)) (if (string=? fname "") #t (not (file-name-directory? fname)))) +(define (file-name-nondirectory fname) + (when (not (string? fname)) + (error "file-name-nondirectory error: fname must be string" fname)) + (cond ((string=? fname "/") "/") + (else (path-strip-directory fname)))) + (define (file-name-sans-extension fname) (when (not (string? fname)) (error "file-name-sans-extension error: fname must be string" fname)) @@ -393,4 +400,65 @@ (linux 'linux) (freebsd 'freesdb) (netbsd 'netbsd) + (haiku 'haiku) (else 'unix))) + +(define (parse-file-name fname) + (when (not (string? fname)) + (error "parse-file-name error: fname must be string" fname)) + (let ((f (file-name-nondirectory fname))) + (list (file-name-directory fname) + (file-name-sans-extension f) + (file-name-extension f)))) + +(define (path-list->file-name path-list . args) + (let ((path (string-join path-list "/"))) + (cond ((null? path-list) "") + ((and (not (null? args)) + (string=? (list-ref args 0) "")) + (string-append "/" path)) + ((and (not (null? args)) + (not (string? (list-ref args 0)))) + (error "path-list->file-name error: dir must be string" + (list-ref args 0))) + ((and (not (null? args)) + (string? (list-ref args 0))) + (string-append (file-name-as-directory (list-ref args 0)) path)) + (else path)))) + +(define (port->list reader port) + (reverse (port-fold port reader cons '()))) + +(define (port->sexp-list port) (port->list read port)) + +(define (port->string port) + (letrec* ((result "") + (looper (lambda (str) + (cond ((eof-object? str) result) + (else (set! result (string-append result str)) + (looper (read-string 1024 port))))))) + (looper (read-string 1024 port)))) + +(define (port->string-list port) (reverse (port-fold port 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"))) + (letrec* ((character-set (if (string? char-set) + (string->char-set char-set) + char-set)) + (port (if (>= (length args) 1) + (car args) + (current-input-port))) + (result '()) + (looper (lambda (c) + (cond ((char-set-contains? character-set c) + (list->string (reverse result))) + (else (set! result (cons c result)) + (looper (read-char port))))))) + (looper (read-char port)))) + + + diff --git a/retropikzel/scsh/test.scm b/retropikzel/scsh/test.scm index 07b4fbf..89dbb0c 100644 --- a/retropikzel/scsh/test.scm +++ b/retropikzel/scsh/test.scm @@ -7,6 +7,7 @@ (retropikzel scsh) (retropikzel tap) (retropikzel debug) + (srfi 14) (srfi 19) (srfi 64)) @@ -338,9 +339,15 @@ (test-begin "file-name-directory") -(test-equal "/tmp" (file-name-directory "/tmp/hello.txt")) +(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 "lol/" (file-name-directory "lol/hello.txt")) +(test-equal "" (file-name-directory "")) +(test-equal "/usr/" (file-name-directory "/usr/bdc")) +(test-equal "/usr/bdc/" (file-name-directory "/usr/bdc/")) +(test-equal "bdc/" (file-name-directory "bdc/.login")) +(test-equal "" (file-name-directory "main.c")) +(test-equal "" (file-name-directory "/")) (test-equal "" (file-name-directory "")) (test-end "file-name-directory") @@ -370,6 +377,15 @@ (test-end "file-name-non-directory?") +(test-begin "file-name-nondirectory") +(test-equal "ian" (file-name-nondirectory "/usr/ian")) +(test-equal "" (file-name-nondirectory "/usr/ian/")) +(test-equal ".login" (file-name-nondirectory "ian/.login")) +(test-equal "main.c" (file-name-nondirectory "main.c")) +(test-equal "" (file-name-nondirectory "")) +(test-equal "/" (file-name-nondirectory "/")) +(test-end "file-name-nondirectory") + (test-begin "file-name-sans-extension") (test-equal "foo" (file-name-sans-extension "foo.bar")) (test-equal "foobar" (file-name-sans-extension "foobar")) @@ -444,4 +460,47 @@ (test-end "parent-pid") +(test-begin "parse-file-name") +(test-equal '("/tmp/" "foo" ".bar") (parse-file-name "/tmp/foo.bar")) +(test-end "parse-file-name") + + +(test-begin "path-list->file-name") +(test-equal "src/des/main.c" (path-list->file-name '("src" "des" "main.c"))) +(test-equal "/src/des/main.c" (path-list->file-name '("" "src" "des" "main.c"))) +(test-equal "/usr/shivers/src/des/main.c" + (path-list->file-name '("src" "des" "main.c") "/usr/shivers")) +(test-end "path-list->file-name") + + +(test-begin "port->list") +(test-equal '(foo bar baz) (port->list read (open-input-string "foo bar baz"))) +(test-end "port->list") + + +(test-begin "port->sexp-list") +(test-equal '(foo bar baz (1 2 3)) + (port->sexp-list (open-input-string "foo bar baz (1 2 3)"))) +(test-end "port->sexp-list") + + +(test-begin "port->string") +(test-equal "1 2 3 (1 2 3)" (port->string (open-input-string "1 2 3 (1 2 3)"))) +(test-end "port->string") + + +(test-begin "port->string-list") +(test-equal '("foo" "bar" "baz") + (port->string-list (open-input-string "foo\nbar\nbaz\n"))) +(test-end "port->string-list") + + +(test-begin "read-delimited") +(test-equal "foo" (read-delimited "1" + (open-input-string "foo1bar2baz3"))) +(test-equal "foo" (read-delimited char-set:digit + (open-input-string "foo1bar2baz3"))) +(test-end "read-delimited") + + (test-end "scsh")