]> git.8kb.co.uk Git - dataflex/df32func/blob - src/df32/tap.inc
Maintain types on matrix columns
[dataflex/df32func] / src / df32 / tap.inc
1 //-------------------------------------------------------------------------
2 // tap.inc
3 //      This file contains some DataFlex 3.2 Console Mode classes
4 //      to provide some test anything protocol functionality.
5 //    See: http://testanything.org/
6 //
7 // This file is to be included in df32func.mk
8 //
9 // Copyright (c) 2006-2015, glyn@8kb.co.uk
10 // 
11 // df32func/tap.inc
12 //-------------------------------------------------------------------------
13
14 //-------------------------------------------------------------------------
15 // Classes
16 //-------------------------------------------------------------------------
17
18 // TAP class - impliments the vet basic of the Test Anything Protocol  
19 //
20 // Get methods:
21 //    plan                           - Gets the "plan" or expected number of tests
22 //    tests                          - Gets the number of tests executed so far
23 //
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
26 //
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")
33 //
34 // Notes
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
38 //    seen.
39 //
40 // Example usage:  
41 //
42 //    object myTest is a TAP
43 //    end_object
44 //
45 //    set plan of myTest to 8
46 //
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"
56 //
57 //    send finish to myTest
58 //
59 class TAP is an array
60     procedure construct_object integer argc
61         forward send construct_object
62         property integer c_iPlan public argc        
63         property integer c_iTest
64         set c_iPlan to -1
65         set c_iTest to 0        
66     end_procedure
67     
68     procedure set plan integer argv
69         set c_iPlan to argv
70     end_procedure
71     
72     function plan
73         local integer l_iPlan
74         get c_iPlan to l_iPlan
75         function_return l_iPlan
76     end_procedure    
77
78     function tests
79         local integer l_iTest
80         get c_iTest to l_iTest
81         function_return l_iTest
82     end_procedure 
83     
84     procedure is string argv string argv2 string argv3
85         local integer l_iTest
86         local string l_sTestResult
87         
88         get c_iTest to l_iTest
89         increment l_iTest
90                
91         move (ternary((argv = argv2),"1","0")+string(l_iTest)+" - "+argv3) to l_sTestResult
92                 
93         forward set array_value item l_iTest to l_sTestResult 
94         set c_iTest to l_iTest     
95     end_procedure
96     
97     procedure isnt string argv string argv2 string argv3
98         local integer l_iTest
99         local string l_sTestResult
100         
101         get c_iTest to l_iTest
102         increment l_iTest
103                
104         move (ternary((argv <> argv2),"1","0")+string(l_iTest)+" - "+argv3) to l_sTestResult
105                 
106         forward set array_value item l_iTest to l_sTestResult 
107         set c_iTest to l_iTest     
108     end_procedure 
109     
110     procedure cmp_ok string argv string argv2 string argv3 string argv4
111         local integer l_iTest
112         local string l_sTestResult
113         
114         get c_iTest to l_iTest
115         increment l_iTest
116
117         case begin
118             case ((argv3 = "=") or (argv3 = "eq") or (argv3 = "==")) move (ternary((argv = argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
119             case break
120             case ((argv3 = "<>") or (argv3 = "ne") or (argv3 = "!=") or (argv3 = "!")) move (ternary((argv <> argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
121             case break
122             case ((argv3 = ">") or (argv3 = "gt")) move (ternary((argv > argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
123             case break          
124             case ((argv3 = ">=") or (argv3 = "ge")) move (ternary((argv >= argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
125             case break          
126             case ((argv3 = "<") or (argv3 = "lt")) move (ternary((argv < argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
127             case break                      
128             case ((argv3 = "<=") or (argv3 = "le")) move (ternary((argv <= argv2),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
129             case break                                  
130             case ((argv3 = "~") or (argv3 = "~~") or (argv3 = "contains")) move (ternary(((argv contains argv2) > 0),"1","0")+string(l_iTest)+" - "+argv4) to l_sTestResult
131             case break  
132             case else custom_error ERROR_CODE_COMPARISON_OPERATOR$ ERROR_MSG_COMPARISON_OPERATOR argv3
133         case end
134         
135         forward set array_value item l_iTest to l_sTestResult 
136         set c_iTest to l_iTest     
137     end_procedure      
138     
139     procedure ok integer argv string argv2
140         local integer l_iTest
141         local string l_sTestResult
142         
143         get c_iTest to l_iTest
144         increment l_iTest
145         
146         if ((argv <= 1) and (argv >= 0)) begin
147             move (string(argv)+string(l_iTest)+" - "+argv2) to l_sTestResult
148         end
149         else begin
150             custom_error ERROR_CODE_INVALID_BOOLEAN$ ERROR_MSG_INVALID_BOOLEAN ERROR_DETAIL_INVALID_BOOLEAN argv
151         end
152                 
153         forward set array_value item l_iTest to l_sTestResult 
154         set c_iTest to l_iTest      
155     end_procedure
156     
157     procedure finish
158         local integer l_iPlan l_iTest l_i l_iStatus
159         local string l_sBuf l_sMsg
160         
161         get c_iPlan to l_iPlan
162         get c_iTest to l_iTest
163
164         
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
170             
171             if (l_iStatus = 1) begin
172                 showln "ok " l_sMsg
173             end
174             else begin
175                 showln "not ok " l_sMsg
176             end
177         loop        
178         
179         if (l_iPlan <> -1) begin                
180             set c_iPlan to -1
181         end
182         else showln "1.." l_iTest
183         
184         forward send delete_data
185         set c_iTest to 0
186     end_procedure
187     
188     procedure done_testing
189         send finish
190     end_procedure
191     
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
197         send destroy_object
198     end_procedure
199     
200 end_class
201
202 // TAP_harness class - overrides finish method of TAP class to provide a 
203 //                     basic harness
204 //
205 // Inherits all methods from TAP
206 //
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
212 //
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
219         set c_iNotices to 0
220         set c_iTiming to 0      
221     end_procedure
222
223     function get_timer_seconds returns number
224         local date l_dDate
225         local number l_nHr l_nMin l_nSec
226         
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)
229     end_procedure
230     
231     procedure notices_on 
232         set c_iNotices to 1
233     end_procedure
234     
235     procedure notices_off
236         set c_iNotices to 0
237     end_procedure   
238     
239     procedure timing_on 
240         local number l_iSecs
241         set c_iTiming to 1
242         get get_timer_seconds to l_iSecs
243         set c_nStart to l_iSecs
244     end_procedure
245
246     procedure timing_off
247         set c_iTiming to 0
248     end_procedure
249     
250     procedure finish
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
254         
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
259         
260         move 0 to l_iFailed
261         move "" to l_sFailed
262         
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
268             
269             if (l_iStatus = 1) begin
270                 showln "ok " l_sMsg
271             end
272             else begin
273                 showln "not ok " l_sMsg
274                 if (l_iFailed > 0) append l_sFailed ", "
275                 append l_sFailed l_i
276                 increment l_iFailed
277             end
278         loop        
279         
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
286             end
287                         
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"
291             end
292                 
293             forward set c_iPlan to -1
294         end
295         else showln "1.." l_iTest
296         
297         if (l_iTiming) begin
298             get get_timer_seconds to l_nSecs
299             get c_nStart to l_nStart
300             showln "Timing: " (l_nSecs-l_nStart) " seconds"
301         end
302     end_procedure
303
304 end_class