X-Git-Url: https://git.8kb.co.uk/?p=dataflex%2Fdf32func;a=blobdiff_plain;f=src%2Fdf32%2Ftap.inc;fp=src%2Fdf32%2Ftap.inc;h=51eda438e1ccb9074bedf877f6ee693b507c6e84;hp=0000000000000000000000000000000000000000;hb=21b727fd491be6f9953f1675b18385296cab0955;hpb=0342737c4763de343d9d87c0cb25a8e31f0211e7 diff --git a/src/df32/tap.inc b/src/df32/tap.inc new file mode 100644 index 0000000..51eda43 --- /dev/null +++ b/src/df32/tap.inc @@ -0,0 +1,304 @@ +//------------------------------------------------------------------------- +// tap.inc +// This file contains some DataFlex 3.2 Console Mode classes +// to provide some test anything protocol functionality. +// See: http://testanything.org/ +// +// This file is to be included in df32func.mk +// +// Copyright (c) 2006-2015, glyn@8kb.co.uk +// +// df32func/tap.inc +//------------------------------------------------------------------------- + +//------------------------------------------------------------------------- +// Classes +//------------------------------------------------------------------------- + +// TAP class - impliments the vet basic of the Test Anything Protocol +// +// Get methods: +// plan - Gets the "plan" or expected number of tests +// tests - Gets the number of tests executed so far +// +// Set methods: (All of the following methods are intended to be private) +// plan - Sets the "plan" or expected number of tests +// +// Send message methods: +// ok - Fundamental test, to check binary outcome of an expression +// is - Test values are equivaent +// isnt - Test values are not equivaent +// cmp_ok - Test values are not equivaent +// finish - Complete the set of tests (also alias "done_testing") +// +// Notes +// If a plan has been set, and the program aborts without calling finish, finish is called +// automatically, and results will be output. Piping test output to a file or creating a +// "wrapper" around the program with a simple "chain wait" allows test results to always be +// seen. +// +// Example usage: +// +// object myTest is a TAP +// end_object +// +// set plan of myTest to 8 +// +// send ok to myTest (1=1) "One is equal to one" +// send ok to myTest (2=1) "Two is equal to one" +// send ok to myTest (3=3) "Three is equal to three" +// send is to myTest "pie" 100 "Pie is numeric" +// send isnt to myTest "pie" "pie" "Both should be pie" +// send cmp_ok to myTest "pie" "pie" "=" "Pie equals pie" +// send cmp_ok to myTest 1 2 "=" "One equals two" +// send cmp_ok to myTest 1 2 ">" "One is greater than two" +// send cmp_ok to myTest "pankcake" "cake" "~~" "Pankace contains cake" +// +// send finish to myTest +// +class TAP is an array + procedure construct_object integer argc + forward send construct_object + property integer c_iPlan public argc + property integer c_iTest + set c_iPlan to -1 + set c_iTest to 0 + end_procedure + + procedure set plan integer argv + set c_iPlan to argv + end_procedure + + function plan + local integer l_iPlan + get c_iPlan to l_iPlan + function_return l_iPlan + end_procedure + + function tests + local integer l_iTest + get c_iTest to l_iTest + function_return l_iTest + end_procedure + + procedure is string argv string argv2 string argv3 + local integer l_iTest + local string l_sTestResult + + get c_iTest to l_iTest + increment l_iTest + + move (ternary((argv = argv2),"1","0")+string(l_iTest)+" - "+argv3) to l_sTestResult + + forward set array_value item l_iTest to l_sTestResult + set c_iTest to l_iTest + end_procedure + + procedure isnt string argv string argv2 string argv3 + local integer l_iTest + local string l_sTestResult + + get c_iTest to l_iTest + increment l_iTest + + move (ternary((argv <> argv2),"1","0")+string(l_iTest)+" - "+argv3) to l_sTestResult + + forward set array_value item l_iTest to l_sTestResult + set c_iTest to l_iTest + end_procedure + + procedure cmp_ok string argv string argv2 string argv3 string argv4 + local integer l_iTest + local string l_sTestResult + + get c_iTest to l_iTest + increment l_iTest + + case begin + case ((argv3 = "=") or (argv3 = "eq") or (argv3 = "==")) move (ternary((argv = argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult + case break + case ((argv3 = "<>") or (argv3 = "ne") or (argv3 = "!=") or (argv3 = "!")) move (ternary((argv <> argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult + case break + case ((argv3 = ">") or (argv3 = "gt")) move (ternary((argv > argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult + case break + case ((argv3 = ">=") or (argv3 = "ge")) move (ternary((argv >= argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult + case break + case ((argv3 = "<") or (argv3 = "lt")) move (ternary((argv < argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult + case break + case ((argv3 = "<=") or (argv3 = "le")) move (ternary((argv <= argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult + case break + case ((argv3 = "~") or (argv3 = "~~") or (argv3 = "contains")) move (ternary(((argv contains argv2) > 0),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult + case break + case else custom_error ERROR_CODE_COMPARISON_OPERATOR$ ERROR_MSG_COMPARISON_OPERATOR argv3 + case end + + forward set array_value item l_iTest to l_sTestResult + set c_iTest to l_iTest + end_procedure + + procedure ok integer argv string argv2 + local integer l_iTest + local string l_sTestResult + + get c_iTest to l_iTest + increment l_iTest + + if ((argv <= 1) and (argv >= 0)) begin + move (string(argv)+string(l_iTest)+" - "+argv2) to l_sTestResult + end + else begin + custom_error ERROR_CODE_INVALID_BOOLEAN$ ERROR_MSG_INVALID_BOOLEAN ERROR_DETAIL_INVALID_BOOLEAN argv + end + + forward set array_value item l_iTest to l_sTestResult + set c_iTest to l_iTest + end_procedure + + procedure finish + local integer l_iPlan l_iTest l_i l_iStatus + local string l_sBuf l_sMsg + + get c_iPlan to l_iPlan + get c_iTest to l_iTest + + + if (l_iPlan <> -1) showln "1.." l_iPlan + for l_i from 1 to l_iTest + forward get string_value item l_i to l_sBuf + move (left(l_sBuf,1)) to l_iStatus + move (right(l_sBuf,length(l_sBuf)-1)) to l_sMsg + + if (l_iStatus = 1) begin + showln "ok " l_sMsg + end + else begin + showln "not ok " l_sMsg + end + loop + + if (l_iPlan <> -1) begin + set c_iPlan to -1 + end + else showln "1.." l_iTest + + forward send delete_data + set c_iTest to 0 + end_procedure + + procedure done_testing + send finish + end_procedure + + procedure destroy_object + local integer l_iPlan + get c_iPlan to l_iPlan + if (l_iPlan <> -1) send finish + //forward send destroy_object + send destroy_object + end_procedure + +end_class + +// TAP_harness class - overrides finish method of TAP class to provide a +// basic harness +// +// Inherits all methods from TAP +// +// Set methods: (extra methods) +// timing_on - Turns on test timing +// timing_off - Turns off test timing +// notices_on - Turns on test notices +// notices_off - Turns off test notices +// +class TAP_harness is a TAP + procedure construct_object integer argc + forward send construct_object argc + property integer c_iNotices + property integer c_iTiming + property integer c_nStart + set c_iNotices to 0 + set c_iTiming to 0 + end_procedure + + function get_timer_seconds returns number + local date l_dDate + local number l_nHr l_nMin l_nSec + + sysdate l_dDate l_nHr l_nMin l_nSec + function_return ((integer(l_dDate)-integer(date("01/01/1970"))*86400)+(((l_nHr*60)+l_nMin)*60)+l_nSec) + end_procedure + + procedure notices_on + set c_iNotices to 1 + end_procedure + + procedure notices_off + set c_iNotices to 0 + end_procedure + + procedure timing_on + local number l_iSecs + set c_iTiming to 1 + get get_timer_seconds to l_iSecs + set c_nStart to l_iSecs + end_procedure + + procedure timing_off + set c_iTiming to 0 + end_procedure + + procedure finish + local integer l_iPlan l_iTest l_i l_iStatus l_iFailed l_iNotices l_iTiming + local string l_sBuf l_sMsg l_sFailed + local number l_nStart l_nSecs + + forward get c_iPlan to l_iPlan + forward get c_iTest to l_iTest + get c_iNotices to l_iNotices + get c_iTiming to l_iTiming + + move 0 to l_iFailed + move "" to l_sFailed + + if (l_iPlan <> -1) showln "1.." l_iPlan + for l_i from 1 to l_iTest + forward get string_value item l_i to l_sBuf + move (left(l_sBuf,1)) to l_iStatus + move (right(l_sBuf,length(l_sBuf)-1)) to l_sMsg + + if (l_iStatus = 1) begin + showln "ok " l_sMsg + end + else begin + showln "not ok " l_sMsg + if (l_iFailed > 0) append l_sFailed ", " + append l_sFailed l_i + increment l_iFailed + end + loop + + if (l_iPlan <> -1) begin + if (l_iNotices) begin + if (l_iTest < l_iPlan); + showln "Notice: Only ran " l_iTest " of " l_iPlan " tests" + if (l_iTest > l_iPlan); + showln "Notice: Ran " l_iTest " tests, but only expected " l_iPlan + end + + if (l_iFailed > 0) begin + showln "FAILED test" (ternary((l_iFailed > 1),"s "," ")) l_sFailed + showln "Failed " l_iFailed "/" l_iTest " tests, " (decround(1-(number(l_iFailed)/number(l_iTest))*100,2)) "% ok" + end + + forward set c_iPlan to -1 + end + else showln "1.." l_iTest + + if (l_iTiming) begin + get get_timer_seconds to l_nSecs + get c_nStart to l_nStart + showln "Timing: " (l_nSecs-l_nStart) " seconds" + end + end_procedure + +end_class