From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: John Maxwell Newsgroups: gmane.lisp.guile.user Subject: Re: Unit tests Date: Tue, 11 Mar 2003 17:49:34 -0500 (EST) Sender: guile-user-bounces+guile-user=m.gmane.org@gnu.org Message-ID: References: <5.2.0.9.0.20030311172000.00a62d50@n/a> NNTP-Posting-Host: main.gmane.org Mime-Version: 1.0 Content-Type: TEXT/PLAIN; charset=US-ASCII X-Trace: main.gmane.org 1047424266 19233 80.91.224.249 (11 Mar 2003 23:11:06 GMT) X-Complaints-To: usenet@main.gmane.org NNTP-Posting-Date: Tue, 11 Mar 2003 23:11:06 +0000 (UTC) Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Wed Mar 12 00:11:04 2003 Return-path: Original-Received: from monty-python.gnu.org ([199.232.76.173]) by main.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 18sstF-0004yS-00 for ; Wed, 12 Mar 2003 00:10:33 +0100 Original-Received: from localhost ([127.0.0.1] helo=monty-python.gnu.org) by monty-python.gnu.org with esmtp (Exim 4.10.13) id 18ssj2-0004Tg-00 for guile-user@m.gmane.org; Tue, 11 Mar 2003 18:00:00 -0500 Original-Received: from list by monty-python.gnu.org with tmda-scanned (Exim 4.10.13) id 18ssh3-0003SQ-00 for guile-user@gnu.org; Tue, 11 Mar 2003 17:57:57 -0500 Original-Received: from mail by monty-python.gnu.org with spam-scanned (Exim 4.10.13) id 18ssZn-0000vr-00 for guile-user@gnu.org; Tue, 11 Mar 2003 17:50:29 -0500 Original-Received: from beast.toad.net ([162.33.144.100]) by monty-python.gnu.org with esmtp (Exim 4.10.13) id 18ssZ8-0000Vn-00 for guile-user@gnu.org; Tue, 11 Mar 2003 17:49:46 -0500 Original-Received: by beast.toad.net (Postfix, from userid 1160) id 0558C8DFFB; Tue, 11 Mar 2003 17:49:35 -0500 (EST) Original-Received: from localhost (localhost [127.0.0.1]) by beast.toad.net (Postfix) with ESMTP id F0BE05EAD6 for ; Tue, 11 Mar 2003 17:49:34 -0500 (EST) Original-To: guile-user@gnu.org In-Reply-To: <5.2.0.9.0.20030311172000.00a62d50@n/a> X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1b5 Precedence: list List-Id: General Guile related discussions List-Help: List-Post: List-Subscribe: , List-Archive: List-Unsubscribe: , Errors-To: guile-user-bounces+guile-user=m.gmane.org@gnu.org Xref: main.gmane.org gmane.lisp.guile.user:1728 X-Report-Spam: http://spam.gmane.org/gmane.lisp.guile.user:1728 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 tests-run tests-failed tests-log failure-messages test-started test-failed summary name setUp tearDown run test-case-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 ) (name )) (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 ) (method-name )) (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 () (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 ) (description )) (set! (tests-log self) (append (tests-log self) `(,description))) (set! (tests-run self) (+ 1 (tests-run self)))) (define-method (test-failed (self ) (description )) (set! (failure-messages self) (append (failure-messages self) `(,description))) (set! (tests-failed self) (+ 1 (tests-failed self)))) (define-method (summary (self )) (format #f "~S run, ~S failed" (tests-run self) (tests-failed self))) ;---------------------------------------------------------------- (define-class () (name-value #:init-value "" #:accessor name #:init-keyword #:name)) (define-method (setUp (self ))) (define-method (tearDown (self ))) (define-method (run (self ) (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 () (tests-value #:init-value '() #:accessor tests) (suite-name #:init-value "" #:accessor name)) (define-method (add (self ) (test )) (set! (tests self) (append (tests self) `(,test)))) (define-method (add (self ) (suite )) (set! (tests self) (append (tests self) `(,suite)))) (define-method (run (self ) (result )) (for-each (lambda (test) (run test result)) (tests self))) (define-method (test-case-suite (self )) (let ((suite (make #: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 () (log-value #:init-form '() #:accessor log)) (define-method (log-add (self ) msg) (set! (log self) (append (log self) `(,msg)))) (define-method (setUp (self )) (log-add self "setUp")) (define-method (tearDown (self )) (log-add self "tearDown")) (define-method (testPass (self )) (log-add self "testPass")) (define-method (testFail (self )) (throw 'broken-method)) ;---------------------------------------------------------------- (define-class ()) (define-method (setUp (self )) (throw 'setup-failed)) (define-method (testPass (self ))) ;---------------------------------------------------------------- (define-class () (test-result-value #:init-form (make ) #:accessor test-result)) ;---------------------------------------------------------------- (define-class () (test-value #:init-form (make #:name "testFail") #:accessor test)) (define-method (testFailedResult (self )) (run (test self) (test-result self)) (assert-equal "1 run, 1 failed" (summary (test-result self)))) (define-method (testTearDownFailedResult (self )) (run (test self) (test-result self)) (assert-equal '("setUp" "tearDown") (log (test self)))) ;---------------------------------------------------------------- (define-class () (test-value #:init-form (make #:name "testPass") #:accessor test)) (define-method (testTemplateMethod (self )) (run (test self) (test-result self)) (assert-equal '("setUp" "testPass" "tearDown") (log (test self)))) (define-method (testResult (self )) (run (test self) (test-result self)) (assert-equal "1 run, 0 failed" (summary (test-result self)))) (define-method (testFailedResultFormatting (self )) (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-value #:init-form (make #:name "testPass") #:accessor test)) (define-method (testFailedSetup (self )) (run (test self) (test-result self)) (assert-equal "0 run, 1 failed" (summary (test-result self)))) ;---------------------------------------------------------------- (define-class () (suite-value #:init-form (make #:name "suite-test-suite") #:accessor suite)) (define-method (setUp (self )) (add (suite self) (make #:name "testPass")) (add (suite self) (make #:name "testFail")) ) (define-method (testSuite (self )) (run (suite self) (test-result self)) (assert-equal "2 run, 1 failed" (summary (test-result self)))) (define-method (testTestCaseSuite (self )) (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 ))))) ;---------------------------------------------------------------- (define main-suite (make )) (add main-suite (test-case-suite (make ))) (add main-suite (test-case-suite (make ))) (add main-suite (test-case-suite (make ))) (add main-suite (test-case-suite (make ))) (define result (make )) (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