Added test code for environment procedures.
This commit is contained in:
interp
parent
3b53f2718d
commit
a3a67e69a2
|
|
@ -0,0 +1,35 @@
|
|||
; definitions
|
||||
|
||||
(define alist
|
||||
'(("Test-EDITOR" . "MyEditor")
|
||||
("Test-TERM" . "SuperScsh")
|
||||
("Test-EDITOR" . "HerEditor")))
|
||||
(define env-alist-alist
|
||||
'(("TEST-PATH" . '("Path1" "Path2" "Path3"))))
|
||||
|
||||
(define number-list '("Eins" "Zwei" "Vier" "Eins" "Zwei" "Vier"))
|
||||
|
||||
|
||||
; adds tests
|
||||
|
||||
(add-test! 'setenv 'env setenv-test "Test-Var" "Hello!")
|
||||
;(add-test! 'getenv 'env getenv-test "Test-Var" "Hallihallo!") ; same as setenv-test
|
||||
(add-test! 'env->alist 'env env->alist-test "env->alist-test-var" "env->alist-test-val")
|
||||
|
||||
; COMMENTED OUT, since recent version of scsh produces an exception if
|
||||
; alist contains string-lists as values. Nevertheless the manual
|
||||
; says, stringlists are allowed as values (p.73)
|
||||
;(add-test! 'alist->env 'env alist->env-test (cons '("String-list" . ("String1" "String2" "String3")) alist))
|
||||
(add-test! 'alist-delete 'env alist-delete-test "Test-EDITOR" alist)
|
||||
(add-test! 'alist-update 'env alist-update-test "Test-EDITOR" "HisEditor" alist)
|
||||
|
||||
(add-test! 'alist-compress 'env alist-compress-test alist)
|
||||
(add-test! 'with-env* 'env with-env*-test alist)
|
||||
(add-test! 'with-total-env* 'env with-total-env*-test alist)
|
||||
(add-test! 'home-directory 'env home-directory-test)
|
||||
(add-test! 'exec-path-list 'env exec-path-list-test)
|
||||
(add-test! 'add-before-infix 'env add-before-test "Drei" "Vier" number-list)
|
||||
(add-test! 'add-before-suffix 'env add-before-test "Fünf" "Sechs" number-list)
|
||||
(add-test! 'add-after-infix 'env add-after-test "Drei" "Zwei" number-list)
|
||||
(add-test! 'add-after-prefix 'env add-after-test "Null" "Null" number-list)
|
||||
(add-test! 'add-after-prefix 'env add-after-test "Drei" "Zwei" number-list)
|
||||
|
|
@ -0,0 +1,295 @@
|
|||
|
||||
|
||||
; TEST-CODE ***********************************************************************
|
||||
; all procedures return either #t or #f
|
||||
|
||||
; Deleting a variable via (setenv var #f) cannot be tested, since
|
||||
; getenv returns #f in both cases: a) deleted variable or b) variable set to #f
|
||||
; OK
|
||||
(define (setenv-test var val)
|
||||
(setenv var val)
|
||||
(equal? (getenv var) val))
|
||||
|
||||
; getenv is tested with the same procedure than setenv
|
||||
; OK 2001-04-09 16:21
|
||||
(define getenv-test setenv-test)
|
||||
|
||||
; env->alist-test test, if
|
||||
; env->alist is an alist of pairs of string and if
|
||||
; a previously set variable has the set value
|
||||
; OK 2001-04-09 16:21
|
||||
(define (env->alist-test var val)
|
||||
(setenv var val)
|
||||
(let ((alist (env->alist)))
|
||||
(and (every (lambda (pair) ; syntactical correctness
|
||||
(and (pair? pair) ; entry is a pair
|
||||
(not (list? pair)) ; and not a list
|
||||
(string? (car pair)) ; car is a string...
|
||||
(or (string? (cdr pair)) ; ...cdr is either a string...
|
||||
(string-list? (cdr pair))))) ; ...or a string-list
|
||||
alist)
|
||||
(equal? (cdr (assoc var alist))
|
||||
val)))) ; previously set variable correctly present
|
||||
|
||||
; checks if alist->enc really sets a new environment
|
||||
; by this way, it checks if a string list is transformed correctly to a colon list, too
|
||||
|
||||
; COMMENTED OUT BECAUSE STRING-TOKENIZE IS MISSING (WILL BE FIXED)
|
||||
; OK
|
||||
(define (alist->env-test alist)
|
||||
(let ((old-env (env->alist))) ; save old environment
|
||||
(alist->env alist) ; set new environment
|
||||
(let ( ; compare values of alist with values of the environment
|
||||
(result (every
|
||||
(lambda (var-pair)
|
||||
(let ((var-pair-value (cdr var-pair))
|
||||
(env-var-value (getenv (car var-pair))))
|
||||
; (begin (display var-pair) (newline)
|
||||
; (display var-pair-value) (newline)
|
||||
; (display env-var-value) (newline)
|
||||
; (display "---------------------") (newline))
|
||||
(if (string-list? var-pair-value)
|
||||
(equal? var-pair-value
|
||||
(string-tokenize env-var-value #\:))
|
||||
(equal? var-pair-value env-var-value))))
|
||||
(alist-compress alist))))
|
||||
(alist->env old-env) ; restore old environment
|
||||
result)))
|
||||
|
||||
|
||||
; NOTE: since alist-bla works only on alists, string-list / colon-list-conversion is not implemented
|
||||
; OK 2001-04-09 16:21
|
||||
(define (alist-delete-test key alist)
|
||||
(not (member key (map car (alist-delete key alist)))))
|
||||
|
||||
|
||||
; results #t, if the first occurance of the variable has the expected (new) value, else #f
|
||||
; OK 2001-04-09 16:15
|
||||
(define (alist-update-test key val alist)
|
||||
(letrec ((check-update (lambda (alist)
|
||||
(if (null? alist) ; if alist is empty key wasn't inserted
|
||||
#f
|
||||
(if (equal? key (caar alist)) ; key found
|
||||
(if (equal? val (cdar alist)) ; value ok?
|
||||
; key must not be in the cdr of alist
|
||||
(not (member key (map car (cdr alist))))
|
||||
#f)
|
||||
(check-update (cdr alist)))))))
|
||||
(check-update (alist-update key val alist))))
|
||||
|
||||
|
||||
; checks compression of every variable
|
||||
; OK 2001-04-09 15:46
|
||||
(define (alist-compress-test alist)
|
||||
(letrec ((check-compress (lambda (alist known-vars)
|
||||
(if (null? alist)
|
||||
#t
|
||||
(if (member (caar alist) known-vars)
|
||||
#f
|
||||
(check-compress (cdr alist)
|
||||
(cons (caar alist)
|
||||
known-vars)))))))
|
||||
(check-compress (alist-compress alist) '())))
|
||||
|
||||
|
||||
|
||||
; OK 2001-04-09 15:46
|
||||
(define (with-env*-test env-alist-delta)
|
||||
(with-env*-test-generator with-env*
|
||||
env-alist-delta
|
||||
(update-env (env->alist) env-alist-delta)))
|
||||
|
||||
; OK 2001-04-09 15:45
|
||||
(define (with-total-env*-test env-alist)
|
||||
(with-env*-test-generator with-total-env*
|
||||
env-alist
|
||||
env-alist))
|
||||
|
||||
; generator:
|
||||
; There are three tests for each circumstance (s. scsh manual for details)
|
||||
; * simple thunk: returns usually
|
||||
; * non-local-return thunk: returns using escape-procedure
|
||||
; * reinvoking-thunk: returns non-local, is reinvoked and returns
|
||||
; each thunk return the result of the env-var-test, which is #t if the current
|
||||
; environment is as expected
|
||||
; the tunks are called via run-test that first runs the test and,
|
||||
; if the test returned #t, returns #t if the current environment is as expected.
|
||||
; (there are two test for the current-environment necessary since the environment
|
||||
; during the call and after the call differ (s. manual for details))
|
||||
; OK 2001-04-09 15:45
|
||||
; the generator generates test-procedures for with-total-env* and with-env*
|
||||
; parameters are:
|
||||
; - call: either with-total-env* or with-env*
|
||||
; - call-argument: either an env-alist (for with-total-env*) or an env-alist-delta (for with-env*)
|
||||
; - expected-process-env: expected content of the environment during the with-env-call
|
||||
(define (with-env*-test-generator call call-argument expected-process-env)
|
||||
(let* ((old-env-alist (env->alist))
|
||||
(env-var-test (lambda () ; checks, if the changed environment is as expected
|
||||
(equal-to-current-env? expected-process-env)))
|
||||
|
||||
; store places for continuations:
|
||||
(non-local-exit-cc #f) ; exit poit for a thunk
|
||||
(reinvoking-cc #f) ; entry point to reinvoking thunk
|
||||
(thunk-finished-cc #f) ; exit point for finished reinvoking thunk
|
||||
|
||||
; thunks for testing:
|
||||
(thunk-local-return (lambda () (env-var-test)))
|
||||
(cc-thunk-non-local-return
|
||||
(lambda ()
|
||||
(non-local-exit-cc (env-var-test)) ; non-local return
|
||||
#f)) ; if non-local return fails (?), return #f
|
||||
|
||||
(cc-reinvoking-thunk
|
||||
(lambda ()
|
||||
(call-with-current-continuation
|
||||
(lambda (k)
|
||||
(set! reinvoking-cc k)
|
||||
(non-local-exit-cc #f))) ; non-local-return
|
||||
(thunk-finished-cc (env-var-test)) ; finish with result of env-var-test
|
||||
#f)) ; if continuation-call fails (?), return #f
|
||||
|
||||
; procedure to perform tests (run test and check content of current environment)
|
||||
(run-test
|
||||
(lambda (thunk)
|
||||
(and (thunk)
|
||||
(equal-to-current-env? old-env-alist)))))
|
||||
|
||||
(and (run-test (lambda ()
|
||||
(call call-argument thunk-local-return)))
|
||||
(run-test (lambda ()
|
||||
(call-with-current-continuation (lambda (k)
|
||||
(set! non-local-exit-cc k) ; possibility of non-local return
|
||||
(call call-argument
|
||||
cc-thunk-non-local-return)))))
|
||||
(run-test (lambda ()
|
||||
(call-with-current-continuation
|
||||
(lambda (finished)
|
||||
(set! thunk-finished-cc finished)
|
||||
(call-with-current-continuation
|
||||
(lambda (k)
|
||||
(set! non-local-exit-cc k) ; possibility of non-local return
|
||||
(call call-argument cc-reinvoking-thunk)))
|
||||
(reinvoking-cc #f)))))))) ; reinvoke thunk
|
||||
; the old environment needn't to be restored because with-env* and with-total-env*
|
||||
; don't change the current environment (if successful)
|
||||
|
||||
; checks if home-directory is a string
|
||||
; OK 2001-04-09 15:45
|
||||
(define (home-directory-test)
|
||||
(string? home-directory))
|
||||
|
||||
; checks if exec-path-list is a string-list
|
||||
; OK 2001-04-09 15:45
|
||||
(define (exec-path-list-test)
|
||||
(string-list? exec-path-list))
|
||||
|
||||
|
||||
; OK 2001-04-09 15:45
|
||||
(define (add-tester elt mark original-list add-result)
|
||||
(letrec ((correct-insert
|
||||
(lambda (add-result) ; checks if elt was inserted correctly
|
||||
(if (null? add-result) ; empty list -> element wasn't inserted
|
||||
#f
|
||||
(cond
|
||||
((equal? (car add-result) mark) #f) ; first occurance of mark without elt => #f
|
||||
((equal? (car add-result) elt) ; found elt
|
||||
(or (null? (cdr add-result)) ; either the list terminates or...
|
||||
(equal? (cadr add-result) mark))) ; ...the following string is mark
|
||||
(else ; otherwise the rest of the list has to be correct
|
||||
(correct-insert (cdr add-result)))))))
|
||||
(correct-order
|
||||
(lambda (add-result original-list) ; checks, if order was respected
|
||||
(cond
|
||||
((null? add-result) ; if the result is empty,...
|
||||
(null? original-list)) ; ...so the original list has to be empty, too
|
||||
((null? original-list) ; if the original list is empty...
|
||||
(or (null? add-result) ; ...either the result list has to be empty, ...
|
||||
(and (equal? (car add-result) elt) ; or contains only the inserted element
|
||||
(null? (cdr add-result)))))
|
||||
((equal? (car add-result) (car original-list)) ; cars equal => continue with cdrs
|
||||
(correct-order (cdr add-result) (cdr original-list)))
|
||||
((equal? (car add-result) elt) ; => (car original-list) =/= elt !
|
||||
(correct-order (cdr add-result) original-list)) ; found elt -> skip
|
||||
(else ; lists are unequal
|
||||
#f)))))
|
||||
(and (correct-insert add-result)
|
||||
(correct-order add-result original-list))))
|
||||
|
||||
; OK 2001-04-09 15:44
|
||||
(define (add-before-test elt before liste)
|
||||
(add-tester elt before liste (add-before elt before liste)))
|
||||
|
||||
; add-after operates as add-before on reverse list
|
||||
; OK 2001-04-09 15:44
|
||||
(define (add-after-test elt after liste)
|
||||
(add-tester elt after liste (reverse (add-after elt after (reverse liste)))))
|
||||
|
||||
; helping procedures *************************************************************
|
||||
; returns #t if liste is a list containing only strings, else #f
|
||||
; OK
|
||||
(define string-list?
|
||||
(lambda (liste)
|
||||
(and (list? liste)
|
||||
(every (lambda (elt)
|
||||
(string? elt))
|
||||
liste))))
|
||||
|
||||
; deletes equal-to-this once in list, if present
|
||||
; OK
|
||||
(define (delete-once equal-to-this list)
|
||||
(if (null? list)
|
||||
'()
|
||||
(if (equal? (car list) equal-to-this)
|
||||
(cdr list)
|
||||
(cons (car list) (delete-once equal-to-this (cdr list))))))
|
||||
|
||||
; compares to lists
|
||||
; order is unimportant, but count of each element is
|
||||
; examlpes:
|
||||
; (list-equal? '(1 2) '(2 1)
|
||||
; => #t
|
||||
; (list-equal? '(1 2) '(2 1 1)
|
||||
; #f
|
||||
; OK
|
||||
(define (list-equal? list1 list2)
|
||||
(if (null? list1)
|
||||
(null? list2)
|
||||
(if (member (car list1) list2)
|
||||
(list-equal? (cdr list1)
|
||||
(delete-once (car list1) list2))
|
||||
#f)))
|
||||
|
||||
; updates the environment env-alist via env-alist-delta
|
||||
; NOTE: Test alist-update first (run alist-update-test key val alist)
|
||||
; OK
|
||||
(define update-env
|
||||
(lambda (env-alist env-alist-delta)
|
||||
(if (null? env-alist-delta)
|
||||
env-alist
|
||||
(update-env (alist-update (car (car env-alist-delta))
|
||||
(cdr (car env-alist-delta))
|
||||
env-alist)
|
||||
(cdr env-alist-delta)))))
|
||||
|
||||
|
||||
; compares old-env-alist with actual environment (env->alist)
|
||||
; OK
|
||||
(define equal-to-current-env?
|
||||
(lambda (old-env-alist)
|
||||
(list-equal? old-env-alist (env->alist))))
|
||||
|
||||
; tokenizes a string
|
||||
; example:
|
||||
; (string-tokenize "Tokenize this here" #\space) => ("Tokenize" "this" "here")
|
||||
|
||||
(define (string-tokenize string character)
|
||||
(let ((char-list (string->list string)))
|
||||
(let loop ((liste char-list)
|
||||
(word '())
|
||||
(result '()))
|
||||
(if (null? liste)
|
||||
(append result (list (list->string word)))
|
||||
(if (equal? (car liste) character)
|
||||
(loop (cdr liste) '() (append result (list (list->string word))))
|
||||
(loop (cdr liste) (append word (list (car liste))) result))))))
|
||||
|
||||
|
|
@ -24,4 +24,36 @@
|
|||
(open scsh
|
||||
scheme
|
||||
scsh-test)
|
||||
(files process-state-tests))
|
||||
(files process-state-tests))
|
||||
; defines module env-test
|
||||
|
||||
(define-structure env-test
|
||||
(export
|
||||
setenv-test
|
||||
getenv-test
|
||||
env->alist-test
|
||||
alist->env-test
|
||||
alist-delete-test
|
||||
alist-update-test
|
||||
alist-compress-test
|
||||
with-env*-test
|
||||
with-total-env*-test
|
||||
home-directory-test
|
||||
exec-path-list-test
|
||||
add-before-test
|
||||
add-after-test)
|
||||
(open scsh
|
||||
scheme
|
||||
list-lib
|
||||
string-lib)
|
||||
(files env-test-code))
|
||||
|
||||
; defines module add-env-test
|
||||
(define-structure add-env-test
|
||||
(export )
|
||||
(open scsh
|
||||
scheme
|
||||
scsh-test
|
||||
env-test)
|
||||
(files env-test-add))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue