1 //-------------------------------------------------------------------------
3 // This file contains some DataFlex 3.2 Console Mode classes
4 // to provide some test anything protocol functionality.
5 // See: http://testanything.org/
7 // This file is to be included in df32func.mk
9 // Copyright (c) 2006-2015, glyn@8kb.co.uk
12 //-------------------------------------------------------------------------
14 //-------------------------------------------------------------------------
16 //-------------------------------------------------------------------------
18 // TAP class - impliments the vet basic of the Test Anything Protocol
21 // plan - Gets the "plan" or expected number of tests
22 // tests - Gets the number of tests executed so far
24 // Set methods: (All of the following methods are intended to be private)
25 // plan <number of tests> - Sets the "plan" or expected number of tests
27 // Send message methods:
28 // ok <boolean> - Fundamental test, to check binary outcome of an expression
29 // is <v1> <v2> <msg> - Test values are equivaent
30 // isnt <v1> <v2> <msg> - Test values are not equivaent
31 // cmp_ok <val1> <val2> <op> <msg> - Test values are not equivaent
32 // finish - Complete the set of tests (also alias "done_testing")
35 // If a plan has been set, and the program aborts without calling finish, finish is called
36 // automatically, and results will be output. Piping test output to a file or creating a
37 // "wrapper" around the program with a simple "chain wait" allows test results to always be
42 // object myTest is a TAP
45 // set plan of myTest to 8
47 // send ok to myTest (1=1) "One is equal to one"
48 // send ok to myTest (2=1) "Two is equal to one"
49 // send ok to myTest (3=3) "Three is equal to three"
50 // send is to myTest "pie" 100 "Pie is numeric"
51 // send isnt to myTest "pie" "pie" "Both should be pie"
52 // send cmp_ok to myTest "pie" "pie" "=" "Pie equals pie"
53 // send cmp_ok to myTest 1 2 "=" "One equals two"
54 // send cmp_ok to myTest 1 2 ">" "One is greater than two"
55 // send cmp_ok to myTest "pankcake" "cake" "~~" "Pankace contains cake"
57 // send finish to myTest
60 procedure construct_object integer argc
61 forward send construct_object
62 property integer c_iPlan public argc
63 property integer c_iTest
68 procedure set plan integer argv
74 get c_iPlan to l_iPlan
75 function_return l_iPlan
80 get c_iTest to l_iTest
81 function_return l_iTest
84 procedure is string argv string argv2 string argv3
86 local string l_sTestResult
88 get c_iTest to l_iTest
91 move (ternary((argv = argv2),"1","0")+string(l_iTest)+" - "+argv3) to l_sTestResult
93 forward set array_value item l_iTest to l_sTestResult
94 set c_iTest to l_iTest
97 procedure isnt string argv string argv2 string argv3
99 local string l_sTestResult
101 get c_iTest to l_iTest
104 move (ternary((argv <> argv2),"1","0")+string(l_iTest)+" - "+argv3) to l_sTestResult
106 forward set array_value item l_iTest to l_sTestResult
107 set c_iTest to l_iTest
110 procedure cmp_ok string argv string argv2 string argv3 string argv4
111 local integer l_iTest
112 local string l_sTestResult
114 get c_iTest to l_iTest
118 case ((argv3 = "=") or (argv3 = "eq") or (argv3 = "==")) move (ternary((argv = argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
120 case ((argv3 = "<>") or (argv3 = "ne") or (argv3 = "!=") or (argv3 = "!")) move (ternary((argv <> argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
122 case ((argv3 = ">") or (argv3 = "gt")) move (ternary((argv > argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
124 case ((argv3 = ">=") or (argv3 = "ge")) move (ternary((argv >= argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
126 case ((argv3 = "<") or (argv3 = "lt")) move (ternary((argv < argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
128 case ((argv3 = "<=") or (argv3 = "le")) move (ternary((argv <= argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
130 case ((argv3 = "~") or (argv3 = "~~") or (argv3 = "contains")) move (ternary(((argv contains argv2) > 0),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
132 case else custom_error ERROR_CODE_COMPARISON_OPERATOR$ ERROR_MSG_COMPARISON_OPERATOR argv3
135 forward set array_value item l_iTest to l_sTestResult
136 set c_iTest to l_iTest
139 procedure ok integer argv string argv2
140 local integer l_iTest
141 local string l_sTestResult
143 get c_iTest to l_iTest
146 if ((argv <= 1) and (argv >= 0)) begin
147 move (string(argv)+string(l_iTest)+" - "+argv2) to l_sTestResult
150 custom_error ERROR_CODE_INVALID_BOOLEAN$ ERROR_MSG_INVALID_BOOLEAN ERROR_DETAIL_INVALID_BOOLEAN argv
153 forward set array_value item l_iTest to l_sTestResult
154 set c_iTest to l_iTest
158 local integer l_iPlan l_iTest l_i l_iStatus
159 local string l_sBuf l_sMsg
161 get c_iPlan to l_iPlan
162 get c_iTest to l_iTest
165 if (l_iPlan <> -1) showln "1.." l_iPlan
166 for l_i from 1 to l_iTest
167 forward get string_value item l_i to l_sBuf
168 move (left(l_sBuf,1)) to l_iStatus
169 move (right(l_sBuf,length(l_sBuf)-1)) to l_sMsg
171 if (l_iStatus = 1) begin
175 showln "not ok " l_sMsg
179 if (l_iPlan <> -1) begin
182 else showln "1.." l_iTest
184 forward send delete_data
188 procedure done_testing
192 procedure destroy_object
193 local integer l_iPlan
194 get c_iPlan to l_iPlan
195 if (l_iPlan <> -1) send finish
196 //forward send destroy_object
202 // TAP_harness class - overrides finish method of TAP class to provide a
205 // Inherits all methods from TAP
207 // Set methods: (extra methods)
208 // timing_on - Turns on test timing
209 // timing_off - Turns off test timing
210 // notices_on - Turns on test notices
211 // notices_off - Turns off test notices
213 class TAP_harness is a TAP
214 procedure construct_object integer argc
215 forward send construct_object argc
216 property integer c_iNotices
217 property integer c_iTiming
218 property integer c_nStart
223 function get_timer_seconds returns number
225 local number l_nHr l_nMin l_nSec
227 sysdate l_dDate l_nHr l_nMin l_nSec
228 function_return ((integer(l_dDate)-integer(date("01/01/1970"))*86400)+(((l_nHr*60)+l_nMin)*60)+l_nSec)
235 procedure notices_off
242 get get_timer_seconds to l_iSecs
243 set c_nStart to l_iSecs
251 local integer l_iPlan l_iTest l_i l_iStatus l_iFailed l_iNotices l_iTiming
252 local string l_sBuf l_sMsg l_sFailed
253 local number l_nStart l_nSecs
255 forward get c_iPlan to l_iPlan
256 forward get c_iTest to l_iTest
257 get c_iNotices to l_iNotices
258 get c_iTiming to l_iTiming
263 if (l_iPlan <> -1) showln "1.." l_iPlan
264 for l_i from 1 to l_iTest
265 forward get string_value item l_i to l_sBuf
266 move (left(l_sBuf,1)) to l_iStatus
267 move (right(l_sBuf,length(l_sBuf)-1)) to l_sMsg
269 if (l_iStatus = 1) begin
273 showln "not ok " l_sMsg
274 if (l_iFailed > 0) append l_sFailed ", "
280 if (l_iPlan <> -1) begin
281 if (l_iNotices) begin
282 if (l_iTest < l_iPlan);
283 showln "Notice: Only ran " l_iTest " of " l_iPlan " tests"
284 if (l_iTest > l_iPlan);
285 showln "Notice: Ran " l_iTest " tests, but only expected " l_iPlan
288 if (l_iFailed > 0) begin
289 showln "FAILED test" (ternary((l_iFailed > 1),"s "," ")) l_sFailed
290 showln "Failed " l_iFailed "/" l_iTest " tests, " (decround(1-(number(l_iFailed)/number(l_iTest))*100,2)) "% ok"
293 forward set c_iPlan to -1
295 else showln "1.." l_iTest
298 get get_timer_seconds to l_nSecs
299 get c_nStart to l_nStart
300 showln "Timing: " (l_nSecs-l_nStart) " seconds"