/
PRGUNIT.prg
153 lines (124 loc) · 4.63 KB
/
PRGUNIT.prg
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
* ----------------------------------------------------------------------------
* Harbour Unit Test Worker
* Anthony J. Borla (ajborla@bigpond.com)
* ----------------------------------------------------------------------------
#ifndef UTILS_PRG
#include "utils.prg"
#endif
procedure MakeTestDatabaseStructure(dbfName)
* Creation overwites any existing database
create &dbfName
* Each record describes the structure of a FIELD
append blank
replace Field_name with "NAME", Field_type with "C",;
Field_Len with 80, Field_dec with 0
append blank
replace Field_name with "CMPOP", Field_type with "C",;
Field_Len with 2, Field_dec with 0
append blank
replace Field_name with "EXPVALUE", Field_type with "C",;
Field_Len with 80, Field_dec with 0
append blank
replace Field_name with "CMDSTR", Field_type with "C",;
Field_Len with 80, Field_dec with 0
* Ensure data written to disk
close &dbfName
return
procedure MakeTestDatabase(dbfName)
local dbfStructure := dbfName + "_STRUCTURE"
* Build test database from database structure file
do MakeTestDatabaseStructure with dbfStructure
create &dbfName from &dbfStructure
* Ensure database structure file is removed
dbfStructure := dbfStructure + ".dbf"
erase &dbfStructure
return
procedure AddTestDatabase(dbfName, testName, cmpOp, expValue, cmdStr)
* Load a test data record into tests database (note use of 'Wrap' to
* preserve spaces in expected value string)
use &dbfName
append blank
replace &dbfName->NAME with testName
replace &dbfName->CMPOP with cmpOp
replace &dbfName->EXPVALUE with Wrap(expValue)
replace &dbfName->CMDSTR with cmdStr
close &dbfName
return
function RunTests(dbfName, keepTestDBF, outputJSON)
local testName, cmpOp, expValue, cmdStr, retValue, testExpr
local success := .T.
use &dbfName
* Determine, and print, number of tests (required for TAP)
if outputJSON == NIL .OR. !outputJSON
? "1.." + LTRIM(STR(LASTREC()))
endif
* Execute unit tests
do while !EOF()
* Extract test data (note use of 'Unwrap' to extract space-preserved
* expected value string)
testName := ALLTRIM(&dbfName->NAME)
cmpOp := &dbfName->CMPOP
expValue := Unwrap(ALLTRIM(&dbfName->EXPVALUE))
cmdStr := ALLTRIM(&dbfName->CMDSTR)
* Execute test, and build test expression
retValue := TypeToS(&cmdStr)
testExpr := '"' + retValue + '" ' + cmpOp + ' "' + expValue + '"'
* If the parameter flag, outputJSON, is omitted, or set to .F., then
* emit test report in TAP format
if outputJSON == NIL .OR. !outputJSON
* Report test outcome - TAP
if &testExpr
? "OK " + LTRIM(STR(RECNO())) + " - " + testName
else
* Single test failure signals failure of whole suite
success := .F.
? "FAIL " + LTRIM(STR(RECNO())) + " - " + testName
endif
else
* Report test outcome - JSON
? "JSON"
endif
* ... next test
skip
enddo
close &dbfName
* If the parameter flag, keepTestDBF, is omitted, or set to .F., then
* remove the tests database
if keepTestDBF == NIL .OR. !keepTestDBF
dbfName := dbfName + ".dbf"
erase &dbfName
endif
return success
function TypeToS(value)
* Use VALTYPE() instead of TYPE() to check type
local typeValue := VALTYPE(value)
switch typeValue
* Array type (assume 1D array of non-aggregate elements),
* returns the concatenation of elements as a string
case "A" ; return ArrToS(value)
* Character type returned untouched
case "C" ; return value
* Date as "yyyymmdd"
case "D" ; return DTOS(value)
* Logical as literal string representation of self
case "L" ; return IIF(value, ".T.", ".F.")
* String-converted numerics are right-justified, so ensure are
* returned trimmed
case "N" ; return ALLTRIM(STR(value))
* Support use of NIL return type (usually to indicate error)
case "U" ; return "NIL"
endswitch
* Ignore the remaining types, just return NIL (likely runtime error)
return NIL
* Utilities to preserve leading and trailing spaces in strings as they
* are stored into, and extracted from, database fields
function Wrap(string) ; return WrapString(string, .F., "[", "]")
function Unwrap(string) ; return WrapString(string, .T.)
function WrapString(string, doUnwrap, wrapStart, wrapEnd)
local uws
if doUnwrap
uws := SUBSTR(SUBSTR(string, 2), 1, LEN(string) - 2)
else
uws := wrapStart + string + wrapEnd
endif
return uws