Unit tests

Unit tests

[Luigi Ballabio]

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



_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-user

Re: Unit tests

[Stan Pinte]

On Tue, 11 Mar 2003 17:23:13 +0100
Luigi Ballabio <luigi.ballabio@fastwebnet.it> 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?

I have seen this:

http://www.gnu.org/software/greg/greg.html

> 
> Thanks in advance,
> 			Luigi
> 
> 
> 
> _______________________________________________
> Guile-user mailing list
> Guile-user@gnu.org
> http://mail.gnu.org/mailman/listinfo/guile-user
> 


-- 

Stanislas Pinte

Computer Consultant

	98, rue Bois l'Evêque
	B-4000 Liège

web:		http://www.altosw.be
email:		alto_stan@wanadoo.be



_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-user

Re: Unit tests

[Thien-Thi Nguyen]

   From: Luigi Ballabio <luigi.ballabio@fastwebnet.it>
   Date: Tue, 11 Mar 2003 17:23:13 +0100

   [test frameworks?]

see module (ice-9 testing-lib) and guile-1.4.x "make check" flow.

  http://www.glug.org/alt/

thi


_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-user

Re: Unit tests

[John Maxwell]

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

Re: Unit tests

[James LewisMoss]

>>>>> On Tue, 11 Mar 2003 17:23:13 +0100, Luigi Ballabio <luigi.ballabio@fastwebnet.it> said:

 Luigi> Hi all,
 Luigi> 	quick question(s): are there any unit test frameworks
 Luigi> 	(a la
 Luigi> JUnit) for Guile? Do they require any particular version of
 Luigi> Guile? Is there any one which is considered the "standard"
 Luigi> one?

Also check out autounit.  My attempt at a unit testing framework.  It
still needs work, but I haven't been writing enough scheme code
recently to test its interface.

Jim

-- 
@James LewisMoss <dres@lewismoss.org>   |  Blessed Be!
@    http://www.lewismoss.org/~dres     |  Linux is kewl!
@"Argue for your limitations and sure enough, they're yours." Bach


_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-user