* Re: Unit tests
2003-03-11 16:23 Unit tests Luigi Ballabio
2003-03-11 17:09 ` Stan Pinte
2003-03-11 17:11 ` Thien-Thi Nguyen
@ 2003-03-11 22:49 ` John Maxwell
2003-04-01 14:18 ` James LewisMoss
3 siblings, 0 replies; 5+ messages in thread
From: John Maxwell @ 2003-03-11 22:49 UTC (permalink / raw)
On Tue, 11 Mar 2003, Luigi Ballabio wrote:
>
> Hi all,
> quick question(s): are there any unit test frameworks (a la JUnit) for
> Guile? Do they require any particular version of Guile? Is there any one
> which is considered the "standard" one?
>
> Thanks in advance,
> Luigi
>
Well, it may not be the most finished/polished thing around, but for
whatever it's worth, you're welcome to use this. It's a fairly literal
translation of the unit test code in Kent Beck's "Test-Driven Development"
book (the book's code is in Java). Done for my own edification as I was
reading the book, it also served as a nice way to get my feet wet in
goops.
goops-unit.scm is the actual framework; goops-unit-test.scm is a set of
unit tests for it written using it.
Hope this is of some use; feedback is welcome.
-John
********************************************************************************
goops-unit.scm:
********************************************************************************
(define-module (oop goops-unit)
#:use-module (oop goops)
#:use-module (ice-9 format)
#:export (assert-equal
<test-result> tests-run tests-failed tests-log failure-messages test-started test-failed summary
<test-case> name setUp tearDown run test-case-suite
<test-suite> tests add))
; Utility method for finding an object's method given its name. The
; equivalent probably already exists somewhere in the MOP, but the doc
; is a little sketchy.
(define-method (lookup-method (object <object>) (name <string>))
(call-with-current-continuation
(lambda (return)
(for-each (lambda (method)
(if (string=? name
(symbol->string (generic-function-name (method-generic-function method))))
(return (method-generic-function method))
#f))
(class-direct-methods (class-of object)))
(throw 'no-such-method-exception
(string-append name
": no such method in class "
(symbol->string (class-name (class-of object))))))))
; Utility method for finding out whether a method is a slot-accessor
; method for a particular class.
(define-method (slot-accessor? (object <object>) (method-name <string>))
(call-with-current-continuation
(lambda (return)
(for-each
(lambda (slot)
(if (or (and (slot-definition-getter slot)
(string=? method-name
(symbol->string (generic-function-name (slot-definition-getter slot)))))
(and (slot-definition-setter slot)
(string=? method-name
(symbol->string (generic-function-name (slot-definition-setter slot)))))
(and (slot-definition-accessor slot)
(string=? method-name
(symbol->string (generic-function-name (slot-definition-accessor slot))))))
(return #t)))
(class-slots (class-of object)))
(return #f))))
(define (assert-equal expected got)
(if (not (equal? expected got))
(throw 'test-failed-exception
(with-output-to-string
(lambda ()
(display "assert-equal: expected: ")
(write expected)
(display " got: ")
(write got))))))
;----------------------------------------------------------------
(define-class <test-result> ()
(tests-run-count #:init-value 0 #:accessor tests-run)
(tests-failed-count #:init-value 0 #:accessor tests-failed)
(tests-log-messages #:init-value '() #:accessor tests-log)
(test-failure-messages #:init-value '() #:accessor failure-messages))
(define-method (test-started (self <test-result>) (description <string>))
(set! (tests-log self)
(append (tests-log self) `(,description)))
(set! (tests-run self)
(+ 1 (tests-run self))))
(define-method (test-failed (self <test-result>) (description <string>))
(set! (failure-messages self)
(append (failure-messages self) `(,description)))
(set! (tests-failed self)
(+ 1 (tests-failed self))))
(define-method (summary (self <test-result>))
(format #f "~S run, ~S failed" (tests-run self) (tests-failed self)))
;----------------------------------------------------------------
(define-class <test-case> ()
(name-value #:init-value "" #:accessor name #:init-keyword #:name))
(define-method (setUp (self <test-case>)))
(define-method (tearDown (self <test-case>)))
(define-method (run (self <test-case>) (result <test-result>))
(catch #t
(lambda ()
(setUp self)
(test-started result (name self))
(catch #t
(lambda ()
(catch 'test-failed-exception
(lambda ()
((lookup-method self (name self)) self))
(lambda (exception description)
(test-failed result
(with-output-to-string
(lambda ()
(display (name self))
(display " failed: ")
(display description)))))))
(lambda throw-args
(test-failed result
(with-output-to-string
(lambda ()
(display (name self))
(display ": exception in test: ")
(write throw-args))))))
(tearDown self))
(lambda throw-args
(test-failed result
(with-output-to-string
(lambda ()
(display (name self))
(display ": exception in set up: ")
(write throw-args)))))))
;----------------------------------------------------------------
(define-class <test-suite> ()
(tests-value #:init-value '() #:accessor tests)
(suite-name #:init-value "" #:accessor name))
(define-method (add (self <test-suite>) (test <test-case>))
(set! (tests self)
(append (tests self) `(,test))))
(define-method (add (self <test-suite>) (suite <test-suite>))
(set! (tests self)
(append (tests self) `(,suite))))
(define-method (run (self <test-suite>) (result <test-result>))
(for-each
(lambda (test)
(run test result))
(tests self)))
(define-method (test-case-suite (self <test-case>))
(let ((suite (make <test-suite> #:name (string-append (name self) "-suite"))))
(for-each
(lambda (method-name)
(if (and (>= (string-length method-name) 4)
(string=? "test" (substring method-name 0 4))
(not (slot-accessor? self method-name)))
(add suite (make (class-of self) #:name method-name))))
(map (lambda (method)
(symbol->string (generic-function-name (method-generic-function method))))
(class-direct-methods (class-of self))))
suite))
********************************************************************************
goops-unit-test.scm
********************************************************************************
(use-modules (oop goops))
(use-modules (oop goops-unit))
;----------------------------------------------------------------
(define-class <was-run> (<test-case>)
(log-value #:init-form '()
#:accessor log))
(define-method (log-add (self <was-run>) msg)
(set! (log self)
(append (log self) `(,msg))))
(define-method (setUp (self <was-run>))
(log-add self "setUp"))
(define-method (tearDown (self <was-run>))
(log-add self "tearDown"))
(define-method (testPass (self <was-run>))
(log-add self "testPass"))
(define-method (testFail (self <was-run>))
(throw 'broken-method))
;----------------------------------------------------------------
(define-class <setup-fails> (<test-case>))
(define-method (setUp (self <setup-fails>))
(throw 'setup-failed))
(define-method (testPass (self <setup-fails>)))
;----------------------------------------------------------------
(define-class <test-case-private-result> (<test-case>)
(test-result-value #:init-form (make <test-result>)
#:accessor test-result))
;----------------------------------------------------------------
(define-class <test-case-failure-test> (<test-case-private-result>)
(test-value #:init-form (make <was-run> #:name "testFail")
#:accessor test))
(define-method (testFailedResult (self <test-case-failure-test>))
(run (test self) (test-result self))
(assert-equal "1 run, 1 failed"
(summary (test-result self))))
(define-method (testTearDownFailedResult (self <test-case-failure-test>))
(run (test self) (test-result self))
(assert-equal '("setUp" "tearDown")
(log (test self))))
;----------------------------------------------------------------
(define-class <test-case-test> (<test-case-private-result>)
(test-value #:init-form (make <was-run> #:name "testPass")
#:accessor test))
(define-method (testTemplateMethod (self <test-case-test>))
(run (test self) (test-result self))
(assert-equal '("setUp" "testPass" "tearDown")
(log (test self))))
(define-method (testResult (self <test-case-test>))
(run (test self) (test-result self))
(assert-equal "1 run, 0 failed"
(summary (test-result self))))
(define-method (testFailedResultFormatting (self <test-case-test>))
(test-started (test-result self) "testFailedResultFormatting")
(test-failed (test-result self) "expected failure")
(assert-equal "1 run, 1 failed"
(summary (test-result self))))
;----------------------------------------------------------------
(define-class <test-setup-fails-test> (<test-case-private-result>)
(test-value #:init-form (make <setup-fails> #:name "testPass")
#:accessor test))
(define-method (testFailedSetup (self <test-setup-fails-test>))
(run (test self) (test-result self))
(assert-equal "0 run, 1 failed"
(summary (test-result self))))
;----------------------------------------------------------------
(define-class <suite-test> (<test-case-private-result>)
(suite-value #:init-form (make <test-suite> #:name "suite-test-suite")
#:accessor suite))
(define-method (setUp (self <suite-test>))
(add (suite self) (make <was-run> #:name "testPass"))
(add (suite self) (make <was-run> #:name "testFail")) )
(define-method (testSuite (self <suite-test>))
(run (suite self) (test-result self))
(assert-equal "2 run, 1 failed"
(summary (test-result self))))
(define-method (testTestCaseSuite (self <suite-test>))
(define (test-names test-suite)
(sort! (map (lambda (test-case) (name test-case))
(tests test-suite))
string<=?))
(assert-equal (test-names (suite self))
(test-names (test-case-suite (make <was-run>)))))
;----------------------------------------------------------------
(define main-suite (make <test-suite>))
(add main-suite (test-case-suite (make <test-case-failure-test>)))
(add main-suite (test-case-suite (make <test-case-test>)))
(add main-suite (test-case-suite (make <test-setup-fails-test>)))
(add main-suite (test-case-suite (make <suite-test>)))
(define result (make <test-result>))
(run main-suite result)
(newline)
(for-each
(lambda (failure-message)
(display failure-message)
(newline))
(failure-messages result))
(display (summary result))
(newline)
_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-user
^ permalink raw reply [flat|nested] 5+ messages in thread