git.8kb.co.uk Git - dataflex/df32func/blob - 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