scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

*** empty log message ***

This commit is contained in:
chetz 2004-07-07 13:37:56 +00:00
parent f2e92c652a
commit 5c0ff0293b
3 changed files with 817 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

570
scsh/test/awk-test.scm Normal file
View File

@ -0,0 +1,570 @@
;;; Test for the function in section 8.2 of the scsh-manual "awk"
;;; Author: Christoph Hetz
;; for testing: (certainly the path will be an other on other systems...)
;; ,open define-record-types handle
;; ,config ,load C:/cygwin/home/mephisto/cvs_scsh/scsh/scsh/test/test-packages.scm
;; ,load C:/cygwin/home/mephisto/cvs_scsh/scsh/scsh/test/test-base.scm
;; load this file
;; (test-all)
;; *** basic help-functions ***
(define ascii->string
(lambda (i)
(list->string (list (ascii->char i)))))
(define char->string
(lambda (ch)
(list->string (list ch))))
(define reverse-string
(lambda (str)
(list->string (reverse (string->list str)))))
;; *** help-functions ***
(define str-palindrom?
(lambda (str)
(equal? str (reverse-string str))))
(define int-palindrom?
(lambda (i)
(str-palindrom? (number->string i))))
;; *** tests ***
;; --- is the <counter> incremented correct ---
(add-test! 'counter-inc-test 'awk
(lambda ()
(let ((read '())
(tmp-file (create-temp-file)))
(call-with-output-file tmp-file
(lambda (out-port)
(let loop ((i 0))
(if (not (= 9 i))
(begin
(write "test-zeile\n" out-port)
(loop (+ i 1)))))))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) counter ()
(#t (set! read (cons counter read))))))
(delete-file tmp-file)
(equal? read '(10 9 8 7 6 5 4 3 2 1)))))
;; --- does the "int-test" work properly ---
(add-test! 'int-test-test 'awk
(lambda ()
(let ((read '())
(tmp-file (create-temp-file)))
(call-with-output-file tmp-file
(lambda (out-port)
(let loop ((i 0))
(if (not (= 20 i))
(begin
(write "test-zeile\n" out-port)
(loop (+ i 1)))))))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) counter ()
(1 (set! read (cons 1 read)))
(2 (set! read (cons 2 read)))
(3 (set! read (cons 3 read)))
(4 (set! read (cons 4 read)))
(5 (set! read (cons 5 read)))
(6 (set! read (cons 6 read)))
(7 (set! read (cons 7 read)))
(8 (set! read (cons 8 read)))
(9 (set! read (cons 9 read)))
(0 (set! read (cons 0 read))))))
(delete-file tmp-file)
(equal? read '(9 8 7 6 5 4 3 2 1)))))
;; --- big line ---
(add-test! 'read-one-mb-line-from-file 'awk
(lambda ()
(let ((one-kb-line (let loop ((i 0))
(if (= 1024 i)
""
(string-append "a" (loop (+ i 1))))))
(tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(let loop ((i 0))
(if (= 1024 i)
(write-string "" out-port)
(begin
(write-string one-kb-line out-port)
(loop (+ i 1)))))))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) c ()
(#t (begin
(set! read line))))))
(delete-file tmp-file)
(and (string? read)
(= (string-length read)
(* 1024 1024))))))
;; --- special signs ---
(add-test! 'read-special-signs 'awk
(lambda ()
(let (( strange-sign-line
(let loop ((i 0))
(if (= i 256)
""
(if (= i 10) ;; comes along with everything but line-feed
(loop (+ i 1))
(string-append (ascii->string i)
(loop (+ i 1)))))))
(tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string strange-sign-line out-port)
(write-string "\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) ()
(#t (set! read line)))))
(delete-file tmp-file)
(equal? read strange-sign-line))))
;; --- sre-expr-test ---
(add-test! 'sre-expr-test-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "sre-expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) ()
(("sre" "zu") (set! read (cons 'sre-zu read)))
("eine" (set! read (cons 'eine read)))
("EINE" (set! read (cons 'EINE read)))
((* "3") (set! read (cons '*3 read)))
((? "s") (set! read (cons '?s read)))
((+ "+") (set! read (cons '++ read))))))
(delete-file tmp-file)
;; |z6 |z5 |z4 |z3 |z2 |z1 |
(equal? (list '++ '?s '*3 '?s '*3 'eine 'sre-zu '?s '*3 'eine 'sre-zu '?s '*3 'EINE '?s '*3 'sre-zu '?s '*3 'sre-zu)
read))))
;; --- when-test ---
(add-test! 'when-bool-exp-test-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "when-bool-expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) counter ()
((when (= counter 1))
(set! read (cons 'first-clause read)))
((when (equal? line
"when-bool-expr-test zu prüfen:"))
(set! read (cons 'second-clause read)))
((when (> counter 2))
(set! read (cons 'third-clause read))))))
(delete-file tmp-file)
(equal? read
(list 'third-clause 'third-clause 'third-clause 'third-clause 'second-clause 'first-clause)))))
;; --- expr-test-test ---
(add-test! 'expr-test-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) counter ()
("paar" (set! read (cons 'first-clause read)))
((equal? line
"expr-test zu prüfen:")
(set! line (cons 'second-clause read)))
((> counter 5)
(set! read (cons 'third-clause read)))
((+ "3") ;; makes problems here, but was ok in sre-xpr-test ;;FIXXX it
(set! read (cons 'fourth-clause read))))))
(delete-file tmp-file)
(equal? read
(list 'third-clause 'fourth-clause 'second-clause 'first-clause)))))
;; --- several-bodys-in-clause-test ---
;; XX to do: only for <test>s that were ok till now (int, when)
(add-test! 'several-bodys-in-clause-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) counter ()
(1 (set! read (cons 'clause-one-body-one read))
(set! read (cons 'clause-one-body-two read))
(set! read (cons 'clause-one-body-three read)))
((when (equal? line
"eine zeile klein..."))
(set! read (cons 'clause-two-body-one read))
(set! read (cons 'clause-two-body-two read))
(set! read (cons 'clause-two-body-three read))))))
(delete-file tmp-file)
(equal? read
(list 'clause-two-body-three 'clause-two-body-two 'clause-two-body-one
'clause-one-body-three 'clause-one-body-two 'clause-one-body-one)))))
;; --- range-wo-begin-wo-end-test ---
;; XX to do: only ok <test>s ... s.u.
(add-test! 'range-wo-begin-wo-end-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) counter ()
(range 1 3 (set! read (cons 'first-clause read)))
(range (when (equal? line
"EINE ZEILE GRO/3..."))
(when (equal? line
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}"))
(set! read (cons 'second-clause read)))
(range (when (equal? line
"expr-test zu prüfen:"))
4
(set! read (cons 'third-clause read))))))
(delete-file tmp-file)
(equal? read
(list 'second-clause 'second-clause 'third-clause 'first-clause)))))
;; --- range-w-begin-wo-end-test ---
;; XX to do: only ok <test>s ... s.u.
(add-test! 'range-w-begin-wo-end-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) counter ()
(:range 1 3 (set! read (cons 'first-clause read)))
(:range (when (equal? line
"EINE ZEILE GRO/3..."))
(when (equal? line
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}"))
(set! read (cons 'second-clause read)))
(:range (when (equal? line
"expr-test zu prüfen:"))
4
(set! read (cons 'third-clause read))))))
(delete-file tmp-file)
(equal? read
(list 'second-clause 'second-clause 'third-clause 'second-clause 'third-clause 'first-clause 'first-clause)))))
;; --- range-wo-begin-w-end-test ---
;; XX to do: only ok <test>s ... s.u.
(add-test! 'range-wo-begin-w-end-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) counter ()
(range: 1 3 (set! read (cons 'first-clause read)))
(range: (when (equal? line
"EINE ZEILE GRO/3..."))
(when (equal? line
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}"))
(set! read (cons 'second-clause read)))
(range: (when (equal? line
"expr-test zu prüfen:"))
4
(set! read (cons 'third-clause read))))))
(delete-file tmp-file)
(equal? read
(list 'second-clause 'second-clause 'third-clause 'second-clause 'third-clause 'first-clause 'first-clause)))))
;; --- range-w-begin-w-end-test ---
;; XX to do: only ok <test>s ... s.u.
(add-test! 'range-w-begin-w-end-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) counter ()
(:range: 1 3 (set! read (cons 'first-clause read)))
(:range: (when (equal? line
"EINE ZEILE GRO/3..."))
(when (equal? line
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}"))
(set! read (cons 'second-clause read)))
(:range: (when (equal? line
"expr-test zu prüfen:"))
4
(set! read (cons 'third-clause read))))))
(delete-file tmp-file)
(equal? read
(list 'second-clause 'second-clause 'third-clause 'second-clause 'third-clause
'second-clause 'first-clause 'third-clause 'first-clause 'first-clause)))))
;; --- else-test ---
(add-test! 'else-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) ()
(1 (set! read (cons 'first-clause read)))
(else (set! read (cons 'second-clause read)))
(4 (set! read (cons 'third-clause read)))
(5 (set! read (cons 'fourth-clause read)))
(else (set! read (cons 'fifth-clause read))))))
(delete-file tmp-file)
(equal? read
(list 'fifth-clause 'second-clause 'fourth-clause 'second-clause 'third-clause
'second-clause 'fifth-clause 'second-clause 'fifth-clause 'second-clause
'fifth-clause 'first-clause)))))
;; --- test=>expr-test ---
(add-test! 'test=>expr-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) counter ()
(counter => (lambda (c)
(set! read (cons c read))))
(#f => (lambda (c)
(set! read (cons c read)))))))
(delete-file tmp-file)
(equal? read (list 6 5 4 3 2 1)))))
;; --- after-test ---
(add-test! 'after-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(set! read
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) ()
(1 (set! read 1))
(2 (set! read 2))
(after 'return)))))
(delete-file tmp-file)
(equal? read 'return))))
;; --- var-decl-test ---
(add-test! 'var-decl-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) counter ((i 0)
(x 2)
(y 3))
(1 (set! i (+ x y)))
(2 (set! x (+ i y)))
(3 (set! i (* i 2)))
(4 (set! i (- i y)))
(5 (set! i (* i x)))
(6 (set! read i)))))
(delete-file tmp-file)
(= read 56))))
;; --- multiple-return-values-of-next-record-test ---
(add-test! 'multiple-return-values-of-next-record-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(write-string "ein paar testzeilen, um\n" out-port)
(write-string "expr-test zu prüfen:\n" out-port)
(write-string "EINE ZEILE GRO/3...\n" out-port)
(write-string "eine zeile klein...\n" out-port)
(write-string "eine zeile mit zeichen...\n" out-port)
(write-string "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n" out-port)))
(call-with-input-file tmp-file
(lambda (in-port)
(awk ((lambda ()
(values (read-line in-port)1 2 'a 'b))) (line x y a b) counter ()
(1 (set! read (cons x read)))
(2 (set! read (cons y read)))
(3 (set! read (cons a read)))
(4 (set! read (cons b read))))))
(delete-file tmp-file)
(equal? read
(list 'b 'a 2 1)))))
;; --- awk-in-awk-test ---
(add-test! 'awk-in-awk-test 'awk
(lambda ()
(let ((tmp-file (create-temp-file))
(read '()))
(call-with-output-file tmp-file
(lambda (out-port)
(let loop ((i 1))
(if (= 10000 i)
(write-string (number->string i) out-port)
(begin
(write-string (number->string i) out-port)
(if (zero? (modulo i 100))
(write-string "\n" out-port)
(write-string " " out-port))
(loop (+ i 1)))))))
(call-with-input-file tmp-file
(lambda (in-port)
(awk (read-line in-port) (line) ()
(#t (let ((tmp-file-1 (create-temp-file))
(l (string-length line)))
(call-with-output-file tmp-file-1
(lambda (out-port)
(let loop ((i 0))
(if (= i l)
(write-string "" out-port)
(let ((ch (string-ref line i)))
(if (= 32 (char->ascii ch))
(write-string "\n" out-port)
(write-string (char->string ch) out-port))
(loop (+ i 1)))))))
(call-with-input-file tmp-file-1
(lambda (in-port)
(awk (read-line in-port) (number-str) ()
((str-palindrom? number-str) (set! read (cons number-str read))))))
(delete-file tmp-file-1))))))
(delete-file tmp-file)
(equal? read
(let loop ((i 10000))
(if (zero? i)
'()
(if (int-palindrom? i)
(cons (number->string i) (loop (- i 1)))
(loop (- i 1)))))))))

201
scsh/test/file-name-manipulation-test.scm Normal file
View File

@ -0,0 +1,201 @@
;;; Test for function in section 5.1 of the scsh-manual "file-name-... , diretory-... , ..."
;;; Author: Christoph Hetz
;; for now just the examples from the manual will be tested
;; for testing: (certainly the path will be an other on other systems...)
;; ,open define-record-types handle
;; ,config ,load C:/cygwin/home/mephisto/cvs-scsh/scsh/scsh/test/test-packages.scm
;; ,load C:/cygwin/home/mephisto/cvs-scsh/scsh/scsh/test/test-base.scm
;; load this file
;; (test-all)
;; *** tests ***
(add-test! 'file-name-directory? 'file-name-manipulation
(lambda ()
(and (not (file-name-directory? "src/des"))
(file-name-directory? "src/des/")
(file-name-directory? "/")
(not (file-name-directory? "."))
(file-name-directory? ""))))
(add-test! 'file-name-non-directory? 'file-name-manipulation
(lambda ()
(and (file-name-non-directory? "src/des")
(not (file-name-non-directory? "src/des/"))
(not (file-name-non-directory? "/"))
(file-name-non-directory? ".")
(file-name-non-directory? ""))))
(add-test! 'file-name-as-directory 'file-name-manipulation
(lambda ()
(and (equal? "src/des/"
(file-name-as-directory "src/des"))
(equal? "src/des/"
(file-name-as-directory "src/des/"))
(equal? ""
(file-name-as-directory "."))
(equal? "/"
(file-name-as-directory "/"))
(equal? "/"
(file-name-as-directory "")))))
(add-test! 'directory-as-file-name 'file-name-manipulation
(lambda ()
(and (equal? "foo/bar"
(directory-as-file-name "foo/bar/"))
(equal? "foo/bar"
(directory-as-file-name "foo/bar"))
(equal? "/"
(directory-as-file-name "/"))
(equal? "."
(directory-as-file-name "")))))
(add-test! 'file-name-absolute? 'file-name-manipulation
(lambda ()
(and (file-name-absolute? "/usr/shievers")
(not (file-name-absolute? "src/des"))
(file-name-absolute? "/src/des")
(file-name-absolute? ""))))
(add-test! 'file-name-directory 'file-name-manipuation
(lambda ()
(and (equal? "/usr/"
(file-name-directory "/usr/bcd"))
(equal? "/usr/bcd/"
(file-name-directory "/usr/bcd/"))
(equal? "bdc/"
(file-name-directory "bdc/.login"))
(equal? ""
(file-name-directory "main.c"))
(equal? ""
(file-name-directory "/"))
(equal? ""
(file-name-directory "")))))
(add-test! 'file-name-nondirectory 'file-name-manipulation
(lambda ()
(and (equal? "ian"
(file-name-nondirectory "/usr/ian"))
(equal? ""
(file-name-nondirectory "/usr/ian/"))
(equal? ".login"
(file-name-nondirectory "ian/.login"))
(equal? "main.c"
(file-name-nondirectory "main.c"))
(equal? ""
(file-name-nondirectory ""))
(equal? "/"
(file-name-nondirectory "/")))))
(add-test! 'split-file-name 'file-name-manipulation
(lambda ()
(and (equal? '("src" "des" "main.c")
(split-file-name "src/des/main.c"))
(equal? '("" "src" "des" "main.c")
(split-file-name "/src/des/main.c"))
(equal? '("main.c")
(split-file-name "main.c"))
(equal? '("")
(split-file-name "/")))))
(add-test! 'path-list->file-name 'file-name-manipulation
(lambda ()
(and (equal? "src/des/main.c"
(path-list->file-name '("src" "des" "main.c")))
(equal? "/src/des/main.c"
(path-list->file-name '("" "src" "des" "main.c")))
(equal? "/usr/shivers/src/des/main.c"
(path-list->file-name '("src" "des" "main.c")
"/usr/shivers")))))
(add-test! 'file-name-extension 'file-name-manipulation
(lambda ()
(and (equal? ".c"
(file-name-extension "main.c"))
(equal? ".old"
(file-name-extension "main.c.old"))
(equal? ""
(file-name-extension "/usr/shivers"))
(equal? "."
(file-name-extension "foo."))
(equal? "."
(file-name-extension "foo.."))
(equal? ""
(file-name-extension "/usr/shivers/.login")))))
(add-test! 'file-name-sans-extension 'file-name-manipulation
(lambda ()
(and (equal? "main"
(file-name-sans-extension "main.c"))
(equal? "main.c"
(file-name-sans-extension "main.c.old"))
(equal? "/usr/shivers"
(file-name-sans-extension "/usr/shivers"))
(equal? "foo"
(file-name-sans-extension "foo."))
(equal? "foo."
(file-name-sans-extension "foo.."))
(equal? "/usr/shivers/.login"
(file-name-sans-extension "/usr/shivers/.login")))))
(add-test! 'parse-file-name 'file-name-manipulation
(lambda ()
(let* ((fname "/usr/shivers/main.c")
(f (file-name-nondirectory fname)))
(equal? (list (file-name-directory fname)
(file-name-sans-extension f)
(file-name-extension f))
(call-with-values
(lambda ()
(parse-file-name fname))
(lambda (a b c)
(list a b c)))))))
(add-test! 'replace-extension 'file-name-manipulation
(lambda ()
(let ((fname "/usr/shivers/main.c")
(ext "old"))
(equal? (string-append (file-name-sans-extension fname) ext)
(replace-extension fname ext)))))
(add-test! 'simplify-file-name 'file-name-manipulation
(lambda ()
(and (equal? "/usr/shivers"
(simplify-file-name "/usr/shivers"))
(equal? "/usr/shivers"
(simplify-file-name "////usr//shivers/"))
(equal? "/usr/shivers/."
(simplify-file-name "////usr/shivers/."))
(equal? "//usr/shivers"
(simplify-file-name "//usr/shivers/"))
(equal? "/usr/shivers/../test"
(simplify-file-name "////usr/shivers/../test/")))))
;; XX todo:
(add-test! 'resolve-file-name 'file-name-manipulation
(lambda ()
(and (equal? (resolve-file-name "~")
(home-dir))
(string? (resolve-file-name "~/c/main.c" "/usr/bin")))))
(add-test! 'expand-file-name 'file-name-manipulation
(lambda ()
(equal? (expand-file-name "~/..///c/bin/main.out" "/usr/bin")
(simplify-file-name (resolve-file-name "~/..///c/bin/main.out" "/usr/bin")))))
(add-test! 'absolute-file-name 'file-name-manipulation
(lambda ()
(equal? (absolute-file-name "~/c/bin/c.out" "/usr/local")
"/usr/local/~/c/bin/c.out")))
;;(add-test! 'home-dir 'file-name-manipulation
;; was tested with resolve-file-name
(add-test! 'home-file 'file-name-manipulation
(lambda ()
(equal? (home-file "man")
(resolve-file-name "~/man"))))

46
scsh/test/time-procedure-calls.scm Normal file
View File

@ -0,0 +1,46 @@
;;; "Test" for the functions in section 3.10 of the scsh manual "time"
;;; "Test", because these are no real test - they just call the prozedures to check if they are implemented
;;; Author: Christoph Hetz
;; ,open define-record-types handle
;; ,config ,load C:/cygwin/home/mephisto/cvs_scsh/scsh/scsh/test/test-packages.scm
;; ,load C:/cygwin/home/mephisto/cvs_scsh/scsh/scsh/test/test-base.scm
;; load this file
;; (test-all)
;; *** tests ***
(add-test! 'time-ticks 'time
(lambda ()
(call-with-values
(lambda ()
(time+ticks))
(lambda (tme tcks)
(and (number? tme)
(number? tcks))))))
(add-test! 'ticks/sec 'time
(lambda ()
(real? (ticks/sec))))
(add-test! 'date 'time
(lambda ()
(date? (date))))
(add-test! 'time 'time
(lambda ()
(integer? (time))))
(add-test! 'date->string 'time
(lambda ()
(string? (date->string (date)))))
(add-test! 'format-date 'time
(lambda ()
(string? (format-date "~a ~A ~b ~B ~c ~d ~H ~I ~j ~m ~M ~p ~S ~U ~w ~W ~x ~X ~y ~Y ~Z" (date)))))
;;; fill-in-date! seems to be not implemented yet.
;(add-test! 'fill-in-date! 'time
; (lambda ()
; (date? (fill-in-date! (date)))))