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
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
|
# -*- tcl -*-
# Tests for the logger facility.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2002 by David N. Welton <davidw@dedasys.com>.
# Copyright (c) 2004,2005 by Michael Schlenker <mic42@users.sourceforge.net>.
#
# $Id: logger_trace.test,v 1.2 2006/10/09 21:41:41 andreas_kupries Exp $
# -------------------------------------------------------------------------
source [file join \
[file dirname [file dirname [file join [pwd] [info script]]]] \
devtools testutilities.tcl]
testsNeedTcl 8.4
testsNeedTcltest 2.0
testing {
useLocal logger.tcl logger
}
# -------------------------------------------------------------------------
proc traceproc0 { } {
traceproc1
}
proc traceproc1 { args } {
return "procresult1"
}
proc traceproc2 { args } {
return "procresult2"
}
proc traceproc3 { args } {
return "procresult3"
}
test logger-trace-1.1 {Test <service>::trace with no arguments.} -body {
set l [::logger::init tracetest]
${l}::trace
} -returnCodes 1 -result [::tcltest::wrongNumArgs ::logger::tree::tracetest::trace {action args} 0]
test logger-trace-1.2 {Test <service>::trace with an unknown action} -body {
set l [::logger::init tracetest]
${l}::trace foo
} -returnCodes 1 -result \
{Invalid action "foo": must be status, add, remove, on, or off}
test logger-trace-on-1.1 {Verify that tracing is disabled by default.} -body {
set l [::logger::init tracetest]
set ${l}::tracingEnabled
} -result 0
test logger-trace-on-1.2 {Test <service>::trace on with extra arguments} -body {
set l [::logger::init tracetest]
${l}::trace on 1
} -returnCodes 1 -result {wrong # args: should be "trace on"}
test logger-trace-on-1.3 {Test <service>::trace on with no extra arguments and verify that the tracing state flag is enabled afterward.} -body {
set l [::logger::init tracetest]
${l}::trace on
set ${l}::tracingEnabled
} -cleanup {
${l}::trace off
} -result 1
test logger-trace-on-1.4 {Verify <service>::trace on enables tracing only for the one service and not for any of its children.} -body {
set l1 [::logger::init tracetest]
set l2 [::logger::init tracetest::child]
${l1}::trace on
set ${l2}::tracingEnabled
} -cleanup {
${l1}::trace off
} -result 0
test logger-trace-off-1.1 {Test <service>::trace off with extra arguments} -body {
set l [::logger::init tracetest]
${l}::trace off 1
} -returnCodes 1 -result {wrong # args: should be "trace off"}
test logger-trace-off-1.2 {Test <service>::trace off with no extra arguments and verify that tracing state flag is disabled afterward.} -body {
set l [::logger::init tracetest]
${l}::trace off
set ${l}::tracingEnabled
} -result 0
test logger-trace-off-1.3 {Verify that <service>::trace on followed by off leaves tracing disabled.} -body {
set l [::logger::init tracetest]
${l}::trace on
${l}::trace off
set ${l}::tracingEnabled
} -result 0
test logger-trace-remove-1.1 {Test <service>::trace remove with no targets specified.} -body {
set l [::logger::init tracetest]
${l}::trace remove
} -returnCodes 1 -result \
{wrong # args: should be "trace remove ?-ns? <proc> ..."}
test logger-trace-remove-1.2 {Test <service>::trace remove with procedure names that don't exist.} -body {
set l [::logger::init tracetest]
${l}::trace remove nosuchproc1 nosuchproc2
} -result {}
test logger-trace-remove-1.3 {Test <service>::trace remove with -ns switch and namespace names that don't exist.} -body {
set l [::logger::init tracetest]
${l}::trace remove -ns nosuchns
} -result {}
test logger-trace-remove-1.4 {Verify that <service>::trace remove does glob pattern matching on procedure names.} -body {
namespace eval ::tracetest {
proc foo1 {} {}
proc foo2 {} {}
proc bar1 {} {}
proc bar2 {} {}
proc bar3 {} {}
}
set l [::logger::init tracetest]
${l}::trace add ::tracetest::bar1
${l}::trace add ::tracetest::bar2
${l}::trace add ::tracetest::bar3
${l}::trace remove ::tracetest::bar*
${l}::trace status
} -cleanup {
namespace delete ::tracetest
} -result {}
test logger-trace-add-1.1 {Test <service>::trace add with no targets specified.} -body {
set l [::logger::init tracetest]
${l}::trace add
} -returnCodes 1 -result \
{wrong # args: should be "trace add ?-ns? <proc> ..."}
test logger-trace-add-1.2 {Test <service>::trace add with procedure names that don't exist, and verify that they are not listed in <service>::trace status.} -body {
set l [::logger::init tracetest]
${l}::trace add nosuchproc1 nosuchproc2
${l}::trace status
} -cleanup {
${l}::trace remove nosuchproc1 nosuchproc2
} -result {}
test logger-trace-add-1.3 {Verify that <service>::trace add with the -ns switch followed by <service>::trace remove with the -ns switch, both with the same namespace, leaves no traces for the namespace remaining.} -body {
namespace eval ::tracetest {
proc test1 {} {}
proc test2 {} {}
proc test3 {} {}
}
set l [::logger::init tracetest]
${l}::trace add -ns ::tracetest
${l}::trace remove -ns ::tracetest
${l}::trace status
} -cleanup {
namespace delete ::tracetest
} -result {}
test logger-trace-add-1.4 {Verify that <service>::trace add with the -ns switch registers traces for all of the procedures in that namespace.} -body {
namespace eval ::tracetest {
proc test1 {} {}
proc test2 {} {}
proc test3 {} {}
}
set l [::logger::init tracetest]
${l}::trace add -ns ::tracetest
lsort -dictionary [${l}::trace status]
} -cleanup {
${l}::trace remove -ns ::tracetest
namespace delete ::tracetest
} -result {::tracetest::test1 ::tracetest::test2 ::tracetest::test3}
test logger-trace-add-1.5 {Verify that <service>::trace add does glob pattern matching on procedure names.} -body {
namespace eval ::tracetest {
proc foo1 {} {}
proc foo2 {} {}
proc bar1 {} {}
proc bar2 {} {}
proc bar3 {} {}
}
set l [::logger::init tracetest]
${l}::trace add ::tracetest::bar*
lsort -dictionary [${l}::trace status]
} -cleanup {
${l}::trace remove -ns ::tracetest
namespace delete ::tracetest
} -result {::tracetest::bar1 ::tracetest::bar2 ::tracetest::bar3}
test logger-trace-status-1.1 {Verify that <service>::trace status with no argument returns an empty list when no traces are currently active.} -body {
set l [::logger::init tracetest]
${l}::trace status
} -result {}
test logger-trace-status-1.2 {Verify that <service>::trace status returns 0 when given the name of a procedure that is not currently being traced.} -body {
set l [::logger::init tracetest]
${l}::trace status foo
} -result 0
test logger-trace-status-1.3 {Verify that <service>::trace status returns 0 when given the name of a procedure that was, but is no longer, being traced.} -body {
set l [::logger::init tracetest]
${l}::trace add foo
${l}::trace remove foo
${l}::trace status foo
} -result 0
test logger-trace-status-1.4 {Verify that <service>::trace status returns 0 when given the name of a procedure that doesn't exist, but was passed to <service>::trace add.} -body {
set l [::logger::init tracetest]
${l}::trace add nosuchproc
${l}::trace status nosuchproc
} -cleanup {
${l}::trace remove nosuchproc
} -result 0
test logger-trace-status-1.5 {Verify that <service>::trace status returns 1 when given the name of an existing procedure that is currently registered via <service>::trace add.} -body {
set l [::logger::init tracetest]
${l}::trace add traceproc1
${l}::trace status traceproc1
} -cleanup {
${l}::trace remove traceproc1
} -result 1
test logger-trace-log-1.1 {Verify that invoking a procedure that has been registered for tracing via <service>::trace add does NOT generate a log message when tracing is turned off.} -body {
set l [::logger::init tracetest]
${l}::trace off ;# Should already be off. Just in case.
${l}::trace add traceproc1
traceproc1
} -cleanup {
${l}::trace remove traceproc1
} -result "procresult1" -output {}
test logger-trace-log-1.2 {Verify that invoking a procedure that has been registered for tracing via <service>::trace add DOES generate a log message when tracing is turned on BEFORE registration. This test calls the traced function through another function, which should result in a non-empty caller string.} -body {
set l [::logger::init tracetest]
${l}::trace on
${l}::trace add traceproc1
traceproc0
} -cleanup {
${l}::trace remove traceproc1
${l}::trace off
} -result "procresult1" -match regexp -output \
{\[.*\] \[tracetest\] \[trace\] 'enter {proc ::traceproc1 level 2 script .*logger_trace.test caller ::traceproc0 procargs {args {}}}'
\[.*\] \[tracetest\] \[trace\] 'leave {proc ::traceproc1 level 2 script .*logger_trace.test caller ::traceproc0 status ok result procresult1}'
}
test logger-trace-log-1.3 {Verify that invoking a procedure that has been registered for tracing via <service>::trace add DOES generate a log message when tracing is turned on AFTER registration. This test calls the traced function directly, which should result in the caller being an empty string.} -body {
set l [::logger::init tracetest]
${l}::trace add traceproc2
${l}::trace on
traceproc2
} -cleanup {
${l}::trace remove traceproc2
${l}::trace off
} -result "procresult2" -match regexp -output \
{\[.*\] \[tracetest\] \[trace\] 'enter {proc ::traceproc2 level 1 script .*logger_trace.test caller {} procargs {args {}}}'
\[.*\] \[tracetest\] \[trace\] 'leave {proc ::traceproc2 level 1 script .*logger_trace.test caller {} status ok result procresult2}'
}
test logger-trace-logproc-1.1 {Verify that a logproc can be specified for trace logging.} -body {
set l [::logger::init tracetest]
proc ::tracelog { message } {
puts $message
}
${l}::logproc trace ::tracelog
${l}::trace add traceproc2
${l}::trace on
traceproc2
} -cleanup {
${l}::trace remove traceproc2
${l}::trace off
rename ::tracelog {}
} -result "procresult2" -match regexp -output \
{enter {proc ::traceproc2 level 1 script .*logger_trace.test caller {} procargs {args {}}}
leave {proc ::traceproc2 level 1 script .*logger_trace.test caller {} status ok result procresult2}
}
# -------------------------------------------------------------------------
testsuiteCleanup
return
|