Update of /cvsroot/scsh/scsh-0.6/scsh/test
In directory usw-pr-cvs1:/tmp/cvs-serv26412
Added Files:
file-system-tests.scm test-base.scm test-packages.scm
Log Message:
Added implementation of a test suite.
Added tests for the file system operations (sec. 3.3 of the manual).
Author: David Frese
--- NEW FILE ---
;;; Tests for the function in section 3.3 of the scsh-manual "File system"
;;; Author: David Frese
; file-type: don't know how to test block-special, char-special
; socket should be tested in section "Networking"!!
; file-device: ??
; file-inode: only tested for overflow
;
; sync-file: Test is not very stable, I guess??
;
; glob: hard work ??
; temp-file-iterate: could it be ignored?? create-temp-file uses it anyway??
; temp-file-channel: ??
(define create-temp-dir
(let ((temp-dir "/tmp/scsh-test/"))
(lambda ()
(if (file-not-exists? temp-dir)
(create-directory temp-dir))
temp-dir)))
(define (file-perms fname/fd/port)
(bitwise-and (file-mode fname/fd/port)
#o777))
(define (mask fixnum)
(bitwise-and fixnum
(bitwise-not (umask))))
(define (create-file fname)
(close-output-port (open-output-file fname)))
(define (open/create-file fname flags)
(if (file-not-exists? fname)
(create-file fname))
(open-file fname flags))
(define (symbol-append symbol string)
(string->symbol (string-append
(symbol->string symbol)
string)))
;; --- Create-Directory ---
(add-test! 'create-directory-1 'file-system
(lambda (name)
(with-cwd (create-temp-dir)
(create-directory name)
(let ((result (file-directory? name)))
(delete-filesys-object name)
result)))
"dir")
(add-test! 'create-directory-2 'file-system
(lambda (name perms)
(with-cwd (create-temp-dir)
(create-directory name perms)
(let ((result (and (file-directory? name)
(= (file-perms name)
(mask perms)))))
(delete-filesys-object name)
result)))
"dir" #o700)
;; --- Create FIFO ---
(add-test! 'create-fifo-1 'file-system
(lambda (name)
(with-cwd (create-temp-dir)
(create-fifo name)
(let ((result (eq? (file-type name)
'fifo)))
(delete-filesys-object name)
result)))
"fifo")
(add-test! 'create-fifo-2 'file-system
(lambda (name perms)
(with-cwd (create-temp-dir)
(create-fifo name perms)
(let ((result (and (eq? (file-type name)
'fifo)
(= (file-perms name)
(mask perms)))))
(delete-filesys-object name)
result)))
"fifo" #o700)
;; --- Create-hard-link ---
(add-test! 'create-hard-link 'file-system
(lambda (fname linkname)
(with-cwd (create-temp-dir)
(close-output-port (open-output-file fname))
(create-hard-link fname linkname)
(let ((result (file-exists? linkname)))
(delete-filesys-object fname)
(delete-filesys-object linkname)
result)))
"file" "hard-link")
;; --- Create-symlink ---
(add-test! 'create-symlink 'file-system
(lambda (fname linkname)
(with-cwd (create-temp-dir)
(create-file fname)
(create-symlink fname linkname)
(let ((result (and (file-exists? linkname)
(eq? (file-type linkname #f)
'symlink)
(eq? (file-type linkname #t)
'regular))))
(delete-filesys-object fname)
(delete-filesys-object linkname)
result)))
"file" "symlink")
;; --- Delete-Directory ---
(add-test! 'delete-directory 'file-system
(lambda (name)
(with-cwd (create-temp-dir)
(create-directory name)
(delete-directory name)
(file-not-exists? name)))
"dir")
;; --- Delete-File ---
(add-test! 'delete-file 'file-system
(lambda (name)
(with-cwd (create-temp-dir)
(create-file name)
(delete-file name)
(file-not-exists? name)))
"file")
(add-test! 'delete-filesys-object 'file-system
(lambda (name)
(with-cwd (create-temp-dir)
(create-file name)
(delete-filesys-object name)
(and (file-not-exists? name)
;; even now, it shouldn't signal an error
(delete-filesys-object name))))
"file")
;; --- Read-Symlink ---
(add-test! 'read-symlink 'file-system
(lambda (fname linkname)
(with-cwd (create-temp-dir)
(create-file fname)
(create-symlink fname linkname)
(let ((result (equal? fname
(read-symlink linkname))))
(delete-filesys-object fname)
(delete-filesys-object linkname)
result)))
"file" "symlink")
;; --- Rename-File ---
(add-test! 'rename-file 'file-system
(lambda (name1 name2)
(with-cwd (create-temp-dir)
(create-file name1)
(rename-file name1 name2)
(let ((result (and (file-exists? name2)
(file-not-exists? name1))))
(delete-filesys-object name2)
result)))
"file-1" "file-2")
;; --- Little Abstraction for funcs with fname/fd/port ---
;; uses add-test-multiple!
(define (add-test/fname/fd/port! name before-func func result-func .
input-lists)
(let ((name-1 (string->symbol (string-append (symbol->string name)
"/fname")))
(name-2 (string->symbol (string-append (symbol->string name)
"/fd")))
(name-3 (string->symbol (string-append (symbol->string name)
"/port"))))
;; Test as a filename
(apply add-test-multiple!
name-1 'file-system
(lambda (fname . params)
(with-cwd (create-temp-dir)
(let ((port (open/create-file fname open/write)))
(if before-func (before-func port))
(let ((result (apply func (cons fname params))))
(close port)
(delete-filesys-object fname)
(if result-func
(apply result-func result params)
result)))))
input-lists)
;; Test as a fdes
(apply add-test-multiple!
name-2 'file-system
(lambda (fname . params)
(with-cwd (create-temp-dir)
(let ((port (open/create-file fname open/write)))
(if before-func (before-func port))
(let ((result (apply func (cons (port->fdes port)
params))))
(close port)
(delete-filesys-object fname)
(if result-func
(apply result-func result params)
result)))))
input-lists)
;; Test as a port
(apply add-test-multiple!
name-3 'file-system
(lambda (fname . params)
(with-cwd (create-temp-dir)
(let ((port (open/create-file fname open/write)))
(if before-func (before-func port))
(let ((result (apply func (cons port params))))
(close port)
(delete-filesys-object fname)
(if result-func
(apply result-func result params)
result)))))
input-lists)
))
;; --- Set-file-mode ---
(add-test/fname/fd/port! 'set-file-mode
#f
(lambda (fname/fd/port mode)
(set-file-mode fname/fd/port mode)
(file-perms fname/fd/port))
=
'("file") '(#o754))
;; --- Set-file-owner ---
(add-test/fname/fd/port! 'set-file-owner
#f
(lambda (fname/fd/port uid)
(set-file-owner fname/fd/port uid)
(file-owner fname/fd/port))
equal?
'("file") (list (user-uid)))
;; --- Set-file-group ---
(add-test/fname/fd/port! 'set-file-group
#f
(lambda (fname/fd/port gid)
(set-file-group fname/fd/port gid)
(file-group fname/fd/port))
equal?
'("file") (list (user-gid)))
;; --- set-file-times ---
(add-test! 'set-file-times-1 'file-system
(lambda (fname time-1)
(with-cwd (create-temp-dir)
(create-file fname)
(set-file-times fname time-1 0)
(let ((result (file-last-access fname)))
(delete-filesys-object fname)
(= result time-1))))
"file" 10000)
(add-test! 'set-file-times-2 'file-system
(lambda (fname time-2)
(with-cwd (create-temp-dir)
(create-file fname)
(set-file-times fname 0 time-2)
(let ((result (file-last-mod fname)))
(delete-filesys-object fname)
(= result time-2))))
"file" 10000)
;; --- sync-file ---
(add-test! 'sync-file 'file-system
(lambda (fname)
(with-cwd (create-temp-dir)
(create-file fname)
(let ((port (open-file fname open/write)))
(write-string "1" port)
(let ((res-1 (file-size fname)))
(sync-file port)
(let ((res-2 (file-size fname)))
(close port)
(delete-filesys-object fname)
(and (= 0 res-1) (> 0 res-2)))))))
"file")
;; --- truncate-file ---
(add-test/fname/fd/port! 'truncate-file
(lambda (port)
(write (make-string 100 #\*) port))
(lambda (fname/fd/port len)
(truncate-file fname/fd/port len)
(file-size fname/fd/port))
=
'("file") '(10))
;; --- file-info stuff ---
;; --- file-type ---
(add-test! 'file-type-dir 'file-system
(lambda (fname)
(with-cwd (create-temp-dir)
(create-directory fname)
(let ((result (file-type fname)))
(delete-filesys-object fname)
(equal? result 'directory))))
"dir")
(add-test! 'file-type-fifo 'file-system
(lambda (fname)
(with-cwd (create-temp-dir)
(create-fifo fname)
(let ((result (file-type fname)))
(delete-filesys-object fname)
(equal? result 'fifo))))
"fifo")
(add-test! 'file-type-regular 'file-system
(lambda (fname)
(with-cwd (create-temp-dir)
(create-file fname)
(let ((result (file-type fname)))
(delete-filesys-object fname)
(equal? result 'regular))))
"file")
;(add-test! 'file-type-socket 'file-system
; (lambda (fname)
; (let* ((pathname (string-append (create-temp-dir)
; fname))
; (socket (create-socket protocol-family/unix
; socket-type/raw))
; (addr (unix-address->socket-address
; pathname)))
; (bind-socket socket addr)
; ;; now fname should be a socket
; (let ((result (file-info pathname)))
; (delete-filesys-object pathname)
; (equal? result 'socket))))
; "socket")
(add-test! 'file-type-symlink 'file-system
(lambda (fname linkname)
(create-file fname)
(create-symlink fname linkname)
(let ((result (file-type linkname #f))
(result-2 (file-type linkname #t)))
(delete-filesys-object linkname)
(delete-filesys-object fname)
(and (equal? result 'symlink)
(equal? result-2 'regular))))
"file" "symlink")
;; --- file-inode ---
;; only check for overrun (problem on AFS according to Martin)
(add-test/fname/fd/port! 'file-inode
#f
(lambda (fname/fd/port)
(> 0 (file-inode fname/fd/port)))
'("file"))
;; --- file-mode ---
(add-test/fname/fd/port! 'file-mode
#f
(lambda (fname/fd/port mode)
(set-file-mode fname/fd/port mode)
(bitwise-and (file-mode fname/fd/port)
#o777))
=
'("file") (list #o754))
;; --- file-nlinks ---
(add-test/fname/fd/port! 'file-nlinks
#f
(lambda (fname/fd/port fname1 fname2)
(create-hard-link fname1 fname2)
(let ((result (file-nlinks fname/fd/port)))
(delete-filesys-object fname2)
(= result 2)))
#f
'("file-1") '("file-1") '("file-2"))
;; --- file-owner ---
(add-test/fname/fd/port! 'file-owner
#f
(lambda (fname/fd/port uid)
(set-file-owner fname/fd/port uid)
(file-owner fname/fd/port))
equal?
'("file") (list (user-uid)))
;; --- file-group ---
(add-test/fname/fd/port! 'file-group
#f
(lambda (fname/fd/port gid)
(set-file-group fname/fd/port gid)
(file-group fname/fd/port))
equal?
'("file") (list (user-gid)))
;; --- file-size ---
(add-test/fname/fd/port! 'file-size
(lambda (port)
(write-string "0123456789" port)
(sync-file port))
file-size
(lambda (res) (= res 10))
'("file"))
;; --- file-last-access ---
(add-test/fname/fd/port! 'file-last-access
#f
(lambda (fname/fd/port fname atime)
(set-file-times fname atime 0)
(file-last-access fname/fd/port))
(lambda (restime fname mtime)
(= restime mtime))
'("file") '("file") '(10000))
;; --- file-last-mod ---
(add-test/fname/fd/port! 'file-last-mod
#f
(lambda (fname/fd/port fname mtime)
(set-file-times fname 0 mtime)
(file-last-mod fname/fd/port))
(lambda (restime fname mtime)
(= restime mtime))
'("file") '("file") '(10000))
;; -- file-last-status-change ---
(add-test/fname/fd/port! 'file-last-status-change
#f
(lambda (fname/fd/port)
(let ((before (file-last-status-change
fname/fd/port)))
;; do anything
(set-file-mode fname/fd/port #o777)
(let ((after (file-last-status-change
fname/fd/port)))
(> after before) ;; how much??
)))
'("file"))
;; --- file-not-read/write/exec-able ---
(define (add-file-not-?-able func name perms)
;; normal function
(add-test! (symbol-append name "-normal") 'file-system
(lambda (fname)
(with-cwd (create-temp-dir)
(create-file fname)
(set-file-mode fname perms)
(let ((result (not (func fname))))
(delete-filesys-object fname)
result)))
"file")
;; search-denied
(add-test! (symbol-append name "-search-denied") 'file-system
(lambda (fname dirname)
(with-cwd (create-temp-dir)
(create-directory dirname)
(create-file (string-append dirname fname))
(set-file-mode dirname 0) ;; or 666 ??
(let ((result (func (string-append dirname fname))))
(set-file-mode dirname #o777)
(delete-filesys-object (string-append dirname fname))
(delete-filesys-object dirname)
(equal? result 'search-denied))))
"file" "dir/")
;; permission denied
(add-test! (symbol-append name "-permission") 'file-system
(lambda (fname)
(with-cwd (create-temp-dir)
(create-file fname)
(set-file-mode fname
(bitwise-xor perms #o777))
(let ((result (func fname)))
(delete-filesys-object fname)
(equal? result 'permission))))
"file")
;; not-directory
(add-test! (symbol-append name "-no-directory") 'file-system
(lambda (fname fname2)
(with-cwd (create-temp-dir)
(create-file fname2)
(let ((result (func (string-append
fname2 "/" fname))))
(delete-filesys-object fname2)
(equal? result 'not-directory))))
"file" "file2")
;; nonexistent
(add-test! (symbol-append name "-nonexistent") 'file-system
(lambda (fname)
(with-cwd (create-temp-dir)
(delete-filesys-object fname)
(let ((result (func fname)))
(or (equal? result 'nonexistent)
(and (not result)
(eq? func file-not-writable?))))))
"file"))
(add-file-not-?-able file-not-readable? 'file-not-readable? #o444)
(add-file-not-?-able file-not-writable? 'file-not-writable? #o222)
(add-file-not-?-able file-not-executable? 'file-not-executable? #o111)
;; --- file-(not)-exists? --
(add-test! 'file-not-exists-1? 'file-system
(lambda (fname)
(with-cwd (create-temp-dir)
(delete-filesys-object fname)
(let ((res-1 (file-not-exists? fname)))
(create-file fname)
(let ((res-2 (file-exists? fname)))
(delete-filesys-object fname)
(and res-1 res-2)))))
"file")
(add-test! 'file-not-exists-2? 'file-system
(lambda (fname dirname)
(with-cwd (create-temp-dir)
(create-directory dirname)
(create-file (string-append dirname fname))
(set-file-mode dirname 0)
(let ((result (file-not-exists? (string-append
dirname fname))))
(set-file-mode dirname #o777)
(delete-filesys-object (string-append dirname fname))
(delete-filesys-object dirname)
(equal? result 'search-denied))))
"file" "dir/")
;; --- directory-files ---
(add-test-multiple! 'directory-files 'file-system
(lambda (fname dotfiles?)
(with-cwd (create-temp-dir)
(create-file fname)
(or (and (string-ref fname 0) (not dotfiles?))
(member fname (directory-files (cwd)
dotfiles?)))))
'("file" ".file") '(#t #f))
;; --- create-temp-file ---
(add-test! 'create-temp-file 'file-system
(lambda ()
(let ((temp-dir (create-temp-dir)))
(let ((file-1 (create-temp-file temp-dir))
(file-2 (create-temp-file temp-dir)))
(let ((result (and (not (equal? file-1 file-2))
(file-exists? file-1)
(file-exists? file-2))))
(delete-filesys-object file-1)
(delete-filesys-object file-2)
result)))))
--- NEW FILE ---
;;; Basic functions for the scsh-test-suite
;;; Author: 2001 David Frese
;; --- The list to store the tests ---
(define *test-list* '())
;; --- add-test! ------------------------------------------------
;; This is the main function to add a test to the test-suite
;; name - a symbol naming the test uniquely
;; group - a symbol for the group of this test
;; proc - the function that does the test
;; args - the arguments for proc
;; add-test deletes all previously added tests that have the same
;; name (group is ignored)!
;; proc should return #f or signal an error, if the test failed.
;; Every other value means, that the test succeeded.
(define (add-test! name group proc . args)
(let ((test (make-testdt name group proc args)))
(let ((other (filter (lambda (test)
(equal? (testdt-name test)
name))
*test-list*)))
(for-each (lambda (test)
(set! *test-list* (delete! test *test-list*)))
other))
(set! *test-list* (cons test *test-list*))))
(define (find-test name)
(find (lambda (test)
(eq? (testdt-name test) name))
*test-list*))
;; --- add-test-multiple! ----------------------------------------
;; This function calls add-test! multiple times, with the same proc,
;; but different arguments.
;; name, group, proc see add-test! above
;; input-lists - each additional parameter has to be a list, specifying
;; alternative operands for proc.
;; Now add-test! is called for each permutation of input-lists.
;; If there's more than 1 permutation, the name is appended with
;; "-1"..."-n" respectively.
;; Example:
;; (add-test-multiple! 'test 'general proc '(a b) '(1 2))
;; results in 4 tests, that could have been generated with
;; (add-test 'test-1 'general proc 'a 1)
;; (add-test 'test-2 'general proc 'b 1)
;; (add-test 'test-3 'general proc 'a 2)
;; (add-test 'test-4 'general proc 'b 2)
;; Note: In future versions, these tests will run simultanously
;; with multi-threading.
(define (add-test-multiple! name group proc . input-lists)
(let* ((permutations (permute-lists input-lists))
(single? (and (not (null? permutations))
(null? (cdr permutations)))))
(let loop ((i 0)
(permutations permutations))
(if (not (null? permutations))
(let ((input-params (car permutations))
(new-name (if single?
name
(string->symbol (string-append
(symbol->string name)
"-"
(number->string i))))))
(apply add-test!
new-name
group
proc
input-params)
(loop (+ i 1) (cdr permutations)))))))
(define (permute-lists lists)
(cond
((null? lists) lists)
((null? (cdr lists)) (map list (car lists)))
(else
(let ((first-list (car lists))
(rest-perm (permute-lists (cdr lists))))
(fold-right (lambda (elem result)
(append
(map (lambda (new-param)
(cons new-param elem))
first-list)
result))
'()
rest-perm)))))
;; --- Functions for the test-datatype ---
(define-record-type testdt :testdt
(make-testdt name group proc args)
testdt?
(name testdt-name)
(group testdt-group)
(proc testdt-proc)
(args testdt-args))
;; --- Basic function to make a test ---
(define (run-test test . rest)
(let ((silent (if (null? rest) #f (car rest)))
(name (testdt-name test))
(group (testdt-group test))
(proc (testdt-proc test))
(args (testdt-args test)))
(let ((display-start (lambda ()
(display "Testing ")
(display group)
(display ":")
(display name)
(display " ... "))))
(if (not silent)
(display-start))
(if (apply proc args)
(begin
(if silent
(display ".")
(display "OK\n"))
#t)
(begin
(if silent
(begin (newline)
(display-start)))
(display "Error! Input was ")
(display args)
(newline)
#f)))))
;; --- Exported functions to make a test -------------------------------
;; The following 3 functions start the testing. They all have an
;; optional parameter >silent< with default #f. if silent is #t,
;; only those tests that signaled an error are printed on the screen.
;; test-single - runs the test with that name, returns the result of proc.
;; test-group - runs all tests that are part of that group. the result
;; is unspecified.
;; test-all - runs all tests in the test-suite.
(define (test-single name . rest)
(let ((test (find-test name)))
(if test
(apply run-test test rest)
(begin
(display "Test ") (display name)
(display " not found")
(newline)))))
(define (test-single/args name . args)
(let* ((test (find-test name))
(group (testdt-group test))
(proc (testdt-proc test)))
(run-test (apply make-testdt name group proc args))))
(define (test-group group . rest)
(let ((tests (filter (lambda (test)
(eq? (testdt-group test)
group))
*test-list*)))
(if (null? tests)
(begin
(display "Group ") (display group)
(display " doesn't contain any tests")
(newline))
(for-each (lambda (test)
(apply run-test
test rest))
tests))))
(define (test-all . rest)
(for-each (lambda (test)
(apply run-test
test rest))
*test-list*))
;; --- Summary functions -------------------------------------------
;; test-summary displays all registered tests in the test-suite, if
;; called with no arguments. Calling it with the additional parameter
;; group, displays only those tests that belong to that group.
(define (test-summary . rest)
(let ((group (if (null? rest) #f (car rest))))
(if group
(begin
(display "Listing group: ") (display group) (newline)
(for-each (lambda (test)
(if (eq? (testdt-group test) group)
(begin
(display (testdt-name test))
(newline))))
*test-list*))
(begin
(display "Listing all tests in format: group:name") (newline)
(for-each (lambda (test)
(display (testdt-group test))
(display ":")
(display (testdt-name test))
(newline))
*test-list*)))))
--- NEW FILE ---
(define-interface scsh-test-interface
(export add-test!
add-test-multiple!
test-all
test-group
test-single
test-single/args
test-summary))
(define-structure scsh-test scsh-test-interface
(open scsh
scheme
list-lib
define-record-types)
(files test-base))
(define-structure file-system-test (export)
(open scsh
scheme
scsh-test)
(files file-system-tests))
|