REBOL [ title: "(R)EBOL (Un)it" date: 14-apr-06 file: %run.r Author: "Christophe 'REBOLtof' Coussement" Email: "reboltof-at-yahoo-dot-com" purpose: { RUn is a TestCase Framework wich allows the use of TestCases as defined by the eXtreme Programming development methodology and the test-driven development } usage: { Background information can be found into eXtreme Programming method. >> do %run.r 1. Submitted test file can be Unit or Suite >> run-test %unit-1.test >> run-test %suite-1.test 2. Output can be optionaly logged >> run-test/log %test_suite.test 3. A TestCase file contains: - optionaly a Setup function - one or more Developper Tests function(s) - optionaly a Teardown function 4. Each Developer Test can use one of the following test-functions: - assert (logic!) - assert-equal (any-value! any-value!) - assert-not-equal (any-value! any-value!) - assert-error (block!) 5. A TestSuite contains: One block! named 'test-suite and containing the TestCase files names or/and TestSuite file names } history: [ 1.9.3 [12-dec-07 {copy 'now and 'print so that they can be over-written in tests} "pwawood" ] 1.9.2 [14-mar-06 "cleanup for publishing" "cou"] 1.8.2 [27-mar-05 "add 'assert-error" "cou"] 1.7.2 [20-oct-04 {- 'pf_assert can take any-type! for evaluation - add 'pf_assert_not_equal (suggested by fvzn} "cou"] 1.6.2 [07-oct-04 {add /only ref to 'assert-equal} "cou"] 1.5.2 [20-sep-04 {- 'display made public (request from Coccinelle) - asserting object! into object! would fail => fixed (thanks again Coccinelle) - force the use of a %.test file (thanks Johnatemps)} "cou"] 1.4.2 [16-sep-04 {- assert-equal make object! [a: 1] make object! [a: 1] would fail ==> fixed (Thanks to Coccinelle, for reporting the bug) - code documentation compatible with RDocGen} "cou"] 1.3.2 [08-sep-04 {assert-equal [1 2 3] [1 2] would pass ==> fixed (Thanks to Coccinelle, for reporting the bug)} "cou"] 1.2.2 [03-sep-04 {- append quiet mode (as suggested by Johnatemps) - reformat error message (as suggested by Coccinelle)} "cou"] 1.1.2 [02-sep-04 {- assert-equal [1 2 3] [] would pass ==> fixed - assert-equal [1] [[1]] triggers error ==> fixed Thanks to Coccinelle, for reporting the bug} "cou"] 1.0.2 [30-aug-04 "first public release" "cou"] 0.3.2 [10-may-04 { Thanks to Philippe LEGOFF's feedback: - modify test report layout - function name where error happened is now displayed in error report - log file name composed based on test file name} "COU"] 0.2.2 [22-apr-04 "add recurrent comparison of blocks" "COU"] 0.1.2 [07-apr-04 "Beta 1" "COU"] 0.1.0 [05-apr-04 "History begins" "COU"] ] uses: 'face library: [ level: 'advanced platform: all type: [tool] domain: 'testing tested-under: [View 1.3.2.3.1 on "Windows XP"] support: "Contact the author" license: 'lgpl ] ] ;---- make a copy of print and now so that tests can overwrite them now-copy: :now print-copy: :print RUn_ctx: context [ ;---- make a copy of print and now so that tests can overwrite them now-copy: :now print-copy: :print ;--- init private vars prl_log: false ;==> flag for logging test reports ; ;--- header to display prs_header: { ================== = (R)EBOL-(Un)it = = Test Framework = = v.1.9 = ================== == OUTPUT =============================================== } ;--- end test report header prs_report: { == TEST REPORT ========================================== } ;--- end test footer prs_footer: { ========================================================= End of test } ;=========================================================================== ;--- assert functions pf_assert: func [ {@ xUnit Assert function. Display if submitted condition passes @RETURN TRUE or FALSE} al_condition [any-type!] "condition to evaluate" ;[1.7] /local lerr_result ll_result ][ ;--- start chronometer prtime_duration: now-copy/time/precise - prtime_start ;--- evaluate condition and feedback either not al_condition [ pri_failure_count: pri_failure_count + 1 pf_display rejoin [tab tab "*-> Assertion Failed"] return false ][ if not prl_quiet [pf_display rejoin [tab tab "--> Passed in <" prtime_duration ">"]] ;[1.2] return true ] ] ;=========================================================================== pf_assert_equal: func [ {@ xUnit AssertEqual Function. Display if or not the two args are of the same value and type. @RETURN true or false} aany_current [any-type!] "current result of evaluation" aany_expected [any-type!] "expected result of evaluation" /only "place of the element does not matter" ;[1.7] /local lerr_result ][ ;--- start chronometer prtime_duration: now-copy/time/precise - prtime_start ;--- set order matter prl_sorted: only ;[1.7] ;--- if object! set argument on third object! and handle it ;- as being block! if all [ ;[1.4] object? aany_current object? aany_expected ][ aany_current: third aany_current aany_expected: third aany_expected ] ;--- if the current and expected data are a block, we're going to compare ;- each sub-block one by one in a recursive way either all [ block? aany_expected block? aany_current ][ either prf_assert_block_equal aany_current aany_expected [ if not prl_quiet [pf_display rejoin [tab tab "--> Passed in <" prtime_duration ">"]] ;[1.2] return true ][ pri_failure_count: pri_failure_count + 1 pf_display rejoin [tab tab "*-> Assertion Failed"] return false ] ][ ;--- evaluate comparison and feedback either not aany_current == aany_expected [ pri_failure_count: pri_failure_count + 1 pf_display rejoin [ tab tab "*-> Data expected: " mold aany_expected " of type: [" type? aany_expected "!]^/" tab tab " but was : " mold aany_current " of type: [" type? aany_current "!]" ] return false ][ if not prl_quiet [pf_display rejoin [tab tab "--> Passed in <" prtime_duration ">"]] ;[1.2] return true ] ] ] pf_assert_not_equal: func [ {@ xUnit AssertNotEqual Function. Display if or not the two args are NOT @ of the same value and type. @RETURN true or false} aany_current [any-type!] "current result of evaluation" aany_expected [any-type!] "expected result of evaluation" /only "place of the element does not matter" /local lerr_result ][ return not either only [ pf_assert_equal/only aany_current aany_expected ][ pf_assert_equal aany_current aany_expected ] ] pf_assert_error: func [ ;[1.8] {@ Display if error is triggered @RETURN true or false} ab_code [block!] "block to evaluate" /type-id "Specify the type-id of the error" ab_type-id "Type-ID of the error" /local lerr_result ][ either error? lerr_result: try ab_code [ lerr_result: disarm lerr_result either type-id [ answer: all [ lerr_result/type = ab_type-id/1 lerr_result/id = ab_type-id/2 ] ] [ answer: true ] ] [ answer: false ] return pf_assert answer ] ;=========================================================================== prf_assert_block_equal: func [ ;[0.2] {@ compare the inside of two blocks @RETURN true or false} ab_current [block!] "current block of evaluation" ab_expected [block!] "expected block of evaluation" /local lerr_result lb_current ][ if prl_sorted [sort ab_current sort ab_expected] ;[1.6] ;--- get clean copy for ref lb_current: copy ab_current ;--- if one of block is empty, then other must be too ;- otherwise, test fails. It fails too if the blocks ;- are not of the same length if (length? ab_current) <> (length? ab_expected) [ ;[1.1][1.3] pf_display rejoin [ tab tab "*-> Block! of length : " length? ab_expected " was expected^/" tab tab " but was block! of length : " length? ab_current " was provided !]" ] return false ] foreach eany_expected ab_expected [ ;--- if the two members are objects, convert them to block! if all [ ;[1.5] object? eany_expected object? lb_current/1 ][ eany_expected: third eany_expected lb_current/1: third lb_current/1 ] either all [block? eany_expected block? lb_current/1][ ;[1.1] ;--- if we find a block here, we have to recurent call the func ;- if it fails (return false), the failure will be transmitted ;- to the first level of recursion if not prf_assert_block_equal lb_current/1 eany_expected [ return false ] ][ ;--- if word is 'none is we have to re-give a meaning to it ;- because it is known as word (not bound to the same context) ;- (perhaps is there a more elegant way to solve this ?) if 'none = eany_expected [eany_expected: none] ;--- compare each found values. ;- comparison stops when the first difference is found if not lb_current/1 == eany_expected [ pf_display rejoin [ tab tab "*-> Data expected into block : " mold eany_expected " of type: [" type? eany_expected "!]^/" tab tab " but was : " mold lb_current/1 " of type: [" type? lb_current/1 "!]" ] return false ] ] ;--- go one position further into current block lb_current: next lb_current ] return true ] ;=========================================================================== pf_display: func [ {@ Display any message, rejoining block! if provided. Should be GUI in a next release. @RETURN none} aany_msg [string! block!] "msg to display" /local lerr_result ][ ;--- display message. ;- some VID layout could be used here print-copy either block? aany_msg [rejoin aany_msg][aany_msg] ;--- if we want to log, check log file existance and log ;- msg into it if prl_log [ if not exists? prfile_log [ write prfile_log "" ] write/append prfile_log either block? aany_msg [rejoin aany_msg][aany_msg] write/append prfile_log newline ] ] ;=========================================================================== prf_error: func [ {@ handle test error by displaying the disarmed value @RETURN none} aerr_data [error!] "error to handle" as_func_name [string!] "func name where error happened" /local lerr_result lo_error ][ ;--- make error useful lo_error: disarm aerr_data lw_type: lo_error/type ;[1.2] li_id: lo_error/id ;[1.2] ls_msg: rejoin [ ;[1.2] system/error/:lw_type/type ": " system/error/:lw_type/:li_id ] attempt [replace ls_msg "arg1" form lo_error/arg1] ;[1.2] attempt [replace ls_msg "arg2" form lo_error/arg2] attempt [replace ls_msg "arg3" form lo_error/arg3] pri_error_count: pri_error_count + 1 ;--- disply error pf_display rejoin [ tab tab "!-> ERROR generated:" newline tab tab tab ls_msg newline ;[1.2] tab tab tab "Near : " copy/part mold/only lo_error/near 100 newline ;[1.2] tab tab tab "Where: " as_func_name newline ;[0.3] ] ] ;=========================================================================== ;--- Run test functions pf_run_test: func [ {@ handle submitted TestCase or TestSuite file. @RETURN none} afile_test [file!] "file to handle" /log "write down all output from console" /quiet "output only for failed tests" /local lerr_result lo_test ][ ;--- force the use of %.test suffix if not find afile_test %.test [ ;[1.5] print-copy [ "***" afile_test "is not a test file !" newline "*** Please provide a valid file name." ] ask "Press [Enter] to quit" quit ] ;--- 'log option if log [ ;--- activate log prl_log: true ;--- set log file name prfile_log: replace copy afile_test %.test %-TestReport.log ;[0.3] ] prl_quiet: quiet ;--- set some private vars prb_func: copy [] ;==> container for tests functions names pri_test_count: pri_error_count: pri_failure_count: 0 ;==> counters prtime_duration: prtime_start: 0:0 ;==> chronometer ;--- display RUn header pf_display prs_header if log [pf_display form now-copy] ;--- branch test to TestCase or TestSuite ;- allowing recurent call prf_branch_test afile_test ;--- display test results pf_display prs_report pf_display [ ;[0.3] " TOTAL : " pri_test_count newline " => Passed : " pri_test_count - pri_failure_count - pri_error_count newline " => Failures : " pri_failure_count newline " => Errors : " pri_error_count ] ;--- display footer pf_display prs_footer ask "Press [ENTER] to Quit" ] ;=========================================================================== prf_branch_test: func [ {@ If submitted file contains a TestSuite file, this func will @ make a recurent call until a TestCase file is found. If it @ contains a TestCase, it will run each test. @RETURN none} afile_test [file!] "file to branch" /local lerr_result ][ ;--- convert test file into object for easier access lo_test: make object! load afile_test ;--- if there is a 'test-suite defined into object's context ;- then where dealing with a Suite of Tests either find first lo_test 'test-suite [ ;--- Suite of Tests: handle test file one at the time foreach efile_test lo_test/test-suite [ prf_branch_test efile_test ] ][ ;--- no Suite of Tests: handle single test file, allowing recurrent call prf_run_unit_test afile_test ] ] ;=========================================================================== prf_run_unit_test: func [ {@ Run Developer Tests found into provided file. @RETURN none} afile_test [file!] "file to handle" /local lerr_result lo_test ll_setup? prl_teardown? ][ ;--- convert single test into object for easier access ;- and creation of execution context lo_test: make object! load afile_test ;--- check presence of setup and teardown func ll_setup?: if find first lo_test 'setup [true][false] ll_teardown?: if find first lo_test 'teardown [true][false] ;--- display test file name pf_display [newline "> " afile_test] ;--- execute setup if exists, if needed, handle error if ll_setup? [ if not prl_quiet [pf_display [newline " >> SETUP"]] ;[1.2] either error? set/any 'lerr_result try [ lo_test/setup ][ prf_error lerr_result "Setup" ][ if not prl_quiet [pf_display [tab tab "--> Done"]] ;[1.2] ] ] ;--- execute all tests found foreach ew_func_name first lo_test [ if all [ ew_func_name <> 'teardown ew_func_name <> 'setup ew_func_name <> 'self ][ if not prl_quiet [pf_display [" >> " :ew_func_name]] ;[1.2] pri_test_count: pri_test_count + 1 ;--- execute single test and , if needed, handle error if error? set/any 'lerr_result try [ prtime_start: now-copy/time/precise if all [ ;[1.2] not lo_test/:ew_func_name prl_quiet ][ pf_display [" [in " :ew_func_name "]"] ] ][ prf_error lerr_result form ew_func_name ] ] ] ;--- execute teardown if exists if ll_teardown? [ if not prl_quiet [pf_display [newline " >> TEARDOWN"]] ;[1.2] either error? set/any 'lerr_result try [ lo_test/teardown ][ prf_error lerr_result "Teardown" ][ if not prl_quiet [pf_display [tab tab "--> Done"]] ;[1.2] ] ] ] ;=========================================================================== ;--- set to public interface using 'rebolian' wording: prl_quiet: false set 'assert :pf_assert set 'assert-equal :pf_assert_equal set 'assert-not-equal :pf_assert_not_equal set 'assert-error :pf_assert_error ;[1.8] set 'run-test :pf_run_test set 'display :pf_display ;[1.5] ]