Added implementation of a test suite.
Added tests for the file system operations (sec. 3.3 of the manual). Author: David Frese
This commit is contained in:
mainzelm
parent
d708ef06e2
commit
effab78a3d
|
|
@ -0,0 +1,587 @@
|
|||
;;; 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)))))
|
||||
|
||||
|
|
@ -0,0 +1,204 @@
|
|||
;;; 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*)))))
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
(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))
|
||||
Loading…
Reference in New Issue