scsh: Adding more features

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

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))))
+
+
+

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")